diff --git a/compiler/GHC.hs b/compiler/GHC.hs --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -159,11 +159,11 @@ -- * Abstract syntax elements - -- ** Packages - UnitId, + -- ** Units + Unit, -- ** Modules - Module, mkModule, pprModule, moduleName, moduleUnitId, + Module, mkModule, pprModule, moduleName, moduleUnit, ModuleName, mkModuleName, moduleNameString, -- ** Names @@ -293,7 +293,7 @@ #include "HsVersions.h" -import GhcPrelude hiding (init) +import GHC.Prelude hiding (init) import GHC.ByteCode.Types import GHC.Runtime.Eval @@ -308,18 +308,18 @@ import GHC.Driver.Hooks import GHC.Driver.Pipeline ( compileOne' ) import GHC.Driver.Monad -import TcRnMonad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) -import GHC.Iface.Load ( loadSysInterface ) -import TcRnTypes +import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) +import GHC.Iface.Load ( loadSysInterface ) +import GHC.Tc.Types import GHC.Core.Predicate -import GHC.Driver.Packages +import GHC.Unit.State import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Hs import GHC.Core.Type hiding( typeKind ) -import TcType +import GHC.Tc.Utils.TcType import GHC.Types.Id -import TysPrim ( alphaTyVars ) +import GHC.Builtin.Types.Prim ( alphaTyVars ) import GHC.Core.TyCon import GHC.Core.TyCo.Ppr ( pprForAll ) import GHC.Core.Class @@ -338,29 +338,29 @@ import GHC.Driver.CmdLine import GHC.Driver.Session hiding (WarnReason(..)) import GHC.Driver.Ways -import SysTools -import SysTools.BaseDir +import GHC.SysTools +import GHC.SysTools.BaseDir import GHC.Types.Annotations -import GHC.Types.Module -import Panic +import GHC.Unit.Module +import GHC.Utils.Panic import GHC.Platform -import Bag ( listToBag ) -import ErrUtils -import MonadUtils -import Util -import StringBuffer -import Outputable +import GHC.Data.Bag ( listToBag ) +import GHC.Utils.Error +import GHC.Utils.Monad +import GHC.Utils.Misc +import GHC.Data.StringBuffer +import GHC.Utils.Outputable import GHC.Types.Basic -import FastString -import qualified Parser -import Lexer -import ApiAnnotation +import GHC.Data.FastString +import qualified GHC.Parser as Parser +import GHC.Parser.Lexer +import GHC.Parser.Annotation import qualified GHC.LanguageExtensions as LangExt import GHC.Types.Name.Env -import TcRnDriver -import Inst -import FamInst -import FileCleanup +import GHC.Tc.Module +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Instance.Family +import GHC.SysTools.FileCleanup import Data.Foldable import qualified Data.Map.Strict as Map @@ -373,13 +373,13 @@ import Data.Word ( Word8 ) import Control.Monad import System.Exit ( exitWith, ExitCode(..) ) -import Exception +import GHC.Utils.Exception import Data.IORef import System.FilePath import Control.Concurrent import Control.Applicative ((<|>)) -import Maybes +import GHC.Data.Maybe import System.IO.Error ( isDoesNotExistError ) import System.Environment ( getEnv ) import System.Directory @@ -594,7 +594,7 @@ -- flags. If you are not doing linking or doing static linking, you -- can ignore the list of packages returned. -- -setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] +setSessionDynFlags :: GhcMonad m => DynFlags -> m [UnitId] setSessionDynFlags dflags = do dflags' <- checkNewDynFlags dflags dflags'' <- liftIO $ interpretPackageEnv dflags' @@ -643,7 +643,7 @@ -- | Sets the program 'DynFlags'. Note: this invalidates the internal -- cached module graph, causing more work to be done the next time -- 'load' is called. -setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] +setProgramDynFlags :: GhcMonad m => DynFlags -> m [UnitId] setProgramDynFlags dflags = setProgramDynFlags_ True dflags -- | Set the action taken when the compiler produces a message. This @@ -655,7 +655,7 @@ void $ setProgramDynFlags_ False $ dflags' { log_action = action } -setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId] +setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [UnitId] setProgramDynFlags_ invalidate_needed dflags = do dflags' <- checkNewDynFlags dflags dflags_prev <- getProgramDynFlags @@ -857,7 +857,7 @@ , pm_parsed_source :: ParsedSource , pm_extra_src_files :: [FilePath] , pm_annotations :: ApiAnns } - -- See Note [Api annotations] in ApiAnnotation.hs + -- See Note [Api annotations] in GHC.Parser.Annotation instance ParsedMod ParsedModule where modSummary m = pm_mod_summary m @@ -951,7 +951,7 @@ hpm <- liftIO $ hscParse hsc_env_tmp ms return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm) (hpm_annotations hpm)) - -- See Note [Api annotations] in ApiAnnotation.hs + -- See Note [Api annotations] in GHC.Parser.Annotation -- | Typecheck and rename a parsed module. -- @@ -1322,7 +1322,7 @@ ; (pkg_fie, home_fie) <- tcGetFamInstEnvs -- We use Data.Sequence.Seq because we are creating left associated -- mappends. - -- cls_index and fam_index below are adapted from TcRnDriver.lookupInsts + -- cls_index and fam_index below are adapted from GHC.Tc.Module.lookupInsts ; let cls_index = Map.fromListWith mappend [ (n, Seq.singleton ispec) | ispec <- instEnvElts ie_local ++ instEnvElts ie_global @@ -1357,7 +1357,7 @@ [ mkModule pid modname | p <- pkgs , not only_exposed || exposed p - , let pid = packageConfigId p + , let pid = mkUnit p , modname <- exposedModules p ++ map exportName (reexportedModules p) ] -} @@ -1489,7 +1489,7 @@ this_pkg = thisPackage dflags -- case maybe_pkg of - Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do + Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of Found _ m -> return m @@ -1501,7 +1501,7 @@ Nothing -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of - Found loc m | moduleUnitId m /= this_pkg -> return m + Found loc m | moduleUnit m /= this_pkg -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError dflags noSrcSpan mod_name err @@ -1545,7 +1545,7 @@ liftIO $ hscCheckSafe hsc_env m noSrcSpan -- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set InstalledUnitId) +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId) moduleTrustReqs m = withSession $ \hsc_env -> liftIO $ hscGetSafe hsc_env m noSrcSpan diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Builtin/Names/TH.hs @@ -0,0 +1,1093 @@ +-- %************************************************************************ +-- %* * +-- The known-key names for Template Haskell +-- %* * +-- %************************************************************************ + +module GHC.Builtin.Names.TH where + +import GHC.Prelude () + +import GHC.Builtin.Names( mk_known_key_name ) +import GHC.Unit +import GHC.Types.Name( Name ) +import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName ) +import GHC.Types.Name.Reader( RdrName, nameRdrName ) +import GHC.Types.Unique +import GHC.Data.FastString + +-- To add a name, do three things +-- +-- 1) Allocate a key +-- 2) Make a "Name" +-- 3) Add the name to templateHaskellNames + +templateHaskellNames :: [Name] +-- The names that are implicitly mentioned by ``bracket'' +-- Should stay in sync with the import list of GHC.HsToCore.Quote + +templateHaskellNames = [ + returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, + mkNameSName, + liftStringName, + unTypeName, + unTypeQName, + unsafeTExpCoerceName, + + -- Lit + charLName, stringLName, integerLName, intPrimLName, wordPrimLName, + floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, + charPrimLName, + -- Pat + litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, + conPName, tildePName, bangPName, infixPName, + asPName, wildPName, recPName, listPName, sigPName, viewPName, + -- FieldPat + fieldPatName, + -- Match + matchName, + -- Clause + clauseName, + -- Exp + varEName, conEName, litEName, appEName, appTypeEName, infixEName, + infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName, + tupEName, unboxedTupEName, unboxedSumEName, + condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName, + fromEName, fromThenEName, fromToEName, fromThenToEName, + listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName, + labelEName, implicitParamVarEName, + -- FieldExp + fieldExpName, + -- Body + guardedBName, normalBName, + -- Guard + normalGEName, patGEName, + -- Stmt + bindSName, letSName, noBindSName, parSName, recSName, + -- Dec + funDName, valDName, dataDName, newtypeDName, tySynDName, + classDName, instanceWithOverlapDName, + standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName, + pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, + pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, + dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, + dataInstDName, newtypeInstDName, tySynInstDName, + infixLDName, infixRDName, infixNDName, + roleAnnotDName, patSynDName, patSynSigDName, + implicitParamBindDName, + -- Cxt + cxtName, + + -- SourceUnpackedness + noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName, + -- SourceStrictness + noSourceStrictnessName, sourceLazyName, sourceStrictName, + -- Con + normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName, + -- Bang + bangName, + -- BangType + bangTypeName, + -- VarBangType + varBangTypeName, + -- PatSynDir (for pattern synonyms) + unidirPatSynName, implBidirPatSynName, explBidirPatSynName, + -- PatSynArgs (for pattern synonyms) + prefixPatSynName, infixPatSynName, recordPatSynName, + -- Type + forallTName, forallVisTName, varTName, conTName, infixTName, appTName, + appKindTName, equalityTName, tupleTName, unboxedTupleTName, + unboxedSumTName, arrowTName, listTName, sigTName, litTName, + promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, + wildCardTName, implicitParamTName, + -- TyLit + numTyLitName, strTyLitName, + -- TyVarBndr + plainTVName, kindedTVName, + -- Role + nominalRName, representationalRName, phantomRName, inferRName, + -- Kind + starKName, constraintKName, + -- FamilyResultSig + noSigName, kindSigName, tyVarSigName, + -- InjectivityAnn + injectivityAnnName, + -- Callconv + cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName, + -- Safety + unsafeName, + safeName, + interruptibleName, + -- Inline + noInlineDataConName, inlineDataConName, inlinableDataConName, + -- RuleMatch + conLikeDataConName, funLikeDataConName, + -- Phases + allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName, + -- Overlap + overlappableDataConName, overlappingDataConName, overlapsDataConName, + incoherentDataConName, + -- DerivStrategy + stockStrategyName, anyclassStrategyName, + newtypeStrategyName, viaStrategyName, + -- TExp + tExpDataConName, + -- RuleBndr + ruleVarName, typedRuleVarName, + -- FunDep + funDepName, + -- TySynEqn + tySynEqnName, + -- AnnTarget + valueAnnotationName, typeAnnotationName, moduleAnnotationName, + -- DerivClause + derivClauseName, + + -- The type classes + liftClassName, quoteClassName, + + -- And the tycons + qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchTyConName, + expQTyConName, fieldExpTyConName, predTyConName, + stmtTyConName, decsTyConName, conTyConName, bangTypeTyConName, + varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName, + typeTyConName, tyVarBndrTyConName, clauseTyConName, + patQTyConName, funDepTyConName, decsQTyConName, + ruleBndrTyConName, tySynEqnTyConName, + roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName, + overlapTyConName, derivClauseTyConName, derivStrategyTyConName, + + -- Quasiquoting + quoteDecName, quoteTypeName, quoteExpName, quotePatName] + +thSyn, thLib, qqLib :: Module +thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax") +thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal") +qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") + +mkTHModule :: FastString -> Module +mkTHModule m = mkModule thUnitId (mkModuleNameFS m) + +libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: 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 + +-------------------- TH.Syntax ----------------------- +liftClassName :: Name +liftClassName = thCls (fsLit "Lift") liftClassKey + +quoteClassName :: Name +quoteClassName = thCls (fsLit "Quote") quoteClassKey + +qTyConName, nameTyConName, fieldExpTyConName, patTyConName, + fieldPatTyConName, expTyConName, decTyConName, typeTyConName, + matchTyConName, clauseTyConName, funDepTyConName, predTyConName, + tExpTyConName, injAnnTyConName, overlapTyConName, decsTyConName :: Name +qTyConName = thTc (fsLit "Q") qTyConKey +nameTyConName = thTc (fsLit "Name") nameTyConKey +fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey +patTyConName = thTc (fsLit "Pat") patTyConKey +fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey +expTyConName = thTc (fsLit "Exp") expTyConKey +decTyConName = thTc (fsLit "Dec") decTyConKey +decsTyConName = libTc (fsLit "Decs") decsTyConKey +typeTyConName = thTc (fsLit "Type") typeTyConKey +matchTyConName = thTc (fsLit "Match") matchTyConKey +clauseTyConName = thTc (fsLit "Clause") clauseTyConKey +funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey +predTyConName = thTc (fsLit "Pred") predTyConKey +tExpTyConName = thTc (fsLit "TExp") tExpTyConKey +injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey +overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey + +returnQName, bindQName, sequenceQName, newNameName, liftName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, + mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName, + unsafeTExpCoerceName, liftTypedName :: Name +returnQName = thFun (fsLit "returnQ") returnQIdKey +bindQName = thFun (fsLit "bindQ") bindQIdKey +sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey +newNameName = thFun (fsLit "newName") newNameIdKey +liftName = thFun (fsLit "lift") liftIdKey +liftStringName = thFun (fsLit "liftString") liftStringIdKey +mkNameName = thFun (fsLit "mkName") mkNameIdKey +mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey +mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey +mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey +mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey +mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey +unTypeName = thFun (fsLit "unType") unTypeIdKey +unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey +unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey +liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey + + +-------------------- TH.Lib ----------------------- +-- data Lit = ... +charLName, stringLName, integerLName, intPrimLName, wordPrimLName, + floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, + charPrimLName :: Name +charLName = libFun (fsLit "charL") charLIdKey +stringLName = libFun (fsLit "stringL") stringLIdKey +integerLName = libFun (fsLit "integerL") integerLIdKey +intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey +wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey +floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey +doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey +rationalLName = libFun (fsLit "rationalL") rationalLIdKey +stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey +charPrimLName = libFun (fsLit "charPrimL") charPrimLIdKey + +-- data Pat = ... +litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName, + infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName, + sigPName, viewPName :: Name +litPName = libFun (fsLit "litP") litPIdKey +varPName = libFun (fsLit "varP") varPIdKey +tupPName = libFun (fsLit "tupP") tupPIdKey +unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey +unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey +conPName = libFun (fsLit "conP") conPIdKey +infixPName = libFun (fsLit "infixP") infixPIdKey +tildePName = libFun (fsLit "tildeP") tildePIdKey +bangPName = libFun (fsLit "bangP") bangPIdKey +asPName = libFun (fsLit "asP") asPIdKey +wildPName = libFun (fsLit "wildP") wildPIdKey +recPName = libFun (fsLit "recP") recPIdKey +listPName = libFun (fsLit "listP") listPIdKey +sigPName = libFun (fsLit "sigP") sigPIdKey +viewPName = libFun (fsLit "viewP") viewPIdKey + +-- type FieldPat = ... +fieldPatName :: Name +fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey + +-- data Match = ... +matchName :: Name +matchName = libFun (fsLit "match") matchIdKey + +-- data Clause = ... +clauseName :: Name +clauseName = libFun (fsLit "clause") clauseIdKey + +-- data Exp = ... +varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName, + sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, + unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName, + caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName, + labelEName, implicitParamVarEName :: Name +varEName = libFun (fsLit "varE") varEIdKey +conEName = libFun (fsLit "conE") conEIdKey +litEName = libFun (fsLit "litE") litEIdKey +appEName = libFun (fsLit "appE") appEIdKey +appTypeEName = libFun (fsLit "appTypeE") appTypeEIdKey +infixEName = libFun (fsLit "infixE") infixEIdKey +infixAppName = libFun (fsLit "infixApp") infixAppIdKey +sectionLName = libFun (fsLit "sectionL") sectionLIdKey +sectionRName = libFun (fsLit "sectionR") sectionRIdKey +lamEName = libFun (fsLit "lamE") lamEIdKey +lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey +tupEName = libFun (fsLit "tupE") tupEIdKey +unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey +unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey +condEName = libFun (fsLit "condE") condEIdKey +multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey +letEName = libFun (fsLit "letE") letEIdKey +caseEName = libFun (fsLit "caseE") caseEIdKey +doEName = libFun (fsLit "doE") doEIdKey +mdoEName = libFun (fsLit "mdoE") mdoEIdKey +compEName = libFun (fsLit "compE") compEIdKey +-- ArithSeq skips a level +fromEName, fromThenEName, fromToEName, fromThenToEName :: Name +fromEName = libFun (fsLit "fromE") fromEIdKey +fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey +fromToEName = libFun (fsLit "fromToE") fromToEIdKey +fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey +-- end ArithSeq +listEName, sigEName, recConEName, recUpdEName :: Name +listEName = libFun (fsLit "listE") listEIdKey +sigEName = libFun (fsLit "sigE") sigEIdKey +recConEName = libFun (fsLit "recConE") recConEIdKey +recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey +staticEName = libFun (fsLit "staticE") staticEIdKey +unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey +labelEName = libFun (fsLit "labelE") labelEIdKey +implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey + +-- type FieldExp = ... +fieldExpName :: Name +fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey + +-- data Body = ... +guardedBName, normalBName :: Name +guardedBName = libFun (fsLit "guardedB") guardedBIdKey +normalBName = libFun (fsLit "normalB") normalBIdKey + +-- data Guard = ... +normalGEName, patGEName :: Name +normalGEName = libFun (fsLit "normalGE") normalGEIdKey +patGEName = libFun (fsLit "patGE") patGEIdKey + +-- data Stmt = ... +bindSName, letSName, noBindSName, parSName, recSName :: Name +bindSName = libFun (fsLit "bindS") bindSIdKey +letSName = libFun (fsLit "letS") letSIdKey +noBindSName = libFun (fsLit "noBindS") noBindSIdKey +parSName = libFun (fsLit "parS") parSIdKey +recSName = libFun (fsLit "recS") recSIdKey + +-- data Dec = ... +funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, + instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName, + pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, + pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, + dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName, + openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName, + infixNDName, roleAnnotDName, patSynDName, patSynSigDName, + pragCompleteDName, implicitParamBindDName :: Name +funDName = libFun (fsLit "funD") funDIdKey +valDName = libFun (fsLit "valD") valDIdKey +dataDName = libFun (fsLit "dataD") dataDIdKey +newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey +tySynDName = libFun (fsLit "tySynD") tySynDIdKey +classDName = libFun (fsLit "classD") classDIdKey +instanceWithOverlapDName = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey +standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey +sigDName = libFun (fsLit "sigD") sigDIdKey +kiSigDName = libFun (fsLit "kiSigD") kiSigDIdKey +defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey +forImpDName = libFun (fsLit "forImpD") forImpDIdKey +pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey +pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey +pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey +pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey +pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey +pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey +pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey +dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey +newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey +tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey +openTypeFamilyDName = libFun (fsLit "openTypeFamilyD") openTypeFamilyDIdKey +closedTypeFamilyDName = libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey +dataFamilyDName = libFun (fsLit "dataFamilyD") dataFamilyDIdKey +infixLDName = libFun (fsLit "infixLD") infixLDIdKey +infixRDName = libFun (fsLit "infixRD") infixRDIdKey +infixNDName = libFun (fsLit "infixND") infixNDIdKey +roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey +patSynDName = libFun (fsLit "patSynD") patSynDIdKey +patSynSigDName = libFun (fsLit "patSynSigD") patSynSigDIdKey +implicitParamBindDName = libFun (fsLit "implicitParamBindD") implicitParamBindDIdKey + +-- type Ctxt = ... +cxtName :: Name +cxtName = libFun (fsLit "cxt") cxtIdKey + +-- data SourceUnpackedness = ... +noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name +noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey +sourceNoUnpackName = libFun (fsLit "sourceNoUnpack") sourceNoUnpackKey +sourceUnpackName = libFun (fsLit "sourceUnpack") sourceUnpackKey + +-- data SourceStrictness = ... +noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name +noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey +sourceLazyName = libFun (fsLit "sourceLazy") sourceLazyKey +sourceStrictName = libFun (fsLit "sourceStrict") sourceStrictKey + +-- data Con = ... +normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name +normalCName = libFun (fsLit "normalC" ) normalCIdKey +recCName = libFun (fsLit "recC" ) recCIdKey +infixCName = libFun (fsLit "infixC" ) infixCIdKey +forallCName = libFun (fsLit "forallC" ) forallCIdKey +gadtCName = libFun (fsLit "gadtC" ) gadtCIdKey +recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey + +-- data Bang = ... +bangName :: Name +bangName = libFun (fsLit "bang") bangIdKey + +-- type BangType = ... +bangTypeName :: Name +bangTypeName = libFun (fsLit "bangType") bangTKey + +-- type VarBangType = ... +varBangTypeName :: Name +varBangTypeName = libFun (fsLit "varBangType") varBangTKey + +-- data PatSynDir = ... +unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name +unidirPatSynName = libFun (fsLit "unidir") unidirPatSynIdKey +implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey +explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey + +-- data PatSynArgs = ... +prefixPatSynName, infixPatSynName, recordPatSynName :: Name +prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey +infixPatSynName = libFun (fsLit "infixPatSyn") infixPatSynIdKey +recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey + +-- data Type = ... +forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName, + unboxedTupleTName, unboxedSumTName, arrowTName, listTName, appTName, + appKindTName, sigTName, equalityTName, litTName, promotedTName, + promotedTupleTName, promotedNilTName, promotedConsTName, + wildCardTName, implicitParamTName :: Name +forallTName = libFun (fsLit "forallT") forallTIdKey +forallVisTName = libFun (fsLit "forallVisT") forallVisTIdKey +varTName = libFun (fsLit "varT") varTIdKey +conTName = libFun (fsLit "conT") conTIdKey +tupleTName = libFun (fsLit "tupleT") tupleTIdKey +unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey +unboxedSumTName = libFun (fsLit "unboxedSumT") unboxedSumTIdKey +arrowTName = libFun (fsLit "arrowT") arrowTIdKey +listTName = libFun (fsLit "listT") listTIdKey +appTName = libFun (fsLit "appT") appTIdKey +appKindTName = libFun (fsLit "appKindT") appKindTIdKey +sigTName = libFun (fsLit "sigT") sigTIdKey +equalityTName = libFun (fsLit "equalityT") equalityTIdKey +litTName = libFun (fsLit "litT") litTIdKey +promotedTName = libFun (fsLit "promotedT") promotedTIdKey +promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey +promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey +promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey +wildCardTName = libFun (fsLit "wildCardT") wildCardTIdKey +infixTName = libFun (fsLit "infixT") infixTIdKey +implicitParamTName = libFun (fsLit "implicitParamT") implicitParamTIdKey + +-- data TyLit = ... +numTyLitName, strTyLitName :: Name +numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey +strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey + +-- data TyVarBndr = ... +plainTVName, kindedTVName :: Name +plainTVName = libFun (fsLit "plainTV") plainTVIdKey +kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey + +-- data Role = ... +nominalRName, representationalRName, phantomRName, inferRName :: Name +nominalRName = libFun (fsLit "nominalR") nominalRIdKey +representationalRName = libFun (fsLit "representationalR") representationalRIdKey +phantomRName = libFun (fsLit "phantomR") phantomRIdKey +inferRName = libFun (fsLit "inferR") inferRIdKey + +-- data Kind = ... +starKName, constraintKName :: Name +starKName = libFun (fsLit "starK") starKIdKey +constraintKName = libFun (fsLit "constraintK") constraintKIdKey + +-- data FamilyResultSig = ... +noSigName, kindSigName, tyVarSigName :: Name +noSigName = libFun (fsLit "noSig") noSigIdKey +kindSigName = libFun (fsLit "kindSig") kindSigIdKey +tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey + +-- data InjectivityAnn = ... +injectivityAnnName :: Name +injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey + +-- data Callconv = ... +cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name +cCallName = libFun (fsLit "cCall") cCallIdKey +stdCallName = libFun (fsLit "stdCall") stdCallIdKey +cApiCallName = libFun (fsLit "cApi") cApiCallIdKey +primCallName = libFun (fsLit "prim") primCallIdKey +javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey + +-- data Safety = ... +unsafeName, safeName, interruptibleName :: Name +unsafeName = libFun (fsLit "unsafe") unsafeIdKey +safeName = libFun (fsLit "safe") safeIdKey +interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey + +-- newtype TExp a = ... +tExpDataConName :: Name +tExpDataConName = thCon (fsLit "TExp") tExpDataConKey + +-- data RuleBndr = ... +ruleVarName, typedRuleVarName :: Name +ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey +typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey + +-- data FunDep = ... +funDepName :: Name +funDepName = libFun (fsLit "funDep") funDepIdKey + +-- data TySynEqn = ... +tySynEqnName :: Name +tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey + +-- data AnnTarget = ... +valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name +valueAnnotationName = libFun (fsLit "valueAnnotation") valueAnnotationIdKey +typeAnnotationName = libFun (fsLit "typeAnnotation") typeAnnotationIdKey +moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey + +-- type DerivClause = ... +derivClauseName :: Name +derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey + +-- data DerivStrategy = ... +stockStrategyName, anyclassStrategyName, newtypeStrategyName, + viaStrategyName :: Name +stockStrategyName = libFun (fsLit "stockStrategy") stockStrategyIdKey +anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey +newtypeStrategyName = libFun (fsLit "newtypeStrategy") newtypeStrategyIdKey +viaStrategyName = libFun (fsLit "viaStrategy") viaStrategyIdKey + +patQTyConName, expQTyConName, stmtTyConName, + conTyConName, bangTypeTyConName, + varBangTypeTyConName, typeQTyConName, + decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName, + derivClauseTyConName, kindTyConName, tyVarBndrTyConName, + derivStrategyTyConName :: Name +-- These are only used for the types of top-level splices +expQTyConName = libTc (fsLit "ExpQ") expQTyConKey +decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec] +typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey +patQTyConName = libTc (fsLit "PatQ") patQTyConKey + +-- These are used in GHC.HsToCore.Quote but always wrapped in a type variable +stmtTyConName = thTc (fsLit "Stmt") stmtTyConKey +conTyConName = thTc (fsLit "Con") conTyConKey +bangTypeTyConName = thTc (fsLit "BangType") bangTypeTyConKey +varBangTypeTyConName = thTc (fsLit "VarBangType") varBangTypeTyConKey +ruleBndrTyConName = thTc (fsLit "RuleBndr") ruleBndrTyConKey +tySynEqnTyConName = thTc (fsLit "TySynEqn") tySynEqnTyConKey +roleTyConName = libTc (fsLit "Role") roleTyConKey +derivClauseTyConName = thTc (fsLit "DerivClause") derivClauseTyConKey +kindTyConName = thTc (fsLit "Kind") kindTyConKey +tyVarBndrTyConName = thTc (fsLit "TyVarBndr") tyVarBndrTyConKey +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 + +-- data Inline = ... +noInlineDataConName, inlineDataConName, inlinableDataConName :: Name +noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey +inlineDataConName = thCon (fsLit "Inline") inlineDataConKey +inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey + +-- data RuleMatch = ... +conLikeDataConName, funLikeDataConName :: Name +conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey +funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey + +-- data Phases = ... +allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name +allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey +fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey +beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey + +-- data Overlap = ... +overlappableDataConName, + overlappingDataConName, + overlapsDataConName, + incoherentDataConName :: Name +overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey +overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey +overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey +incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey + +{- ********************************************************************* +* * + Class keys +* * +********************************************************************* -} + +-- ClassUniques available: 200-299 +-- Check in GHC.Builtin.Names if you want to change this + +liftClassKey :: Unique +liftClassKey = mkPreludeClassUnique 200 + +quoteClassKey :: Unique +quoteClassKey = mkPreludeClassUnique 201 + +{- ********************************************************************* +* * + TyCon keys +* * +********************************************************************* -} + +-- TyConUniques available: 200-299 +-- Check in GHC.Builtin.Names if you want to change this + +expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, + patTyConKey, + stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey, + tyVarBndrTyConKey, decTyConKey, bangTypeTyConKey, varBangTypeTyConKey, + fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, + funDepTyConKey, predTyConKey, + predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey, + roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey, + overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey + :: Unique +expTyConKey = mkPreludeTyConUnique 200 +matchTyConKey = mkPreludeTyConUnique 201 +clauseTyConKey = mkPreludeTyConUnique 202 +qTyConKey = mkPreludeTyConUnique 203 +expQTyConKey = mkPreludeTyConUnique 204 +patTyConKey = mkPreludeTyConUnique 206 +stmtTyConKey = mkPreludeTyConUnique 209 +conTyConKey = mkPreludeTyConUnique 210 +typeQTyConKey = mkPreludeTyConUnique 211 +typeTyConKey = mkPreludeTyConUnique 212 +decTyConKey = mkPreludeTyConUnique 213 +bangTypeTyConKey = mkPreludeTyConUnique 214 +varBangTypeTyConKey = mkPreludeTyConUnique 215 +fieldExpTyConKey = mkPreludeTyConUnique 216 +fieldPatTyConKey = mkPreludeTyConUnique 217 +nameTyConKey = mkPreludeTyConUnique 218 +patQTyConKey = mkPreludeTyConUnique 219 +funDepTyConKey = mkPreludeTyConUnique 222 +predTyConKey = mkPreludeTyConUnique 223 +predQTyConKey = mkPreludeTyConUnique 224 +tyVarBndrTyConKey = mkPreludeTyConUnique 225 +decsQTyConKey = mkPreludeTyConUnique 226 +ruleBndrTyConKey = mkPreludeTyConUnique 227 +tySynEqnTyConKey = mkPreludeTyConUnique 228 +roleTyConKey = mkPreludeTyConUnique 229 +tExpTyConKey = mkPreludeTyConUnique 230 +injAnnTyConKey = mkPreludeTyConUnique 231 +kindTyConKey = mkPreludeTyConUnique 232 +overlapTyConKey = mkPreludeTyConUnique 233 +derivClauseTyConKey = mkPreludeTyConUnique 234 +derivStrategyTyConKey = mkPreludeTyConUnique 235 +decsTyConKey = mkPreludeTyConUnique 236 + +{- ********************************************************************* +* * + DataCon keys +* * +********************************************************************* -} + +-- DataConUniques available: 100-150 +-- If you want to change this, make sure you check in GHC.Builtin.Names + +-- data Inline = ... +noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique +noInlineDataConKey = mkPreludeDataConUnique 200 +inlineDataConKey = mkPreludeDataConUnique 201 +inlinableDataConKey = mkPreludeDataConUnique 202 + +-- data RuleMatch = ... +conLikeDataConKey, funLikeDataConKey :: Unique +conLikeDataConKey = mkPreludeDataConUnique 203 +funLikeDataConKey = mkPreludeDataConUnique 204 + +-- data Phases = ... +allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique +allPhasesDataConKey = mkPreludeDataConUnique 205 +fromPhaseDataConKey = mkPreludeDataConUnique 206 +beforePhaseDataConKey = mkPreludeDataConUnique 207 + +-- newtype TExp a = ... +tExpDataConKey :: Unique +tExpDataConKey = mkPreludeDataConUnique 208 + +-- data Overlap = .. +overlappableDataConKey, + overlappingDataConKey, + overlapsDataConKey, + incoherentDataConKey :: Unique +overlappableDataConKey = mkPreludeDataConUnique 209 +overlappingDataConKey = mkPreludeDataConUnique 210 +overlapsDataConKey = mkPreludeDataConUnique 211 +incoherentDataConKey = mkPreludeDataConUnique 212 + +{- ********************************************************************* +* * + Id keys +* * +********************************************************************* -} + +-- IdUniques available: 200-499 +-- 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, + mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey, + unsafeTExpCoerceIdKey, liftTypedIdKey :: Unique +returnQIdKey = mkPreludeMiscIdUnique 200 +bindQIdKey = mkPreludeMiscIdUnique 201 +sequenceQIdKey = mkPreludeMiscIdUnique 202 +liftIdKey = mkPreludeMiscIdUnique 203 +newNameIdKey = mkPreludeMiscIdUnique 204 +mkNameIdKey = mkPreludeMiscIdUnique 205 +mkNameG_vIdKey = mkPreludeMiscIdUnique 206 +mkNameG_dIdKey = mkPreludeMiscIdUnique 207 +mkNameG_tcIdKey = mkPreludeMiscIdUnique 208 +mkNameLIdKey = mkPreludeMiscIdUnique 209 +mkNameSIdKey = mkPreludeMiscIdUnique 210 +unTypeIdKey = mkPreludeMiscIdUnique 211 +unTypeQIdKey = mkPreludeMiscIdUnique 212 +unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213 +liftTypedIdKey = mkPreludeMiscIdUnique 214 + + +-- data Lit = ... +charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey, + floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey, + charPrimLIdKey:: Unique +charLIdKey = mkPreludeMiscIdUnique 220 +stringLIdKey = mkPreludeMiscIdUnique 221 +integerLIdKey = mkPreludeMiscIdUnique 222 +intPrimLIdKey = mkPreludeMiscIdUnique 223 +wordPrimLIdKey = mkPreludeMiscIdUnique 224 +floatPrimLIdKey = mkPreludeMiscIdUnique 225 +doublePrimLIdKey = mkPreludeMiscIdUnique 226 +rationalLIdKey = mkPreludeMiscIdUnique 227 +stringPrimLIdKey = mkPreludeMiscIdUnique 228 +charPrimLIdKey = mkPreludeMiscIdUnique 229 + +liftStringIdKey :: Unique +liftStringIdKey = mkPreludeMiscIdUnique 230 + +-- data Pat = ... +litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey, + infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, + listPIdKey, sigPIdKey, viewPIdKey :: Unique +litPIdKey = mkPreludeMiscIdUnique 240 +varPIdKey = mkPreludeMiscIdUnique 241 +tupPIdKey = mkPreludeMiscIdUnique 242 +unboxedTupPIdKey = mkPreludeMiscIdUnique 243 +unboxedSumPIdKey = mkPreludeMiscIdUnique 244 +conPIdKey = mkPreludeMiscIdUnique 245 +infixPIdKey = mkPreludeMiscIdUnique 246 +tildePIdKey = mkPreludeMiscIdUnique 247 +bangPIdKey = mkPreludeMiscIdUnique 248 +asPIdKey = mkPreludeMiscIdUnique 249 +wildPIdKey = mkPreludeMiscIdUnique 250 +recPIdKey = mkPreludeMiscIdUnique 251 +listPIdKey = mkPreludeMiscIdUnique 252 +sigPIdKey = mkPreludeMiscIdUnique 253 +viewPIdKey = mkPreludeMiscIdUnique 254 + +-- type FieldPat = ... +fieldPatIdKey :: Unique +fieldPatIdKey = mkPreludeMiscIdUnique 260 + +-- data Match = ... +matchIdKey :: Unique +matchIdKey = mkPreludeMiscIdUnique 261 + +-- data Clause = ... +clauseIdKey :: Unique +clauseIdKey = mkPreludeMiscIdUnique 262 + + +-- data Exp = ... +varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey, + infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, + tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey, + letEIdKey, caseEIdKey, doEIdKey, compEIdKey, + fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, + listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey, + unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey :: Unique +varEIdKey = mkPreludeMiscIdUnique 270 +conEIdKey = mkPreludeMiscIdUnique 271 +litEIdKey = mkPreludeMiscIdUnique 272 +appEIdKey = mkPreludeMiscIdUnique 273 +appTypeEIdKey = mkPreludeMiscIdUnique 274 +infixEIdKey = mkPreludeMiscIdUnique 275 +infixAppIdKey = mkPreludeMiscIdUnique 276 +sectionLIdKey = mkPreludeMiscIdUnique 277 +sectionRIdKey = mkPreludeMiscIdUnique 278 +lamEIdKey = mkPreludeMiscIdUnique 279 +lamCaseEIdKey = mkPreludeMiscIdUnique 280 +tupEIdKey = mkPreludeMiscIdUnique 281 +unboxedTupEIdKey = mkPreludeMiscIdUnique 282 +unboxedSumEIdKey = mkPreludeMiscIdUnique 283 +condEIdKey = mkPreludeMiscIdUnique 284 +multiIfEIdKey = mkPreludeMiscIdUnique 285 +letEIdKey = mkPreludeMiscIdUnique 286 +caseEIdKey = mkPreludeMiscIdUnique 287 +doEIdKey = mkPreludeMiscIdUnique 288 +compEIdKey = mkPreludeMiscIdUnique 289 +fromEIdKey = mkPreludeMiscIdUnique 290 +fromThenEIdKey = mkPreludeMiscIdUnique 291 +fromToEIdKey = mkPreludeMiscIdUnique 292 +fromThenToEIdKey = mkPreludeMiscIdUnique 293 +listEIdKey = mkPreludeMiscIdUnique 294 +sigEIdKey = mkPreludeMiscIdUnique 295 +recConEIdKey = mkPreludeMiscIdUnique 296 +recUpdEIdKey = mkPreludeMiscIdUnique 297 +staticEIdKey = mkPreludeMiscIdUnique 298 +unboundVarEIdKey = mkPreludeMiscIdUnique 299 +labelEIdKey = mkPreludeMiscIdUnique 300 +implicitParamVarEIdKey = mkPreludeMiscIdUnique 301 +mdoEIdKey = mkPreludeMiscIdUnique 302 + +-- type FieldExp = ... +fieldExpIdKey :: Unique +fieldExpIdKey = mkPreludeMiscIdUnique 305 + +-- data Body = ... +guardedBIdKey, normalBIdKey :: Unique +guardedBIdKey = mkPreludeMiscIdUnique 306 +normalBIdKey = mkPreludeMiscIdUnique 307 + +-- data Guard = ... +normalGEIdKey, patGEIdKey :: Unique +normalGEIdKey = mkPreludeMiscIdUnique 308 +patGEIdKey = mkPreludeMiscIdUnique 309 + +-- data Stmt = ... +bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique +bindSIdKey = mkPreludeMiscIdUnique 310 +letSIdKey = mkPreludeMiscIdUnique 311 +noBindSIdKey = mkPreludeMiscIdUnique 312 +parSIdKey = mkPreludeMiscIdUnique 313 +recSIdKey = mkPreludeMiscIdUnique 314 + +-- data Dec = ... +funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, + instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, + pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, + pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey, + openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey, + newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey, + infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey, + patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey, + kiSigDIdKey :: Unique +funDIdKey = mkPreludeMiscIdUnique 320 +valDIdKey = mkPreludeMiscIdUnique 321 +dataDIdKey = mkPreludeMiscIdUnique 322 +newtypeDIdKey = mkPreludeMiscIdUnique 323 +tySynDIdKey = mkPreludeMiscIdUnique 324 +classDIdKey = mkPreludeMiscIdUnique 325 +instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 326 +instanceDIdKey = mkPreludeMiscIdUnique 327 +sigDIdKey = mkPreludeMiscIdUnique 328 +forImpDIdKey = mkPreludeMiscIdUnique 329 +pragInlDIdKey = mkPreludeMiscIdUnique 330 +pragSpecDIdKey = mkPreludeMiscIdUnique 331 +pragSpecInlDIdKey = mkPreludeMiscIdUnique 332 +pragSpecInstDIdKey = mkPreludeMiscIdUnique 333 +pragRuleDIdKey = mkPreludeMiscIdUnique 334 +pragAnnDIdKey = mkPreludeMiscIdUnique 335 +dataFamilyDIdKey = mkPreludeMiscIdUnique 336 +openTypeFamilyDIdKey = mkPreludeMiscIdUnique 337 +dataInstDIdKey = mkPreludeMiscIdUnique 338 +newtypeInstDIdKey = mkPreludeMiscIdUnique 339 +tySynInstDIdKey = mkPreludeMiscIdUnique 340 +closedTypeFamilyDIdKey = mkPreludeMiscIdUnique 341 +infixLDIdKey = mkPreludeMiscIdUnique 342 +infixRDIdKey = mkPreludeMiscIdUnique 343 +infixNDIdKey = mkPreludeMiscIdUnique 344 +roleAnnotDIdKey = mkPreludeMiscIdUnique 345 +standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346 +defaultSigDIdKey = mkPreludeMiscIdUnique 347 +patSynDIdKey = mkPreludeMiscIdUnique 348 +patSynSigDIdKey = mkPreludeMiscIdUnique 349 +pragCompleteDIdKey = mkPreludeMiscIdUnique 350 +implicitParamBindDIdKey = mkPreludeMiscIdUnique 351 +kiSigDIdKey = mkPreludeMiscIdUnique 352 + +-- type Cxt = ... +cxtIdKey :: Unique +cxtIdKey = mkPreludeMiscIdUnique 361 + +-- data SourceUnpackedness = ... +noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique +noSourceUnpackednessKey = mkPreludeMiscIdUnique 362 +sourceNoUnpackKey = mkPreludeMiscIdUnique 363 +sourceUnpackKey = mkPreludeMiscIdUnique 364 + +-- data SourceStrictness = ... +noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique +noSourceStrictnessKey = mkPreludeMiscIdUnique 365 +sourceLazyKey = mkPreludeMiscIdUnique 366 +sourceStrictKey = mkPreludeMiscIdUnique 367 + +-- data Con = ... +normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey, + recGadtCIdKey :: Unique +normalCIdKey = mkPreludeMiscIdUnique 368 +recCIdKey = mkPreludeMiscIdUnique 369 +infixCIdKey = mkPreludeMiscIdUnique 370 +forallCIdKey = mkPreludeMiscIdUnique 371 +gadtCIdKey = mkPreludeMiscIdUnique 372 +recGadtCIdKey = mkPreludeMiscIdUnique 373 + +-- data Bang = ... +bangIdKey :: Unique +bangIdKey = mkPreludeMiscIdUnique 374 + +-- type BangType = ... +bangTKey :: Unique +bangTKey = mkPreludeMiscIdUnique 375 + +-- type VarBangType = ... +varBangTKey :: Unique +varBangTKey = mkPreludeMiscIdUnique 376 + +-- data PatSynDir = ... +unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique +unidirPatSynIdKey = mkPreludeMiscIdUnique 377 +implBidirPatSynIdKey = mkPreludeMiscIdUnique 378 +explBidirPatSynIdKey = mkPreludeMiscIdUnique 379 + +-- data PatSynArgs = ... +prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique +prefixPatSynIdKey = mkPreludeMiscIdUnique 380 +infixPatSynIdKey = mkPreludeMiscIdUnique 381 +recordPatSynIdKey = mkPreludeMiscIdUnique 382 + +-- data Type = ... +forallTIdKey, forallVisTIdKey, varTIdKey, conTIdKey, tupleTIdKey, + unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, + appKindTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey, + promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey, + wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique +forallTIdKey = mkPreludeMiscIdUnique 390 +forallVisTIdKey = mkPreludeMiscIdUnique 391 +varTIdKey = mkPreludeMiscIdUnique 392 +conTIdKey = mkPreludeMiscIdUnique 393 +tupleTIdKey = mkPreludeMiscIdUnique 394 +unboxedTupleTIdKey = mkPreludeMiscIdUnique 395 +unboxedSumTIdKey = mkPreludeMiscIdUnique 396 +arrowTIdKey = mkPreludeMiscIdUnique 397 +listTIdKey = mkPreludeMiscIdUnique 398 +appTIdKey = mkPreludeMiscIdUnique 399 +appKindTIdKey = mkPreludeMiscIdUnique 400 +sigTIdKey = mkPreludeMiscIdUnique 401 +equalityTIdKey = mkPreludeMiscIdUnique 402 +litTIdKey = mkPreludeMiscIdUnique 403 +promotedTIdKey = mkPreludeMiscIdUnique 404 +promotedTupleTIdKey = mkPreludeMiscIdUnique 405 +promotedNilTIdKey = mkPreludeMiscIdUnique 406 +promotedConsTIdKey = mkPreludeMiscIdUnique 407 +wildCardTIdKey = mkPreludeMiscIdUnique 408 +implicitParamTIdKey = mkPreludeMiscIdUnique 409 +infixTIdKey = mkPreludeMiscIdUnique 410 + +-- data TyLit = ... +numTyLitIdKey, strTyLitIdKey :: Unique +numTyLitIdKey = mkPreludeMiscIdUnique 411 +strTyLitIdKey = mkPreludeMiscIdUnique 412 + +-- data TyVarBndr = ... +plainTVIdKey, kindedTVIdKey :: Unique +plainTVIdKey = mkPreludeMiscIdUnique 413 +kindedTVIdKey = mkPreludeMiscIdUnique 414 + +-- data Role = ... +nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique +nominalRIdKey = mkPreludeMiscIdUnique 415 +representationalRIdKey = mkPreludeMiscIdUnique 416 +phantomRIdKey = mkPreludeMiscIdUnique 417 +inferRIdKey = mkPreludeMiscIdUnique 418 + +-- data Kind = ... +starKIdKey, constraintKIdKey :: Unique +starKIdKey = mkPreludeMiscIdUnique 425 +constraintKIdKey = mkPreludeMiscIdUnique 426 + +-- data FamilyResultSig = ... +noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique +noSigIdKey = mkPreludeMiscIdUnique 427 +kindSigIdKey = mkPreludeMiscIdUnique 428 +tyVarSigIdKey = mkPreludeMiscIdUnique 429 + +-- data InjectivityAnn = ... +injectivityAnnIdKey :: Unique +injectivityAnnIdKey = mkPreludeMiscIdUnique 430 + +-- data Callconv = ... +cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey, + javaScriptCallIdKey :: Unique +cCallIdKey = mkPreludeMiscIdUnique 431 +stdCallIdKey = mkPreludeMiscIdUnique 432 +cApiCallIdKey = mkPreludeMiscIdUnique 433 +primCallIdKey = mkPreludeMiscIdUnique 434 +javaScriptCallIdKey = mkPreludeMiscIdUnique 435 + +-- data Safety = ... +unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique +unsafeIdKey = mkPreludeMiscIdUnique 440 +safeIdKey = mkPreludeMiscIdUnique 441 +interruptibleIdKey = mkPreludeMiscIdUnique 442 + +-- data FunDep = ... +funDepIdKey :: Unique +funDepIdKey = mkPreludeMiscIdUnique 445 + +-- data TySynEqn = ... +tySynEqnIdKey :: Unique +tySynEqnIdKey = mkPreludeMiscIdUnique 460 + +-- quasiquoting +quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique +quoteExpKey = mkPreludeMiscIdUnique 470 +quotePatKey = mkPreludeMiscIdUnique 471 +quoteDecKey = mkPreludeMiscIdUnique 472 +quoteTypeKey = mkPreludeMiscIdUnique 473 + +-- data RuleBndr = ... +ruleVarIdKey, typedRuleVarIdKey :: Unique +ruleVarIdKey = mkPreludeMiscIdUnique 480 +typedRuleVarIdKey = mkPreludeMiscIdUnique 481 + +-- data AnnTarget = ... +valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique +valueAnnotationIdKey = mkPreludeMiscIdUnique 490 +typeAnnotationIdKey = mkPreludeMiscIdUnique 491 +moduleAnnotationIdKey = mkPreludeMiscIdUnique 492 + +-- type DerivPred = ... +derivClauseIdKey :: Unique +derivClauseIdKey = mkPreludeMiscIdUnique 493 + +-- data DerivStrategy = ... +stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey, + viaStrategyIdKey :: Unique +stockStrategyIdKey = mkPreludeDataConUnique 494 +anyclassStrategyIdKey = mkPreludeDataConUnique 495 +newtypeStrategyIdKey = mkPreludeDataConUnique 496 +viaStrategyIdKey = mkPreludeDataConUnique 497 + +{- +************************************************************************ +* * + RdrNames +* * +************************************************************************ +-} + +lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName +lift_RDR = nameRdrName liftName +liftTyped_RDR = nameRdrName liftTypedName +mkNameG_dRDR = nameRdrName mkNameG_dName +mkNameG_vRDR = nameRdrName mkNameG_vName + +-- data Exp = ... +conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName +conE_RDR = nameRdrName conEName +litE_RDR = nameRdrName litEName +appE_RDR = nameRdrName appEName +infixApp_RDR = nameRdrName infixAppName + +-- data Lit = ... +stringL_RDR, intPrimL_RDR, wordPrimL_RDR, floatPrimL_RDR, + doublePrimL_RDR, stringPrimL_RDR, charPrimL_RDR :: RdrName +stringL_RDR = nameRdrName stringLName +intPrimL_RDR = nameRdrName intPrimLName +wordPrimL_RDR = nameRdrName wordPrimLName +floatPrimL_RDR = nameRdrName floatPrimLName +doublePrimL_RDR = nameRdrName doublePrimLName +stringPrimL_RDR = nameRdrName stringPrimLName +charPrimL_RDR = nameRdrName charPrimLName diff --git a/compiler/GHC/Builtin/Types/Literals.hs b/compiler/GHC/Builtin/Types/Literals.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Builtin/Types/Literals.hs @@ -0,0 +1,991 @@ +{-# LANGUAGE LambdaCase #-} + +module GHC.Builtin.Types.Literals + ( typeNatTyCons + , typeNatCoAxiomRules + , BuiltInSynFamily(..) + + -- If you define a new built-in type family, make sure to export its TyCon + -- from here as well. + -- See Note [Adding built-in type families] + , typeNatAddTyCon + , typeNatMulTyCon + , typeNatExpTyCon + , typeNatLeqTyCon + , typeNatSubTyCon + , typeNatDivTyCon + , typeNatModTyCon + , typeNatLogTyCon + , typeNatCmpTyCon + , typeSymbolCmpTyCon + , typeSymbolAppendTyCon + ) where + +import GHC.Prelude + +import GHC.Core.Type +import GHC.Data.Pair +import GHC.Tc.Utils.TcType ( TcType, tcEqType ) +import GHC.Core.TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon + , Injectivity(..) ) +import GHC.Core.Coercion ( Role(..) ) +import GHC.Tc.Types.Constraint ( Xi ) +import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn ) +import GHC.Types.Name ( Name, BuiltInSyntax(..) ) +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim ( mkTemplateAnonTyConBinders ) +import GHC.Builtin.Names + ( gHC_TYPELITS + , gHC_TYPENATS + , typeNatAddTyFamNameKey + , typeNatMulTyFamNameKey + , typeNatExpTyFamNameKey + , typeNatLeqTyFamNameKey + , typeNatSubTyFamNameKey + , typeNatDivTyFamNameKey + , typeNatModTyFamNameKey + , typeNatLogTyFamNameKey + , typeNatCmpTyFamNameKey + , typeSymbolCmpTyFamNameKey + , typeSymbolAppendFamNameKey + ) +import GHC.Data.FastString +import qualified Data.Map as Map +import Data.Maybe ( isJust ) +import Control.Monad ( guard ) +import Data.List ( isPrefixOf, isSuffixOf ) + +{- +Note [Type-level literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are currently two forms of type-level literals: natural numbers, and +symbols (even though this module is named GHC.Builtin.Types.Literals, it covers both). + +Type-level literals are supported by CoAxiomRules (conditional axioms), which +power the built-in type families (see Note [Adding built-in type families]). +Currently, all built-in type families are for the express purpose of supporting +type-level literals. + +See also the Wiki page: + + https://gitlab.haskell.org/ghc/ghc/wikis/type-nats + +Note [Adding built-in type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a few steps to adding a built-in type family: + +* Adding a unique for the type family TyCon + + These go in GHC.Builtin.Names. It will likely be of the form + @myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that + has not been chosen before in GHC.Builtin.Names. There are several examples already + in GHC.Builtin.Names—see, for instance, typeNatAddTyFamNameKey. + +* Adding the type family TyCon itself + + This goes in GHC.Builtin.Types.Literals. There are plenty of examples of how to define + these—see, for instance, typeNatAddTyCon. + + Once your TyCon has been defined, be sure to: + + - Export it from GHC.Builtin.Types.Literals. (Not doing so caused #14632.) + - Include it in the typeNatTyCons list, defined in GHC.Builtin.Types.Literals. + +* Exposing associated type family axioms + + When defining the type family TyCon, you will need to define an axiom for + the type family in general (see, for instance, axAddDef), and perhaps other + auxiliary axioms for special cases of the type family (see, for instance, + axAdd0L and axAdd0R). + + After you have defined all of these axioms, be sure to include them in the + typeNatCoAxiomRules list, defined in GHC.Builtin.Types.Literals. + (Not doing so caused #14934.) + +* Define the type family somewhere + + Finally, you will need to define the type family somewhere, likely in @base@. + Currently, all of the built-in type families are defined in GHC.TypeLits or + GHC.TypeNats, so those are likely candidates. + + Since the behavior of your built-in type family is specified in GHC.Builtin.Types.Literals, + you should give an open type family definition with no instances, like so: + + type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat + + Changing the argument and result kinds as appropriate. + +* Update the relevant test cases + + The GHC test suite will likely need to be updated after you add your built-in + type family. For instance: + + - The T9181 test prints the :browse contents of GHC.TypeLits, so if you added + a test there, the expected output of T9181 will need to change. + - The TcTypeNatSimple and TcTypeSymbolSimple tests have compile-time unit + tests, as well as TcTypeNatSimpleRun and TcTypeSymbolSimpleRun, which have + runtime unit tests. Consider adding further unit tests to those if your + built-in type family deals with Nats or Symbols, respectively. +-} + +{------------------------------------------------------------------------------- +Built-in type constructors for functions on type-level nats +-} + +-- The list of built-in type family TyCons that GHC uses. +-- If you define a built-in type family, make sure to add it to this list. +-- See Note [Adding built-in type families] +typeNatTyCons :: [TyCon] +typeNatTyCons = + [ typeNatAddTyCon + , typeNatMulTyCon + , typeNatExpTyCon + , typeNatLeqTyCon + , typeNatSubTyCon + , typeNatDivTyCon + , typeNatModTyCon + , typeNatLogTyCon + , typeNatCmpTyCon + , typeSymbolCmpTyCon + , typeSymbolAppendTyCon + ] + +typeNatAddTyCon :: TyCon +typeNatAddTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamAdd + , sfInteractTop = interactTopAdd + , sfInteractInert = interactInertAdd + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "+") + typeNatAddTyFamNameKey typeNatAddTyCon + +typeNatSubTyCon :: TyCon +typeNatSubTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamSub + , sfInteractTop = interactTopSub + , sfInteractInert = interactInertSub + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "-") + typeNatSubTyFamNameKey typeNatSubTyCon + +typeNatMulTyCon :: TyCon +typeNatMulTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamMul + , sfInteractTop = interactTopMul + , sfInteractInert = interactInertMul + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "*") + typeNatMulTyFamNameKey typeNatMulTyCon + +typeNatDivTyCon :: TyCon +typeNatDivTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamDiv + , sfInteractTop = interactTopDiv + , sfInteractInert = interactInertDiv + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Div") + typeNatDivTyFamNameKey typeNatDivTyCon + +typeNatModTyCon :: TyCon +typeNatModTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamMod + , sfInteractTop = interactTopMod + , sfInteractInert = interactInertMod + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod") + typeNatModTyFamNameKey typeNatModTyCon + + + + + +typeNatExpTyCon :: TyCon +typeNatExpTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamExp + , sfInteractTop = interactTopExp + , sfInteractInert = interactInertExp + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "^") + typeNatExpTyFamNameKey typeNatExpTyCon + +typeNatLogTyCon :: TyCon +typeNatLogTyCon = mkTypeNatFunTyCon1 name + BuiltInSynFamily + { sfMatchFam = matchFamLog + , sfInteractTop = interactTopLog + , sfInteractInert = interactInertLog + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2") + typeNatLogTyFamNameKey typeNatLogTyCon + + + +typeNatLeqTyCon :: TyCon +typeNatLeqTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) + boolTy + Nothing + (BuiltInSynFamTyCon ops) + Nothing + NotInjective + + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "<=?") + typeNatLeqTyFamNameKey typeNatLeqTyCon + ops = BuiltInSynFamily + { sfMatchFam = matchFamLeq + , sfInteractTop = interactTopLeq + , sfInteractInert = interactInertLeq + } + +typeNatCmpTyCon :: TyCon +typeNatCmpTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) + orderingKind + Nothing + (BuiltInSynFamTyCon ops) + Nothing + NotInjective + + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "CmpNat") + typeNatCmpTyFamNameKey typeNatCmpTyCon + ops = BuiltInSynFamily + { sfMatchFam = matchFamCmpNat + , sfInteractTop = interactTopCmpNat + , sfInteractInert = \_ _ _ _ -> [] + } + +typeSymbolCmpTyCon :: TyCon +typeSymbolCmpTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ]) + orderingKind + Nothing + (BuiltInSynFamTyCon ops) + Nothing + NotInjective + + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpSymbol") + typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon + ops = BuiltInSynFamily + { sfMatchFam = matchFamCmpSymbol + , sfInteractTop = interactTopCmpSymbol + , sfInteractInert = \_ _ _ _ -> [] + } + +typeSymbolAppendTyCon :: TyCon +typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamAppendSymbol + , sfInteractTop = interactTopAppendSymbol + , sfInteractInert = interactInertAppendSymbol + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol") + typeSymbolAppendFamNameKey typeSymbolAppendTyCon + + + +-- Make a unary built-in constructor of kind: Nat -> Nat +mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon +mkTypeNatFunTyCon1 op tcb = + mkFamilyTyCon op + (mkTemplateAnonTyConBinders [ typeNatKind ]) + typeNatKind + Nothing + (BuiltInSynFamTyCon tcb) + Nothing + NotInjective + + +-- Make a binary built-in constructor of kind: Nat -> Nat -> Nat +mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon +mkTypeNatFunTyCon2 op tcb = + mkFamilyTyCon op + (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) + typeNatKind + Nothing + (BuiltInSynFamTyCon tcb) + Nothing + NotInjective + +-- Make a binary built-in constructor of kind: Symbol -> Symbol -> Symbol +mkTypeSymbolFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon +mkTypeSymbolFunTyCon2 op tcb = + mkFamilyTyCon op + (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ]) + typeSymbolKind + Nothing + (BuiltInSynFamTyCon tcb) + Nothing + NotInjective + + +{------------------------------------------------------------------------------- +Built-in rules axioms +-------------------------------------------------------------------------------} + +-- If you add additional rules, please remember to add them to +-- `typeNatCoAxiomRules` also. +-- See Note [Adding built-in type families] +axAddDef + , axMulDef + , axExpDef + , axLeqDef + , axCmpNatDef + , axCmpSymbolDef + , axAppendSymbolDef + , axAdd0L + , axAdd0R + , axMul0L + , axMul0R + , axMul1L + , axMul1R + , axExp1L + , axExp0R + , axExp1R + , axLeqRefl + , axCmpNatRefl + , axCmpSymbolRefl + , axLeq0L + , axSubDef + , axSub0R + , axAppendSymbol0R + , axAppendSymbol0L + , axDivDef + , axDiv1 + , axModDef + , axMod1 + , axLogDef + :: CoAxiomRule + +axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon $ + \x y -> Just $ num (x + y) + +axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon $ + \x y -> Just $ num (x * y) + +axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon $ + \x y -> Just $ num (x ^ y) + +axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon $ + \x y -> Just $ bool (x <= y) + +axCmpNatDef = mkBinAxiom "CmpNatDef" typeNatCmpTyCon + $ \x y -> Just $ ordering (compare x y) + +axCmpSymbolDef = + CoAxiomRule + { coaxrName = fsLit "CmpSymbolDef" + , coaxrAsmpRoles = [Nominal, Nominal] + , coaxrRole = Nominal + , coaxrProves = \cs -> + do [Pair s1 s2, Pair t1 t2] <- return cs + s2' <- isStrLitTy s2 + t2' <- isStrLitTy t2 + return (mkTyConApp typeSymbolCmpTyCon [s1,t1] === + ordering (compare s2' t2')) } + +axAppendSymbolDef = CoAxiomRule + { coaxrName = fsLit "AppendSymbolDef" + , coaxrAsmpRoles = [Nominal, Nominal] + , coaxrRole = Nominal + , coaxrProves = \cs -> + do [Pair s1 s2, Pair t1 t2] <- return cs + s2' <- isStrLitTy s2 + t2' <- isStrLitTy t2 + let z = mkStrLitTy (appendFS s2' t2') + return (mkTyConApp typeSymbolAppendTyCon [s1, t1] === z) + } + +axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $ + \x y -> fmap num (minus x y) + +axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon $ + \x y -> do guard (y /= 0) + return (num (div x y)) + +axModDef = mkBinAxiom "ModDef" typeNatModTyCon $ + \x y -> do guard (y /= 0) + return (num (mod x y)) + +axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon $ + \x -> do (a,_) <- genLog x 2 + return (num a) + +axAdd0L = mkAxiom1 "Add0L" $ \(Pair s t) -> (num 0 .+. s) === t +axAdd0R = mkAxiom1 "Add0R" $ \(Pair s t) -> (s .+. num 0) === t +axSub0R = mkAxiom1 "Sub0R" $ \(Pair s t) -> (s .-. num 0) === t +axMul0L = mkAxiom1 "Mul0L" $ \(Pair s _) -> (num 0 .*. s) === num 0 +axMul0R = mkAxiom1 "Mul0R" $ \(Pair s _) -> (s .*. num 0) === num 0 +axMul1L = mkAxiom1 "Mul1L" $ \(Pair s t) -> (num 1 .*. s) === t +axMul1R = mkAxiom1 "Mul1R" $ \(Pair s t) -> (s .*. num 1) === t +axDiv1 = mkAxiom1 "Div1" $ \(Pair s t) -> (tDiv s (num 1) === t) +axMod1 = mkAxiom1 "Mod1" $ \(Pair s _) -> (tMod s (num 1) === num 0) + -- XXX: Shouldn't we check that _ is 0? +axExp1L = mkAxiom1 "Exp1L" $ \(Pair s _) -> (num 1 .^. s) === num 1 +axExp0R = mkAxiom1 "Exp0R" $ \(Pair s _) -> (s .^. num 0) === num 1 +axExp1R = mkAxiom1 "Exp1R" $ \(Pair s t) -> (s .^. num 1) === t +axLeqRefl = mkAxiom1 "LeqRefl" $ \(Pair s _) -> (s <== s) === bool True +axCmpNatRefl = mkAxiom1 "CmpNatRefl" + $ \(Pair s _) -> (cmpNat s s) === ordering EQ +axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl" + $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ +axLeq0L = mkAxiom1 "Leq0L" $ \(Pair s _) -> (num 0 <== s) === bool True +axAppendSymbol0R = mkAxiom1 "Concat0R" + $ \(Pair s t) -> (mkStrLitTy nilFS `appendSymbol` s) === t +axAppendSymbol0L = mkAxiom1 "Concat0L" + $ \(Pair s t) -> (s `appendSymbol` mkStrLitTy nilFS) === t + +-- The list of built-in type family axioms that GHC uses. +-- If you define new axioms, make sure to include them in this list. +-- See Note [Adding built-in type families] +typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule +typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x)) + [ axAddDef + , axMulDef + , axExpDef + , axLeqDef + , axCmpNatDef + , axCmpSymbolDef + , axAppendSymbolDef + , axAdd0L + , axAdd0R + , axMul0L + , axMul0R + , axMul1L + , axMul1R + , axExp1L + , axExp0R + , axExp1R + , axLeqRefl + , axCmpNatRefl + , axCmpSymbolRefl + , axLeq0L + , axSubDef + , axSub0R + , axAppendSymbol0R + , axAppendSymbol0L + , axDivDef + , axDiv1 + , axModDef + , axMod1 + , axLogDef + ] + + + +{------------------------------------------------------------------------------- +Various utilities for making axioms and types +-------------------------------------------------------------------------------} + +(.+.) :: Type -> Type -> Type +s .+. t = mkTyConApp typeNatAddTyCon [s,t] + +(.-.) :: Type -> Type -> Type +s .-. t = mkTyConApp typeNatSubTyCon [s,t] + +(.*.) :: Type -> Type -> Type +s .*. t = mkTyConApp typeNatMulTyCon [s,t] + +tDiv :: Type -> Type -> Type +tDiv s t = mkTyConApp typeNatDivTyCon [s,t] + +tMod :: Type -> Type -> Type +tMod s t = mkTyConApp typeNatModTyCon [s,t] + +(.^.) :: Type -> Type -> Type +s .^. t = mkTyConApp typeNatExpTyCon [s,t] + +(<==) :: Type -> Type -> Type +s <== t = mkTyConApp typeNatLeqTyCon [s,t] + +cmpNat :: Type -> Type -> Type +cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t] + +cmpSymbol :: Type -> Type -> Type +cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t] + +appendSymbol :: Type -> Type -> Type +appendSymbol s t = mkTyConApp typeSymbolAppendTyCon [s, t] + +(===) :: Type -> Type -> Pair Type +x === y = Pair x y + +num :: Integer -> Type +num = mkNumLitTy + +bool :: Bool -> Type +bool b = if b then mkTyConApp promotedTrueDataCon [] + else mkTyConApp promotedFalseDataCon [] + +isBoolLitTy :: Type -> Maybe Bool +isBoolLitTy tc = + do (tc,[]) <- splitTyConApp_maybe tc + case () of + _ | tc == promotedFalseDataCon -> return False + | tc == promotedTrueDataCon -> return True + | otherwise -> Nothing + +orderingKind :: Kind +orderingKind = mkTyConApp orderingTyCon [] + +ordering :: Ordering -> Type +ordering o = + case o of + LT -> mkTyConApp promotedLTDataCon [] + EQ -> mkTyConApp promotedEQDataCon [] + GT -> mkTyConApp promotedGTDataCon [] + +isOrderingLitTy :: Type -> Maybe Ordering +isOrderingLitTy tc = + do (tc1,[]) <- splitTyConApp_maybe tc + case () of + _ | tc1 == promotedLTDataCon -> return LT + | tc1 == promotedEQDataCon -> return EQ + | tc1 == promotedGTDataCon -> return GT + | otherwise -> Nothing + +known :: (Integer -> Bool) -> TcType -> Bool +known p x = case isNumLitTy x of + Just a -> p a + Nothing -> False + + +mkUnAxiom :: String -> TyCon -> (Integer -> Maybe Type) -> CoAxiomRule +mkUnAxiom str tc f = + CoAxiomRule + { coaxrName = fsLit str + , coaxrAsmpRoles = [Nominal] + , coaxrRole = Nominal + , coaxrProves = \cs -> + do [Pair s1 s2] <- return cs + s2' <- isNumLitTy s2 + z <- f s2' + return (mkTyConApp tc [s1] === z) + } + + + +-- For the definitional axioms +mkBinAxiom :: String -> TyCon -> + (Integer -> Integer -> Maybe Type) -> CoAxiomRule +mkBinAxiom str tc f = + CoAxiomRule + { coaxrName = fsLit str + , coaxrAsmpRoles = [Nominal, Nominal] + , coaxrRole = Nominal + , coaxrProves = \cs -> + do [Pair s1 s2, Pair t1 t2] <- return cs + s2' <- isNumLitTy s2 + t2' <- isNumLitTy t2 + z <- f s2' t2' + return (mkTyConApp tc [s1,t1] === z) + } + + + +mkAxiom1 :: String -> (TypeEqn -> TypeEqn) -> CoAxiomRule +mkAxiom1 str f = + CoAxiomRule + { coaxrName = fsLit str + , coaxrAsmpRoles = [Nominal] + , coaxrRole = Nominal + , coaxrProves = \case [eqn] -> Just (f eqn) + _ -> Nothing + } + + +{------------------------------------------------------------------------------- +Evaluation +-------------------------------------------------------------------------------} + +matchFamAdd :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamAdd [s,t] + | Just 0 <- mbX = Just (axAdd0L, [t], t) + | Just 0 <- mbY = Just (axAdd0R, [s], s) + | Just x <- mbX, Just y <- mbY = + Just (axAddDef, [s,t], num (x + y)) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamAdd _ = Nothing + +matchFamSub :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamSub [s,t] + | Just 0 <- mbY = Just (axSub0R, [s], s) + | Just x <- mbX, Just y <- mbY, Just z <- minus x y = + Just (axSubDef, [s,t], num z) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamSub _ = Nothing + +matchFamMul :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamMul [s,t] + | Just 0 <- mbX = Just (axMul0L, [t], num 0) + | Just 0 <- mbY = Just (axMul0R, [s], num 0) + | Just 1 <- mbX = Just (axMul1L, [t], t) + | Just 1 <- mbY = Just (axMul1R, [s], s) + | Just x <- mbX, Just y <- mbY = + Just (axMulDef, [s,t], num (x * y)) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamMul _ = Nothing + +matchFamDiv :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamDiv [s,t] + | Just 1 <- mbY = Just (axDiv1, [s], s) + | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axDivDef, [s,t], num (div x y)) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamDiv _ = Nothing + +matchFamMod :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamMod [s,t] + | Just 1 <- mbY = Just (axMod1, [s], num 0) + | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axModDef, [s,t], num (mod x y)) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamMod _ = Nothing + + + +matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamExp [s,t] + | Just 0 <- mbY = Just (axExp0R, [s], num 1) + | Just 1 <- mbX = Just (axExp1L, [t], num 1) + | Just 1 <- mbY = Just (axExp1R, [s], s) + | Just x <- mbX, Just y <- mbY = + Just (axExpDef, [s,t], num (x ^ y)) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamExp _ = Nothing + +matchFamLog :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamLog [s] + | Just x <- mbX, Just (n,_) <- genLog x 2 = Just (axLogDef, [s], num n) + where mbX = isNumLitTy s +matchFamLog _ = Nothing + + +matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamLeq [s,t] + | Just 0 <- mbX = Just (axLeq0L, [t], bool True) + | Just x <- mbX, Just y <- mbY = + Just (axLeqDef, [s,t], bool (x <= y)) + | tcEqType s t = Just (axLeqRefl, [s], bool True) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamLeq _ = Nothing + +matchFamCmpNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamCmpNat [s,t] + | Just x <- mbX, Just y <- mbY = + Just (axCmpNatDef, [s,t], ordering (compare x y)) + | tcEqType s t = Just (axCmpNatRefl, [s], ordering EQ) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamCmpNat _ = Nothing + +matchFamCmpSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamCmpSymbol [s,t] + | Just x <- mbX, Just y <- mbY = + Just (axCmpSymbolDef, [s,t], ordering (compare x y)) + | tcEqType s t = Just (axCmpSymbolRefl, [s], ordering EQ) + where mbX = isStrLitTy s + mbY = isStrLitTy t +matchFamCmpSymbol _ = Nothing + +matchFamAppendSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamAppendSymbol [s,t] + | Just x <- mbX, nullFS x = Just (axAppendSymbol0R, [t], t) + | Just y <- mbY, nullFS y = Just (axAppendSymbol0L, [s], s) + | Just x <- mbX, Just y <- mbY = + Just (axAppendSymbolDef, [s,t], mkStrLitTy (appendFS x y)) + where + mbX = isStrLitTy s + mbY = isStrLitTy t +matchFamAppendSymbol _ = Nothing + +{------------------------------------------------------------------------------- +Interact with axioms +-------------------------------------------------------------------------------} + +interactTopAdd :: [Xi] -> Xi -> [Pair Type] +interactTopAdd [s,t] r + | Just 0 <- mbZ = [ s === num 0, t === num 0 ] -- (s + t ~ 0) => (s ~ 0, t ~ 0) + | Just x <- mbX, Just z <- mbZ, Just y <- minus z x = [t === num y] -- (5 + t ~ 8) => (t ~ 3) + | Just y <- mbY, Just z <- mbZ, Just x <- minus z y = [s === num x] -- (s + 5 ~ 8) => (s ~ 3) + where + mbX = isNumLitTy s + mbY = isNumLitTy t + mbZ = isNumLitTy r +interactTopAdd _ _ = [] + +{- +Note [Weakened interaction rule for subtraction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A simpler interaction here might be: + + `s - t ~ r` --> `t + r ~ s` + +This would enable us to reuse all the code for addition. +Unfortunately, this works a little too well at the moment. +Consider the following example: + + 0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0) + +This (correctly) spots that the constraint cannot be solved. + +However, this may be a problem if the constraint did not +need to be solved in the first place! Consider the following example: + +f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5 +f = id + +Currently, GHC is strict while evaluating functions, so this does not +work, because even though the `If` should evaluate to `5 - 0`, we +also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`, +which fails. + +So, for the time being, we only add an improvement when the RHS is a constant, +which happens to work OK for the moment, although clearly we need to do +something more general. +-} +interactTopSub :: [Xi] -> Xi -> [Pair Type] +interactTopSub [s,t] r + | Just z <- mbZ = [ s === (num z .+. t) ] -- (s - t ~ 5) => (5 + t ~ s) + where + mbZ = isNumLitTy r +interactTopSub _ _ = [] + + + + + +interactTopMul :: [Xi] -> Xi -> [Pair Type] +interactTopMul [s,t] r + | Just 1 <- mbZ = [ s === num 1, t === num 1 ] -- (s * t ~ 1) => (s ~ 1, t ~ 1) + | Just x <- mbX, Just z <- mbZ, Just y <- divide z x = [t === num y] -- (3 * t ~ 15) => (t ~ 5) + | Just y <- mbY, Just z <- mbZ, Just x <- divide z y = [s === num x] -- (s * 3 ~ 15) => (s ~ 5) + where + mbX = isNumLitTy s + mbY = isNumLitTy t + mbZ = isNumLitTy r +interactTopMul _ _ = [] + +interactTopDiv :: [Xi] -> Xi -> [Pair Type] +interactTopDiv _ _ = [] -- I can't think of anything... + +interactTopMod :: [Xi] -> Xi -> [Pair Type] +interactTopMod _ _ = [] -- I can't think of anything... + +interactTopExp :: [Xi] -> Xi -> [Pair Type] +interactTopExp [s,t] r + | Just 0 <- mbZ = [ s === num 0 ] -- (s ^ t ~ 0) => (s ~ 0) + | Just x <- mbX, Just z <- mbZ, Just y <- logExact z x = [t === num y] -- (2 ^ t ~ 8) => (t ~ 3) + | Just y <- mbY, Just z <- mbZ, Just x <- rootExact z y = [s === num x] -- (s ^ 2 ~ 9) => (s ~ 3) + where + mbX = isNumLitTy s + mbY = isNumLitTy t + mbZ = isNumLitTy r +interactTopExp _ _ = [] + +interactTopLog :: [Xi] -> Xi -> [Pair Type] +interactTopLog _ _ = [] -- I can't think of anything... + + + +interactTopLeq :: [Xi] -> Xi -> [Pair Type] +interactTopLeq [s,t] r + | Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ] -- (s <= 0) => (s ~ 0) + where + mbY = isNumLitTy t + mbZ = isBoolLitTy r +interactTopLeq _ _ = [] + +interactTopCmpNat :: [Xi] -> Xi -> [Pair Type] +interactTopCmpNat [s,t] r + | Just EQ <- isOrderingLitTy r = [ s === t ] +interactTopCmpNat _ _ = [] + +interactTopCmpSymbol :: [Xi] -> Xi -> [Pair Type] +interactTopCmpSymbol [s,t] r + | Just EQ <- isOrderingLitTy r = [ s === t ] +interactTopCmpSymbol _ _ = [] + +interactTopAppendSymbol :: [Xi] -> Xi -> [Pair Type] +interactTopAppendSymbol [s,t] r + -- (AppendSymbol a b ~ "") => (a ~ "", b ~ "") + | Just z <- mbZ, nullFS z = + [s === mkStrLitTy nilFS, t === mkStrLitTy nilFS ] + + -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar") + | Just x <- fmap unpackFS mbX, Just z <- fmap unpackFS mbZ, x `isPrefixOf` z = + [ t === mkStrLitTy (mkFastString $ drop (length x) z) ] + + -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo") + | Just y <- fmap unpackFS mbY, Just z <- fmap unpackFS mbZ, y `isSuffixOf` z = + [ t === mkStrLitTy (mkFastString $ take (length z - length y) z) ] + + where + mbX = isStrLitTy s + mbY = isStrLitTy t + mbZ = isStrLitTy r + +interactTopAppendSymbol _ _ = [] + +{------------------------------------------------------------------------------- +Interaction with inerts +-------------------------------------------------------------------------------} + +interactInertAdd :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertAdd [x1,y1] z1 [x2,y2] z2 + | sameZ && tcEqType x1 x2 = [ y1 === y2 ] + | sameZ && tcEqType y1 y2 = [ x1 === x2 ] + where sameZ = tcEqType z1 z2 +interactInertAdd _ _ _ _ = [] + +interactInertSub :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertSub [x1,y1] z1 [x2,y2] z2 + | sameZ && tcEqType x1 x2 = [ y1 === y2 ] + | sameZ && tcEqType y1 y2 = [ x1 === x2 ] + where sameZ = tcEqType z1 z2 +interactInertSub _ _ _ _ = [] + +interactInertMul :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertMul [x1,y1] z1 [x2,y2] z2 + | sameZ && known (/= 0) x1 && tcEqType x1 x2 = [ y1 === y2 ] + | sameZ && known (/= 0) y1 && tcEqType y1 y2 = [ x1 === x2 ] + where sameZ = tcEqType z1 z2 + +interactInertMul _ _ _ _ = [] + +interactInertDiv :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertDiv _ _ _ _ = [] + +interactInertMod :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertMod _ _ _ _ = [] + +interactInertExp :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertExp [x1,y1] z1 [x2,y2] z2 + | sameZ && known (> 1) x1 && tcEqType x1 x2 = [ y1 === y2 ] + | sameZ && known (> 0) y1 && tcEqType y1 y2 = [ x1 === x2 ] + where sameZ = tcEqType z1 z2 + +interactInertExp _ _ _ _ = [] + +interactInertLog :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertLog _ _ _ _ = [] + + +interactInertLeq :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertLeq [x1,y1] z1 [x2,y2] z2 + | bothTrue && tcEqType x1 y2 && tcEqType y1 x2 = [ x1 === y1 ] + | bothTrue && tcEqType y1 x2 = [ (x1 <== y2) === bool True ] + | bothTrue && tcEqType y2 x1 = [ (x2 <== y1) === bool True ] + where bothTrue = isJust $ do True <- isBoolLitTy z1 + True <- isBoolLitTy z2 + return () + +interactInertLeq _ _ _ _ = [] + + +interactInertAppendSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2 + | sameZ && tcEqType x1 x2 = [ y1 === y2 ] + | sameZ && tcEqType y1 y2 = [ x1 === x2 ] + where sameZ = tcEqType z1 z2 +interactInertAppendSymbol _ _ _ _ = [] + + + +{- ----------------------------------------------------------------------------- +These inverse functions are used for simplifying propositions using +concrete natural numbers. +----------------------------------------------------------------------------- -} + +-- | Subtract two natural numbers. +minus :: Integer -> Integer -> Maybe Integer +minus x y = if x >= y then Just (x - y) else Nothing + +-- | Compute the exact logarithm of a natural number. +-- The logarithm base is the second argument. +logExact :: Integer -> Integer -> Maybe Integer +logExact x y = do (z,True) <- genLog x y + return z + + +-- | Divide two natural numbers. +divide :: Integer -> Integer -> Maybe Integer +divide _ 0 = Nothing +divide x y = case divMod x y of + (a,0) -> Just a + _ -> Nothing + +-- | Compute the exact root of a natural number. +-- The second argument specifies which root we are computing. +rootExact :: Integer -> Integer -> Maybe Integer +rootExact x y = do (z,True) <- genRoot x y + return z + + + +{- | Compute the n-th root of a natural number, rounded down to +the closest natural number. The boolean indicates if the result +is exact (i.e., True means no rounding was done, False means rounded down). +The second argument specifies which root we are computing. -} +genRoot :: Integer -> Integer -> Maybe (Integer, Bool) +genRoot _ 0 = Nothing +genRoot x0 1 = Just (x0, True) +genRoot x0 root = Just (search 0 (x0+1)) + where + search from to = let x = from + div (to - from) 2 + a = x ^ root + in case compare a x0 of + EQ -> (x, True) + LT | x /= from -> search x to + | otherwise -> (from, False) + GT | x /= to -> search from x + | otherwise -> (from, False) + +{- | Compute the logarithm of a number in the given base, rounded down to the +closest integer. The boolean indicates if we the result is exact +(i.e., True means no rounding happened, False means we rounded down). +The logarithm base is the second argument. -} +genLog :: Integer -> Integer -> Maybe (Integer, Bool) +genLog x 0 = if x == 1 then Just (0, True) else Nothing +genLog _ 1 = Nothing +genLog 0 _ = Nothing +genLog x base = Just (exactLoop 0 x) + where + exactLoop s i + | i == 1 = (s,True) + | i < base = (s,False) + | otherwise = + let s1 = s + 1 + in s1 `seq` case divMod i base of + (j,r) + | r == 0 -> exactLoop s1 j + | otherwise -> (underLoop s1 j, False) + + underLoop s i + | i < base = s + | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base) diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Builtin/Utils.hs @@ -0,0 +1,305 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} + +-- | The @GHC.Builtin.Utils@ interface to the compiler's prelude knowledge. +-- +-- This module serves as the central gathering point for names which the +-- compiler knows something about. This includes functions for, +-- +-- * discerning whether a 'Name' is known-key +-- +-- * given a 'Unique', looking up its corresponding known-key 'Name' +-- +-- See Note [Known-key names] and Note [About wired-in things] for information +-- about the two types of prelude things in GHC. +-- +module GHC.Builtin.Utils ( + -- * Known-key names + isKnownKeyName, + lookupKnownKeyName, + lookupKnownNameInfo, + + -- ** Internal use + -- | 'knownKeyNames' is exported to seed the original name cache only; + -- if you find yourself wanting to look at it you might consider using + -- 'lookupKnownKeyName' or 'isKnownKeyName'. + knownKeyNames, + + -- * Miscellaneous + wiredInIds, ghcPrimIds, + primOpRules, builtinRules, + + ghcPrimExports, + ghcPrimDeclDocs, + primOpId, + + -- * Random other things + maybeCharLikeCon, maybeIntLikeCon, + + -- * Class categories + isNumericClass, isStandardClass + + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Builtin.Uniques +import GHC.Types.Unique ( isValidKnownKeyUnique ) + +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Builtin.Names.TH ( templateHaskellNames ) +import GHC.Builtin.Names +import GHC.Core.Opt.ConstantFold +import GHC.Types.Avail +import GHC.Builtin.PrimOps +import GHC.Core.DataCon +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Id.Make +import GHC.Utils.Outputable +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types +import GHC.Driver.Types +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Types.Unique.FM +import GHC.Utils.Misc +import GHC.Builtin.Types.Literals ( typeNatTyCons ) +import GHC.Hs.Doc + +import Control.Applicative ((<|>)) +import Data.List ( intercalate , find ) +import Data.Array +import Data.Maybe +import qualified Data.Map as Map + +{- +************************************************************************ +* * +\subsection[builtinNameInfo]{Lookup built-in names} +* * +************************************************************************ + +Note [About wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Wired-in things are Ids\/TyCons that are completely known to the compiler. + They are global values in GHC, (e.g. listTyCon :: TyCon). + +* A wired-in Name contains the thing itself inside the Name: + see Name.wiredInNameTyThing_maybe + (E.g. listTyConName contains listTyCon. + +* The name cache is initialised with (the names of) all wired-in things + (except tuples and sums; see Note [Infinite families of known-key names]) + +* The type environment itself contains no wired in things. The type + checker sees if the Name is wired in before looking up the name in + the type environment. + +* GHC.Iface.Make prunes out wired-in things before putting them in an interface file. + So interface files never contain wired-in things. +-} + + +-- | This list is used to ensure that when you say "Prelude.map" in your source +-- code, or in an interface file, you get a Name with the correct known key (See +-- Note [Known-key names] in GHC.Builtin.Names) +knownKeyNames :: [Name] +knownKeyNames + | debugIsOn + , Just badNamesStr <- knownKeyNamesOkay all_names + = panic ("badAllKnownKeyNames:\n" ++ badNamesStr) + -- NB: We can't use ppr here, because this is sometimes evaluated in a + -- context where there are no DynFlags available, leading to a cryptic + -- "<
>" error. (This seems to happen only in the + -- stage 2 compiler, for reasons I [Richard] have no clue of.) + | otherwise + = all_names + where + all_names = + -- We exclude most tuples from this list—see + -- Note [Infinite families of known-key names] in GHC.Builtin.Names. + -- We make an exception for Unit (i.e., the boxed 1-tuple), since it does + -- not use special syntax like other tuples. + -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys) + -- in GHC.Builtin.Types. + tupleTyConName BoxedTuple 1 : tupleDataConName Boxed 1 : + concat [ wired_tycon_kk_names funTyCon + , concatMap wired_tycon_kk_names primTyCons + , concatMap wired_tycon_kk_names wiredInTyCons + , concatMap wired_tycon_kk_names typeNatTyCons + , map idName wiredInIds + , map (idName . primOpId) allThePrimOps + , map (idName . primOpWrapperId) allThePrimOps + , basicKnownKeyNames + , templateHaskellNames + ] + -- All of the names associated with a wired-in TyCon. + -- This includes the TyCon itself, its DataCons and promoted TyCons. + wired_tycon_kk_names :: TyCon -> [Name] + wired_tycon_kk_names tc = + tyConName tc : (rep_names tc ++ implicits) + where implicits = concatMap thing_kk_names (implicitTyConThings tc) + + wired_datacon_kk_names :: DataCon -> [Name] + wired_datacon_kk_names dc = + dataConName dc : rep_names (promoteDataCon dc) + + thing_kk_names :: TyThing -> [Name] + thing_kk_names (ATyCon tc) = wired_tycon_kk_names tc + thing_kk_names (AConLike (RealDataCon dc)) = wired_datacon_kk_names dc + thing_kk_names thing = [getName thing] + + -- The TyConRepName for a known-key TyCon has a known key, + -- but isn't itself an implicit thing. Yurgh. + -- NB: if any of the wired-in TyCons had record fields, the record + -- field names would be in a similar situation. Ditto class ops. + -- But it happens that there aren't any + rep_names tc = case tyConRepName_maybe tc of + Just n -> [n] + Nothing -> [] + +-- | Check the known-key names list of consistency. +knownKeyNamesOkay :: [Name] -> Maybe String +knownKeyNamesOkay all_names + | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names + = Just $ " Out-of-range known-key uniques: [" + ++ intercalate ", " (map (occNameString . nameOccName) ns) ++ + "]" + | null badNamesPairs + = Nothing + | otherwise + = Just badNamesStr + where + namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) singleton m n n) + emptyUFM all_names + badNamesEnv = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv + badNamesPairs = nonDetUFMToList badNamesEnv + -- It's OK to use nonDetUFMToList here because the ordering only affects + -- the message when we get a panic + badNamesStrs = map pairToStr badNamesPairs + badNamesStr = unlines badNamesStrs + + pairToStr (uniq, ns) = " " ++ + show uniq ++ + ": [" ++ + intercalate ", " (map (occNameString . nameOccName) ns) ++ + "]" + +-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a +-- known-key thing. +lookupKnownKeyName :: Unique -> Maybe Name +lookupKnownKeyName u = + knownUniqueName u <|> lookupUFM knownKeysMap u + +-- | Is a 'Name' known-key? +isKnownKeyName :: Name -> Bool +isKnownKeyName n = + isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap + +knownKeysMap :: UniqFM Name +knownKeysMap = listToUFM [ (nameUnique n, n) | n <- knownKeyNames ] + +-- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by +-- GHCi's ':info' command. +lookupKnownNameInfo :: Name -> SDoc +lookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of + -- If we do find a doc, we add comment delimiters to make the output + -- of ':info' valid Haskell. + Nothing -> empty + Just doc -> vcat [text "{-", doc, text "-}"] + +-- A map from Uniques to SDocs, used in GHCi's ':info' command. (#12390) +knownNamesInfo :: NameEnv SDoc +knownNamesInfo = unitNameEnv coercibleTyConName $ + vcat [ text "Coercible is a special constraint with custom solving rules." + , text "It is not a class." + , text "Please see section `The Coercible constraint`" + , text "of the user's guide for details." ] + +{- +We let a lot of "non-standard" values be visible, so that we can make +sense of them in interface pragmas. It's cool, though they all have +"non-standard" names, so they won't get past the parser in user code. + +************************************************************************ +* * + PrimOpIds +* * +************************************************************************ +-} + +primOpIds :: Array Int Id +-- A cache of the PrimOp Ids, indexed by PrimOp tag +primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) + | op <- allThePrimOps ] + +primOpId :: PrimOp -> Id +primOpId op = primOpIds ! primOpTag op + +{- +************************************************************************ +* * + Export lists for pseudo-modules (GHC.Prim) +* * +************************************************************************ + +GHC.Prim "exports" all the primops and primitive types, some +wired-in Ids. +-} + +ghcPrimExports :: [IfaceExport] +ghcPrimExports + = map (avail . idName) ghcPrimIds ++ + map (avail . idName . primOpId) allThePrimOps ++ + [ AvailTC n [n] [] + | tc <- funTyCon : exposedPrimTyCons, let n = tyConName tc ] + +ghcPrimDeclDocs :: DeclDocMap +ghcPrimDeclDocs = DeclDocMap $ Map.fromList $ mapMaybe findName primOpDocs + where + names = map idName ghcPrimIds ++ + map (idName . primOpId) allThePrimOps ++ + map tyConName (funTyCon : exposedPrimTyCons) + findName (nameStr, doc) + | Just name <- find ((nameStr ==) . getOccString) names + = Just (name, mkHsDocString doc) + | otherwise = Nothing + +{- +************************************************************************ +* * + Built-in keys +* * +************************************************************************ + +ToDo: make it do the ``like'' part properly (as in 0.26 and before). +-} + +maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool +maybeCharLikeCon con = con `hasKey` charDataConKey +maybeIntLikeCon con = con `hasKey` intDataConKey + +{- +************************************************************************ +* * + Class predicates +* * +************************************************************************ +-} + +isNumericClass, isStandardClass :: Class -> Bool + +isNumericClass clas = classKey clas `is_elem` numericClassKeys +isStandardClass clas = classKey clas `is_elem` standardClassKeys + +is_elem :: Eq a => a -> [a] -> Bool +is_elem = isIn "is_X_Class" 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 @@ -15,7 +15,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.ByteCode.Instr import GHC.ByteCode.InfoTable @@ -28,13 +28,13 @@ import GHC.Types.Name.Set import GHC.Types.Literal import GHC.Core.TyCon -import FastString +import GHC.Data.FastString import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Runtime.Heap.Layout import GHC.Driver.Session -import Outputable +import GHC.Utils.Outputable import GHC.Platform -import Util +import GHC.Utils.Misc import GHC.Types.Unique import GHC.Types.Unique.DSet diff --git a/compiler/GHC/ByteCode/InfoTable.hs b/compiler/GHC/ByteCode/InfoTable.hs --- a/compiler/GHC/ByteCode/InfoTable.hs +++ b/compiler/GHC/ByteCode/InfoTable.hs @@ -9,7 +9,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.ByteCode.Types import GHC.Runtime.Interpreter @@ -22,8 +22,8 @@ import GHC.Types.RepType import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) -import Util -import Panic +import GHC.Utils.Misc +import GHC.Utils.Panic {- Manufacturing of info tables for DataCons 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 @@ -11,15 +11,15 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.ByteCode.Types import GHCi.RemoteTypes import GHCi.FFI (C_ffi_cif) import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Core.Ppr -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Types.Name import GHC.Types.Unique import GHC.Types.Id @@ -27,7 +27,7 @@ import GHC.Types.Literal import GHC.Core.DataCon import GHC.Types.Var.Set -import PrimOp +import GHC.Builtin.PrimOps import GHC.Runtime.Heap.Layout import Data.Word 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 @@ -18,7 +18,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHCi.RemoteTypes import GHCi.ResolvedBCO @@ -30,12 +30,12 @@ import GHC.Driver.Types import GHC.Types.Name import GHC.Types.Name.Env -import PrimOp -import GHC.Types.Module -import FastString -import Panic -import Outputable -import Util +import GHC.Builtin.PrimOps +import GHC.Unit +import GHC.Data.FastString +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Utils.Misc -- Standard libraries import Data.Array.Unboxed @@ -164,7 +164,7 @@ where encodeZ = zString . zEncodeFS (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n - packagePart = encodeZ (unitIdFS pkgKey) + packagePart = encodeZ (unitFS pkgKey) modulePart = encodeZ (moduleNameFS modName) occPart = encodeZ (occNameFS (nameOccName n)) 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 @@ -5,7 +5,7 @@ realArgRegsCover ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm.Expr import GHC.Runtime.Heap.Layout @@ -14,7 +14,7 @@ import GHC.Driver.Session import GHC.Platform -import Outputable +import GHC.Utils.Outputable -- Calculate the 'GlobalReg' or stack locations for function call -- parameters as used by the Cmm calling convention. 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 @@ -6,7 +6,7 @@ where -import GhcPrelude hiding (iterate, succ, unzip, zip) +import GHC.Prelude hiding (iterate, succ, unzip, zip) import GHC.Cmm.BlockId import GHC.Cmm @@ -23,8 +23,8 @@ import qualified Data.List as List import Data.Word import qualified Data.Map as M -import Outputable -import qualified TrieMap as TM +import GHC.Utils.Outputable +import qualified GHC.Data.TrieMap as TM import GHC.Types.Unique.FM import GHC.Types.Unique import Control.Arrow (first, second) diff --git a/compiler/GHC/Cmm/ContFlowOpt.hs b/compiler/GHC/Cmm/ContFlowOpt.hs --- a/compiler/GHC/Cmm/ContFlowOpt.hs +++ b/compiler/GHC/Cmm/ContFlowOpt.hs @@ -10,7 +10,7 @@ ) where -import GhcPrelude hiding (succ, unzip, zip) +import GHC.Prelude hiding (succ, unzip, zip) import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections @@ -20,9 +20,9 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Switch (mapSwitchTargets, switchTargetsToList) -import Maybes -import Panic -import Util +import GHC.Data.Maybe +import GHC.Utils.Panic +import GHC.Utils.Misc import Control.Monad diff --git a/compiler/GHC/Cmm/Dataflow.hs b/compiler/GHC/Cmm/Dataflow.hs --- a/compiler/GHC/Cmm/Dataflow.hs +++ b/compiler/GHC/Cmm/Dataflow.hs @@ -34,7 +34,7 @@ ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm import GHC.Types.Unique.Supply 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 @@ -25,7 +25,7 @@ UnwindExpr(..), toUnwindExpr ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Cmm.BlockId @@ -33,12 +33,12 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Core -import FastString ( nilFS, mkFastString ) -import GHC.Types.Module -import Outputable +import GHC.Data.FastString ( nilFS, mkFastString ) +import GHC.Unit.Module +import GHC.Utils.Outputable import GHC.Cmm.Ppr.Expr ( pprExpr ) import GHC.Types.SrcLoc -import Util ( seqList ) +import GHC.Utils.Misc ( seqList ) import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections @@ -162,7 +162,7 @@ = DebugBlock { dblProcedure = g_entry graph , dblLabel = label , dblCLabel = case info of - Just (RawCmmStatics infoLbl _) -> infoLbl + Just (CmmStaticsRaw infoLbl _) -> infoLbl Nothing | g_entry graph == label -> entryLbl | otherwise -> blockLbl label 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 @@ -21,7 +21,7 @@ ) where -import GhcPrelude hiding ( (<*>) ) -- avoid importing (<*>) +import GHC.Prelude hiding ( (<*>) ) -- avoid importing (<*>) import GHC.Cmm.BlockId import GHC.Cmm @@ -32,13 +32,13 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Types.ForeignCall -import OrdList +import GHC.Data.OrdList import GHC.Runtime.Heap.Layout (ByteOff) import GHC.Types.Unique.Supply -import Util -import Panic +import GHC.Utils.Misc +import GHC.Utils.Panic ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -33,26 +33,26 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout import GHC.Data.Bitmap -import Stream (Stream) -import qualified Stream +import GHC.Data.Stream (Stream) +import qualified GHC.Data.Stream as Stream import GHC.Cmm.Dataflow.Collections import GHC.Platform -import Maybes +import GHC.Data.Maybe import GHC.Driver.Session -import ErrUtils (withTimingSilent) -import Panic +import GHC.Utils.Error (withTimingSilent) +import GHC.Utils.Panic import GHC.Types.Unique.Supply -import MonadUtils -import Util -import Outputable +import GHC.Utils.Monad +import GHC.Utils.Misc +import GHC.Utils.Outputable import Data.ByteString (ByteString) import Data.Bits @@ -167,7 +167,7 @@ rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits -- - return (top_decls, (lbl, RawCmmStatics info_lbl $ map CmmStaticLit $ + return (top_decls, (lbl, CmmStaticsRaw info_lbl $ map CmmStaticLit $ reverse rel_extra_bits ++ rel_std_info)) ----------------------------------------------------- @@ -206,7 +206,7 @@ ; return (prof_data ++ liveness_data, (std_info, srt_label)) } | HeapRep _ ptrs nonptrs closure_type <- smrep - = do { let layout = packIntsCLit dflags ptrs nonptrs + = do { let layout = packIntsCLit platform ptrs nonptrs ; (prof_lits, prof_data) <- mkProfLits platform prof ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt ; (mb_srt_field, mb_layout, extra_bits, ct_data) @@ -238,14 +238,14 @@ -- Layout known (one free var); we use the layout field for offset mk_pieces (Fun arity (ArgSpec fun_type)) srt_label - = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label + = do { let extra_bits = packIntsCLit platform fun_type arity : srt_label ; return (Nothing, Nothing, extra_bits, []) } mk_pieces (Fun arity (ArgGen arg_bits)) srt_label = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits ; let fun_type | null liveness_data = aRG_GEN | otherwise = aRG_GEN_BIG - extra_bits = [ packIntsCLit dflags fun_type arity ] + extra_bits = [ packIntsCLit platform fun_type arity ] ++ (if inlineSRT dflags then [] else [ srt_lit ]) ++ [ liveness_lit, slow_entry ] ; return (Nothing, Nothing, extra_bits, liveness_data) } @@ -259,11 +259,10 @@ mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier -packIntsCLit :: DynFlags -> Int -> Int -> CmmLit -packIntsCLit dflags a b = packHalfWordsCLit dflags +packIntsCLit :: Platform -> Int -> Int -> CmmLit +packIntsCLit platform a b = packHalfWordsCLit platform (toStgHalfWord platform (fromIntegral a)) (toStgHalfWord platform (fromIntegral b)) - where platform = targetPlatform dflags mkSRTLit :: DynFlags diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -8,7 +8,7 @@ , SRTMap, srtMapNonCAFs ) where -import GhcPrelude hiding (succ) +import GHC.Prelude hiding (succ) import GHC.Types.Id import GHC.Types.Id.Info @@ -18,19 +18,21 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow -import GHC.Types.Module +import GHC.Unit.Module import GHC.Platform -import Digraph +import GHC.Data.Graph.Directed import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils import GHC.Driver.Session -import Maybes -import Outputable +import GHC.Data.Maybe +import GHC.Utils.Outputable import GHC.Runtime.Heap.Layout import GHC.Types.Unique.Supply import GHC.Types.CostCentre import GHC.StgToCmm.Heap +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Config import Control.Monad import Data.Map.Strict (Map) @@ -409,6 +411,30 @@ resurrection can occur? So, no shortcutting. + +Note [Ticky labels in SRT analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Raw Cmm data (CmmStaticsRaw) can't contain pointers so they're considered +non-CAFFY in SRT analysis and we update the SRTMap mapping them to `Nothing` +(meaning they're not CAFFY). + +However when building with -ticky we generate ticky CLabels using the function's +`Name`. For example, if we have a top-level function `sat_s1rQ`, in a ticky +build we get two IdLabels using the name `sat_s1rQ`: + +- For the function itself: IdLabel sat_s1rQ ... Entry +- For the ticky counter: IdLabel sat_s1rQ ... RednCounts + +In these cases we really want to use the function definition for the SRT +analysis of this Name, because that's what we export for this Name -- ticky +counters are not exported. So we ignore ticky counters in SRT analysis (which +are never CAFFY and never exported). + +Not doing this caused #17947 where we analysed the function first mapped the +name to CAFFY. We then saw the ticky constructor, and becuase it has the same +Name as the function and is not CAFFY we overrode the CafInfo of the name as +non-CAFFY. -} -- --------------------------------------------------------------------- @@ -818,8 +844,11 @@ -- already updated by oneSRT srtMap CmmData _ (CmmStaticsRaw lbl _) - | isIdLabel lbl -> - -- not analysed by oneSRT, declare it non-CAFFY here + | isIdLabel lbl && not (isTickyLabel lbl) -> + -- Raw data are not analysed by oneSRT and they can't + -- be CAFFY. + -- See Note [Ticky labels in SRT analysis] above for + -- why we exclude ticky labels here. Map.insert (mkCAFLabel lbl) Nothing srtMap | otherwise -> -- Not an IdLabel, ignore @@ -898,6 +927,7 @@ topSRT <- get let + config = initConfig dflags srtMap = moduleSRTMap topSRT blockids = getBlockLabels lbls @@ -997,11 +1027,11 @@ -- when dynamic linking is used we cannot guarantee that the offset -- between the SRT and the info table will fit in the offset field. -- Consequently we build a singleton SRT in in this case. - not (labelDynamic dflags this_mod lbl) + not (labelDynamic config this_mod lbl) -- MachO relocations can't express offsets between compilation units at -- all, so we are always forced to build a singleton SRT in this case. - && (not (osMachOTarget $ platformOS $ targetPlatform dflags) + && (not (osMachOTarget $ platformOS $ ncgPlatform config) || isLocalCLabel this_mod lbl) -> do -- If we have a static function closure, then it becomes the @@ -1107,10 +1137,10 @@ -> [CmmDeclSRTs] updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics)) - = [CmmData s (RawCmmStatics lbl statics)] + = [CmmData s (CmmStaticsRaw lbl statics)] updInfoSRTs dflags _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload)) - = [CmmData s (RawCmmStatics lbl (map CmmStaticLit field_lits))] + = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))] where caf_info = if caffy then MayHaveCafRefs else NoCafRefs field_lits = mkStaticClosureFields dflags itbl ccs caf_info payload 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 @@ -3,7 +3,7 @@ cmmLayoutStack, setInfoTableStackMap ) where -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) import GHC.StgToCmm.Utils ( callerSaveVolatileRegs, newTemp ) -- XXX layering violation import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState ) -- XXX layering violation @@ -25,14 +25,14 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Types.Unique.Supply -import Maybes +import GHC.Data.Maybe import GHC.Types.Unique.FM -import Util +import GHC.Utils.Misc import GHC.Platform import GHC.Driver.Session -import FastString -import Outputable hiding ( isEmpty ) +import GHC.Data.FastString +import GHC.Utils.Outputable hiding ( isEmpty ) import qualified Data.Set as Set import Control.Monad.Fix import Data.Array as Array 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 @@ -15,18 +15,18 @@ CmmToken(..), cmmlex, ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm.Expr -import Lexer +import GHC.Parser.Lexer import GHC.Cmm.Monad import GHC.Types.SrcLoc import GHC.Types.Unique.FM -import StringBuffer -import FastString -import Ctype -import Util +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Parser.CharClass +import GHC.Utils.Misc --import TRACE import Data.Word 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 @@ -11,7 +11,7 @@ cmmLint, cmmLintGraph ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Cmm.Dataflow.Block @@ -23,7 +23,7 @@ import GHC.Cmm.Liveness import GHC.Cmm.Switch (switchTargetsToList) import GHC.Cmm.Ppr () -- For Outputable instances -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Session import Control.Monad (ap) diff --git a/compiler/GHC/Cmm/Liveness.hs b/compiler/GHC/Cmm/Liveness.hs --- a/compiler/GHC/Cmm/Liveness.hs +++ b/compiler/GHC/Cmm/Liveness.hs @@ -12,7 +12,7 @@ ) where -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Cmm.BlockId @@ -23,8 +23,8 @@ import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Label -import Maybes -import Outputable +import GHC.Data.Maybe +import GHC.Utils.Outputable ----------------------------------------------------------------------------- -- Calculating what variables are live on entry to a basic block diff --git a/compiler/GHC/Cmm/Monad.hs b/compiler/GHC/Cmm/Monad.hs --- a/compiler/GHC/Cmm/Monad.hs +++ b/compiler/GHC/Cmm/Monad.hs @@ -13,12 +13,12 @@ , failMsgPD ) where -import GhcPrelude +import GHC.Prelude import Control.Monad import GHC.Driver.Session -import Lexer +import GHC.Parser.Lexer newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a } 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 @@ -13,13 +13,13 @@ cmmMachOpFoldM ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm.Utils import GHC.Cmm -import Util +import GHC.Utils.Misc -import Outputable +import GHC.Utils.Outputable import GHC.Platform import Data.Bits 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 @@ -202,7 +202,7 @@ module GHC.Cmm.Parser ( parseCmmFile ) where -import GhcPrelude +import GHC.Prelude import GHC.StgToCmm.ExtCode import GHC.Cmm.CallConv @@ -232,25 +232,25 @@ import GHC.Cmm.CLabel import GHC.Cmm.Monad import GHC.Runtime.Heap.Layout -import Lexer +import GHC.Parser.Lexer import GHC.Types.CostCentre import GHC.Types.ForeignCall -import GHC.Types.Module +import GHC.Unit.Module import GHC.Platform import GHC.Types.Literal import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.SrcLoc import GHC.Driver.Session -import ErrUtils -import StringBuffer -import FastString -import Panic -import Constants -import Outputable +import GHC.Utils.Error +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Utils.Panic +import GHC.Settings.Constants +import GHC.Utils.Outputable import GHC.Types.Basic -import Bag ( emptyBag, unitBag ) +import GHC.Data.Bag ( emptyBag, unitBag ) import GHC.Types.Var import Control.Monad @@ -585,7 +585,7 @@ -- A label imported with an explicit packageId. | STRING NAME - { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) } + { ($2, mkCmmCodeLabel (fsToUnit (mkFastString $1)) $2) } names :: { [FastString] } @@ -1163,11 +1163,11 @@ then NoProfilingInfo else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str) -staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () +staticClosure :: Unit -> FastString -> FastString -> [CmmLit] -> CmmParse () staticClosure pkg cl_label info payload = do dflags <- getDynFlags let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] - code $ emitRawDataLits (mkCmmDataLabel pkg cl_label) lits + code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits foreignCall :: String diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -9,7 +9,7 @@ cmmPipeline ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm import GHC.Cmm.Lint @@ -24,10 +24,10 @@ import GHC.Types.Unique.Supply import GHC.Driver.Session -import ErrUtils +import GHC.Utils.Error import GHC.Driver.Types import Control.Monad -import Outputable +import GHC.Utils.Outputable import GHC.Platform import Data.Either (partitionEithers) diff --git a/compiler/GHC/Cmm/Ppr.hs b/compiler/GHC/Cmm/Ppr.hs --- a/compiler/GHC/Cmm/Ppr.hs +++ b/compiler/GHC/Cmm/Ppr.hs @@ -40,7 +40,7 @@ ) where -import GhcPrelude hiding (succ) +import GHC.Prelude hiding (succ) import GHC.Platform import GHC.Driver.Session (targetPlatform) @@ -48,11 +48,11 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Switch -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Cmm.Ppr.Decl import GHC.Cmm.Ppr.Expr -import Util +import GHC.Utils.Misc import GHC.Types.Basic import GHC.Cmm.Dataflow.Block diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs --- a/compiler/GHC/Cmm/Ppr/Decl.hs +++ b/compiler/GHC/Cmm/Ppr/Decl.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GADTs #-} + ---------------------------------------------------------------------------- -- -- Pretty-printing of common Cmm types @@ -38,15 +40,15 @@ ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Cmm.Ppr.Expr import GHC.Cmm import GHC.Driver.Session -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import Data.List import System.IO @@ -70,12 +72,9 @@ => Outputable (GenCmmDecl d info i) where ppr t = pprTop t -instance Outputable CmmStatics where +instance Outputable (GenCmmStatics a) where ppr = pprStatics -instance Outputable RawCmmStatics where - ppr = pprRawStatics - instance Outputable CmmStatic where ppr e = sdocWithDynFlags $ \dflags -> pprStatic (targetPlatform dflags) e @@ -142,19 +141,17 @@ -- following C-- -- -pprStatics :: CmmStatics -> SDoc +pprStatics :: GenCmmStatics a -> SDoc pprStatics (CmmStatics lbl itbl ccs payload) = ppr lbl <> colon <+> ppr itbl <+> ppr ccs <+> ppr payload -pprStatics (CmmStaticsRaw lbl ds) = pprRawStatics (RawCmmStatics lbl ds) - -pprRawStatics :: RawCmmStatics -> SDoc -pprRawStatics (RawCmmStatics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds) +pprStatics (CmmStaticsRaw lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds) pprStatic :: Platform -> CmmStatic -> SDoc pprStatic platform s = case s of CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit platform lit <> semi CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') + CmmFileEmbed path -> nest 4 $ text "incbin " <+> text (show path) -- -------------------------------------------------------------------------- -- data sections diff --git a/compiler/GHC/Cmm/Ppr/Expr.hs b/compiler/GHC/Cmm/Ppr/Expr.hs --- a/compiler/GHC/Cmm/Ppr/Expr.hs +++ b/compiler/GHC/Cmm/Ppr/Expr.hs @@ -39,13 +39,13 @@ ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Driver.Session (targetPlatform) import GHC.Cmm.Expr -import Outputable +import GHC.Utils.Outputable import Data.Maybe import Numeric ( fromRat ) diff --git a/compiler/GHC/Cmm/ProcPoint.hs b/compiler/GHC/Cmm/ProcPoint.hs --- a/compiler/GHC/Cmm/ProcPoint.hs +++ b/compiler/GHC/Cmm/ProcPoint.hs @@ -9,7 +9,7 @@ ) where -import GhcPrelude hiding (last, unzip, succ, zip) +import GHC.Prelude hiding (last, unzip, succ, zip) import GHC.Driver.Session import GHC.Cmm.BlockId @@ -21,9 +21,9 @@ import GHC.Cmm.Liveness import GHC.Cmm.Switch import Data.List (sortBy) -import Maybes +import GHC.Data.Maybe import Control.Monad -import Outputable +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique.Supply import GHC.Cmm.Dataflow.Block 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 @@ -3,7 +3,7 @@ cmmSink ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm import GHC.Cmm.Opt diff --git a/compiler/GHC/Cmm/Switch/Implement.hs b/compiler/GHC/Cmm/Switch/Implement.hs --- a/compiler/GHC/Cmm/Switch/Implement.hs +++ b/compiler/GHC/Cmm/Switch/Implement.hs @@ -4,7 +4,7 @@ ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Cmm.Dataflow.Block @@ -14,7 +14,7 @@ import GHC.Cmm.Switch import GHC.Types.Unique.Supply import GHC.Driver.Session -import MonadUtils (concatMapM) +import GHC.Utils.Monad (concatMapM) -- -- This module replaces Switch statements as generated by the Stg -> Cmm diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -20,7 +20,7 @@ -- CmmLit zeroCLit, mkIntCLit, mkWordCLit, packHalfWordsCLit, - mkByteStringCLit, + mkByteStringCLit, mkFileEmbedLit, mkDataLits, mkRODataLits, mkStgWordCLit, @@ -71,7 +71,7 @@ blockTicks ) where -import GhcPrelude +import GHC.Prelude import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) ) import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 ) @@ -81,7 +81,7 @@ import GHC.Cmm import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Session import GHC.Types.Unique import GHC.Platform.Regs @@ -195,23 +195,29 @@ mkWordCLit :: Platform -> Integer -> CmmLit mkWordCLit platform wd = CmmInt wd (wordWidth platform) +-- | We make a top-level decl for the string, and return a label pointing to it mkByteStringCLit - :: CLabel -> ByteString -> (CmmLit, GenCmmDecl RawCmmStatics info stmt) --- We have to make a top-level decl for the string, --- and return a literal pointing to it + :: CLabel -> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt) mkByteStringCLit lbl bytes - = (CmmLabel lbl, CmmData (Section sec lbl) $ RawCmmStatics lbl [CmmString bytes]) + = (CmmLabel lbl, CmmData (Section sec lbl) $ CmmStaticsRaw lbl [CmmString bytes]) where -- This can not happen for String literals (as there \NUL is replaced by -- C0 80). However, it can happen with Addr# literals. sec = if 0 `BS.elem` bytes then ReadOnlyData else CString -mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl RawCmmStatics info stmt --- Build a data-segment data block +-- | We make a top-level decl for the embedded binary file, and return a label pointing to it +mkFileEmbedLit + :: CLabel -> FilePath -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt) +mkFileEmbedLit lbl path + = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path])) + + +-- | Build a data-segment data block +mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt mkDataLits section lbl lits - = CmmData section (RawCmmStatics lbl $ map CmmStaticLit lits) + = CmmData section (CmmStaticsRaw lbl $ map CmmStaticLit lits) -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl RawCmmStatics info stmt +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt -- Build a read-only data block mkRODataLits lbl lits = mkDataLits section lbl lits @@ -225,19 +231,18 @@ mkStgWordCLit :: Platform -> StgWord -> CmmLit mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform) -packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit +packHalfWordsCLit :: Platform -> StgHalfWord -> StgHalfWord -> CmmLit -- Make a single word literal in which the lower_half_word is -- at the lower address, and the upper_half_word is at the -- higher address -- ToDo: consider using half-word lits instead -- but be careful: that's vulnerable when reversed -packHalfWordsCLit dflags lower_half_word upper_half_word - = if wORDS_BIGENDIAN dflags - then mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u) - else mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform)) +packHalfWordsCLit platform lower_half_word upper_half_word + = case platformByteOrder platform of + BigEndian -> mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u) + LittleEndian -> mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform)) where l = fromStgHalfWord lower_half_word u = fromStgHalfWord upper_half_word - platform = targetPlatform dflags --------------------------------------------------- -- diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -30,7 +30,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import qualified GHC.CmmToAsm.X86.CodeGen as X86.CodeGen import qualified GHC.CmmToAsm.X86.Regs as X86.Regs @@ -53,12 +53,12 @@ import GHC.CmmToAsm.Reg.Liveness import qualified GHC.CmmToAsm.Reg.Linear as Linear -import qualified GraphColor as Color +import qualified GHC.Data.Graph.Color as Color import qualified GHC.CmmToAsm.Reg.Graph as Color import qualified GHC.CmmToAsm.Reg.Graph.Stats as Color import qualified GHC.CmmToAsm.Reg.Graph.TrivColorable as Color -import AsmUtils +import GHC.Utils.Asm import GHC.CmmToAsm.Reg.Target import GHC.Platform import GHC.CmmToAsm.BlockLayout as BlockLayout @@ -86,21 +86,21 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Driver.Session -import Util +import GHC.Utils.Misc import GHC.Types.Basic ( Alignment ) -import qualified Pretty -import BufWrite -import Outputable -import FastString +import qualified GHC.Utils.Ppr as Pretty +import GHC.Utils.BufHandle +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString import GHC.Types.Unique.Set -import ErrUtils -import GHC.Types.Module -import Stream (Stream) -import qualified Stream +import GHC.Utils.Error +import GHC.Unit +import GHC.Data.Stream (Stream) +import qualified GHC.Data.Stream as Stream -- DEBUGGING ONLY ---import OrdList +--import GHC.Data.OrdList import Data.List import Data.Maybe @@ -162,35 +162,36 @@ -> Stream IO RawCmmGroup a -> IO a nativeCodeGen dflags this_mod modLoc h us cmms - = let platform = targetPlatform dflags + = let config = initConfig dflags + platform = ncgPlatform config nCG' :: ( Outputable statics, Outputable instr , Outputable jumpDest, Instruction instr) => NcgImpl statics instr jumpDest -> IO a nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms in case platformArch platform of - ArchX86 -> nCG' (x86NcgImpl dflags) - ArchX86_64 -> nCG' (x86_64NcgImpl dflags) - ArchPPC -> nCG' (ppcNcgImpl dflags) + ArchX86 -> nCG' (x86NcgImpl config) + ArchX86_64 -> nCG' (x86_64NcgImpl config) + ArchPPC -> nCG' (ppcNcgImpl config) ArchS390X -> panic "nativeCodeGen: No NCG for S390X" - ArchSPARC -> nCG' (sparcNcgImpl dflags) + ArchSPARC -> nCG' (sparcNcgImpl config) ArchSPARC64 -> panic "nativeCodeGen: No NCG for SPARC64" ArchARM {} -> panic "nativeCodeGen: No NCG for ARM" ArchARM64 -> panic "nativeCodeGen: No NCG for ARM64" - ArchPPC_64 _ -> nCG' (ppcNcgImpl dflags) + ArchPPC_64 _ -> nCG' (ppcNcgImpl config) ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha" ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb" ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel" ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript" -x86NcgImpl :: DynFlags -> NcgImpl (Alignment, RawCmmStatics) +x86NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr.Instr X86.Instr.JumpDest -x86NcgImpl dflags - = (x86_64NcgImpl dflags) +x86NcgImpl config + = (x86_64NcgImpl config) -x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, RawCmmStatics) +x86_64NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr.Instr X86.Instr.JumpDest -x86_64NcgImpl dflags +x86_64NcgImpl config = NcgImpl { ncgConfig = config ,cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen @@ -209,11 +210,10 @@ ,invertCondBranches = X86.CodeGen.invertCondBranches } where - config = initConfig dflags platform = ncgPlatform config -ppcNcgImpl :: DynFlags -> NcgImpl RawCmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest -ppcNcgImpl dflags +ppcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest +ppcNcgImpl config = NcgImpl { ncgConfig = config ,cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen @@ -232,11 +232,10 @@ ,invertCondBranches = \_ _ -> id } where - config = initConfig dflags platform = ncgPlatform config -sparcNcgImpl :: DynFlags -> NcgImpl RawCmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest -sparcNcgImpl dflags +sparcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest +sparcNcgImpl config = NcgImpl { ncgConfig = config ,cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen @@ -255,7 +254,6 @@ ,invertCondBranches = \_ _ -> id } where - config = initConfig dflags platform = ncgPlatform config -- @@ -387,7 +385,8 @@ dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats) -- write out the imports - printSDocLn Pretty.LeftMode dflags h (mkCodeStyle AsmStyle) + let ctx = initSDocContext dflags (mkCodeStyle AsmStyle) + printSDocLn ctx Pretty.LeftMode h $ makeImportsDoc dflags (concat (ngs_imports ngs)) return us' where @@ -516,8 +515,8 @@ emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO () emitNativeCode dflags h sdoc = do - {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc dflags h - (mkCodeStyle AsmStyle) sdoc + let ctx = initSDocContext dflags (mkCodeStyle AsmStyle) + {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc -- dump native code dumpIfSet_dyn dflags @@ -564,7 +563,7 @@ -- cmm to cmm optimisations let (opt_cmm, imports) = {-# SCC "cmmToCmm" #-} - cmmToCmm dflags this_mod fixed_cmm + cmmToCmm config this_mod fixed_cmm dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM @@ -1066,10 +1065,10 @@ temp assignments, and certain assigns to mem...) -} -cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel]) +cmmToCmm :: NCGConfig -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel]) cmmToCmm _ _ top@(CmmData _ _) = (top, []) -cmmToCmm dflags this_mod (CmmProc info lbl live graph) - = runCmmOpt dflags this_mod $ +cmmToCmm config this_mod (CmmProc info lbl live graph) + = runCmmOpt config this_mod $ do blocks' <- mapM cmmBlockConFold (toBlockList graph) return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') @@ -1086,7 +1085,7 @@ data OptMResult a = OptMResult !a ![CLabel] deriving (Functor) #endif -newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> OptMResult a) +newtype CmmOptM a = CmmOptM (NCGConfig -> Module -> [CLabel] -> OptMResult a) deriving (Functor) instance Applicative CmmOptM where @@ -1095,11 +1094,11 @@ instance Monad CmmOptM where (CmmOptM f) >>= g = - CmmOptM $ \dflags this_mod imports0 -> - case f dflags this_mod imports0 of + CmmOptM $ \config this_mod imports0 -> + case f config this_mod imports0 of OptMResult x imports1 -> case g x of - CmmOptM g' -> g' dflags this_mod imports1 + CmmOptM g' -> g' config this_mod imports1 instance CmmMakeDynamicReferenceM CmmOptM where addImport = addImportCmmOpt @@ -1108,12 +1107,12 @@ addImportCmmOpt :: CLabel -> CmmOptM () addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> OptMResult () (lbl:imports) -instance HasDynFlags CmmOptM where - getDynFlags = CmmOptM $ \dflags _ imports -> OptMResult dflags imports +getCmmOptConfig :: CmmOptM NCGConfig +getCmmOptConfig = CmmOptM $ \config _ imports -> OptMResult config imports -runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel]) -runCmmOpt dflags this_mod (CmmOptM f) = - case f dflags this_mod [] of +runCmmOpt :: NCGConfig -> Module -> CmmOptM a -> (a, [CLabel]) +runCmmOpt config this_mod (CmmOptM f) = + case f config this_mod [] of OptMResult result imports -> (result, imports) cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock @@ -1177,29 +1176,26 @@ cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr cmmExprConFold referenceKind expr = do - dflags <- getDynFlags + config <- getCmmOptConfig - -- With -O1 and greater, the cmmSink pass does constant-folding, so - -- we don't need to do it again here. - let expr' = if optLevel dflags >= 1 + let expr' = if not (ncgDoConstantFolding config) then expr - else cmmExprCon dflags expr + else cmmExprCon config expr cmmExprNative referenceKind expr' -cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr -cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep -cmmExprCon dflags (CmmMachOp mop args) - = cmmMachOpFold platform mop (map (cmmExprCon dflags) args) - where platform = targetPlatform dflags +cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr +cmmExprCon config (CmmLoad addr rep) = CmmLoad (cmmExprCon config addr) rep +cmmExprCon config (CmmMachOp mop args) + = cmmMachOpFold (ncgPlatform config) mop (map (cmmExprCon config) args) cmmExprCon _ other = other -- handles both PIC and non-PIC cases... a very strange mixture -- of things to do. cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr cmmExprNative referenceKind expr = do - dflags <- getDynFlags - let platform = targetPlatform dflags + config <- getCmmOptConfig + let platform = ncgPlatform config arch = platformArch platform case expr of CmmLoad addr rep @@ -1218,10 +1214,10 @@ CmmLit (CmmLabel lbl) -> do - cmmMakeDynamicReference dflags referenceKind lbl + cmmMakeDynamicReference config referenceKind lbl CmmLit (CmmLabelOff lbl off) -> do - dynRef <- cmmMakeDynamicReference dflags referenceKind lbl + dynRef <- cmmMakeDynamicReference config referenceKind lbl -- need to optimize here, since it's late return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [ dynRef, @@ -1232,15 +1228,15 @@ -- to use the register table, so we replace these registers -- with the corresponding labels: CmmReg (CmmGlobal EagerBlackholeInfo) - | arch == ArchPPC && not (positionIndependent dflags) + | arch == ArchPPC && not (ncgPIC config) -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info"))) CmmReg (CmmGlobal GCEnter1) - | arch == ArchPPC && not (positionIndependent dflags) + | arch == ArchPPC && not (ncgPIC config) -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) - | arch == ArchPPC && not (positionIndependent dflags) + | arch == ArchPPC && not (ncgPIC config) -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun"))) 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,7 +14,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Monad @@ -28,19 +28,19 @@ import GHC.Platform import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform) import GHC.Types.Unique.FM -import Util +import GHC.Utils.Misc import GHC.Types.Unique -import Digraph -import Outputable -import Maybes +import GHC.Data.Graph.Directed +import GHC.Utils.Outputable +import GHC.Data.Maybe -- DEBUGGING ONLY --import GHC.Cmm.DebugBlock --import Debug.Trace -import ListSetOps (removeDups) +import GHC.Data.List.SetOps (removeDups) -import OrdList +import GHC.Data.OrdList import Data.List import Data.Foldable (toList) 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 @@ -44,7 +44,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Cmm.BlockId import GHC.Cmm as Cmm @@ -56,9 +56,9 @@ import GHC.Cmm.Dataflow.Block import qualified GHC.Cmm.Dataflow.Graph as G -import Util -import Digraph -import Maybes +import GHC.Utils.Misc +import GHC.Data.Graph.Directed +import GHC.Data.Maybe import GHC.Types.Unique import qualified GHC.CmmToAsm.CFG.Dominators as Dom @@ -72,10 +72,10 @@ import Data.Tree import Data.Bifunctor -import Outputable +import GHC.Utils.Outputable -- DEBUGGING ONLY --import GHC.Cmm.DebugBlock ---import OrdList +--import GHC.Data.OrdList --import GHC.Cmm.DebugBlock.Trace import GHC.Cmm.Ppr () -- For Outputable instances import qualified GHC.Driver.Session as D 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 @@ -38,7 +38,7 @@ ,parents,ancestors ) where -import GhcPrelude +import GHC.Prelude import Data.Bifunctor import Data.Tuple (swap) @@ -58,7 +58,7 @@ -- ,unsafeWrite,unsafeRead -- ,readArray,writeArray) -import Util (debugIsOn) +import GHC.Utils.Misc (debugIsOn) ----------------------------------------------------------------------------- diff --git a/compiler/GHC/CmmToAsm/CPrim.hs b/compiler/GHC/CmmToAsm/CPrim.hs --- a/compiler/GHC/CmmToAsm/CPrim.hs +++ b/compiler/GHC/CmmToAsm/CPrim.hs @@ -14,11 +14,11 @@ , word2FloatLabel ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm.Type import GHC.Cmm.MachOp -import Outputable +import GHC.Utils.Outputable popCntLabel :: Width -> String popCntLabel w = "hs_popcnt" ++ pprWidth w diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/Config.hs +++ /dev/null @@ -1,37 +0,0 @@ --- | Native code generator configuration -module GHC.CmmToAsm.Config - ( NCGConfig(..) - , ncgWordWidth - , platformWordWidth - ) -where - -import GhcPrelude -import GHC.Platform -import GHC.Cmm.Type (Width(..)) - --- | Native code generator configuration -data NCGConfig = NCGConfig - { ncgPlatform :: !Platform -- ^ Target platform - , ncgProcAlignment :: !(Maybe Int) -- ^ Mandatory proc alignment - , ncgDebugLevel :: !Int -- ^ Debug level - , ncgExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries - , ncgPIC :: !Bool -- ^ Enable Position-Independent Code - , ncgSplitSections :: !Bool -- ^ Split sections - , ncgSpillPreallocSize :: !Int -- ^ Size in bytes of the pre-allocated spill space on the C stack - , ncgRegsIterative :: !Bool - , ncgAsmLinting :: !Bool -- ^ Perform ASM linting pass - , ncgDumpRegAllocStages :: !Bool - , ncgDumpAsmStats :: !Bool - , ncgDumpAsmConflicts :: !Bool - } - --- | Return Word size -ncgWordWidth :: NCGConfig -> Width -ncgWordWidth config = platformWordWidth (ncgPlatform config) - --- | Return Word size -platformWordWidth :: Platform -> Width -platformWordWidth platform = case platformWordSize platform of - PW4 -> W32 - PW8 -> W64 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 @@ -2,7 +2,7 @@ dwarfGen ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm.CLabel import GHC.Cmm.Expr ( GlobalReg(..) ) @@ -10,8 +10,8 @@ import GHC.Core ( Tickish(..) ) import GHC.Cmm.DebugBlock import GHC.Driver.Session -import GHC.Types.Module -import Outputable +import GHC.Unit.Module +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique import GHC.Types.Unique.Supply diff --git a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs --- a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs @@ -3,15 +3,16 @@ module GHC.CmmToAsm.Dwarf.Constants where -import GhcPrelude +import GHC.Prelude -import AsmUtils -import FastString +import GHC.Utils.Asm +import GHC.Data.FastString import GHC.Platform -import Outputable +import GHC.Utils.Outputable import GHC.Platform.Reg import GHC.CmmToAsm.X86.Regs +import GHC.CmmToAsm.PPC.Regs (toRegNo) import Data.Word @@ -215,6 +216,7 @@ | r == xmm13 -> 30 | r == xmm14 -> 31 | r == xmm15 -> 32 + ArchPPC_64 _ -> fromIntegral $ toRegNo r _other -> error "dwarfRegNo: Unsupported platform or unknown register!" -- | Virtual register number to use for return address. @@ -226,4 +228,5 @@ = case platformArch p of ArchX86 -> 8 -- eip ArchX86_64 -> 16 -- rip + ArchPPC_64 ELF_V2 -> 65 -- lr (link register) _other -> error "dwarfReturnRegNo: Unsupported platform!" 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 @@ -22,19 +22,19 @@ ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm.DebugBlock import GHC.Cmm.CLabel import GHC.Cmm.Expr ( GlobalReg(..) ) -import Encoding -import FastString -import Outputable +import GHC.Utils.Encoding +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique import GHC.Platform.Reg import GHC.Types.SrcLoc -import Util +import GHC.Utils.Misc import GHC.CmmToAsm.Dwarf.Constants diff --git a/compiler/GHC/CmmToAsm/Format.hs b/compiler/GHC/CmmToAsm/Format.hs --- a/compiler/GHC/CmmToAsm/Format.hs +++ b/compiler/GHC/CmmToAsm/Format.hs @@ -20,10 +20,10 @@ where -import GhcPrelude +import GHC.Prelude import GHC.Cmm -import Outputable +import GHC.Utils.Outputable -- It looks very like the old MachRep, but it's now of purely local -- significance, here in the native code generator. You can change it 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 @@ -14,7 +14,7 @@ where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Platform.Reg 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 @@ -46,7 +46,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Platform.Reg @@ -59,17 +59,17 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel ( CLabel ) import GHC.Cmm.DebugBlock -import FastString ( FastString ) +import GHC.Data.FastString ( FastString ) import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Types.Unique ( Unique ) import GHC.Driver.Session -import GHC.Types.Module +import GHC.Unit.Module import Control.Monad ( ap ) import GHC.CmmToAsm.Instr -import Outputable (SDoc, pprPanic, ppr) +import GHC.Utils.Outputable (SDoc, pprPanic, ppr) import GHC.Cmm (RawCmmDecl, RawCmmStatics) import GHC.CmmToAsm.CFG @@ -148,18 +148,46 @@ -- | Initialize the native code generator configuration from the DynFlags initConfig :: DynFlags -> NCGConfig initConfig dflags = NCGConfig - { ncgPlatform = targetPlatform dflags - , ncgProcAlignment = cmmProcAlignment dflags - , ncgDebugLevel = debugLevel dflags - , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags - , ncgPIC = positionIndependent dflags - , ncgSplitSections = gopt Opt_SplitSections dflags - , ncgSpillPreallocSize = rESERVED_C_STACK_BYTES dflags - , ncgRegsIterative = gopt Opt_RegsIterative dflags - , ncgAsmLinting = gopt Opt_DoAsmLinting dflags - , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags - , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags - , ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags + { ncgPlatform = targetPlatform dflags + , ncgUnitId = thisPackage dflags + , ncgProcAlignment = cmmProcAlignment dflags + , ncgDebugLevel = debugLevel dflags + , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags + , ncgPIC = positionIndependent dflags + , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags + , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags + , ncgSplitSections = gopt Opt_SplitSections dflags + , ncgSpillPreallocSize = rESERVED_C_STACK_BYTES dflags + , ncgRegsIterative = gopt Opt_RegsIterative dflags + , ncgAsmLinting = gopt Opt_DoAsmLinting dflags + + -- With -O1 and greater, the cmmSink pass does constant-folding, so + -- we don't need to do it again in the native code generator. + , ncgDoConstantFolding = optLevel dflags < 1 + + , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags + , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags + , ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags + , ncgBmiVersion = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags + ArchX86 -> bmiVersion dflags + _ -> Nothing + + -- We Assume SSE1 and SSE2 operations are available on both + -- x86 and x86_64. Historically we didn't default to SSE2 and + -- SSE1 on x86, which results in defacto nondeterminism for how + -- rounding behaves in the associated x87 floating point instructions + -- because variations in the spill/fpu stack placement of arguments for + -- operations would change the precision and final result of what + -- would otherwise be the same expressions with respect to single or + -- double precision IEEE floating point computations. + , ncgSseVersion = + let v | sseVersion dflags < Just SSE2 = Just SSE2 + | otherwise = sseVersion dflags + in case platformArch (targetPlatform dflags) of + ArchX86_64 -> v + ArchX86 -> v + _ -> Nothing } 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 @@ -47,7 +47,7 @@ where -import GhcPrelude +import GHC.Prelude import qualified GHC.CmmToAsm.PPC.Instr as PPC import qualified GHC.CmmToAsm.PPC.Regs as PPC @@ -71,12 +71,12 @@ import GHC.Types.Basic -import GHC.Types.Module +import GHC.Unit.Module -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Session -import FastString +import GHC.Data.FastString @@ -109,21 +109,20 @@ cmmMakeDynamicReference :: CmmMakeDynamicReferenceM m - => DynFlags + => NCGConfig -> ReferenceKind -- whether this is the target of a jump -> CLabel -- the label -> m CmmExpr -cmmMakeDynamicReference dflags referenceKind lbl +cmmMakeDynamicReference config referenceKind lbl | Just _ <- dynamicLinkerLabelInfo lbl = return $ CmmLit $ CmmLabel lbl -- already processed it, pass through | otherwise = do this_mod <- getThisModule - let config = initConfig dflags - platform = ncgPlatform config + let platform = ncgPlatform config case howToAccessLabel - dflags + config (platformArch platform) (platformOS platform) this_mod @@ -215,9 +214,7 @@ | AccessViaSymbolPtr | AccessDirectly -howToAccessLabel - :: DynFlags -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle - +howToAccessLabel :: NCGConfig -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle -- Windows -- In Windows speak, a "module" is a set of objects linked into the @@ -240,15 +237,15 @@ -- into the same .exe file. In this case we always access symbols directly, -- and never use __imp_SYMBOL. -- -howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl +howToAccessLabel config _ OSMinGW32 this_mod _ lbl -- Assume all symbols will be in the same PE, so just access them directly. - | not (gopt Opt_ExternalDynamicRefs dflags) + | not (ncgExternalDynamicRefs config) = AccessDirectly -- If the target symbol is in another PE we need to access it via the -- appropriate __imp_SYMBOL pointer. - | labelDynamic dflags this_mod lbl + | labelDynamic config this_mod lbl = AccessViaSymbolPtr -- Target symbol is in the same PE as the caller, so just access it directly. @@ -264,9 +261,9 @@ -- It is always possible to access something indirectly, -- even when it's not necessary. -- -howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl +howToAccessLabel config arch OSDarwin this_mod DataReference lbl -- data access to a dynamic library goes via a symbol pointer - | labelDynamic dflags this_mod lbl + | labelDynamic config this_mod lbl = AccessViaSymbolPtr -- when generating PIC code, all cross-module data references must @@ -279,27 +276,27 @@ -- we'd need to pass the current Module all the way in to -- this function. | arch /= ArchX86_64 - , positionIndependent dflags && externallyVisibleCLabel lbl + , ncgPIC config && externallyVisibleCLabel lbl = AccessViaSymbolPtr | otherwise = AccessDirectly -howToAccessLabel dflags arch OSDarwin this_mod JumpReference lbl +howToAccessLabel config arch OSDarwin this_mod JumpReference lbl -- dyld code stubs don't work for tailcalls because the -- stack alignment is only right for regular calls. -- Therefore, we have to go via a symbol pointer: | arch == ArchX86 || arch == ArchX86_64 - , labelDynamic dflags this_mod lbl + , labelDynamic config this_mod lbl = AccessViaSymbolPtr -howToAccessLabel dflags arch OSDarwin this_mod _ lbl +howToAccessLabel config arch OSDarwin this_mod _ lbl -- Code stubs are the usual method of choice for imported code; -- not needed on x86_64 because Apple's new linker, ld64, generates -- them automatically. | arch /= ArchX86_64 - , labelDynamic dflags this_mod lbl + , labelDynamic config this_mod lbl = AccessViaStub | otherwise @@ -310,7 +307,7 @@ -- AIX -- quite simple (for now) -howToAccessLabel _dflags _arch OSAIX _this_mod kind _lbl +howToAccessLabel _config _arch OSAIX _this_mod kind _lbl = case kind of DataReference -> AccessViaSymbolPtr CallReference -> AccessDirectly @@ -339,27 +336,27 @@ -- regular calls are handled by the runtime linker _ -> AccessDirectly -howToAccessLabel dflags _ os _ _ _ +howToAccessLabel config _ os _ _ _ -- no PIC -> the dynamic linker does everything for us; -- if we don't dynamically link to Haskell code, -- it actually manages to do so without messing things up. | osElfTarget os - , not (positionIndependent dflags) && - not (gopt Opt_ExternalDynamicRefs dflags) + , not (ncgPIC config) && + not (ncgExternalDynamicRefs config) = AccessDirectly -howToAccessLabel dflags arch os this_mod DataReference lbl +howToAccessLabel config arch os this_mod DataReference lbl | osElfTarget os = case () of -- A dynamic label needs to be accessed via a symbol pointer. - _ | labelDynamic dflags this_mod lbl + _ | labelDynamic config this_mod lbl -> AccessViaSymbolPtr -- For PowerPC32 -fPIC, we have to access even static data -- via a symbol pointer (see below for an explanation why -- PowerPC32 Linux is especially broken). | arch == ArchPPC - , positionIndependent dflags + , ncgPIC config -> AccessViaSymbolPtr | otherwise @@ -378,26 +375,26 @@ -- (AccessDirectly, because we get an implicit symbol stub) -- and calling functions from PIC code on non-i386 platforms (via a symbol stub) -howToAccessLabel dflags arch os this_mod CallReference lbl +howToAccessLabel config arch os this_mod CallReference lbl | osElfTarget os - , labelDynamic dflags this_mod lbl && not (positionIndependent dflags) + , labelDynamic config this_mod lbl && not (ncgPIC config) = AccessDirectly | osElfTarget os , arch /= ArchX86 - , labelDynamic dflags this_mod lbl - , positionIndependent dflags + , labelDynamic config this_mod lbl + , ncgPIC config = AccessViaStub -howToAccessLabel dflags _ os this_mod _ lbl +howToAccessLabel config _ os this_mod _ lbl | osElfTarget os - = if labelDynamic dflags this_mod lbl + = if labelDynamic config this_mod lbl then AccessViaSymbolPtr else AccessDirectly -- all other platforms -howToAccessLabel dflags _ _ _ _ _ - | not (positionIndependent dflags) +howToAccessLabel config _ _ _ _ _ + | not (ncgPIC config) = AccessDirectly | otherwise 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 @@ -23,17 +23,20 @@ #include "HsVersions.h" -- NCG stuff: -import GhcPrelude +import GHC.Prelude import GHC.Platform.Regs import GHC.CmmToAsm.PPC.Instr import GHC.CmmToAsm.PPC.Cond import GHC.CmmToAsm.PPC.Regs import GHC.CmmToAsm.CPrim +import GHC.Cmm.DebugBlock + ( DebugBlock(..) ) import GHC.CmmToAsm.Monad ( NatM, getNewRegNat, getNewLabelNat , getBlockIdNat, getPicBaseNat, getNewRegPairNat - , getPicBaseMaybeNat, getPlatform, initConfig + , getPicBaseMaybeNat, getPlatform, getConfig + , getDebugBlock, getFileId ) import GHC.CmmToAsm.Instr import GHC.CmmToAsm.PIC @@ -53,19 +56,20 @@ import GHC.Cmm.CLabel import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph +import GHC.Core ( Tickish(..) ) +import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) -- The rest: -import OrdList -import Outputable -import GHC.Driver.Session +import GHC.Data.OrdList +import GHC.Utils.Outputable import Control.Monad ( mapAndUnzipM, when ) import Data.Bits import Data.Word import GHC.Types.Basic -import FastString -import Util +import GHC.Data.FastString +import GHC.Utils.Misc -- ----------------------------------------------------------------------------- -- Top-level of the instruction selector @@ -124,9 +128,17 @@ let (_, nodes, tail) = blockSplit block id = entryLabel block stmts = blockToList nodes + -- Generate location directive + dbg <- getDebugBlock (entryLabel block) + loc_instrs <- case dblSourceTick =<< dbg of + Just (SourceNote span name) + -> do fileid <- getFileId (srcSpanFile span) + let line = srcSpanStartLine span; col =srcSpanStartCol span + return $ unitOL $ LOCATION fileid line col name + _ -> return nilOL mid_instrs <- stmtsToInstrs stmts tail_instrs <- stmtToInstrs tail - let instrs = mid_instrs `appOL` tail_instrs + let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs -- code generation may introduce new basic block boundaries, which -- are indicated by the NEWBLOCK instruction. We must split up the -- instruction stream into basic blocks again. Also, we extract @@ -149,7 +161,7 @@ stmtToInstrs :: CmmNode e x -> NatM InstrBlock stmtToInstrs stmt = do - dflags <- getDynFlags + config <- getConfig platform <- getPlatform case stmt of CmmComment s -> return (unitOL (COMMENT s)) @@ -180,7 +192,7 @@ b1 <- genCondJump true arg prediction b2 <- genBranch false return (b1 `appOL` b2) - CmmSwitch arg ids -> genSwitch dflags arg ids + CmmSwitch arg ids -> genSwitch config arg ids CmmCall { cml_target = arg , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs) _ -> @@ -404,10 +416,10 @@ getRegister :: CmmExpr -> NatM Register -getRegister e = do dflags <- getDynFlags - getRegister' dflags (targetPlatform dflags) e +getRegister e = do config <- getConfig + getRegister' config (ncgPlatform config) e -getRegister' :: DynFlags -> Platform -> CmmExpr -> NatM Register +getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg)) | OSAIX <- platformOS platform = do @@ -424,8 +436,8 @@ = return (Fixed (cmmTypeFormat (cmmRegType platform reg)) (getRegisterReg platform reg) nilOL) -getRegister' dflags platform tree@(CmmRegOff _ _) - = getRegister' dflags platform (mangleIndexTree platform tree) +getRegister' config platform tree@(CmmRegOff _ _) + = getRegister' config platform (mangleIndexTree platform tree) -- for 32-bit architectures, support some 64 -> 32 bit conversions: -- TO_W_(x), TO_W_(x >> 32) @@ -509,7 +521,7 @@ Amode addr addr_code <- getAmode DS mem return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr)) -getRegister' dflags platform (CmmMachOp mop [x]) -- unary MachOps +getRegister' config platform (CmmMachOp mop [x]) -- unary MachOps = case mop of MO_Not rep -> triv_ucode_int rep NOT @@ -539,7 +551,7 @@ triv_ucode_float width instr = trivialUCode (floatFormat width) instr x conversionNop new_format expr - = do e_code <- getRegister' dflags platform expr + = do e_code <- getRegister' config platform expr return (swizzleRegisterRep e_code new_format) clearLeft from to @@ -662,18 +674,18 @@ in return (Any (intFormat rep) code) -getRegister' dflags _ (CmmLit (CmmFloat f frep)) = do +getRegister' config _ (CmmLit (CmmFloat f frep)) = do lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference dflags DataReference lbl + dynRef <- cmmMakeDynamicReference config DataReference lbl Amode addr addr_code <- getAmode D dynRef let format = floatFormat frep code dst = LDATA (Section ReadOnlyData lbl) - (RawCmmStatics lbl [CmmStaticLit (CmmFloat f frep)]) + (CmmStaticsRaw lbl [CmmStaticLit (CmmFloat f frep)]) `consOL` (addr_code `snocOL` LD format dst addr) return (Any format code) -getRegister' dflags platform (CmmLit lit) +getRegister' config platform (CmmLit lit) | target32Bit platform = let rep = cmmLitType platform lit imm = litToImm lit @@ -684,12 +696,12 @@ in return (Any (cmmTypeFormat rep) code) | otherwise = do lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference dflags DataReference lbl + dynRef <- cmmMakeDynamicReference config DataReference lbl Amode addr addr_code <- getAmode D dynRef let rep = cmmLitType platform lit format = cmmTypeFormat rep code dst = - LDATA (Section ReadOnlyData lbl) (RawCmmStatics lbl [CmmStaticLit lit]) + LDATA (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmStaticLit lit]) `consOL` (addr_code `snocOL` LD format dst addr) return (Any format code) @@ -1031,8 +1043,8 @@ -- dst is a reg, but src could be anything assignReg_IntCode _ reg src = do - dflags <- getDynFlags - let dst = getRegisterReg (targetPlatform dflags) reg + platform <- getPlatform + let dst = getRegisterReg platform reg r <- getRegister src return $ case r of Any _ code -> code dst @@ -1053,8 +1065,8 @@ genJump tree gregs = do - dflags <- getDynFlags - genJump' tree (platformToGCP (targetPlatform dflags)) gregs + platform <- getPlatform + genJump' tree (platformToGCP platform) gregs genJump' :: CmmExpr -> GenCCallPlatform -> [Reg] -> NatM InstrBlock @@ -1132,9 +1144,8 @@ = return $ nilOL genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] - = do dflags <- getDynFlags - let platform = targetPlatform dflags - fmt = intFormat width + = do platform <- getPlatform + let fmt = intFormat width reg_dst = getRegisterReg platform (CmmLocal dst) (instr, n_code) <- case amop of AMO_Add -> getSomeRegOrImm ADD True reg_dst @@ -1184,9 +1195,8 @@ return (op dst dst (RIReg n_reg), n_code) genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr] - = do dflags <- getDynFlags - let platform = targetPlatform dflags - fmt = intFormat width + = do platform <- getPlatform + let fmt = intFormat width reg_dst = getRegisterReg platform (CmmLocal dst) form = if widthInBits width == 64 then DS else D Amode addr_reg addr_code <- getAmode form addr @@ -1216,9 +1226,8 @@ return $ unitOL(HWSYNC) `appOL` code genCCall (PrimTarget (MO_Clz width)) [dst] [src] - = do dflags <- getDynFlags - let platform = targetPlatform dflags - reg_dst = getRegisterReg platform (CmmLocal dst) + = do platform <- getPlatform + let reg_dst = getRegisterReg platform (CmmLocal dst) if target32Bit platform && width == W64 then do ChildCode64 code vr_lo <- iselExpr64 src @@ -1268,9 +1277,8 @@ return $ s_code `appOL` pre `appOL` cntlz `appOL` post genCCall (PrimTarget (MO_Ctz width)) [dst] [src] - = do dflags <- getDynFlags - let platform = targetPlatform dflags - reg_dst = getRegisterReg platform (CmmLocal dst) + = do platform <- getPlatform + let reg_dst = getRegisterReg platform (CmmLocal dst) if target32Bit platform && width == W64 then do let format = II32 @@ -1334,8 +1342,7 @@ ] genCCall target dest_regs argsAndHints - = do dflags <- getDynFlags - let platform = targetPlatform dflags + = do platform <- getPlatform case target of PrimTarget (MO_S_QuotRem width) -> divOp1 platform True width dest_regs argsAndHints @@ -1354,7 +1361,8 @@ dest_regs argsAndHints PrimTarget MO_F64_Fabs -> fabs platform dest_regs argsAndHints PrimTarget MO_F32_Fabs -> fabs platform dest_regs argsAndHints - _ -> genCCall' dflags (platformToGCP platform) + _ -> do config <- getConfig + genCCall' config (platformToGCP platform) target dest_regs argsAndHints where divOp1 platform signed width [res_q, res_r] [arg_x, arg_y] = do let reg_q = getRegisterReg platform (CmmLocal res_q) @@ -1586,7 +1594,7 @@ genCCall' - :: DynFlags + :: NCGConfig -> GenCCallPlatform -> ForeignTarget -- function to call -> [CmmFormal] -- where to put the result @@ -1639,7 +1647,7 @@ -} -genCCall' dflags gcp target dest_regs args +genCCall' config gcp target dest_regs args = do (finalStack,passArgumentsCode,usedRegs) <- passArguments (zip3 args argReps argHints) @@ -1705,7 +1713,6 @@ `snocOL` BCTRL usedRegs `appOL` codeAfter) where - config = initConfig dflags platform = ncgPlatform config uses_pic_base_implicitly = do @@ -1777,7 +1784,7 @@ passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed) passArguments ((arg,arg_ty,_):args) gprs fprs stackOffset accumCode accumUsed | isWord64 arg_ty - && target32Bit (targetPlatform dflags) = + && target32Bit (ncgPlatform config) = do ChildCode64 code vr_lo <- iselExpr64 arg let vr_hi = getHiVRegFromLo vr_lo @@ -1945,8 +1952,7 @@ outOfLineMachOp mop = do - dflags <- getDynFlags - mopExpr <- cmmMakeDynamicReference dflags CallReference $ + mopExpr <- cmmMakeDynamicReference config CallReference $ mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction let mopLabelOrExpr = case mopExpr of CmmLit (CmmLabel lbl) -> Left lbl @@ -2041,8 +2047,8 @@ -- ----------------------------------------------------------------------------- -- Generating a table-branch -genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock -genSwitch dflags expr targets +genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock +genSwitch config expr targets | OSAIX <- platformOS platform = do (reg,e_code) <- getSomeReg (cmmOffset platform expr offset) @@ -2050,7 +2056,7 @@ sha = if target32Bit platform then 2 else 3 tmp <- getNewRegNat fmt lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference dflags DataReference lbl + dynRef <- cmmMakeDynamicReference config DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let code = e_code `appOL` t_code `appOL` toOL [ SL fmt tmp reg (RIImm (ImmInt sha)), @@ -2067,7 +2073,7 @@ sha = if target32Bit platform then 2 else 3 tmp <- getNewRegNat fmt lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference dflags DataReference lbl + dynRef <- cmmMakeDynamicReference config DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let code = e_code `appOL` t_code `appOL` toOL [ SL fmt tmp reg (RIImm (ImmInt sha)), @@ -2095,7 +2101,6 @@ where (offset, ids) = switchTargetsToTable targets platform = ncgPlatform config - config = initConfig dflags generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl RawCmmStatics Instr) @@ -2110,7 +2115,7 @@ = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 (ncgWordWidth config)) where blockLabel = blockLbl blockid - in Just (CmmData (Section ReadOnlyData lbl) (RawCmmStatics lbl jumpTable)) + in Just (CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl jumpTable)) generateJumpTableForInstr _ _ = Nothing -- ----------------------------------------------------------------------------- @@ -2334,13 +2339,13 @@ lbl <- getNewLabelNat itmp <- getNewRegNat II32 ftmp <- getNewRegNat FF64 - dflags <- getDynFlags + config <- getConfig platform <- getPlatform - dynRef <- cmmMakeDynamicReference dflags DataReference lbl + dynRef <- cmmMakeDynamicReference config DataReference lbl Amode addr addr_code <- getAmode D dynRef let code' dst = code `appOL` maybe_exts `appOL` toOL [ - LDATA (Section ReadOnlyData lbl) $ RawCmmStatics lbl + LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl [CmmStaticLit (CmmInt 0x43300000 W32), CmmStaticLit (CmmInt 0x80000000 W32)], XORIS itmp src (ImmInt 0x8000), diff --git a/compiler/GHC/CmmToAsm/PPC/Cond.hs b/compiler/GHC/CmmToAsm/PPC/Cond.hs --- a/compiler/GHC/CmmToAsm/PPC/Cond.hs +++ b/compiler/GHC/CmmToAsm/PPC/Cond.hs @@ -8,9 +8,9 @@ where -import GhcPrelude +import GHC.Prelude -import Panic +import GHC.Utils.Panic data Cond = ALWAYS 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 @@ -24,7 +24,7 @@ where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.PPC.Regs import GHC.CmmToAsm.PPC.Cond @@ -41,9 +41,9 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Cmm.Info -import FastString +import GHC.Data.FastString import GHC.Cmm.CLabel -import Outputable +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique.FM (listToUFM, lookupUFM) import GHC.Types.Unique.Supply @@ -187,6 +187,9 @@ -- comment pseudo-op = COMMENT FastString + -- location pseudo-op (file, line, col, name) + | LOCATION Int Int Int String + -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. @@ -643,6 +646,7 @@ ppc_isMetaInstr instr = case instr of COMMENT{} -> True + LOCATION{} -> True LDATA{} -> True NEWBLOCK{} -> True DELTA{} -> True 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 @@ -9,7 +9,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module GHC.CmmToAsm.PPC.Ppr (pprNatCmmDecl) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.PPC.Regs import GHC.CmmToAsm.PPC.Instr @@ -32,8 +32,8 @@ import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Driver.Session (targetPlatform) import Data.Word @@ -59,14 +59,17 @@ ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null, -- so label needed - vcat (map (pprBasicBlock platform top_info) blocks) + vcat (map (pprBasicBlock config top_info) blocks) $$ + (if ncgDebugLevel config > 0 + then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ + pprSizeDecl platform lbl - Just (RawCmmStatics info_lbl _) -> + Just (CmmStaticsRaw info_lbl _) -> pprSectionAlign config (Section Text info_lbl) $$ (if platformHasSubsectionsViaSymbols platform then ppr (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ - vcat (map (pprBasicBlock platform top_info) blocks) $$ + vcat (map (pprBasicBlock config 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 @@ -76,8 +79,16 @@ <+> ppr info_lbl <+> char '-' <+> ppr (mkDeadStripPreventer info_lbl) - else empty) + else empty) $$ + pprSizeDecl platform info_lbl +-- | Output the ELF .size directive. +pprSizeDecl :: Platform -> CLabel -> SDoc +pprSizeDecl platform lbl + = if osElfTarget (platformOS platform) + then text "\t.size" <+> ppr lbl <> text ", .-" <> ppr lbl + else empty + pprFunctionDescriptor :: CLabel -> SDoc pprFunctionDescriptor lab = pprGloblDecl lab $$ text "\t.section \".opd\", \"aw\"" @@ -105,15 +116,22 @@ $$ text "\t.localentry\t" <> ppr lab <> text ",.-" <> ppr lab -pprBasicBlock :: Platform -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc -pprBasicBlock platform info_env (BasicBlock blockid instrs) +pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr + -> SDoc +pprBasicBlock config info_env (BasicBlock blockid instrs) = maybe_infotable $$ - pprLabel platform (blockLbl blockid) $$ - vcat (map (pprInstr platform) instrs) + pprLabel platform asmLbl $$ + vcat (map (pprInstr platform) instrs) $$ + (if ncgDebugLevel config > 0 + then ppr (mkAsmTempEndLabel asmLbl) <> char ':' + else empty + ) where + asmLbl = blockLbl blockid + platform = ncgPlatform config maybe_infotable = case mapLookup blockid info_env of Nothing -> empty - Just (RawCmmStatics info_lbl info) -> + Just (CmmStaticsRaw info_lbl info) -> pprAlignForSection platform Text $$ vcat (map (pprData platform) info) $$ pprLabel platform info_lbl @@ -122,7 +140,7 @@ pprDatas :: Platform -> RawCmmStatics -> SDoc -- See note [emit-time elimination of static indirections] in CLabel. -pprDatas _platform (RawCmmStatics 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 @@ -131,11 +149,12 @@ , alias `mayRedirectTo` ind' = pprGloblDecl alias $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') -pprDatas platform (RawCmmStatics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) +pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) pprData :: Platform -> CmmStatic -> SDoc pprData platform d = case d of - CmmString str -> pprBytes str + CmmString str -> pprString str + CmmFileEmbed path -> pprFileEmbed path CmmUninitialised bytes -> text ".space " <> int bytes CmmStaticLit lit -> pprDataItem platform lit @@ -336,6 +355,9 @@ -- -> if platformOS platform == OSLinux -- then text "# " <> ftext s -- else text "; " <> ftext s + + LOCATION file line col _name + -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col DELTA d -> pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) diff --git a/compiler/GHC/CmmToAsm/PPC/RegInfo.hs b/compiler/GHC/CmmToAsm/PPC/RegInfo.hs --- a/compiler/GHC/CmmToAsm/PPC/RegInfo.hs +++ b/compiler/GHC/CmmToAsm/PPC/RegInfo.hs @@ -19,7 +19,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.PPC.Instr @@ -28,7 +28,7 @@ import GHC.Cmm.CLabel import GHC.Types.Unique -import Outputable (ppr, text, Outputable, (<>)) +import GHC.Utils.Outputable (ppr, text, Outputable, (<>)) data JumpDest = DestBlockId BlockId @@ -48,8 +48,8 @@ -- Here because it knows about JumpDest shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics -shortcutStatics fn (RawCmmStatics lbl statics) - = RawCmmStatics lbl $ map (shortcutStatic fn) statics +shortcutStatics fn (CmmStaticsRaw lbl statics) + = CmmStaticsRaw lbl $ map (shortcutStatic fn) statics -- we need to get the jump tables, so apply the mapping to the entries -- of a CmmData too. diff --git a/compiler/GHC/CmmToAsm/PPC/Regs.hs b/compiler/GHC/CmmToAsm/PPC/Regs.hs --- a/compiler/GHC/CmmToAsm/PPC/Regs.hs +++ b/compiler/GHC/CmmToAsm/PPC/Regs.hs @@ -31,6 +31,7 @@ allMachRegNos, classOfRealReg, showReg, + toRegNo, -- machine specific allFPArgRegs, @@ -49,7 +50,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform.Reg import GHC.Platform.Reg.Class @@ -60,7 +61,7 @@ import GHC.Types.Unique import GHC.Platform.Regs -import Outputable +import GHC.Utils.Outputable import GHC.Platform import Data.Word ( Word8, Word16, Word32, Word64 ) @@ -250,7 +251,9 @@ | n >= 32 && n <= 63 = "%f" ++ show (n - 32) | otherwise = "%unknown_powerpc_real_reg_" ++ show n - +toRegNo :: Reg -> RegNo +toRegNo (RegReal (RealRegSingle n)) = n +toRegNo _ = panic "PPC.toRegNo: unsupported register" -- machine specific ------------------------------------------------------------ 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 @@ -14,23 +14,22 @@ floatToBytes, doubleToBytes, pprASCII, - pprBytes, + pprString, + pprFileEmbed, pprSectionHeader ) where -import GhcPrelude +import GHC.Prelude -import AsmUtils +import GHC.Utils.Asm import GHC.Cmm.CLabel import GHC.Cmm import GHC.CmmToAsm.Config -import GHC.Driver.Session -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Platform -import FileCleanup import qualified Data.Array.Unsafe as U ( castSTUArray ) import Data.Array.ST @@ -43,7 +42,6 @@ import qualified Data.ByteString as BS import GHC.Exts import GHC.Word -import System.IO.Unsafe @@ -98,7 +96,7 @@ -- Printing ASCII strings. -- -- Print as a string and escape non-printable characters. --- This is similar to charToC in Utils. +-- This is similar to charToC in GHC.Utils.Misc pprASCII :: ByteString -> SDoc pprASCII str @@ -129,24 +127,18 @@ ] ord0 = 0x30 -- = ord '0' --- | Pretty print binary data. --- --- Use either the ".string" directive or a ".incbin" directive. --- See Note [Embedding large binary blobs] +-- | Emit a ".string" directive +pprString :: ByteString -> SDoc +pprString bs = text "\t.string " <> doubleQuotes (pprASCII bs) + +-- | Emit a ".incbin" directive -- -- A NULL byte is added after the binary data. --- -pprBytes :: ByteString -> SDoc -pprBytes bs = sdocWithDynFlags $ \dflags -> - if binBlobThreshold dflags == 0 - || fromIntegral (BS.length bs) <= binBlobThreshold dflags - then text "\t.string " <> doubleQuotes (pprASCII bs) - else unsafePerformIO $ do - bFile <- newTempName dflags TFL_CurrentModule ".dat" - BS.writeFile bFile bs - return $ text "\t.incbin " - <> pprFilePathString bFile -- proper escape (see #16389) - <> text "\n\t.byte 0" +pprFileEmbed :: FilePath -> SDoc +pprFileEmbed path + = text "\t.incbin " + <> pprFilePathString path -- proper escape (see #16389) + <> text "\n\t.byte 0" {- Note [Embedding large binary blobs] diff --git a/compiler/GHC/CmmToAsm/Reg/Graph.hs b/compiler/GHC/CmmToAsm/Reg/Graph.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph.hs @@ -5,9 +5,9 @@ module GHC.CmmToAsm.Reg.Graph ( regAlloc ) where -import GhcPrelude +import GHC.Prelude -import qualified GraphColor as Color +import qualified GHC.Data.Graph.Color as Color import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Reg.Graph.Spill import GHC.CmmToAsm.Reg.Graph.SpillClean @@ -20,13 +20,13 @@ import GHC.Platform.Reg.Class import GHC.Platform.Reg -import Bag -import Outputable +import GHC.Data.Bag +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Types.Unique.Supply -import Util (seqList) +import GHC.Utils.Misc (seqList) import GHC.CmmToAsm.CFG import Data.Maybe diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs @@ -22,12 +22,12 @@ squeese ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique -import MonadUtils (concatMapM) +import GHC.Utils.Monad (concatMapM) -- Some basic register classes. diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs @@ -3,15 +3,15 @@ regCoalesce, slurpJoinMovs ) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr import GHC.Platform.Reg import GHC.Cmm -import Bag -import Digraph +import GHC.Data.Bag +import GHC.Data.Graph.Directed import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Types.Unique.Supply diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs @@ -7,7 +7,7 @@ SpillStats(..), accSpillSL ) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr @@ -16,13 +16,13 @@ import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections -import MonadUtils -import State +import GHC.Utils.Monad +import GHC.Utils.Monad.State import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Types.Unique.Supply -import Outputable +import GHC.Utils.Outputable import GHC.Platform import Data.List diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs @@ -29,7 +29,7 @@ module GHC.CmmToAsm.Reg.Graph.SpillClean ( cleanSpills ) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr @@ -40,8 +40,8 @@ import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique -import State -import Outputable +import GHC.Utils.Monad.State +import GHC.Utils.Outputable import GHC.Platform import GHC.Cmm.Dataflow.Collections diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs @@ -13,24 +13,24 @@ lifeMapFromSpillCostInfo ) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr import GHC.Platform.Reg.Class import GHC.Platform.Reg -import GraphBase +import GHC.Data.Graph.Base import GHC.Cmm.Dataflow.Collections (mapLookup) import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Types.Unique.FM import GHC.Types.Unique.Set -import Digraph (flattenSCCs) -import Outputable +import GHC.Data.Graph.Directed (flattenSCCs) +import GHC.Utils.Outputable import GHC.Platform -import State +import GHC.Utils.Monad.State import GHC.CmmToAsm.CFG import Data.List (nub, minimumBy) diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs @@ -16,9 +16,9 @@ countSRMs, addSRM ) where -import GhcPrelude +import GHC.Prelude -import qualified GraphColor as Color +import qualified GHC.Data.Graph.Color as Color import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Reg.Graph.Spill import GHC.CmmToAsm.Reg.Graph.SpillCost @@ -29,10 +29,10 @@ import GHC.CmmToAsm.Reg.Target import GHC.Platform -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique.FM import GHC.Types.Unique.Set -import State +import GHC.Utils.Monad.State -- | Holds interesting statistics from the register allocator. data RegAllocStats statics instr 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 @@ -8,16 +8,16 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform.Reg.Class import GHC.Platform.Reg -import GraphBase +import GHC.Data.Graph.Base import GHC.Types.Unique.Set import GHC.Platform -import Panic +import GHC.Utils.Panic -- trivColorable --------------------------------------------------------------- diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs b/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs @@ -15,7 +15,7 @@ squeese, ) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Graph.Base (Reg(..), RegSub(..), RegClass(..)) import GHC.Types.Unique.Set diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs @@ -104,7 +104,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Linear.State import GHC.CmmToAsm.Reg.Linear.Base @@ -126,12 +126,12 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm hiding (RegSet) -import Digraph +import GHC.Data.Graph.Directed import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique.Supply -import Outputable +import GHC.Utils.Outputable import GHC.Platform import Data.Maybe diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs @@ -17,14 +17,14 @@ where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Linear.StackMap import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Config import GHC.Platform.Reg -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Supply diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs @@ -9,13 +9,13 @@ where -import GhcPrelude +import GHC.Prelude import GHC.Platform.Reg import GHC.Platform.Reg.Class import GHC.CmmToAsm.Config -import Panic +import GHC.Utils.Panic import GHC.Platform -- ----------------------------------------------------------------------------- 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 @@ -10,7 +10,7 @@ -- module GHC.CmmToAsm.Reg.Linear.JoinToTargets (joinToTargets) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Linear.State import GHC.CmmToAsm.Reg.Linear.Base @@ -22,8 +22,8 @@ import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections -import Digraph -import Outputable +import GHC.Data.Graph.Directed +import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs b/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs @@ -1,13 +1,13 @@ -- | Free regs map for PowerPC module GHC.CmmToAsm.Reg.Linear.PPC where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.PPC.Regs import GHC.Platform.Reg.Class import GHC.Platform.Reg -import Outputable +import GHC.Utils.Outputable import GHC.Platform import Data.Word diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs b/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs @@ -3,14 +3,14 @@ -- | Free regs map for SPARC module GHC.CmmToAsm.Reg.Linear.SPARC where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Regs import GHC.Platform.Reg.Class import GHC.Platform.Reg import GHC.Platform.Regs -import Outputable +import GHC.Utils.Outputable import GHC.Platform import Data.Word diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs b/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs @@ -20,7 +20,7 @@ where -import GhcPrelude +import GHC.Prelude import GHC.Types.Unique.FM import GHC.Types.Unique diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs @@ -38,7 +38,7 @@ ) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Linear.Stats import GHC.CmmToAsm.Reg.Linear.StackMap diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs @@ -6,16 +6,16 @@ where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Linear.Base import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr import GHC.Types.Unique.FM -import Outputable +import GHC.Utils.Outputable -import State +import GHC.Utils.Monad.State -- | Build a map of how many times each reg was alloced, clobbered, loaded etc. binSpillReasons diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs b/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs @@ -2,12 +2,12 @@ -- | Free regs map for i386 module GHC.CmmToAsm.Reg.Linear.X86 where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.X86.Regs import GHC.Platform.Reg.Class import GHC.Platform.Reg -import Panic +import GHC.Utils.Panic import GHC.Platform import Data.Word diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs b/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs @@ -2,12 +2,12 @@ -- | Free regs map for x86_64 module GHC.CmmToAsm.Reg.Linear.X86_64 where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.X86.Regs import GHC.Platform.Reg.Class import GHC.Platform.Reg -import Panic +import GHC.Utils.Panic import GHC.Platform import Data.Word 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 @@ -37,7 +37,7 @@ regLiveness, cmmTopLiveness ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform.Reg import GHC.CmmToAsm.Instr @@ -49,15 +49,15 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm hiding (RegSet, emptyRegSet) -import Digraph -import MonadUtils -import Outputable +import GHC.Data.Graph.Directed +import GHC.Utils.Monad +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique.Supply -import Bag -import State +import GHC.Data.Bag +import GHC.Utils.Monad.State import Data.List import Data.Maybe diff --git a/compiler/GHC/CmmToAsm/Reg/Target.hs b/compiler/GHC/CmmToAsm/Reg/Target.hs --- a/compiler/GHC/CmmToAsm/Reg/Target.hs +++ b/compiler/GHC/CmmToAsm/Reg/Target.hs @@ -21,13 +21,13 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform.Reg import GHC.Platform.Reg.Class import GHC.CmmToAsm.Format -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Platform diff --git a/compiler/GHC/CmmToAsm/SPARC/AddrMode.hs b/compiler/GHC/CmmToAsm/SPARC/AddrMode.hs --- a/compiler/GHC/CmmToAsm/SPARC/AddrMode.hs +++ b/compiler/GHC/CmmToAsm/SPARC/AddrMode.hs @@ -6,7 +6,7 @@ where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Imm import GHC.CmmToAsm.SPARC.Base diff --git a/compiler/GHC/CmmToAsm/SPARC/Base.hs b/compiler/GHC/CmmToAsm/SPARC/Base.hs --- a/compiler/GHC/CmmToAsm/SPARC/Base.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Base.hs @@ -17,9 +17,9 @@ where -import GhcPrelude +import GHC.Prelude -import Panic +import GHC.Utils.Panic import Data.Int diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs @@ -20,7 +20,7 @@ #include "HsVersions.h" -- NCG stuff: -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Base import GHC.CmmToAsm.SPARC.CodeGen.Sanity @@ -53,10 +53,9 @@ -- The rest: import GHC.Types.Basic -import GHC.Driver.Session -import FastString -import OrdList -import Outputable +import GHC.Data.FastString +import GHC.Data.OrdList +import GHC.Utils.Outputable import GHC.Platform import Control.Monad ( mapAndUnzipM ) @@ -342,7 +341,7 @@ -> Maybe (NatCmmDecl RawCmmStatics Instr) generateJumpTableForInstr platform (JMP_TBL _ ids label) = let jumpTable = map (jumpTableEntry platform) ids - in Just (CmmData (Section ReadOnlyData label) (RawCmmStatics label jumpTable)) + in Just (CmmData (Section ReadOnlyData label) (CmmStaticsRaw label jumpTable)) generateJumpTableForInstr _ _ = Nothing @@ -455,7 +454,7 @@ let transfer_code = toOL (move_final vregs allArgRegs extraStackArgsHere) - dflags <- getDynFlags + platform <- getPlatform return $ argcode `appOL` move_sp_down `appOL` @@ -463,7 +462,7 @@ callinsns `appOL` unitOL NOP `appOL` move_sp_up `appOL` - assign_code (targetPlatform dflags) dest_regs + assign_code platform dest_regs -- | Generate code to calculate an argument, and move it into one @@ -594,8 +593,8 @@ = do let functionName = outOfLineMachOp_table mop - dflags <- getDynFlags - mopExpr <- cmmMakeDynamicReference dflags CallReference + config <- getConfig + mopExpr <- cmmMakeDynamicReference config CallReference $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction let mopLabelOrExpr diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs @@ -4,7 +4,7 @@ where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 import GHC.CmmToAsm.SPARC.CodeGen.Base @@ -18,7 +18,7 @@ import GHC.Cmm -import OrdList +import GHC.Data.OrdList -- | Generate code to reference a memory address. diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs @@ -13,7 +13,7 @@ where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Instr import GHC.CmmToAsm.SPARC.Cond @@ -27,8 +27,8 @@ import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Platform -import Outputable -import OrdList +import GHC.Utils.Outputable +import GHC.Data.OrdList -------------------------------------------------------------------------------- -- | 'InstrBlock's are the insn sequences generated by the insn selectors. diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs @@ -6,7 +6,7 @@ where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 import GHC.CmmToAsm.SPARC.CodeGen.Base @@ -20,8 +20,8 @@ import GHC.Cmm -import OrdList -import Outputable +import GHC.Data.OrdList +import GHC.Utils.Outputable getCondCode :: CmmExpr -> NatM CondCode diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs @@ -7,7 +7,7 @@ where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Instr import GHC.CmmToAsm.SPARC.Imm @@ -19,8 +19,8 @@ import GHC.Cmm -import Outputable -import OrdList +import GHC.Utils.Outputable +import GHC.Data.OrdList -- | Expand out synthetic instructions in this top level thing expandTop :: NatCmmDecl RawCmmStatics Instr -> NatCmmDecl RawCmmStatics Instr diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs @@ -6,7 +6,7 @@ where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.CodeGen.CondCode import GHC.CmmToAsm.SPARC.CodeGen.Amode @@ -26,8 +26,8 @@ import GHC.Cmm import Control.Monad (liftM) -import OrdList -import Outputable +import GHC.Data.OrdList +import GHC.Utils.Outputable -- | The dual to getAnyReg: compute an expression into a register, but -- we don't mind which one it is. @@ -86,7 +86,7 @@ let code dst = toOL [ -- the data area - LDATA (Section ReadOnlyData lbl) $ RawCmmStatics lbl + LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl [CmmStaticLit (CmmFloat f W32)], -- load the literal @@ -99,7 +99,7 @@ lbl <- getNewLabelNat tmp <- getNewRegNat II32 let code dst = toOL [ - LDATA (Section ReadOnlyData lbl) $ RawCmmStatics lbl + LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl [CmmStaticLit (CmmFloat d W64)], SETHI (HI (ImmCLbl lbl)) tmp, LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs @@ -7,7 +7,7 @@ where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 import GHC.CmmToAsm.SPARC.CodeGen.Base @@ -24,8 +24,8 @@ import GHC.Cmm -import OrdList -import Outputable +import GHC.Data.OrdList +import GHC.Utils.Outputable -- | Code to assign a 64 bit value to memory. assignMem_I64Code diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs @@ -6,7 +6,7 @@ where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Instr import GHC.CmmToAsm.SPARC.Ppr () -- For Outputable instances @@ -14,7 +14,7 @@ import GHC.Cmm -import Outputable +import GHC.Utils.Outputable -- | Enforce intra-block invariants. diff --git a/compiler/GHC/CmmToAsm/SPARC/Cond.hs b/compiler/GHC/CmmToAsm/SPARC/Cond.hs --- a/compiler/GHC/CmmToAsm/SPARC/Cond.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Cond.hs @@ -7,7 +7,7 @@ where -import GhcPrelude +import GHC.Prelude -- | Branch condition codes. data Cond diff --git a/compiler/GHC/CmmToAsm/SPARC/Imm.hs b/compiler/GHC/CmmToAsm/SPARC/Imm.hs --- a/compiler/GHC/CmmToAsm/SPARC/Imm.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Imm.hs @@ -7,12 +7,12 @@ where -import GhcPrelude +import GHC.Prelude import GHC.Cmm import GHC.Cmm.CLabel -import Outputable +import GHC.Utils.Outputable -- | An immediate value. -- Not all of these are directly representable by the machine. diff --git a/compiler/GHC/CmmToAsm/SPARC/Instr.hs b/compiler/GHC/CmmToAsm/SPARC/Instr.hs --- a/compiler/GHC/CmmToAsm/SPARC/Instr.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Instr.hs @@ -24,7 +24,7 @@ where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Stack import GHC.CmmToAsm.SPARC.Imm @@ -43,8 +43,8 @@ import GHC.Platform.Regs import GHC.Cmm.BlockId import GHC.Cmm -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Platform diff --git a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs --- a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs @@ -24,7 +24,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Regs import GHC.CmmToAsm.SPARC.Instr @@ -46,9 +46,9 @@ import GHC.Cmm.Dataflow.Collections import GHC.Types.Unique ( pprUniqueAlways ) -import Outputable +import GHC.Utils.Outputable import GHC.Platform -import FastString +import GHC.Data.FastString -- ----------------------------------------------------------------------------- -- Printing this stuff out @@ -67,7 +67,7 @@ pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock platform top_info) blocks) - Just (RawCmmStatics info_lbl _) -> + Just (CmmStaticsRaw info_lbl _) -> (if platformHasSubsectionsViaSymbols platform then pprSectionAlign config dspSection $$ ppr (mkDeadStripPreventer info_lbl) <> char ':' @@ -96,7 +96,7 @@ where maybe_infotable = case mapLookup blockid info_env of Nothing -> empty - Just (RawCmmStatics info_lbl info) -> + Just (CmmStaticsRaw info_lbl info) -> pprAlignForSection Text $$ vcat (map (pprData platform) info) $$ pprLabel platform info_lbl @@ -104,7 +104,7 @@ pprDatas :: Platform -> RawCmmStatics -> SDoc -- See note [emit-time elimination of static indirections] in CLabel. -pprDatas _platform (RawCmmStatics 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 @@ -113,12 +113,14 @@ , alias `mayRedirectTo` ind' = pprGloblDecl alias $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') -pprDatas platform (RawCmmStatics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) +pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) pprData :: Platform -> CmmStatic -> SDoc -pprData _ (CmmString str) = pprBytes str -pprData _ (CmmUninitialised bytes) = text ".skip " <> int bytes -pprData platform (CmmStaticLit lit) = pprDataItem platform lit +pprData platform d = case d of + CmmString str -> pprString str + CmmFileEmbed path -> pprFileEmbed path + CmmUninitialised bytes -> text ".skip " <> int bytes + CmmStaticLit lit -> pprDataItem platform lit pprGloblDecl :: CLabel -> SDoc pprGloblDecl lbl diff --git a/compiler/GHC/CmmToAsm/SPARC/Regs.hs b/compiler/GHC/CmmToAsm/SPARC/Regs.hs --- a/compiler/GHC/CmmToAsm/SPARC/Regs.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Regs.hs @@ -32,7 +32,7 @@ where -import GhcPrelude +import GHC.Prelude import GHC.Platform.SPARC import GHC.Platform.Reg @@ -40,7 +40,7 @@ import GHC.CmmToAsm.Format import GHC.Types.Unique -import Outputable +import GHC.Utils.Outputable {- The SPARC has 64 registers of interest; 32 integer registers and 32 diff --git a/compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs b/compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs --- a/compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs +++ b/compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs @@ -8,7 +8,7 @@ where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Instr import GHC.CmmToAsm.SPARC.Imm @@ -17,8 +17,8 @@ import GHC.Cmm.BlockId import GHC.Cmm -import Panic -import Outputable +import GHC.Utils.Panic +import GHC.Utils.Outputable data JumpDest = DestBlockId BlockId @@ -44,8 +44,8 @@ shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics -shortcutStatics fn (RawCmmStatics lbl statics) - = RawCmmStatics lbl $ map (shortcutStatic fn) statics +shortcutStatics fn (CmmStaticsRaw lbl statics) + = CmmStaticsRaw lbl $ map (shortcutStatic fn) statics -- we need to get the jump tables, so apply the mapping to the entries -- of a CmmData too. diff --git a/compiler/GHC/CmmToAsm/SPARC/Stack.hs b/compiler/GHC/CmmToAsm/SPARC/Stack.hs --- a/compiler/GHC/CmmToAsm/SPARC/Stack.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Stack.hs @@ -7,7 +7,7 @@ where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.AddrMode import GHC.CmmToAsm.SPARC.Regs @@ -15,7 +15,7 @@ import GHC.CmmToAsm.SPARC.Imm import GHC.CmmToAsm.Config -import Outputable +import GHC.Utils.Outputable -- | Get an AddrMode relative to the address in sp. -- This gives us a stack relative addressing mode for volatile 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 @@ -36,7 +36,7 @@ #include "HsVersions.h" -- NCG stuff: -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.X86.Instr import GHC.CmmToAsm.X86.Cond @@ -67,7 +67,7 @@ -- Our intermediate code: import GHC.Types.Basic import GHC.Cmm.BlockId -import GHC.Types.Module ( primUnitId ) +import GHC.Unit ( primUnitId ) import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Cmm @@ -81,11 +81,11 @@ -- The rest: import GHC.Types.ForeignCall ( CCallConv(..) ) -import OrdList -import Outputable -import FastString +import GHC.Data.OrdList +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Driver.Session -import Util +import GHC.Utils.Misc import GHC.Types.Unique.Supply ( getUniqueM ) import Control.Monad @@ -104,26 +104,13 @@ sse2Enabled :: NatM Bool sse2Enabled = do - platform <- getPlatform - case platformArch platform of - -- We Assume SSE1 and SSE2 operations are available on both - -- x86 and x86_64. Historically we didn't default to SSE2 and - -- SSE1 on x86, which results in defacto nondeterminism for how - -- rounding behaves in the associated x87 floating point instructions - -- because variations in the spill/fpu stack placement of arguments for - -- operations would change the precision and final result of what - -- would otherwise be the same expressions with respect to single or - -- double precision IEEE floating point computations. - ArchX86_64 -> return True - ArchX86 -> return True - _ -> panic "trying to generate x86/x86_64 on the wrong platform" - + config <- getConfig + return (ncgSseVersion config >= Just SSE2) sse4_2Enabled :: NatM Bool sse4_2Enabled = do - dflags <- getDynFlags - return (isSse4_2Enabled dflags) - + config <- getConfig + return (ncgSseVersion config >= Just SSE42) cmmTopCodeGen :: RawCmmDecl @@ -1474,18 +1461,18 @@ memConstant align lit = do lbl <- getNewLabelNat let rosection = Section ReadOnlyData lbl - dflags <- getDynFlags + config <- getConfig platform <- getPlatform (addr, addr_code) <- if target32Bit platform then do dynRef <- cmmMakeDynamicReference - dflags + config DataReference lbl Amode addr addr_code <- getAmode dynRef return (addr, addr_code) else return (ripRel (ImmCLbl lbl), nilOL) let code = - LDATA rosection (align, RawCmmStatics lbl [CmmStaticLit lit]) + LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit]) `consOL` addr_code return (Amode addr code) @@ -2122,10 +2109,10 @@ | otherwise = do code_src <- getAnyReg src - platform <- ncgPlatform <$> getConfig + config <- getConfig + let platform = ncgPlatform config let dst_r = getRegisterReg platform (CmmLocal dst) - dflags <- getDynFlags - if isBmi2Enabled dflags + if ncgBmiVersion config >= Just BMI2 then do src_r <- getNewRegNat (intFormat width) let instrs = appOL (code_src src_r) $ case width of @@ -2158,13 +2145,13 @@ bw = widthInBits width genCCall bits mop dst args bid = do - dflags <- getDynFlags - instr <- genCCall' dflags bits mop dst args bid + config <- getConfig + instr <- genCCall' config bits mop dst args bid return (instr, Nothing) -- genCCall' handles cases not introducing new code blocks. genCCall' - :: DynFlags + :: NCGConfig -> Bool -- 32 bit platform? -> ForeignTarget -- function to call -> [CmmFormal] -- where to put the result @@ -2174,9 +2161,9 @@ -- Unroll memcpy calls if the number of bytes to copy isn't too -- large. Otherwise, call C's memcpy. -genCCall' dflags _ (PrimTarget (MO_Memcpy align)) _ +genCCall' config _ (PrimTarget (MO_Memcpy align)) _ [dst, src, CmmLit (CmmInt n _)] _ - | fromInteger insns <= maxInlineMemcpyInsns dflags = do + | fromInteger insns <= ncgInlineThresholdMemcpy config = do code_dst <- getAnyReg dst dst_r <- getNewRegNat format code_src <- getAnyReg src @@ -2185,7 +2172,7 @@ return $ code_dst dst_r `appOL` code_src src_r `appOL` go dst_r src_r tmp_r (fromInteger n) where - platform = targetPlatform dflags + platform = ncgPlatform config -- The number of instructions we will generate (approx). We need 2 -- instructions per move. insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes) @@ -2224,12 +2211,12 @@ dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - i)) -genCCall' dflags _ (PrimTarget (MO_Memset align)) _ +genCCall' config _ (PrimTarget (MO_Memset align)) _ [dst, CmmLit (CmmInt c _), CmmLit (CmmInt n _)] _ - | fromInteger insns <= maxInlineMemsetInsns dflags = do + | fromInteger insns <= ncgInlineThresholdMemset config = do code_dst <- getAnyReg dst dst_r <- getNewRegNat format if format == II64 && n >= 8 then do @@ -2242,7 +2229,7 @@ return $ code_dst dst_r `appOL` go4 dst_r (fromInteger n) where - platform = targetPlatform dflags + platform = ncgPlatform config maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported effectiveAlignment = min (alignmentOf align) maxAlignment format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment @@ -2348,10 +2335,10 @@ where format = intFormat width -genCCall' dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] +genCCall' config is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] args@[src] bid = do sse4_2 <- sse4_2Enabled - platform <- ncgPlatform <$> getConfig + let platform = ncgPlatform config if sse4_2 then do code_src <- getAnyReg src src_r <- getNewRegNat format @@ -2369,20 +2356,20 @@ unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) else nilOL) else do - targetExpr <- cmmMakeDynamicReference dflags + targetExpr <- cmmMakeDynamicReference config CallReference lbl let target = ForeignTarget targetExpr (ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn) - genCCall' dflags is32Bit target dest_regs args bid + genCCall' config is32Bit target dest_regs args bid where format = intFormat width lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width)) -genCCall' dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst] +genCCall' config is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst] args@[src, mask] bid = do - platform <- ncgPlatform <$> getConfig - if isBmi2Enabled dflags + let platform = ncgPlatform config + if ncgBmiVersion config >= Just BMI2 then do code_src <- getAnyReg src code_mask <- getAnyReg mask src_r <- getNewRegNat format @@ -2402,20 +2389,20 @@ unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) else nilOL) else do - targetExpr <- cmmMakeDynamicReference dflags + targetExpr <- cmmMakeDynamicReference config CallReference lbl let target = ForeignTarget targetExpr (ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn) - genCCall' dflags is32Bit target dest_regs args bid + genCCall' config is32Bit target dest_regs args bid where format = intFormat width lbl = mkCmmCodeLabel primUnitId (fsLit (pdepLabel width)) -genCCall' dflags is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst] +genCCall' config is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst] args@[src, mask] bid = do - platform <- ncgPlatform <$> getConfig - if isBmi2Enabled dflags + let platform = ncgPlatform config + if ncgBmiVersion config >= Just BMI2 then do code_src <- getAnyReg src code_mask <- getAnyReg mask src_r <- getNewRegNat format @@ -2435,30 +2422,31 @@ unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) else nilOL) else do - targetExpr <- cmmMakeDynamicReference dflags + targetExpr <- cmmMakeDynamicReference config CallReference lbl let target = ForeignTarget targetExpr (ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn) - genCCall' dflags is32Bit target dest_regs args bid + genCCall' config is32Bit target dest_regs args bid where format = intFormat width lbl = mkCmmCodeLabel primUnitId (fsLit (pextLabel width)) -genCCall' dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid +genCCall' config is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid | is32Bit && width == W64 = do -- Fallback to `hs_clz64` on i386 - targetExpr <- cmmMakeDynamicReference dflags CallReference lbl + targetExpr <- cmmMakeDynamicReference config CallReference lbl let target = ForeignTarget targetExpr (ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn) - genCCall' dflags is32Bit target dest_regs args bid + genCCall' config is32Bit target dest_regs args bid | otherwise = do code_src <- getAnyReg src - platform <- ncgPlatform <$> getConfig + config <- getConfig + let platform = ncgPlatform config let dst_r = getRegisterReg platform (CmmLocal dst) - if isBmi2Enabled dflags + if ncgBmiVersion config >= Just BMI2 then do src_r <- getNewRegNat (intFormat width) return $ appOL (code_src src_r) $ case width of @@ -2489,13 +2477,13 @@ bw = widthInBits width lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width)) -genCCall' dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do - targetExpr <- cmmMakeDynamicReference dflags +genCCall' config is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do + targetExpr <- cmmMakeDynamicReference config CallReference lbl let target = ForeignTarget targetExpr (ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn) - genCCall' dflags is32Bit target dest_regs args bid + genCCall' config is32Bit target dest_regs args bid where lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width)) @@ -3142,8 +3130,8 @@ -> NatM InstrBlock outOfLineCmmOp bid mop res args = do - dflags <- getDynFlags - targetExpr <- cmmMakeDynamicReference dflags CallReference lbl + config <- getConfig + targetExpr <- cmmMakeDynamicReference config CallReference lbl let target = ForeignTarget targetExpr (ForeignConvention CCallConv [] [] CmmMayReturn) @@ -3252,7 +3240,6 @@ genSwitch expr targets = do config <- getConfig - dflags <- getDynFlags let platform = ncgPlatform config if ncgPIC config then do @@ -3272,7 +3259,7 @@ -- if L0 is not preceded by a non-anonymous label in its section. OSDarwin | not is32bit -> Section Text lbl _ -> Section ReadOnlyData lbl - dynRef <- cmmMakeDynamicReference dflags DataReference lbl + dynRef <- cmmMakeDynamicReference config DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)) @@ -3329,7 +3316,7 @@ where blockLabel = blockLbl blockid in map jumpTableEntryRel ids | otherwise = map (jumpTableEntry config) ids - in CmmData section (mkAlignment 1, RawCmmStatics lbl jumpTable) + in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable) extractUnwindPoints :: [Instr] -> [UnwindPoint] extractUnwindPoints instrs = diff --git a/compiler/GHC/CmmToAsm/X86/Cond.hs b/compiler/GHC/CmmToAsm/X86/Cond.hs --- a/compiler/GHC/CmmToAsm/X86/Cond.hs +++ b/compiler/GHC/CmmToAsm/X86/Cond.hs @@ -9,7 +9,7 @@ where -import GhcPrelude +import GHC.Prelude data Cond = ALWAYS -- What's really used? ToDo 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 @@ -18,7 +18,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.X86.Cond import GHC.CmmToAsm.X86.Regs @@ -34,8 +34,8 @@ import GHC.Cmm.Dataflow.Label import GHC.Platform.Regs import GHC.Cmm -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Basic (Alignment) @@ -1021,8 +1021,8 @@ -- Here because it knows about JumpDest shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, RawCmmStatics) -> (Alignment, RawCmmStatics) -shortcutStatics fn (align, RawCmmStatics lbl statics) - = (align, RawCmmStatics lbl $ map (shortcutStatic fn) statics) +shortcutStatics fn (align, CmmStaticsRaw lbl statics) + = (align, CmmStaticsRaw lbl $ map (shortcutStatic fn) statics) -- we need to get the jump tables, so apply the mapping to the entries -- of a CmmData too. 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 @@ -22,7 +22,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.X86.Regs import GHC.CmmToAsm.X86.Instr @@ -43,8 +43,8 @@ import GHC.Cmm.CLabel import GHC.Types.Unique ( pprUniqueAlways ) import GHC.Platform -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import Data.Word import Data.Bits @@ -93,7 +93,7 @@ then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ pprSizeDecl platform lbl - Just (RawCmmStatics info_lbl _) -> + Just (CmmStaticsRaw info_lbl _) -> pprSectionAlign config (Section Text info_lbl) $$ pprProcAlignment config $$ (if platformHasSubsectionsViaSymbols platform @@ -132,7 +132,7 @@ platform = ncgPlatform config maybe_infotable c = case mapLookup blockid info_env of Nothing -> c - Just (RawCmmStatics infoLbl info) -> + Just (CmmStaticsRaw infoLbl info) -> pprAlignForSection platform Text $$ infoTableLoc $$ vcat (map (pprData config) info) $$ @@ -151,7 +151,7 @@ pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc -- See note [emit-time elimination of static indirections] in CLabel. -pprDatas _config (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +pprDatas _config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l @@ -161,13 +161,14 @@ = pprGloblDecl alias $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') -pprDatas config (align, (RawCmmStatics lbl dats)) +pprDatas config (align, (CmmStaticsRaw lbl dats)) = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats) where platform = ncgPlatform config pprData :: NCGConfig -> CmmStatic -> SDoc -pprData _config (CmmString str) = pprBytes str +pprData _config (CmmString str) = pprString str +pprData _config (CmmFileEmbed path) = pprFileEmbed path pprData config (CmmUninitialised bytes) = let platform = ncgPlatform config diff --git a/compiler/GHC/CmmToAsm/X86/RegInfo.hs b/compiler/GHC/CmmToAsm/X86/RegInfo.hs --- a/compiler/GHC/CmmToAsm/X86/RegInfo.hs +++ b/compiler/GHC/CmmToAsm/X86/RegInfo.hs @@ -8,12 +8,12 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Format import GHC.Platform.Reg -import Outputable +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique diff --git a/compiler/GHC/CmmToAsm/X86/Regs.hs b/compiler/GHC/CmmToAsm/X86/Regs.hs --- a/compiler/GHC/CmmToAsm/X86/Regs.hs +++ b/compiler/GHC/CmmToAsm/X86/Regs.hs @@ -49,7 +49,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform.Regs import GHC.Platform.Reg @@ -57,7 +57,7 @@ import GHC.Cmm import GHC.Cmm.CLabel ( CLabel ) -import Outputable +import GHC.Utils.Outputable import GHC.Platform import qualified Data.Array as A diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -26,7 +26,7 @@ #include "HsVersions.h" -- Cmm stuff -import GhcPrelude +import GHC.Prelude import GHC.Cmm.BlockId import GHC.Cmm.CLabel @@ -42,13 +42,13 @@ -- Utils import GHC.CmmToAsm.CPrim import GHC.Driver.Session -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique -import Util +import GHC.Utils.Misc -- The rest import Data.ByteString (ByteString) @@ -88,7 +88,7 @@ (CmmProc infos clbl _in_live_regs graph) -> (case mapLookup (g_entry graph) infos of Nothing -> empty - Just (RawCmmStatics info_clbl info_dat) -> + Just (CmmStaticsRaw info_clbl info_dat) -> pprDataExterns platform info_dat $$ pprWordArray dflags info_is_in_rodata info_clbl info_dat) $$ (vcat [ @@ -111,21 +111,21 @@ -- We only handle (a) arrays of word-sized things and (b) strings. - (CmmData section (RawCmmStatics lbl [CmmString str])) -> + (CmmData section (CmmStaticsRaw lbl [CmmString str])) -> pprExternDecl platform lbl $$ hcat [ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl, text "[] = ", pprStringInCStyle str, semi ] - (CmmData section (RawCmmStatics lbl [CmmUninitialised size])) -> + (CmmData section (CmmStaticsRaw lbl [CmmUninitialised size])) -> pprExternDecl platform lbl $$ hcat [ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl, brackets (int size), semi ] - (CmmData section (RawCmmStatics lbl lits)) -> + (CmmData section (CmmStaticsRaw lbl lits)) -> pprDataExterns platform lits $$ pprWordArray dflags (isSecConstant section) lbl lits where @@ -520,41 +520,41 @@ (CmmStaticLit (CmmFloat f W32) : rest) -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding | wordWidth platform == W64, CmmStaticLit (CmmInt 0 W32) : rest' <- rest - -> pprLit1 dflags (floatToWord dflags f) : pprStatics' rest' + -> pprLit1 dflags (floatToWord platform f) : pprStatics' rest' -- adjacent floats aren't padded but combined into a single word | wordWidth platform == W64, CmmStaticLit (CmmFloat g W32) : rest' <- rest - -> pprLit1 dflags (floatPairToWord dflags f g) : pprStatics' rest' + -> pprLit1 dflags (floatPairToWord platform f g) : pprStatics' rest' | wordWidth platform == W32 - -> pprLit1 dflags (floatToWord dflags f) : pprStatics' rest + -> pprLit1 dflags (floatToWord platform f) : pprStatics' rest | otherwise -> pprPanic "pprStatics: float" (vcat (map ppr' rest)) where ppr' (CmmStaticLit l) = ppr (cmmLitType platform l) ppr' _other = text "bad static!" (CmmStaticLit (CmmFloat f W64) : rest) - -> map (pprLit1 dflags) (doubleToWords dflags f) ++ pprStatics' rest + -> map (pprLit1 dflags) (doubleToWords platform f) ++ pprStatics' rest (CmmStaticLit (CmmInt i W64) : rest) | wordWidth platform == W32 - -> if wORDS_BIGENDIAN dflags - then pprStatics' (CmmStaticLit (CmmInt q W32) : - CmmStaticLit (CmmInt r W32) : rest) - else pprStatics' (CmmStaticLit (CmmInt r W32) : - CmmStaticLit (CmmInt q W32) : rest) + -> case platformByteOrder platform of + BigEndian -> pprStatics' (CmmStaticLit (CmmInt q W32) : + CmmStaticLit (CmmInt r W32) : rest) + LittleEndian -> pprStatics' (CmmStaticLit (CmmInt r W32) : + CmmStaticLit (CmmInt q W32) : rest) where r = i .&. 0xffffffff q = i `shiftR` 32 (CmmStaticLit (CmmInt a W32) : CmmStaticLit (CmmInt b W32) : rest) | wordWidth platform == W64 - -> if wORDS_BIGENDIAN dflags - then pprStatics' (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) : rest) - else pprStatics' (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) : rest) + -> case platformByteOrder platform of + BigEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) : rest) + LittleEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) : rest) (CmmStaticLit (CmmInt a W16) : CmmStaticLit (CmmInt b W16) : rest) | wordWidth platform == W32 - -> if wORDS_BIGENDIAN dflags - then pprStatics' (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) : rest) - else pprStatics' (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) : rest) + -> case platformByteOrder platform of + BigEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) : rest) + LittleEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) : rest) (CmmStaticLit (CmmInt _ w) : _) | w /= wordWidth platform @@ -574,6 +574,7 @@ -- these should be inlined, like the old .hc CmmString s' -> nest 4 (mkW_ <> parens(pprStringInCStyle s')) + CmmFileEmbed {} -> panic "Unexpected CmmFileEmbed literal" -- --------------------------------------------------------------------------- @@ -1271,8 +1272,8 @@ castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64) castDoubleToWord64Array = U.castSTUArray -floatToWord :: DynFlags -> Rational -> CmmLit -floatToWord dflags r +floatToWord :: Platform -> Rational -> CmmLit +floatToWord platform r = runST (do arr <- newArray_ ((0::Int),0) writeArray arr 0 (fromRational r) @@ -1281,12 +1282,13 @@ return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth platform)) ) where wo | wordWidth platform == W64 - , wORDS_BIGENDIAN dflags = 32 - | otherwise = 0 - platform = targetPlatform dflags + , BigEndian <- platformByteOrder platform + = 32 + | otherwise + = 0 -floatPairToWord :: DynFlags -> Rational -> Rational -> CmmLit -floatPairToWord dflags r1 r2 +floatPairToWord :: Platform -> Rational -> Rational -> CmmLit +floatPairToWord platform r1 r2 = runST (do arr <- newArray_ ((0::Int),1) writeArray arr 0 (fromRational r1) @@ -1297,15 +1299,15 @@ return (pprWord32Pair w32_1 w32_2) ) where pprWord32Pair w32_1 w32_2 - | wORDS_BIGENDIAN dflags = + | BigEndian <- platformByteOrder platform = CmmInt ((shiftL i1 32) .|. i2) W64 | otherwise = CmmInt ((shiftL i2 32) .|. i1) W64 where i1 = toInteger w32_1 i2 = toInteger w32_2 -doubleToWords :: DynFlags -> Rational -> [CmmLit] -doubleToWords dflags r +doubleToWords :: Platform -> Rational -> [CmmLit] +doubleToWords platform r = runST (do arr <- newArray_ ((0::Int),1) writeArray arr 0 (fromRational r) @@ -1314,8 +1316,6 @@ return (pprWord64 w64) ) where targetWidth = wordWidth platform - platform = targetPlatform dflags - targetBE = wORDS_BIGENDIAN dflags pprWord64 w64 | targetWidth == W64 = [ CmmInt (toInteger w64) targetWidth ] @@ -1324,9 +1324,9 @@ , CmmInt (toInteger targetW2) targetWidth ] | otherwise = panic "doubleToWords.pprWord64" - where (targetW1, targetW2) - | targetBE = (wHi, wLo) - | otherwise = (wLo, wHi) + where (targetW1, targetW2) = case platformByteOrder platform of + BigEndian -> (wHi, wLo) + LittleEndian -> (wLo, wHi) wHi = w64 `shiftR` 32 wLo = w64 .&. 0xFFFFffff diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -13,7 +13,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Base @@ -28,14 +28,14 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Ppr -import BufWrite +import GHC.Utils.BufHandle import GHC.Driver.Session import GHC.Platform ( platformArch, Arch(..) ) -import ErrUtils -import FastString -import Outputable -import SysTools ( figureLlvmVersion ) -import qualified Stream +import GHC.Utils.Error +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.SysTools ( figureLlvmVersion ) +import qualified GHC.Data.Stream as Stream import Control.Monad ( when, forM_ ) import Data.Maybe ( fromMaybe, catMaybes ) @@ -75,14 +75,14 @@ -- run code generation a <- runLlvm dflags (fromMaybe supportedLlvmVersion mb_ver) bufh $ - llvmCodeGen' (liftStream cmm_stream) + llvmCodeGen' dflags (liftStream cmm_stream) bFlush bufh return a -llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup a -> LlvmM a -llvmCodeGen' cmm_stream +llvmCodeGen' :: DynFlags -> Stream.Stream LlvmM RawCmmGroup a -> LlvmM a +llvmCodeGen' dflags cmm_stream = do -- Preamble renderLlvm header ghcInternalFunctions @@ -100,19 +100,19 @@ return a where header :: SDoc - header = sdocWithDynFlags $ \dflags -> + header = let target = platformMisc_llvmTarget $ platformMisc dflags - in text ("target datalayout = \"" ++ getDataLayout dflags target ++ "\"") + in text ("target datalayout = \"" ++ getDataLayout (llvmConfig dflags) target ++ "\"") $+$ text ("target triple = \"" ++ target ++ "\"") - getDataLayout :: DynFlags -> String -> String - getDataLayout dflags target = - case lookup target (llvmTargets $ llvmConfig dflags) of + getDataLayout :: LlvmConfig -> String -> String + getDataLayout config target = + case lookup target (llvmTargets config) of Just (LlvmTarget {lDataLayout=dl}) -> dl Nothing -> pprPanic "Failed to lookup LLVM data layout" $ text "Target:" <+> text target $$ hang (text "Available targets:") 4 - (vcat $ map (text . fst) $ llvmTargets $ llvmConfig dflags) + (vcat $ map (text . fst) $ llvmTargets config) llvmGroupLlvmGens :: RawCmmGroup -> LlvmM () llvmGroupLlvmGens cmm = do @@ -121,9 +121,9 @@ let split (CmmData s d' ) = return $ Just (s, d') split (CmmProc h l live g) = do -- Set function type - let l' = case mapLookup (g_entry g) h of + let l' = case mapLookup (g_entry g) h :: Maybe RawCmmStatics of Nothing -> l - Just (RawCmmStatics info_lbl _) -> info_lbl + Just (CmmStaticsRaw info_lbl _) -> info_lbl lml <- strCLabel_llvm l' funInsert lml =<< llvmFunTy live return Nothing 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 @@ -41,7 +41,7 @@ #include "HsVersions.h" #include "ghcautoconf.h" -import GhcPrelude +import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Regs @@ -49,18 +49,18 @@ import GHC.Cmm.CLabel import GHC.Platform.Regs ( activeStgRegs ) import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Cmm hiding ( succ ) import GHC.Cmm.Utils (regsOverlap) -import Outputable as Outp +import GHC.Utils.Outputable as Outp import GHC.Platform import GHC.Types.Unique.FM import GHC.Types.Unique -import BufWrite ( BufHandle ) +import GHC.Utils.BufHandle ( BufHandle ) import GHC.Types.Unique.Set import GHC.Types.Unique.Supply -import ErrUtils -import qualified Stream +import GHC.Utils.Error +import qualified GHC.Data.Stream as Stream import Data.Maybe (fromJust) import Control.Monad (ap) @@ -447,8 +447,8 @@ -- Write to output dflags <- getDynFlags out <- getEnv envOutput - liftIO $ Outp.bufLeftRenderSDoc dflags out - (Outp.mkCodeStyle Outp.CStyle) sdoc + let ctx = initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle) + liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc -- Dump, if requested dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc 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 @@ -8,7 +8,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Base @@ -26,15 +26,15 @@ import GHC.Cmm.Dataflow.Collections import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Types.ForeignCall -import Outputable hiding (panic, pprPanic) -import qualified Outputable +import GHC.Utils.Outputable hiding (panic, pprPanic) +import qualified GHC.Utils.Outputable as Outputable import GHC.Platform -import OrdList +import GHC.Data.OrdList import GHC.Types.Unique.Supply import GHC.Types.Unique -import Util +import GHC.Utils.Misc import Control.Monad.Trans.Class import Control.Monad.Trans.Writer 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 @@ -9,7 +9,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Base @@ -20,8 +20,8 @@ import GHC.Driver.Session import GHC.Platform -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import qualified Data.ByteString as BS -- ---------------------------------------------------------------------------- @@ -44,7 +44,7 @@ -- | Pass a CmmStatic section to an equivalent Llvm code. genLlvmData :: (Section, RawCmmStatics) -> LlvmM LlvmData -- See note [emit-time elimination of static indirections] in CLabel. -genLlvmData (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +genLlvmData (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l @@ -67,7 +67,7 @@ pure ([LMGlobal aliasDef $ Just orig], [tyAlias]) -genLlvmData (sec, RawCmmStatics lbl xs) = do +genLlvmData (sec, CmmStaticsRaw lbl xs) = do label <- strCLabel_llvm lbl static <- mapM genData xs lmsec <- llvmSection sec @@ -132,6 +132,7 @@ -- | Handle static data genData :: CmmStatic -> LlvmM LlvmStatic +genData (CmmFileEmbed {}) = panic "Unexpected CmmFileEmbed literal" genData (CmmString str) = do let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) (BS.unpack str) 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 @@ -11,12 +11,12 @@ module GHC.CmmToLlvm.Mangler ( llvmFixupAsm ) where -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session ( DynFlags, targetPlatform ) import GHC.Platform ( platformArch, Arch(..) ) -import ErrUtils ( withTiming ) -import Outputable ( text ) +import GHC.Utils.Error ( withTiming ) +import GHC.Utils.Outputable ( text ) import Control.Exception import qualified Data.ByteString.Char8 as B 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 @@ -9,7 +9,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Base @@ -18,8 +18,8 @@ import GHC.Cmm.CLabel import GHC.Cmm -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Types.Unique -- ---------------------------------------------------------------------------- @@ -46,7 +46,7 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks)) = do let lbl = case mb_info of Nothing -> entry_lbl - Just (RawCmmStatics info_lbl _) -> info_lbl + Just (CmmStaticsRaw info_lbl _) -> info_lbl link = if externallyVisibleCLabel lbl then ExternallyVisible else Internal @@ -63,7 +63,7 @@ -- generate the info table prefix <- case mb_info of Nothing -> return Nothing - Just (RawCmmStatics _ statics) -> do + Just (CmmStaticsRaw _ statics) -> do infoStatics <- mapM genData statics let infoTy = LMStruct $ map getStatType infoStatics return $ Just $ LMStaticStruc infoStatics infoTy 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 @@ -11,14 +11,14 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Llvm import GHC.Cmm.Expr import GHC.Platform -import FastString -import Outputable ( panic ) +import GHC.Data.FastString +import GHC.Utils.Outputable ( panic ) import GHC.Types.Unique -- | Get the LlvmVar function variable storing the real register diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -8,2832 +8,2841 @@ -} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -module GHC.Core.Lint ( - lintCoreBindings, lintUnfolding, - lintPassResult, lintInteractiveExpr, lintExpr, - lintAnnots, lintTypes, - - -- ** Debug output - endPass, endPassIO, - dumpPassResult, - GHC.Core.Lint.dumpIfSet, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Core -import GHC.Core.FVs -import GHC.Core.Utils -import GHC.Core.Stats ( coreBindsStats ) -import GHC.Core.Op.Monad -import Bag -import GHC.Types.Literal -import GHC.Core.DataCon -import TysWiredIn -import TysPrim -import TcType ( isFloatingTy ) -import GHC.Types.Var as Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Unique.Set( nonDetEltsUniqSet ) -import GHC.Types.Name -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Core.Ppr -import ErrUtils -import GHC.Core.Coercion -import GHC.Types.SrcLoc -import GHC.Core.Type as Type -import GHC.Types.RepType -import GHC.Core.TyCo.Rep -- checks validity of types/coercions -import GHC.Core.TyCo.Subst -import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Ppr ( pprTyVar ) -import GHC.Core.TyCon as TyCon -import GHC.Core.Coercion.Axiom -import GHC.Types.Basic -import ErrUtils as Err -import ListSetOps -import PrelNames -import Outputable -import FastString -import Util -import GHC.Core.InstEnv ( instanceDFunId ) -import GHC.Core.Coercion.Opt ( checkAxInstCo ) -import GHC.Core.Arity ( typeArity ) -import GHC.Types.Demand ( splitStrictSig, isBotDiv ) - -import GHC.Driver.Types -import GHC.Driver.Session -import Control.Monad -import MonadUtils -import Data.Foldable ( toList ) -import Data.List.NonEmpty ( NonEmpty ) -import Data.List ( partition ) -import Data.Maybe -import Pair -import qualified GHC.LanguageExtensions as LangExt - -{- -Note [Core Lint guarantee] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Core Lint is the type-checker for Core. Using it, we get the following guarantee: - -If all of: -1. Core Lint passes, -2. there are no unsafe coercions (i.e. unsafeEqualityProof), -3. all plugin-supplied coercions (i.e. PluginProv) are valid, and -4. all case-matches are complete -then running the compiled program will not seg-fault, assuming no bugs downstream -(e.g. in the code generator). This guarantee is quite powerful, in that it allows us -to decouple the safety of the resulting program from the type inference algorithm. - -However, do note point (4) above. Core Lint does not check for incomplete case-matches; -see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there, -an incomplete case-match might slip by Core Lint and cause trouble at runtime. - -Note [GHC Formalism] -~~~~~~~~~~~~~~~~~~~~ -This file implements the type-checking algorithm for System FC, the "official" -name of the Core language. Type safety of FC is heart of the claim that -executables produced by GHC do not have segmentation faults. Thus, it is -useful to be able to reason about System FC independently of reading the code. -To this purpose, there is a document core-spec.pdf built in docs/core-spec that -contains a formalism of the types and functions dealt with here. If you change -just about anything in this file or you change other types/functions throughout -the Core language (all signposted to this note), you should update that -formalism. See docs/core-spec/README for more info about how to do so. - -Note [check vs lint] -~~~~~~~~~~~~~~~~~~~~ -This file implements both a type checking algorithm and also general sanity -checking. For example, the "sanity checking" checks for TyConApp on the left -of an AppTy, which should never happen. These sanity checks don't really -affect any notion of type soundness. Yet, it is convenient to do the sanity -checks at the same time as the type checks. So, we use the following naming -convention: - -- Functions that begin with 'lint'... are involved in type checking. These - functions might also do some sanity checking. - -- Functions that begin with 'check'... are *not* involved in type checking. - They exist only for sanity checking. - -Issues surrounding variable naming, shadowing, and such are considered *not* -to be part of type checking, as the formalism omits these details. - -Summary of checks -~~~~~~~~~~~~~~~~~ -Checks that a set of core bindings is well-formed. The PprStyle and String -just control what we print in the event of an error. The Bool value -indicates whether we have done any specialisation yet (in which case we do -some extra checks). - -We check for - (a) type errors - (b) Out-of-scope type variables - (c) Out-of-scope local variables - (d) Ill-kinded types - (e) Incorrect unsafe coercions - -If we have done specialisation the we check that there are - (a) No top-level bindings of primitive (unboxed type) - -Outstanding issues: - - -- Things are *not* OK if: - -- - -- * Unsaturated type app before specialisation has been done; - -- - -- * Oversaturated type app after specialisation (eta reduction - -- may well be happening...); - - -Note [Linting function types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As described in Note [Representation of function types], all saturated -applications of funTyCon are represented with the FunTy constructor. We check -this invariant in lintType. - -Note [Linting type lets] -~~~~~~~~~~~~~~~~~~~~~~~~ -In the desugarer, it's very very convenient to be able to say (in effect) - let a = Type Bool in - let x::a = True in -That is, use a type let. See Note [Type let] in CoreSyn. -One place it is used is in mkWwArgs; see Note [Join points and beta-redexes] -in GHC.Core.Op.WorkWrap.Lib. (Maybe there are other "clients" of this feature; I'm not sure). - -* Hence when linting we need to remember that a=Int, else we - might reject a correct program. So we carry a type substitution (in - this example [a -> Bool]) and apply this substitution before - comparing types. In effect, in Lint, type equality is always - equality-moduolo-le-subst. This is in the le_subst field of - LintEnv. But nota bene: - - (SI1) The le_subst substitution is applied to types and coercions only - - (SI2) The result of that substitution is used only to check for type - equality, to check well-typed-ness, /but is then discarded/. - The result of substittion does not outlive the CoreLint pass. - - (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders. - -* The function - lintInTy :: Type -> LintM (Type, Kind) - returns a substituted type. - -* When we encounter a binder (like x::a) we must apply the substitution - to the type of the binding variable. lintBinders does this. - -* Clearly we need to clone tyvar binders as we go. - -* But take care (#17590)! We must also clone CoVar binders: - let a = TYPE (ty |> cv) - in \cv -> blah - blindly substituting for `a` might capture `cv`. - -* Alas, when cloning a coercion variable we might choose a unique - that happens to clash with an inner Id, thus - \cv_66 -> let wild_X7 = blah in blah - We decide to clone `cv_66` becuase it's already in scope. Fine, - choose a new unique. Aha, X7 looks good. So we check the lambda - body with le_subst of [cv_66 :-> cv_X7] - - This is all fine, even though we use the same unique as wild_X7. - As (SI2) says, we do /not/ return a new lambda - (\cv_X7 -> let wild_X7 = blah in ...) - We simply use the le_subst subsitution in types/coercions only, when - checking for equality. - -* We still need to check that Id occurrences are bound by some - enclosing binding. We do /not/ use the InScopeSet for the le_subst - for this purpose -- it contains only TyCoVars. Instead we have a separate - le_ids for the in-scope Id binders. - -Sigh. We might want to explore getting rid of type-let! - -Note [Bad unsafe coercion] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions -Linter introduces additional rules that checks improper coercion between -different types, called bad coercions. Following coercions are forbidden: - - (a) coercions between boxed and unboxed values; - (b) coercions between unlifted values of the different sizes, here - active size is checked, i.e. size of the actual value but not - the space allocated for value; - (c) coercions between floating and integral boxed values, this check - is not yet supported for unboxed tuples, as no semantics were - specified for that; - (d) coercions from / to vector type - (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be - coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules - (a-e) holds. - -Note [Join points] -~~~~~~~~~~~~~~~~~~ -We check the rules listed in Note [Invariants on join points] in GHC.Core. The -only one that causes any difficulty is the first: All occurrences must be tail -calls. To this end, along with the in-scope set, we remember in le_joins the -subset of in-scope Ids that are valid join ids. For example: - - join j x = ... in - case e of - A -> jump j y -- good - B -> case (jump j z) of -- BAD - C -> join h = jump j w in ... -- good - D -> let x = jump j v in ... -- BAD - -A join point remains valid in case branches, so when checking the A -branch, j is still valid. When we check the scrutinee of the inner -case, however, we set le_joins to empty, and catch the -error. Similarly, join points can occur free in RHSes of other join -points but not the RHSes of value bindings (thunks and functions). - -************************************************************************ -* * - Beginning and ending passes -* * -************************************************************************ - -These functions are not CoreM monad stuff, but they probably ought to -be, and it makes a convenient place for them. They print out stuff -before and after core passes, and do Core Lint when necessary. --} - -endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () -endPass pass binds rules - = do { hsc_env <- getHscEnv - ; print_unqual <- getPrintUnqualified - ; liftIO $ endPassIO hsc_env print_unqual pass binds rules } - -endPassIO :: HscEnv -> PrintUnqualified - -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () --- Used by the IO-is CorePrep too -endPassIO hsc_env print_unqual pass binds rules - = do { dumpPassResult dflags print_unqual mb_flag - (ppr pass) (pprPassDetails pass) binds rules - ; lintPassResult hsc_env pass binds } - where - dflags = hsc_dflags hsc_env - mb_flag = case coreDumpFlag pass of - Just flag | dopt flag dflags -> Just flag - | dopt Opt_D_verbose_core2core dflags -> Just flag - _ -> Nothing - -dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO () -dumpIfSet dflags dump_me pass extra_info doc - = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc - -dumpPassResult :: DynFlags - -> PrintUnqualified - -> Maybe DumpFlag -- Just df => show details in a file whose - -- name is specified by df - -> SDoc -- Header - -> SDoc -- Extra info to appear after header - -> CoreProgram -> [CoreRule] - -> IO () -dumpPassResult dflags unqual mb_flag hdr extra_info binds rules - = do { forM_ mb_flag $ \flag -> do - let sty = mkDumpStyle dflags unqual - dumpAction dflags sty (dumpOptionsFromFlag flag) - (showSDoc dflags hdr) FormatCore dump_doc - - -- Report result size - -- This has the side effect of forcing the intermediate to be evaluated - -- if it's not already forced by a -ddump flag. - ; Err.debugTraceMsg dflags 2 size_doc - } - - where - size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] - - dump_doc = vcat [ nest 2 extra_info - , size_doc - , blankLine - , pprCoreBindingsWithSize binds - , ppUnless (null rules) pp_rules ] - pp_rules = vcat [ blankLine - , text "------ Local rules for imported ids --------" - , pprRules rules ] - -coreDumpFlag :: CoreToDo -> Maybe DumpFlag -coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core -coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core -coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core -coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity -coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify -coreDumpFlag CoreDoDemand = Just Opt_D_dump_stranal -coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal -coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper -coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec -coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec -coreDumpFlag CoreCSE = Just Opt_D_dump_cse -coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt -coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds -coreDumpFlag CoreTidy = Just Opt_D_dump_simpl -coreDumpFlag CorePrep = Just Opt_D_dump_prep -coreDumpFlag CoreOccurAnal = Just Opt_D_dump_occur_anal - -coreDumpFlag CoreDoPrintCore = Nothing -coreDumpFlag (CoreDoRuleCheck {}) = Nothing -coreDumpFlag CoreDoNothing = Nothing -coreDumpFlag (CoreDoPasses {}) = Nothing - -{- -************************************************************************ -* * - Top-level interfaces -* * -************************************************************************ --} - -lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO () -lintPassResult hsc_env pass binds - | not (gopt Opt_DoCoreLinting dflags) - = return () - | otherwise - = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds - ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass) - ; displayLintResults dflags pass warns errs binds } - where - dflags = hsc_dflags hsc_env - -displayLintResults :: DynFlags -> CoreToDo - -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram - -> IO () -displayLintResults dflags pass warns errs binds - | not (isEmptyBag errs) - = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan - (defaultDumpStyle dflags) - (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs - , text "*** Offending Program ***" - , pprCoreBindings binds - , text "*** End of Offense ***" ]) - ; Err.ghcExit dflags 1 } - - | not (isEmptyBag warns) - , not (hasNoDebugOutput dflags) - , showLintWarnings pass - -- If the Core linter encounters an error, output to stderr instead of - -- stdout (#13342) - = putLogMsg dflags NoReason Err.SevInfo noSrcSpan - (defaultDumpStyle dflags) - (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) - - | otherwise = return () - where - -lint_banner :: String -> SDoc -> SDoc -lint_banner string pass = text "*** Core Lint" <+> text string - <+> text ": in result of" <+> pass - <+> text "***" - -showLintWarnings :: CoreToDo -> Bool --- Disable Lint warnings on the first simplifier pass, because --- there may be some INLINE knots still tied, which is tiresomely noisy -showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False -showLintWarnings _ = True - -lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO () -lintInteractiveExpr what hsc_env expr - | not (gopt Opt_DoCoreLinting dflags) - = return () - | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr - = do { display_lint_err err - ; Err.ghcExit dflags 1 } - | otherwise - = return () - where - dflags = hsc_dflags hsc_env - - display_lint_err err - = do { putLogMsg dflags NoReason Err.SevDump - noSrcSpan (defaultDumpStyle dflags) - (vcat [ lint_banner "errors" (text what) - , err - , text "*** Offending Program ***" - , pprCoreExpr expr - , text "*** End of Offense ***" ]) - ; Err.ghcExit dflags 1 } - -interactiveInScope :: HscEnv -> [Var] --- In GHCi we may lint expressions, or bindings arising from 'deriving' --- clauses, that mention variables bound in the interactive context. --- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types). --- So we have to tell Lint about them, lest it reports them as out of scope. --- --- We do this by find local-named things that may appear free in interactive --- context. This function is pretty revolting and quite possibly not quite right. --- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty --- so this is a (cheap) no-op. --- --- See #8215 for an example -interactiveInScope hsc_env - = tyvars ++ ids - where - -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr - ictxt = hsc_IC hsc_env - (cls_insts, _fam_insts) = ic_instances ictxt - te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) - te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts) - ids = typeEnvIds te - tyvars = tyCoVarsOfTypesList $ map idType ids - -- Why the type variables? How can the top level envt have free tyvars? - -- I think it's because of the GHCi debugger, which can bind variables - -- f :: [t] -> [t] - -- where t is a RuntimeUnk (see TcType) - --- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. -lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc) --- Returns (warnings, errors) --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoreBindings dflags pass local_in_scope binds - = initL dflags flags local_in_scope $ - addLoc TopLevelBindings $ - lintLetBndrs TopLevel binders $ - -- Put all the top-level binders in scope at the start - -- This is because transformation rules can bring something - -- into use 'unexpectedly' - do { checkL (null dups) (dupVars dups) - ; checkL (null ext_dups) (dupExtVars ext_dups) - ; mapM lint_bind binds } - where - flags = defaultLintFlags - { lf_check_global_ids = check_globals - , lf_check_inline_loop_breakers = check_lbs - , lf_check_static_ptrs = check_static_ptrs } - - -- See Note [Checking for global Ids] - check_globals = case pass of - CoreTidy -> False - CorePrep -> False - _ -> True - - -- See Note [Checking for INLINE loop breakers] - check_lbs = case pass of - CoreDesugar -> False - CoreDesugarOpt -> False - _ -> True - - -- See Note [Checking StaticPtrs] - check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere - | otherwise = case pass of - CoreDoFloatOutwards _ -> AllowAtTopLevel - CoreTidy -> RejectEverywhere - CorePrep -> AllowAtTopLevel - _ -> AllowAnywhere - - binders = bindersOfBinds binds - (_, dups) = removeDups compare binders - - -- dups_ext checks for names with different uniques - -- but but the same External name M.n. We don't - -- allow this at top level: - -- M.n{r3} = ... - -- M.n{r29} = ... - -- because they both get the same linker symbol - ext_dups = snd (removeDups ord_ext (map Var.varName binders)) - ord_ext n1 n2 | Just m1 <- nameModule_maybe n1 - , Just m2 <- nameModule_maybe n2 - = compare (m1, nameOccName n1) (m2, nameOccName n2) - | otherwise = LT - - -- If you edit this function, you may need to update the GHC formalism - -- See Note [GHC Formalism] - lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs - lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs) - -{- -************************************************************************ -* * -\subsection[lintUnfolding]{lintUnfolding} -* * -************************************************************************ - -Note [Linting Unfoldings from Interfaces] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We use this to check all top-level unfoldings that come in from interfaces -(it is very painful to catch errors otherwise). - -We do not need to call lintUnfolding on unfoldings that are nested within -top-level unfoldings; they are linted when we lint the top-level unfolding; -hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore. - --} - -lintUnfolding :: Bool -- True <=> is a compulsory unfolding - -> DynFlags - -> SrcLoc - -> VarSet -- Treat these as in scope - -> CoreExpr - -> Maybe MsgDoc -- Nothing => OK - -lintUnfolding is_compulsory dflags locn var_set expr - | isEmptyBag errs = Nothing - | otherwise = Just (pprMessageBag errs) - where - vars = nonDetEltsUniqSet var_set - (_warns, errs) = initL dflags defaultLintFlags vars $ - if is_compulsory - -- See Note [Checking for levity polymorphism] - then noLPChecks linter - else linter - linter = addLoc (ImportedUnfolding locn) $ - lintCoreExpr expr - -lintExpr :: DynFlags - -> [Var] -- Treat these as in scope - -> CoreExpr - -> Maybe MsgDoc -- Nothing => OK - -lintExpr dflags vars expr - | isEmptyBag errs = Nothing - | otherwise = Just (pprMessageBag errs) - where - (_warns, errs) = initL dflags defaultLintFlags vars linter - linter = addLoc TopLevelBindings $ - lintCoreExpr expr - -{- -************************************************************************ -* * -\subsection[lintCoreBinding]{lintCoreBinding} -* * -************************************************************************ - -Check a core binding, returning the list of variables bound. --} - -lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintSingleBinding top_lvl_flag rec_flag (binder,rhs) - = addLoc (RhsOf binder) $ - -- Check the rhs - do { ty <- lintRhs binder rhs - ; binder_ty <- applySubstTy (idType binder) - ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty) - - -- If the binding is for a CoVar, the RHS should be (Coercion co) - -- See Note [Core type and coercion invariant] in GHC.Core - ; checkL (not (isCoVar binder) || isCoArg rhs) - (mkLetErr binder rhs) - - -- Check that it's not levity-polymorphic - -- Do this first, because otherwise isUnliftedType panics - -- Annoyingly, this duplicates the test in lintIdBdr, - -- because for non-rec lets we call lintSingleBinding first - ; checkL (isJoinId binder || not (isTypeLevPoly binder_ty)) - (badBndrTyMsg binder (text "levity-polymorphic")) - - -- Check the let/app invariant - -- See Note [Core let/app invariant] in GHC.Core - ; checkL ( isJoinId binder - || not (isUnliftedType binder_ty) - || (isNonRec rec_flag && exprOkForSpeculation rhs) - || exprIsTickedString rhs) - (badBndrTyMsg binder (text "unlifted")) - - -- Check that if the binder is top-level or recursive, it's not - -- demanded. Primitive string literals are exempt as there is no - -- computation to perform, see Note [Core top-level string literals]. - ; checkL (not (isStrictId binder) - || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)) - || exprIsTickedString rhs) - (mkStrictMsg binder) - - -- Check that if the binder is at the top level and has type Addr#, - -- that it is a string literal, see - -- Note [Core top-level string literals]. - ; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy) - || exprIsTickedString rhs) - (mkTopNonLitStrMsg binder) - - ; flags <- getLintFlags - - -- Check that a join-point binder has a valid type - -- NB: lintIdBinder has checked that it is not top-level bound - ; case isJoinId_maybe binder of - Nothing -> return () - Just arity -> checkL (isValidJoinPointType arity binder_ty) - (mkInvalidJoinPointMsg binder binder_ty) - - ; when (lf_check_inline_loop_breakers flags - && isStableUnfolding (realIdUnfolding binder) - && isStrongLoopBreaker (idOccInfo binder) - && isInlinePragma (idInlinePragma binder)) - (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder)) - -- Only non-rule loop breakers inhibit inlining - - -- We used to check that the dmdTypeDepth of a demand signature never - -- exceeds idArity, but that is an unnecessary complication, see - -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Op.DmdAnal - - -- Check that the binder's arity is within the bounds imposed by - -- the type and the strictness signature. See Note [exprArity invariant] - -- and Note [Trimming arity] - ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder) - (text "idArity" <+> ppr (idArity binder) <+> - text "exceeds typeArity" <+> - ppr (length (typeArity (idType binder))) <> colon <+> - ppr binder) - - ; case splitStrictSig (idStrictness binder) of - (demands, result_info) | isBotDiv result_info -> - checkL (demands `lengthAtLeast` idArity binder) - (text "idArity" <+> ppr (idArity binder) <+> - text "exceeds arity imposed by the strictness signature" <+> - ppr (idStrictness binder) <> colon <+> - ppr binder) - _ -> return () - - ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) - - ; addLoc (UnfoldingOf binder) $ - lintIdUnfolding binder binder_ty (idUnfolding binder) } - - -- We should check the unfolding, if any, but this is tricky because - -- the unfolding is a SimplifiableCoreExpr. Give up for now. - --- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' --- in that it doesn't reject occurrences of the function 'makeStatic' when they --- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and --- for join points, it skips the outer lambdas that take arguments to the --- join point. --- --- See Note [Checking StaticPtrs]. -lintRhs :: Id -> CoreExpr -> LintM OutType -lintRhs bndr rhs - | Just arity <- isJoinId_maybe bndr - = lint_join_lams arity arity True rhs - | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr) - = lint_join_lams arity arity False rhs - where - lint_join_lams 0 _ _ rhs - = lintCoreExpr rhs - - lint_join_lams n tot enforce (Lam var expr) - = lintLambda var $ lint_join_lams (n-1) tot enforce expr - - lint_join_lams n tot True _other - = failWithL $ mkBadJoinArityMsg bndr tot (tot-n) rhs - lint_join_lams _ _ False rhs - = markAllJoinsBad $ lintCoreExpr rhs - -- Future join point, not yet eta-expanded - -- Body is not a tail position - --- Allow applications of the data constructor @StaticPtr@ at the top --- but produce errors otherwise. -lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go - where - -- Allow occurrences of 'makeStatic' at the top-level but produce errors - -- otherwise. - go AllowAtTopLevel - | (binders0, rhs') <- collectTyBinders rhs - , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' - = markAllJoinsBad $ - foldr - -- imitate @lintCoreExpr (Lam ...)@ - lintLambda - -- imitate @lintCoreExpr (App ...)@ - (do fun_ty <- lintCoreExpr fun - lintCoreArgs fun_ty [Type t, info, e] - ) - binders0 - go _ = markAllJoinsBad $ lintCoreExpr rhs - -lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () -lintIdUnfolding bndr bndr_ty uf - | isStableUnfolding uf - , Just rhs <- maybeUnfoldingTemplate uf - = do { ty <- if isCompulsoryUnfolding uf - then noLPChecks $ lintRhs bndr rhs - -- See Note [Checking for levity polymorphism] - else lintRhs bndr rhs - ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } -lintIdUnfolding _ _ _ - = return () -- Do not Lint unstable unfoldings, because that leads - -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars - -{- -Note [Checking for INLINE loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very suspicious if a strong loop breaker is marked INLINE. - -However, the desugarer generates instance methods with INLINE pragmas -that form a mutually recursive group. Only after a round of -simplification are they unravelled. So we suppress the test for -the desugarer. - -Note [Checking for levity polymorphism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We ordinarily want to check for bad levity polymorphism. See -Note [Levity polymorphism invariants] in GHC.Core. However, we do *not* -want to do this in a compulsory unfolding. Compulsory unfoldings arise -only internally, for things like newtype wrappers, dictionaries, and -(notably) unsafeCoerce#. These might legitimately be levity-polymorphic; -indeed levity-polyorphic unfoldings are a primary reason for the -very existence of compulsory unfoldings (we can't compile code for -the original, levity-poly, binding). - -It is vitally important that we do levity-polymorphism checks *after* -performing the unfolding, but not beforehand. This is all safe because -we will check any unfolding after it has been unfolded; checking the -unfolding beforehand is merely an optimization, and one that actively -hurts us here. - -************************************************************************ -* * -\subsection[lintCoreExpr]{lintCoreExpr} -* * -************************************************************************ --} - --- For OutType, OutKind, the substitution has been applied, --- but has not been linted yet - -type LintedType = Type -- Substitution applied, and type is linted -type LintedKind = Kind - -lintCoreExpr :: CoreExpr -> LintM OutType --- The returned type has the substitution from the monad --- already applied to it: --- lintCoreExpr e subst = exprType (subst e) --- --- The returned "type" can be a kind, if the expression is (Type ty) - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoreExpr (Var var) - = lintVarOcc var 0 - -lintCoreExpr (Lit lit) - = return (literalType lit) - -lintCoreExpr (Cast expr co) - = do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr - ; co' <- applySubstCo co - ; (_, k2, from_ty, to_ty, r) <- lintCoercion co' - ; checkValueKind k2 (text "target of cast" <+> quotes (ppr co)) - ; lintRole co' Representational r - ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) - ; return to_ty } - -lintCoreExpr (Tick tickish expr) - = do case tickish of - Breakpoint _ ids -> forM_ ids $ \id -> do - checkDeadIdOcc id - lookupIdInScope id - _ -> return () - markAllJoinsBadIf block_joins $ lintCoreExpr expr - where - block_joins = not (tickish `tickishScopesLike` SoftScope) - -- TODO Consider whether this is the correct rule. It is consistent with - -- the simplifier's behaviour - cost-centre-scoped ticks become part of - -- the continuation, and thus they behave like part of an evaluation - -- context, but soft-scoped and non-scoped ticks simply wrap the result - -- (see Simplify.simplTick). - -lintCoreExpr (Let (NonRec tv (Type ty)) body) - | isTyVar tv - = -- See Note [Linting type lets] - do { ty' <- applySubstTy ty - ; lintTyBndr tv $ \ tv' -> - do { addLoc (RhsOf tv) $ lintTyKind tv' ty' - -- Now extend the substitution so we - -- take advantage of it in the body - ; extendTvSubstL tv ty' $ - addLoc (BodyOfLetRec [tv]) $ - lintCoreExpr body } } - -lintCoreExpr (Let (NonRec bndr rhs) body) - | isId bndr - = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs) - ; addLoc (BodyOfLetRec [bndr]) - (lintBinder LetBind bndr $ \_ -> - addGoodJoins [bndr] $ - lintCoreExpr body) } - - | otherwise - = failWithL (mkLetErr bndr rhs) -- Not quite accurate - -lintCoreExpr e@(Let (Rec pairs) body) - = lintLetBndrs NotTopLevel bndrs $ - addGoodJoins bndrs $ - do { -- Check that the list of pairs is non-empty - checkL (not (null pairs)) (emptyRec e) - - -- Check that there are no duplicated binders - ; checkL (null dups) (dupVars dups) - - -- Check that either all the binders are joins, or none - ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $ - mkInconsistentRecMsg bndrs - - ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs - ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) } - where - bndrs = map fst pairs - (_, dups) = removeDups compare bndrs - -lintCoreExpr e@(App _ _) - = do { fun_ty <- lintCoreFun fun (length args) - ; lintCoreArgs fun_ty args } - where - (fun, args) = collectArgs e - -lintCoreExpr (Lam var expr) - = markAllJoinsBad $ - lintLambda var $ lintCoreExpr expr - -lintCoreExpr (Case scrut var alt_ty alts) - = lintCaseExpr scrut var alt_ty alts - --- This case can't happen; linting types in expressions gets routed through --- lintCoreArgs -lintCoreExpr (Type ty) - = failWithL (text "Type found as expression" <+> ppr ty) - -lintCoreExpr (Coercion co) - = do { (k1, k2, ty1, ty2, role) <- lintInCo co - ; return (mkHeteroCoercionType role k1 k2 ty1 ty2) } - ----------------------- -lintVarOcc :: Var -> Int -- Number of arguments (type or value) being passed - -> LintM Type -- returns type of the *variable* -lintVarOcc var nargs - = do { checkL (isNonCoVarId var) - (text "Non term variable" <+> ppr var) - -- See GHC.Core Note [Variable occurrences in Core] - - -- Check that the type of the occurrence is the same - -- as the type of the binding site - ; ty <- applySubstTy (idType var) - ; var' <- lookupIdInScope var - ; let ty' = idType var' - ; ensureEqTys ty ty' $ mkBndrOccTypeMismatchMsg var' var ty' ty - - -- Check for a nested occurrence of the StaticPtr constructor. - -- See Note [Checking StaticPtrs]. - ; lf <- getLintFlags - ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $ - checkL (idName var /= makeStaticName) $ - text "Found makeStatic nested in an expression" - - ; checkDeadIdOcc var - ; checkJoinOcc var nargs - - ; return (idType var') } - -lintCoreFun :: CoreExpr - -> Int -- Number of arguments (type or val) being passed - -> LintM Type -- Returns type of the *function* -lintCoreFun (Var var) nargs - = lintVarOcc var nargs - -lintCoreFun (Lam var body) nargs - -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; see - -- Note [Beta redexes] - | nargs /= 0 - = lintLambda var $ lintCoreFun body (nargs - 1) - -lintCoreFun expr nargs - = markAllJoinsBadIf (nargs /= 0) $ - -- See Note [Join points are less general than the paper] - lintCoreExpr expr ------------------- -lintLambda :: Var -> LintM Type -> LintM Type -lintLambda var lintBody = - addLoc (LambdaBodyOf var) $ - lintBinder LambdaBind var $ \ var' -> - do { body_ty <- lintBody - ; return (mkLamType var' body_ty) } ------------------- -checkDeadIdOcc :: Id -> LintM () --- Occurrences of an Id should never be dead.... --- except when we are checking a case pattern -checkDeadIdOcc id - | isDeadOcc (idOccInfo id) - = do { in_case <- inCasePat - ; checkL in_case - (text "Occurrence of a dead Id" <+> ppr id) } - | otherwise - = return () - ------------------- -checkJoinOcc :: Id -> JoinArity -> LintM () --- Check that if the occurrence is a JoinId, then so is the --- binding site, and it's a valid join Id -checkJoinOcc var n_args - | Just join_arity_occ <- isJoinId_maybe var - = do { mb_join_arity_bndr <- lookupJoinId var - ; case mb_join_arity_bndr of { - Nothing -> -- Binder is not a join point - addErrL (invalidJoinOcc var) ; - - Just join_arity_bndr -> - - do { checkL (join_arity_bndr == join_arity_occ) $ - -- Arity differs at binding site and occurrence - mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ - - ; checkL (n_args == join_arity_occ) $ - -- Arity doesn't match #args - mkBadJumpMsg var join_arity_occ n_args } } } - - | otherwise - = return () - -{- -Note [No alternatives lint check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Case expressions with no alternatives are odd beasts, and it would seem -like they would worth be looking at in the linter (cf #10180). We -used to check two things: - -* exprIsHNF is false: it would *seem* to be terribly wrong if - the scrutinee was already in head normal form. - -* exprIsBottom is true: we should be able to see why GHC believes the - scrutinee is diverging for sure. - -It was already known that the second test was not entirely reliable. -Unfortunately (#13990), the first test turned out not to be reliable -either. Getting the checks right turns out to be somewhat complicated. - -For example, suppose we have (comment 8) - - data T a where - TInt :: T Int - - absurdTBool :: T Bool -> a - absurdTBool v = case v of - - data Foo = Foo !(T Bool) - - absurdFoo :: Foo -> a - absurdFoo (Foo x) = absurdTBool x - -GHC initially accepts the empty case because of the GADT conditions. But then -we inline absurdTBool, getting - - absurdFoo (Foo x) = case x of - -x is in normal form (because the Foo constructor is strict) but the -case is empty. To avoid this problem, GHC would have to recognize -that matching on Foo x is already absurd, which is not so easy. - -More generally, we don't really know all the ways that GHC can -lose track of why an expression is bottom, so we shouldn't make too -much fuss when that happens. - - -Note [Beta redexes] -~~~~~~~~~~~~~~~~~~~ -Consider: - - join j @x y z = ... in - (\@x y z -> jump j @x y z) @t e1 e2 - -This is clearly ill-typed, since the jump is inside both an application and a -lambda, either of which is enough to disqualify it as a tail call (see Note -[Invariants on join points] in GHC.Core). However, strictly from a -lambda-calculus perspective, the term doesn't go wrong---after the two beta -reductions, the jump *is* a tail call and everything is fine. - -Why would we want to allow this when we have let? One reason is that a compound -beta redex (that is, one with more than one argument) has different scoping -rules: naively reducing the above example using lets will capture any free -occurrence of y in e2. More fundamentally, type lets are tricky; many passes, -such as Float Out, tacitly assume that the incoming program's type lets have -all been dealt with by the simplifier. Thus we don't want to let-bind any types -in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately -before Float Out. - -All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this -loophole, doing so to avoid re-traversing large functions (beta-reducing a type -lambda without introducing a type let requires a substitution). TODO: Improve -simpleOptPgm so that we can forget all this ever happened. - -************************************************************************ -* * -\subsection[lintCoreArgs]{lintCoreArgs} -* * -************************************************************************ - -The basic version of these functions checks that the argument is a -subtype of the required type, as one would expect. --} - - -lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType -lintCoreArgs fun_ty args = foldM lintCoreArg fun_ty args - -lintCoreArg :: OutType -> CoreArg -> LintM OutType -lintCoreArg fun_ty (Type arg_ty) - = do { checkL (not (isCoercionTy arg_ty)) - (text "Unnecessary coercion-to-type injection:" - <+> ppr arg_ty) - ; arg_ty' <- applySubstTy arg_ty - ; lintTyApp fun_ty arg_ty' } - -lintCoreArg fun_ty arg - = do { arg_ty <- markAllJoinsBad $ lintCoreExpr arg - -- See Note [Levity polymorphism invariants] in GHC.Core - ; flags <- getLintFlags - ; lintL (not (lf_check_levity_poly flags) || not (isTypeLevPoly arg_ty)) - (text "Levity-polymorphic argument:" <+> - (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty)))) - -- check for levity polymorphism first, because otherwise isUnliftedType panics - - ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg) - (mkLetAppMsg arg) - ; lintValApp arg fun_ty arg_ty } - ------------------ -lintAltBinders :: OutType -- Scrutinee type - -> OutType -- Constructor type - -> [OutVar] -- Binders - -> LintM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintAltBinders scrut_ty con_ty [] - = ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) -lintAltBinders scrut_ty con_ty (bndr:bndrs) - | isTyVar bndr - = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) - ; lintAltBinders scrut_ty con_ty' bndrs } - | otherwise - = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr) - ; lintAltBinders scrut_ty con_ty' bndrs } - ------------------ -lintTyApp :: OutType -> OutType -> LintM OutType -lintTyApp fun_ty arg_ty - | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty - = do { lintTyKind tv arg_ty - ; in_scope <- getInScope - -- substTy needs the set of tyvars in scope to avoid generating - -- uniques that are already in scope. - -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst - ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) } - - | otherwise - = failWithL (mkTyAppMsg fun_ty arg_ty) - ------------------ -lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType -lintValApp arg fun_ty arg_ty - | Just (arg,res) <- splitFunTy_maybe fun_ty - = do { ensureEqTys arg arg_ty err1 - ; return res } - | otherwise - = failWithL err2 - where - err1 = mkAppMsg fun_ty arg_ty arg - err2 = mkNonFunAppMsg fun_ty arg_ty arg - -lintTyKind :: OutTyVar -> OutType -> LintM () --- Both args have had substitution applied - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintTyKind tyvar arg_ty - = do { arg_kind <- lintType arg_ty - ; unless (arg_kind `eqType` tyvar_kind) - (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))) } - where - tyvar_kind = tyVarKind tyvar - -{- -************************************************************************ -* * -\subsection[lintCoreAlts]{lintCoreAlts} -* * -************************************************************************ --} - -lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM OutType -lintCaseExpr scrut var alt_ty alts = - do { let e = Case scrut var alt_ty alts -- Just for error messages - - -- Check the scrutinee - ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut - -- See Note [Join points are less general than the paper] - -- in GHC.Core - - ; (alt_ty, _) <- addLoc (CaseTy scrut) $ - lintInTy alt_ty - ; (var_ty, _) <- addLoc (IdTy var) $ - lintInTy (idType var) - - -- We used to try to check whether a case expression with no - -- alternatives was legitimate, but this didn't work. - -- See Note [No alternatives lint check] for details. - - -- Check that the scrutinee is not a floating-point type - -- if there are any literal alternatives - -- See GHC.Core Note [Case expression invariants] item (5) - -- See Note [Rules for floating-point comparisons] in GHC.Core.Op.ConstantFold - ; let isLitPat (LitAlt _, _ , _) = True - isLitPat _ = False - ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts) - (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++ - "expression with literal pattern in case " ++ - "analysis (see #9238).") - $$ text "scrut" <+> ppr scrut) - - ; case tyConAppTyCon_maybe (idType var) of - Just tycon - | debugIsOn - , isAlgTyCon tycon - , not (isAbstractTyCon tycon) - , null (tyConDataCons tycon) - , not (exprIsBottom scrut) - -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) - -- This can legitimately happen for type families - $ return () - _otherwise -> return () - - -- Don't use lintIdBndr on var, because unboxed tuple is legitimate - - ; subst <- getTCvSubst - ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) - -- See GHC.Core Note [Case expression invariants] item (7) - - ; lintBinder CaseBind var $ \_ -> - do { -- Check the alternatives - mapM_ (lintCoreAlt scrut_ty alt_ty) alts - ; checkCaseAlts e scrut_ty alts - ; return alt_ty } } - -checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM () --- a) Check that the alts are non-empty --- b1) Check that the DEFAULT comes first, if it exists --- b2) Check that the others are in increasing order --- c) Check that there's a default for infinite types --- NB: Algebraic cases are not necessarily exhaustive, because --- the simplifier correctly eliminates case that can't --- possibly match. - -checkCaseAlts e ty alts = - do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) - -- See GHC.Core Note [Case expression invariants] item (2) - - ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) - -- See GHC.Core Note [Case expression invariants] item (3) - - -- For types Int#, Word# with an infinite (well, large!) number of - -- possible values, there should usually be a DEFAULT case - -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to - -- have *no* case alternatives. - -- In effect, this is a kind of partial test. I suppose it's possible - -- that we might *know* that 'x' was 1 or 2, in which case - -- case x of { 1 -> e1; 2 -> e2 } - -- would be fine. - ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts) - (nonExhaustiveAltsMsg e) } - where - (con_alts, maybe_deflt) = findDefault alts - - -- Check that successive alternatives have strictly increasing tags - increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest - increasing_tag _ = True - - non_deflt (DEFAULT, _, _) = False - non_deflt _ = True - - is_infinite_ty = case tyConAppTyCon_maybe ty of - Nothing -> False - Just tycon -> isPrimTyCon tycon - -lintAltExpr :: CoreExpr -> OutType -> LintM () -lintAltExpr expr ann_ty - = do { actual_ty <- lintCoreExpr expr - ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) } - -- See GHC.Core Note [Case expression invariants] item (6) - -lintCoreAlt :: OutType -- Type of scrutinee - -> OutType -- Type of the alternative - -> CoreAlt - -> LintM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoreAlt _ alt_ty (DEFAULT, args, rhs) = - do { lintL (null args) (mkDefaultArgsMsg args) - ; lintAltExpr rhs alt_ty } - -lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) - | litIsLifted lit - = failWithL integerScrutinisedMsg - | otherwise - = do { lintL (null args) (mkDefaultArgsMsg args) - ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) - ; lintAltExpr rhs alt_ty } - where - lit_ty = literalType lit - -lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) - | isNewTyCon (dataConTyCon con) - = addErrL (mkNewTyDataConAltMsg scrut_ty alt) - | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty - = addLoc (CaseAlt alt) $ do - { -- First instantiate the universally quantified - -- type variables of the data constructor - -- We've already check - lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) - ; let con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys - - -- And now bring the new binders into scope - ; lintBinders CasePatBind args $ \ args' -> do - { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args') - ; lintAltExpr rhs alt_ty } } - - | otherwise -- Scrut-ty is wrong shape - = addErrL (mkBadAltMsg scrut_ty alt) - -{- -************************************************************************ -* * -\subsection[lint-types]{Types} -* * -************************************************************************ --} - --- When we lint binders, we (one at a time and in order): --- 1. Lint var types or kinds (possibly substituting) --- 2. Add the binder to the in scope set, and if its a coercion var, --- we may extend the substitution to reflect its (possibly) new kind -lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a -lintBinders _ [] linterF = linterF [] -lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> - lintBinders site vars $ \ vars' -> - linterF (var':vars') - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a -lintBinder site var linterF - | isTyVar var = lintTyBndr var linterF - | isCoVar var = lintCoBndr var linterF - | otherwise = lintIdBndr NotTopLevel site var linterF - -lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a -lintTyBndr tv thing_inside - = do { subst <- getTCvSubst - ; let (subst', tv') = substTyVarBndr subst tv - ; lintKind (varType tv') - ; updateTCvSubst subst' (thing_inside tv') } - -lintCoBndr :: InCoVar -> (OutCoVar -> LintM a) -> LintM a -lintCoBndr cv thing_inside - = do { subst <- getTCvSubst - ; let (subst', cv') = substCoVarBndr subst cv - ; lintKind (varType cv') - ; lintL (isCoVarType (varType cv')) - (text "CoVar with non-coercion type:" <+> pprTyVar cv) - ; updateTCvSubst subst' (thing_inside cv') } - -lintLetBndrs :: TopLevelFlag -> [Var] -> LintM a -> LintM a -lintLetBndrs top_lvl ids linterF - = go ids - where - go [] = linterF - go (id:ids) = lintIdBndr top_lvl LetBind id $ \_ -> - go ids - -lintIdBndr :: TopLevelFlag -> BindingSite - -> InVar -> (OutVar -> LintM a) -> LintM a --- Do substitution on the type of a binder and add the var with this --- new type to the in-scope set of the second argument --- ToDo: lint its rules -lintIdBndr top_lvl bind_site id linterF - = ASSERT2( isId id, ppr id ) - do { flags <- getLintFlags - ; checkL (not (lf_check_global_ids flags) || isLocalId id) - (text "Non-local Id binder" <+> ppr id) - -- See Note [Checking for global Ids] - - -- Check that if the binder is nested, it is not marked as exported - ; checkL (not (isExportedId id) || is_top_lvl) - (mkNonTopExportedMsg id) - - -- Check that if the binder is nested, it does not have an external name - ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl) - (mkNonTopExternalNameMsg id) - - ; (id_ty, k) <- addLoc (IdTy id) $ - lintInTy (idType id) - ; let id' = setIdType id id_ty - - -- See Note [Levity polymorphism invariants] in GHC.Core - ; lintL (isJoinId id || not (lf_check_levity_poly flags) || not (isKindLevPoly k)) - (text "Levity-polymorphic binder:" <+> - (ppr id <+> dcolon <+> parens (ppr id_ty <+> dcolon <+> ppr k))) - - -- Check that a join-id is a not-top-level let-binding - ; when (isJoinId id) $ - checkL (not is_top_lvl && is_let_bind) $ - mkBadJoinBindMsg id - - -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2); - -- if so, it should be a CoVar, and checked by lintCoVarBndr - ; lintL (not (isCoVarType id_ty)) - (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty) - - ; addInScopeId id' $ (linterF id') } - where - is_top_lvl = isTopLevel top_lvl - is_let_bind = case bind_site of - LetBind -> True - _ -> False - -{- -%************************************************************************ -%* * - Types -%* * -%************************************************************************ --} - -lintTypes :: DynFlags - -> [TyCoVar] -- Treat these as in scope - -> [Type] - -> Maybe MsgDoc -- Nothing => OK -lintTypes dflags vars tys - | isEmptyBag errs = Nothing - | otherwise = Just (pprMessageBag errs) - where - (_warns, errs) = initL dflags defaultLintFlags vars linter - linter = lintBinders LambdaBind vars $ \_ -> - mapM_ lintInTy tys - -lintInTy :: InType -> LintM (LintedType, LintedKind) --- Types only, not kinds --- Check the type, and apply the substitution to it --- See Note [Linting type lets] -lintInTy ty - = addLoc (InType ty) $ - do { ty' <- applySubstTy ty - ; k <- lintType ty' - ; addLoc (InKind ty' k) $ - lintKind k -- The kind returned by lintType is already - -- a LintedKind but we also want to check that - -- k :: *, which lintKind does - ; return (ty', k) } - -checkTyCon :: TyCon -> LintM () -checkTyCon tc - = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) - -------------------- -lintType :: OutType -> LintM LintedKind --- The returned Kind has itself been linted - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintType (TyVarTy tv) - = do { checkL (isTyVar tv) (mkBadTyVarMsg tv) - ; tv' <- lintTyCoVarInScope tv - ; return (tyVarKind tv') } - -- We checked its kind when we added it to the envt - -lintType ty@(AppTy t1 t2) - | TyConApp {} <- t1 - = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty - | otherwise - = do { k1 <- lintType t1 - ; k2 <- lintType t2 - ; lint_ty_app ty k1 [(t2,k2)] } - -lintType ty@(TyConApp tc tys) - | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc - = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags - ; lintTySynFamApp report_unsat ty tc tys } - - | isFunTyCon tc - , tys `lengthIs` 4 - -- We should never see a saturated application of funTyCon; such - -- applications should be represented with the FunTy constructor. - -- See Note [Linting function types] and - -- Note [Representation of function types]. - = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty)) - - | otherwise -- Data types, data families, primitive types - = do { checkTyCon tc - ; ks <- mapM lintType tys - ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } - --- arrows can related *unlifted* kinds, so this has to be separate from --- a dependent forall. -lintType ty@(FunTy _ t1 t2) - = do { k1 <- lintType t1 - ; k2 <- lintType t2 - ; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 } - -lintType t@(ForAllTy (Bndr tv _vis) ty) - -- forall over types - | isTyVar tv - = lintTyBndr tv $ \tv' -> - do { k <- lintType ty - ; checkValueKind k (text "the body of forall:" <+> ppr t) - ; case occCheckExpand [tv'] k of -- See Note [Stupid type synonyms] - Just k' -> return k' - Nothing -> failWithL (hang (text "Variable escape in forall:") - 2 (vcat [ text "type:" <+> ppr t - , text "kind:" <+> ppr k ])) - } - -lintType t@(ForAllTy (Bndr cv _vis) ty) - -- forall over coercions - = do { lintL (isCoVar cv) - (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr t) - ; lintL (cv `elemVarSet` tyCoVarsOfType ty) - (text "Covar does not occur in the body:" <+> ppr t) - ; lintCoBndr cv $ \_ -> - do { k <- lintType ty - ; checkValueKind k (text "the body of forall:" <+> ppr t) - ; return liftedTypeKind - -- We don't check variable escape here. Namely, k could refer to cv' - }} - -lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) - -lintType (CastTy ty co) - = do { k1 <- lintType ty - ; (k1', k2) <- lintStarCoercion co - ; ensureEqTys k1 k1' (mkCastTyErr ty co k1' k1) - ; return k2 } - -lintType (CoercionTy co) - = do { (k1, k2, ty1, ty2, r) <- lintCoercion co - ; return $ mkHeteroCoercionType r k1 k2 ty1 ty2 } - -{- Note [Stupid type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14939) - type Alg cls ob = ob - f :: forall (cls :: * -> Constraint) (b :: Alg cls *). b - -Here 'cls' appears free in b's kind, which would usually be illegal -(because in (forall a. ty), ty's kind should not mention 'a'). But -#in this case (Alg cls *) = *, so all is well. Currently we allow -this, and make Lint expand synonyms where necessary to make it so. - -c.f. TcUnify.occCheckExpand and GHC.Core.Utils.coreAltsType which deal -with the same problem. A single systematic solution eludes me. --} - ------------------ -lintTySynFamApp :: Bool -> Type -> TyCon -> [Type] -> LintM LintedKind --- The TyCon is a type synonym or a type family (not a data family) --- See Note [Linting type synonym applications] --- c.f. TcValidity.check_syn_tc_app -lintTySynFamApp report_unsat ty tc tys - | report_unsat -- Report unsaturated only if report_unsat is on - , tys `lengthLessThan` tyConArity tc - = failWithL (hang (text "Un-saturated type application") 2 (ppr ty)) - - -- Deal with type synonyms - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' - = do { -- Kind-check the argument types, but without reporting - -- un-saturated type families/synonyms - ks <- setReportUnsat False (mapM lintType tys) - - ; when report_unsat $ - do { _ <- lintType expanded_ty - ; return () } - - ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } - - -- Otherwise this must be a type family - | otherwise - = do { ks <- mapM lintType tys - ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } - ------------------ -lintKind :: OutKind -> LintM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintKind k = do { sk <- lintType k - ; unless (classifiesTypeWithValues sk) - (addErrL (hang (text "Ill-kinded kind:" <+> ppr k) - 2 (text "has kind:" <+> ppr sk))) } - ------------------ --- Confirms that a type is really *, #, Constraint etc -checkValueKind :: OutKind -> SDoc -> LintM () -checkValueKind k doc - = lintL (classifiesTypeWithValues k) - (text "Non-*-like kind when *-like expected:" <+> ppr k $$ - text "when checking" <+> doc) - ------------------ -lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintArrow what k1 k2 -- Eg lintArrow "type or kind `blah'" k1 k2 - -- or lintArrow "coercion `blah'" k1 k2 - = do { unless (classifiesTypeWithValues k1) (addErrL (msg (text "argument") k1)) - ; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result") k2)) - ; return liftedTypeKind } - where - msg ar k - = vcat [ hang (text "Ill-kinded" <+> ar) - 2 (text "in" <+> what) - , what <+> text "kind:" <+> ppr k ] - ------------------ -lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind -lint_ty_app ty k tys - = lint_app (text "type" <+> quotes (ppr ty)) k tys - ----------------- -lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind -lint_co_app ty k tys - = lint_app (text "coercion" <+> quotes (ppr ty)) k tys - ----------------- -lintTyLit :: TyLit -> LintM () -lintTyLit (NumTyLit n) - | n >= 0 = return () - | otherwise = failWithL msg - where msg = text "Negative type literal:" <+> integer n -lintTyLit (StrTyLit _) = return () - -lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind --- (lint_app d fun_kind arg_tys) --- We have an application (f arg_ty1 .. arg_tyn), --- where f :: fun_kind --- Takes care of linting the OutTypes - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lint_app doc kfn kas - = do { in_scope <- getInScope - -- We need the in_scope set to satisfy the invariant in - -- Note [The substitution invariant] in GHC.Core.TyCo.Subst - ; foldlM (go_app in_scope) kfn kas } - where - fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc - , nest 2 (text "Function kind =" <+> ppr kfn) - , nest 2 (text "Arg kinds =" <+> ppr kas) - , extra ] - - go_app in_scope kfn tka - | Just kfn' <- coreView kfn - = go_app in_scope kfn' tka - - go_app _ (FunTy _ kfa kfb) tka@(_,ka) - = do { unless (ka `eqType` kfa) $ - addErrL (fail_msg (text "Fun:" <+> (ppr kfa $$ ppr tka))) - ; return kfb } - - go_app in_scope (ForAllTy (Bndr kv _vis) kfn) tka@(ta,ka) - = do { let kv_kind = varType kv - ; unless (ka `eqType` kv_kind) $ - addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ ppr tka))) - ; return $ substTy (extendTCvSubst (mkEmptyTCvSubst in_scope) kv ta) kfn } - - go_app _ kfn ka - = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ka))) - -{- ********************************************************************* -* * - Linting rules -* * -********************************************************************* -} - -lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM () -lintCoreRule _ _ (BuiltinRule {}) - = return () -- Don't bother - -lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs - , ru_args = args, ru_rhs = rhs }) - = lintBinders LambdaBind bndrs $ \ _ -> - do { lhs_ty <- lintCoreArgs fun_ty args - ; rhs_ty <- case isJoinId_maybe fun of - Just join_arity - -> do { checkL (args `lengthIs` join_arity) $ - mkBadJoinPointRuleMsg fun join_arity rule - -- See Note [Rules for join points] - ; lintCoreExpr rhs } - _ -> markAllJoinsBad $ lintCoreExpr rhs - ; ensureEqTys lhs_ty rhs_ty $ - (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty - , text "rhs type:" <+> ppr rhs_ty - , text "fun_ty:" <+> ppr fun_ty ]) - ; let bad_bndrs = filter is_bad_bndr bndrs - - ; checkL (null bad_bndrs) - (rule_doc <+> text "unbound" <+> ppr bad_bndrs) - -- See Note [Linting rules] - } - where - rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon - - lhs_fvs = exprsFreeVars args - rhs_fvs = exprFreeVars rhs - - is_bad_bndr :: Var -> Bool - -- See Note [Unbound RULE binders] in GHC.Core.Rules - is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs) - && bndr `elemVarSet` rhs_fvs - && isNothing (isReflCoVar_maybe bndr) - - -{- Note [Linting rules] -~~~~~~~~~~~~~~~~~~~~~~~ -It's very bad if simplifying a rule means that one of the template -variables (ru_bndrs) that /is/ mentioned on the RHS becomes -not-mentioned in the LHS (ru_args). How can that happen? Well, in -#10602, SpecConstr stupidly constructed a rule like - - forall x,c1,c2. - f (x |> c1 |> c2) = .... - -But simplExpr collapses those coercions into one. (Indeed in -#10602, it collapsed to the identity and was removed altogether.) - -We don't have a great story for what to do here, but at least -this check will nail it. - -NB (#11643): it's possible that a variable listed in the -binders becomes not-mentioned on both LHS and RHS. Here's a silly -example: - RULE forall x y. f (g x y) = g (x+1) (y-1) -And suppose worker/wrapper decides that 'x' is Absent. Then -we'll end up with - RULE forall x y. f ($gw y) = $gw (x+1) -This seems sufficiently obscure that there isn't enough payoff to -try to trim the forall'd binder list. - -Note [Rules for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A join point cannot be partially applied. However, the left-hand side of a rule -for a join point is effectively a *pattern*, not a piece of code, so there's an -argument to be made for allowing a situation like this: - - join $sj :: Int -> Int -> String - $sj n m = ... - j :: forall a. Eq a => a -> a -> String - {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-} - j @a $dEq x y = ... - -Applying this rule can't turn a well-typed program into an ill-typed one, so -conceivably we could allow it. But we can always eta-expand such an -"undersaturated" rule (see 'GHC.Core.Arity.etaExpandToJoinPointRule'), and in fact -the simplifier would have to in order to deal with the RHS. So we take a -conservative view and don't allow undersaturated rules for join points. See -Note [Rules and join points] in OccurAnal for further discussion. --} - -{- -************************************************************************ -* * - Linting coercions -* * -************************************************************************ --} - -lintInCo :: InCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role) --- Check the coercion, and apply the substitution to it --- See Note [Linting type lets] -lintInCo co - = addLoc (InCo co) $ - do { co' <- applySubstCo co - ; lintCoercion co' } - --- lints a coercion, confirming that its lh kind and its rh kind are both * --- also ensures that the role is Nominal -lintStarCoercion :: OutCoercion -> LintM (LintedType, LintedType) -lintStarCoercion g - = do { (k1, k2, t1, t2, r) <- lintCoercion g - ; checkValueKind k1 (text "the kind of the left type in" <+> ppr g) - ; checkValueKind k2 (text "the kind of the right type in" <+> ppr g) - ; lintRole g Nominal r - ; return (t1, t2) } - -lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role) --- Check the kind of a coercion term, returning the kind --- Post-condition: the returned OutTypes are lint-free --- --- If lintCoercion co = (k1, k2, s1, s2, r) --- then co :: s1 ~r s2 --- s1 :: k1 --- s2 :: k2 - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoercion (Refl ty) - = do { k <- lintType ty - ; return (k, k, ty, ty, Nominal) } - -lintCoercion (GRefl r ty MRefl) - = do { k <- lintType ty - ; return (k, k, ty, ty, r) } - -lintCoercion (GRefl r ty (MCo co)) - = do { k <- lintType ty - ; (_, _, k1, k2, r') <- lintCoercion co - ; ensureEqTys k k1 - (hang (text "GRefl coercion kind mis-match:" <+> ppr co) - 2 (vcat [ppr ty, ppr k, ppr k1])) - ; lintRole co Nominal r' - ; return (k1, k2, ty, mkCastTy ty co, r) } - -lintCoercion co@(TyConAppCo r tc cos) - | tc `hasKey` funTyConKey - , [_rep1,_rep2,_co1,_co2] <- cos - = do { failWithL (text "Saturated TyConAppCo (->):" <+> ppr co) - } -- All saturated TyConAppCos should be FunCos - - | Just {} <- synTyConDefn_maybe tc - = failWithL (text "Synonym in TyConAppCo:" <+> ppr co) - - | otherwise - = do { checkTyCon tc - ; (k's, ks, ss, ts, rs) <- mapAndUnzip5M lintCoercion cos - ; k' <- lint_co_app co (tyConKind tc) (ss `zip` k's) - ; k <- lint_co_app co (tyConKind tc) (ts `zip` ks) - ; _ <- zipWith3M lintRole cos (tyConRolesX r tc) rs - ; return (k', k, mkTyConApp tc ss, mkTyConApp tc ts, r) } - -lintCoercion co@(AppCo co1 co2) - | TyConAppCo {} <- co1 - = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co) - | Just (TyConApp {}, _) <- isReflCo_maybe co1 - = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co) - | otherwise - = do { (k1, k2, s1, s2, r1) <- lintCoercion co1 - ; (k'1, k'2, t1, t2, r2) <- lintCoercion co2 - ; k3 <- lint_co_app co k1 [(t1,k'1)] - ; k4 <- lint_co_app co k2 [(t2,k'2)] - ; if r1 == Phantom - then lintL (r2 == Phantom || r2 == Nominal) - (text "Second argument in AppCo cannot be R:" $$ - ppr co) - else lintRole co Nominal r2 - ; return (k3, k4, mkAppTy s1 t1, mkAppTy s2 t2, r1) } - ----------- -lintCoercion (ForAllCo tv1 kind_co co) - -- forall over types - | isTyVar tv1 - = do { (_, k2) <- lintStarCoercion kind_co - ; let tv2 = setTyVarKind tv1 k2 - ; addInScopeTyCoVar tv1 $ - do { - ; (k3, k4, t1, t2, r) <- lintCoercion co - ; in_scope <- getInScope - ; let tyl = mkInvForAllTy tv1 t1 - subst = mkTvSubst in_scope $ - -- We need both the free vars of the `t2` and the - -- free vars of the range of the substitution in - -- scope. All the free vars of `t2` and `kind_co` should - -- already be in `in_scope`, because they've been - -- linted and `tv2` has the same unique as `tv1`. - -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst. - unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co) - tyr = mkInvForAllTy tv2 $ - substTy subst t2 - ; return (k3, k4, tyl, tyr, r) } } - -lintCoercion (ForAllCo cv1 kind_co co) - -- forall over coercions - = ASSERT( isCoVar cv1 ) - do { lintL (almostDevoidCoVarOfCo cv1 co) - (text "Covar can only appear in Refl and GRefl: " <+> ppr co) - ; (_, k2) <- lintStarCoercion kind_co - ; let cv2 = setVarType cv1 k2 - ; addInScopeTyCoVar cv1 $ - do { - ; (k3, k4, t1, t2, r) <- lintCoercion co - ; checkValueKind k3 (text "the body of a ForAllCo over covar:" <+> ppr co) - ; checkValueKind k4 (text "the body of a ForAllCo over covar:" <+> ppr co) - -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep - ; in_scope <- getInScope - ; let tyl = mkTyCoInvForAllTy cv1 t1 - r2 = coVarRole cv1 - kind_co' = downgradeRole r2 Nominal kind_co - eta1 = mkNthCo r2 2 kind_co' - eta2 = mkNthCo r2 3 kind_co' - subst = mkCvSubst in_scope $ - -- We need both the free vars of the `t2` and the - -- free vars of the range of the substitution in - -- scope. All the free vars of `t2` and `kind_co` should - -- already be in `in_scope`, because they've been - -- linted and `cv2` has the same unique as `cv1`. - -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst. - unitVarEnv cv1 (eta1 `mkTransCo` (mkCoVarCo cv2) - `mkTransCo` (mkSymCo eta2)) - tyr = mkTyCoInvForAllTy cv2 $ - substTy subst t2 - ; return (liftedTypeKind, liftedTypeKind, tyl, tyr, r) } } - -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep - -lintCoercion co@(FunCo r co1 co2) - = do { (k1,k'1,s1,t1,r1) <- lintCoercion co1 - ; (k2,k'2,s2,t2,r2) <- lintCoercion co2 - ; k <- lintArrow (text "coercion" <+> quotes (ppr co)) k1 k2 - ; k' <- lintArrow (text "coercion" <+> quotes (ppr co)) k'1 k'2 - ; lintRole co1 r r1 - ; lintRole co2 r r2 - ; return (k, k', mkVisFunTy s1 s2, mkVisFunTy t1 t2, r) } - -lintCoercion (CoVarCo cv) - | not (isCoVar cv) - = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv) - 2 (text "With offending type:" <+> ppr (varType cv))) - | otherwise - = do { cv' <- lintTyCoVarInScope cv - ; lintUnliftedCoVar cv' - ; return $ coVarKindsTypesRole cv' } - --- See Note [Bad unsafe coercion] -lintCoercion co@(UnivCo prov r ty1 ty2) - = do { k1 <- lintType ty1 - ; k2 <- lintType ty2 - ; case prov of - PhantomProv kco -> do { lintRole co Phantom r - ; check_kinds kco k1 k2 } - - ProofIrrelProv kco -> do { lintL (isCoercionTy ty1) $ - mkBadProofIrrelMsg ty1 co - ; lintL (isCoercionTy ty2) $ - mkBadProofIrrelMsg ty2 co - ; check_kinds kco k1 k2 } - - PluginProv _ -> return () -- no extra checks - - ; when (r /= Phantom && classifiesTypeWithValues k1 - && classifiesTypeWithValues k2) - (checkTypes ty1 ty2) - ; return (k1, k2, ty1, ty2, r) } - where - report s = hang (text $ "Unsafe coercion: " ++ s) - 2 (vcat [ text "From:" <+> ppr ty1 - , text " To:" <+> ppr ty2]) - isUnBoxed :: PrimRep -> Bool - isUnBoxed = not . isGcPtrRep - - -- see #9122 for discussion of these checks - checkTypes t1 t2 - = do { checkWarnL (not lev_poly1) - (report "left-hand type is levity-polymorphic") - ; checkWarnL (not lev_poly2) - (report "right-hand type is levity-polymorphic") - ; when (not (lev_poly1 || lev_poly2)) $ - do { checkWarnL (reps1 `equalLength` reps2) - (report "between values with different # of reps") - ; zipWithM_ validateCoercion reps1 reps2 }} - where - lev_poly1 = isTypeLevPoly t1 - lev_poly2 = isTypeLevPoly t2 - - -- don't look at these unless lev_poly1/2 are False - -- Otherwise, we get #13458 - reps1 = typePrimRep t1 - reps2 = typePrimRep t2 - - validateCoercion :: PrimRep -> PrimRep -> LintM () - validateCoercion rep1 rep2 - = do { platform <- targetPlatform <$> getDynFlags - ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2) - (report "between unboxed and boxed value") - ; checkWarnL (TyCon.primRepSizeB platform rep1 - == TyCon.primRepSizeB platform rep2) - (report "between unboxed values of different size") - ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1) - (TyCon.primRepIsFloat rep2) - ; case fl of - Nothing -> addWarnL (report "between vector types") - Just False -> addWarnL (report "between float and integral values") - _ -> return () - } - - check_kinds kco k1 k2 = do { (k1', k2') <- lintStarCoercion kco - ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft co) - ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) } - - -lintCoercion (SymCo co) - = do { (k1, k2, ty1, ty2, r) <- lintCoercion co - ; return (k2, k1, ty2, ty1, r) } - -lintCoercion co@(TransCo co1 co2) - = do { (k1a, _k1b, ty1a, ty1b, r1) <- lintCoercion co1 - ; (_k2a, k2b, ty2a, ty2b, r2) <- lintCoercion co2 - ; ensureEqTys ty1b ty2a - (hang (text "Trans coercion mis-match:" <+> ppr co) - 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) - ; lintRole co r1 r2 - ; return (k1a, k2b, ty1a, ty2b, r1) } - -lintCoercion the_co@(NthCo r0 n co) - = do { (_, _, s, t, r) <- lintCoercion co - ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of - { (Just (tcv_s, _ty_s), Just (tcv_t, _ty_t)) - -- works for both tyvar and covar - | n == 0 - , (isForAllTy_ty s && isForAllTy_ty t) - || (isForAllTy_co s && isForAllTy_co t) - -> do { lintRole the_co Nominal r0 - ; return (ks, kt, ts, tt, r0) } - where - ts = varType tcv_s - tt = varType tcv_t - ks = typeKind ts - kt = typeKind tt - - ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of - { (Just (tc_s, tys_s), Just (tc_t, tys_t)) - | tc_s == tc_t - , isInjectiveTyCon tc_s r - -- see Note [NthCo and newtypes] in GHC.Core.TyCo.Rep - , tys_s `equalLength` tys_t - , tys_s `lengthExceeds` n - -> do { lintRole the_co tr r0 - ; return (ks, kt, ts, tt, r0) } - where - ts = getNth tys_s n - tt = getNth tys_t n - tr = nthRole r tc_s n - ks = typeKind ts - kt = typeKind tt - - ; _ -> failWithL (hang (text "Bad getNth:") - 2 (ppr the_co $$ ppr s $$ ppr t)) }}} - -lintCoercion the_co@(LRCo lr co) - = do { (_,_,s,t,r) <- lintCoercion co - ; lintRole co Nominal r - ; case (splitAppTy_maybe s, splitAppTy_maybe t) of - (Just s_pr, Just t_pr) - -> return (ks_pick, kt_pick, s_pick, t_pick, Nominal) - where - s_pick = pickLR lr s_pr - t_pick = pickLR lr t_pr - ks_pick = typeKind s_pick - kt_pick = typeKind t_pick - - _ -> failWithL (hang (text "Bad LRCo:") - 2 (ppr the_co $$ ppr s $$ ppr t)) } - -lintCoercion (InstCo co arg) - = do { (k3, k4, t1',t2', r) <- lintCoercion co - ; (k1',k2',s1,s2, r') <- lintCoercion arg - ; lintRole arg Nominal r' - ; in_scope <- getInScope - ; case (splitForAllTy_ty_maybe t1', splitForAllTy_ty_maybe t2') of - -- forall over tvar - { (Just (tv1,t1), Just (tv2,t2)) - | k1' `eqType` tyVarKind tv1 - , k2' `eqType` tyVarKind tv2 - -> return (k3, k4, - substTyWithInScope in_scope [tv1] [s1] t1, - substTyWithInScope in_scope [tv2] [s2] t2, r) - | otherwise - -> failWithL (text "Kind mis-match in inst coercion") - ; _ -> case (splitForAllTy_co_maybe t1', splitForAllTy_co_maybe t2') of - -- forall over covar - { (Just (cv1, t1), Just (cv2, t2)) - | k1' `eqType` varType cv1 - , k2' `eqType` varType cv2 - , CoercionTy s1' <- s1 - , CoercionTy s2' <- s2 - -> do { return $ - (liftedTypeKind, liftedTypeKind - -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep - , substTy (mkCvSubst in_scope $ unitVarEnv cv1 s1') t1 - , substTy (mkCvSubst in_scope $ unitVarEnv cv2 s2') t2 - , r) } - | otherwise - -> failWithL (text "Kind mis-match in inst coercion") - ; _ -> failWithL (text "Bad argument of inst") }}} - -lintCoercion co@(AxiomInstCo con ind cos) - = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con)) - (bad_ax (text "index out of range")) - ; let CoAxBranch { cab_tvs = ktvs - , cab_cvs = cvs - , cab_roles = roles - , cab_lhs = lhs - , cab_rhs = rhs } = coAxiomNthBranch con ind - ; unless (cos `equalLength` (ktvs ++ cvs)) $ - bad_ax (text "lengths") - ; subst <- getTCvSubst - ; let empty_subst = zapTCvSubst subst - ; (subst_l, subst_r) <- foldlM check_ki - (empty_subst, empty_subst) - (zip3 (ktvs ++ cvs) roles cos) - ; let lhs' = substTys subst_l lhs - rhs' = substTy subst_r rhs - fam_tc = coAxiomTyCon con - ; case checkAxInstCo co of - Just bad_branch -> bad_ax $ text "inconsistent with" <+> - pprCoAxBranch fam_tc bad_branch - Nothing -> return () - ; let s2 = mkTyConApp fam_tc lhs' - ; return (typeKind s2, typeKind rhs', s2, rhs', coAxiomRole con) } - where - bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what) - 2 (ppr co)) - - check_ki (subst_l, subst_r) (ktv, role, arg) - = do { (k', k'', s', t', r) <- lintCoercion arg - ; lintRole arg role r - ; let ktv_kind_l = substTy subst_l (tyVarKind ktv) - ktv_kind_r = substTy subst_r (tyVarKind ktv) - ; unless (k' `eqType` ktv_kind_l) - (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr k', ppr ktv, ppr ktv_kind_l ] )) - ; unless (k'' `eqType` ktv_kind_r) - (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr k'', ppr ktv, ppr ktv_kind_r ] )) - ; return (extendTCvSubst subst_l ktv s', - extendTCvSubst subst_r ktv t') } - -lintCoercion (KindCo co) - = do { (k1, k2, _, _, _) <- lintCoercion co - ; return (liftedTypeKind, liftedTypeKind, k1, k2, Nominal) } - -lintCoercion (SubCo co') - = do { (k1,k2,s,t,r) <- lintCoercion co' - ; lintRole co' Nominal r - ; return (k1,k2,s,t,Representational) } - -lintCoercion this@(AxiomRuleCo co cs) - = do { eqs <- mapM lintCoercion cs - ; lintRoles 0 (coaxrAsmpRoles co) eqs - ; case coaxrProves co [ Pair l r | (_,_,l,r,_) <- eqs ] of - Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ] - Just (Pair l r) -> - return (typeKind l, typeKind r, l, r, coaxrRole co) } - where - err m xs = failWithL $ - hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName co) : xs) - - lintRoles n (e : es) ((_,_,_,_,r) : rs) - | e == r = lintRoles (n+1) es rs - | otherwise = err "Argument roles mismatch" - [ text "In argument:" <+> int (n+1) - , text "Expected:" <+> ppr e - , text "Found:" <+> ppr r ] - lintRoles _ [] [] = return () - lintRoles n [] rs = err "Too many coercion arguments" - [ text "Expected:" <+> int n - , text "Provided:" <+> int (n + length rs) ] - - lintRoles n es [] = err "Not enough coercion arguments" - [ text "Expected:" <+> int (n + length es) - , text "Provided:" <+> int n ] - -lintCoercion (HoleCo h) - = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h - ; lintCoercion (CoVarCo (coHoleCoVar h)) } - - ----------- -lintUnliftedCoVar :: CoVar -> LintM () -lintUnliftedCoVar cv - = when (not (isUnliftedType (coVarKind cv))) $ - failWithL (text "Bad lifted equality:" <+> ppr cv - <+> dcolon <+> ppr (coVarKind cv)) - -{- -************************************************************************ -* * -\subsection[lint-monad]{The Lint monad} -* * -************************************************************************ --} - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] -data LintEnv - = LE { le_flags :: LintFlags -- Linting the result of this pass - , le_loc :: [LintLocInfo] -- Locations - - , le_subst :: TCvSubst -- Current TyCo substitution - -- See Note [Linting type lets] - -- /Only/ substitutes for type variables; - -- but might clone CoVars - -- We also use le_subst to keep track of - -- in-scope TyVars and CoVars - - , le_ids :: IdSet -- In-scope Ids - , le_joins :: IdSet -- Join points in scope that are valid - -- A subset of the InScopeSet in le_subst - -- See Note [Join points] - - , le_dynflags :: DynFlags -- DynamicFlags - } - -data LintFlags - = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids] - , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers] - , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs] - , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications] - , lf_check_levity_poly :: Bool -- See Note [Checking for levity polymorphism] - } - --- See Note [Checking StaticPtrs] -data StaticPtrCheck - = AllowAnywhere - -- ^ Allow 'makeStatic' to occur anywhere. - | AllowAtTopLevel - -- ^ Allow 'makeStatic' calls at the top-level only. - | RejectEverywhere - -- ^ Reject any 'makeStatic' occurrence. - deriving Eq - -defaultLintFlags :: LintFlags -defaultLintFlags = LF { lf_check_global_ids = False - , lf_check_inline_loop_breakers = True - , lf_check_static_ptrs = AllowAnywhere - , lf_report_unsat_syns = True - , lf_check_levity_poly = True - } - -newtype LintM a = - LintM { unLintM :: - LintEnv -> - WarnsAndErrs -> -- Warning and error messages so far - (Maybe a, WarnsAndErrs) } -- Result and messages (if any) - deriving (Functor) - -type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) - -{- Note [Checking for global Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before CoreTidy, all locally-bound Ids must be LocalIds, even -top-level ones. See Note [Exported LocalIds] and #9857. - -Note [Checking StaticPtrs] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Note [Grand plan for static forms] in StaticPtrTable for an overview. - -Every occurrence of the function 'makeStatic' should be moved to the -top level by the FloatOut pass. It's vital that we don't have nested -'makeStatic' occurrences after CorePrep, because we populate the Static -Pointer Table from the top-level bindings. See SimplCore Note [Grand -plan for static forms]. - -The linter checks that no occurrence is left behind, nested within an -expression. The check is enabled only after the FloatOut, CorePrep, -and CoreTidy passes and only if the module uses the StaticPointers -language extension. Checking more often doesn't help since the condition -doesn't hold until after the first FloatOut pass. - -Note [Type substitution] -~~~~~~~~~~~~~~~~~~~~~~~~ -Why do we need a type substitution? Consider - /\(a:*). \(x:a). /\(a:*). id a x -This is ill typed, because (renaming variables) it is really - /\(a:*). \(x:a). /\(b:*). id b x -Hence, when checking an application, we can't naively compare x's type -(at its binding site) with its expected type (at a use site). So we -rename type binders as we go, maintaining a substitution. - -The same substitution also supports let-type, current expressed as - (/\(a:*). body) ty -Here we substitute 'ty' for 'a' in 'body', on the fly. - -Note [Linting type synonym applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When linting a type-synonym, or type-family, application - S ty1 .. tyn -we behave as follows (#15057, #T15664): - -* If lf_report_unsat_syns = True, and S has arity < n, - complain about an unsaturated type synonym or type family - -* Switch off lf_report_unsat_syns, and lint ty1 .. tyn. - - Reason: catch out of scope variables or other ill-kinded gubbins, - even if S discards that argument entirely. E.g. (#15012): - type FakeOut a = Int - type family TF a - type instance TF Int = FakeOut a - Here 'a' is out of scope; but if we expand FakeOut, we conceal - that out-of-scope error. - - Reason for switching off lf_report_unsat_syns: with - LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they - are saturated when the type is expanded. Example - type T f = f Int - type S a = a -> a - type Z = T S - In Z's RHS, S appears unsaturated, but it is saturated when T is expanded. - -* If lf_report_unsat_syns is on, expand the synonym application and - lint the result. Reason: want to check that synonyms are saturated - when the type is expanded. --} - -instance Applicative LintM where - pure x = LintM $ \ _ errs -> (Just x, errs) - (<*>) = ap - -instance Monad LintM where - m >>= k = LintM (\ env errs -> - let (res, errs') = unLintM m env errs in - case res of - Just r -> unLintM (k r) env errs' - Nothing -> (Nothing, errs')) - -instance MonadFail LintM where - fail err = failWithL (text err) - -instance HasDynFlags LintM where - getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs)) - -data LintLocInfo - = RhsOf Id -- The variable bound - | LambdaBodyOf Id -- The lambda-binder - | UnfoldingOf Id -- Unfolding of a binder - | BodyOfLetRec [Id] -- One of the binders - | CaseAlt CoreAlt -- Case alternative - | CasePat CoreAlt -- The *pattern* of the case alternative - | CaseTy CoreExpr -- The type field of a case expression - -- with this scrutinee - | IdTy Id -- The type field of an Id binder - | AnExpr CoreExpr -- Some expression - | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) - | TopLevelBindings - | InType Type -- Inside a type - | InKind Type Kind -- Inside a kind - | InCo Coercion -- Inside a coercion - -initL :: DynFlags -> LintFlags -> [Var] - -> LintM a -> WarnsAndErrs -- Warnings and errors -initL dflags flags vars m - = case unLintM m env (emptyBag, emptyBag) of - (Just _, errs) -> errs - (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs - | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++ - "without reporting an error message") empty - where - (tcvs, ids) = partition isTyCoVar vars - env = LE { le_flags = flags - , le_subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet tcvs)) - , le_ids = mkVarSet ids - , le_joins = emptyVarSet - , le_loc = [] - , le_dynflags = dflags } - -setReportUnsat :: Bool -> LintM a -> LintM a --- Switch off lf_report_unsat_syns -setReportUnsat ru thing_inside - = LintM $ \ env errs -> - let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } } - in unLintM thing_inside env' errs - --- See Note [Checking for levity polymorphism] -noLPChecks :: LintM a -> LintM a -noLPChecks thing_inside - = LintM $ \env errs -> - let env' = env { le_flags = (le_flags env) { lf_check_levity_poly = False } } - in unLintM thing_inside env' errs - -getLintFlags :: LintM LintFlags -getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs) - -checkL :: Bool -> MsgDoc -> LintM () -checkL True _ = return () -checkL False msg = failWithL msg - --- like checkL, but relevant to type checking -lintL :: Bool -> MsgDoc -> LintM () -lintL = checkL - -checkWarnL :: Bool -> MsgDoc -> LintM () -checkWarnL True _ = return () -checkWarnL False msg = addWarnL msg - -failWithL :: MsgDoc -> LintM a -failWithL msg = LintM $ \ env (warns,errs) -> - (Nothing, (warns, addMsg True env errs msg)) - -addErrL :: MsgDoc -> LintM () -addErrL msg = LintM $ \ env (warns,errs) -> - (Just (), (warns, addMsg True env errs msg)) - -addWarnL :: MsgDoc -> LintM () -addWarnL msg = LintM $ \ env (warns,errs) -> - (Just (), (addMsg False env warns msg, errs)) - -addMsg :: Bool -> LintEnv -> Bag MsgDoc -> MsgDoc -> Bag MsgDoc -addMsg is_error env msgs msg - = ASSERT( notNull loc_msgs ) - msgs `snocBag` mk_msg msg - where - loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first - loc_msgs = map dumpLoc (le_loc env) - - cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs - , text "Substitution:" <+> ppr (le_subst env) ] - context | is_error = cxt_doc - | otherwise = whenPprDebug cxt_doc - -- Print voluminous info for Lint errors - -- but not for warnings - - msg_span = case [ span | (loc,_) <- loc_msgs - , let span = srcLocSpan loc - , isGoodSrcSpan span ] of - [] -> noSrcSpan - (s:_) -> s - mk_msg msg = mkLocMessage SevWarning msg_span - (msg $$ context) - -addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m - = LintM $ \ env errs -> - unLintM m (env { le_loc = extra_loc : le_loc env }) errs - -inCasePat :: LintM Bool -- A slight hack; see the unique call site -inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs) - where - is_case_pat (LE { le_loc = CasePat {} : _ }) = True - is_case_pat _other = False - -addInScopeTyCoVar :: Var -> LintM a -> LintM a -addInScopeTyCoVar var m - = LintM $ \ env errs -> - unLintM m (env { le_subst = extendTCvInScope (le_subst env) var }) errs - -addInScopeId :: Id -> LintM a -> LintM a -addInScopeId id m - = LintM $ \ env errs -> - unLintM m (env { le_ids = extendVarSet (le_ids env) id - , le_joins = delVarSet (le_joins env) id }) errs - -getInScopeIds :: LintM IdSet -getInScopeIds = LintM (\env errs -> (Just (le_ids env), errs)) - -extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a -extendTvSubstL tv ty m - = LintM $ \ env errs -> - unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs - -updateTCvSubst :: TCvSubst -> LintM a -> LintM a -updateTCvSubst subst' m - = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs - -markAllJoinsBad :: LintM a -> LintM a -markAllJoinsBad m - = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs - -markAllJoinsBadIf :: Bool -> LintM a -> LintM a -markAllJoinsBadIf True m = markAllJoinsBad m -markAllJoinsBadIf False m = m - -addGoodJoins :: [Var] -> LintM a -> LintM a -addGoodJoins vars thing_inside - = LintM $ \ env errs -> unLintM thing_inside (add_joins env) errs - where - add_joins env = env { le_joins = le_joins env `extendVarSetList` join_ids } - join_ids = filter isJoinId vars - -getValidJoins :: LintM IdSet -getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs)) - -getTCvSubst :: LintM TCvSubst -getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs)) - -getInScope :: LintM InScopeSet -getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs)) - -applySubstTy :: InType -> LintM OutType -applySubstTy ty = do { subst <- getTCvSubst; return (substTy subst ty) } - -applySubstCo :: InCoercion -> LintM OutCoercion -applySubstCo co = do { subst <- getTCvSubst; return (substCo subst co) } - -lookupIdInScope :: Id -> LintM Id -lookupIdInScope id_occ - = do { in_scope_ids <- getInScopeIds - ; case lookupVarSet in_scope_ids id_occ of - Just id_bnd -> do { checkL (not (bad_global id_bnd)) global_in_scope - ; return id_bnd } - Nothing -> do { checkL (not is_local) local_out_of_scope - ; return id_occ } } - where - is_local = mustHaveLocalBinding id_occ - local_out_of_scope = text "Out of scope:" <+> pprBndr LetBind id_occ - global_in_scope = hang (text "Occurrence is GlobalId, but binding is LocalId") - 2 (pprBndr LetBind id_occ) - bad_global id_bnd = isGlobalId id_occ - && isLocalId id_bnd - && not (isWiredIn id_occ) - -- 'bad_global' checks for the case where an /occurrence/ is - -- a GlobalId, but there is an enclosing binding fora a LocalId. - -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr, - -- but GHCi adds GlobalIds from the interactive context. These - -- are fine; hence the test (isLocalId id == isLocalId v) - -- NB: when compiling Control.Exception.Base, things like absentError - -- are defined locally, but appear in expressions as (global) - -- wired-in Ids after worker/wrapper - -- So we simply disable the test in this case - -lookupJoinId :: Id -> LintM (Maybe JoinArity) --- Look up an Id which should be a join point, valid here --- If so, return its arity, if not return Nothing -lookupJoinId id - = do { join_set <- getValidJoins - ; case lookupVarSet join_set id of - Just id' -> return (isJoinId_maybe id') - Nothing -> return Nothing } - -lintTyCoVarInScope :: TyCoVar -> LintM TyCoVar -lintTyCoVarInScope var - = do { subst <- getTCvSubst - ; case lookupInScope (getTCvInScope subst) var of - Just var' -> return var' - Nothing -> failWithL $ - hang (text "The TyCo variable" <+> pprBndr LetBind var) - 2 (text "is out of scope") } - -ensureEqTys :: OutType -> OutType -> MsgDoc -> LintM () --- check ty2 is subtype of ty1 (ie, has same structure but usage --- annotations need only be consistent, not equal) --- Assumes ty1,ty2 are have already had the substitution applied -ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg - -lintRole :: Outputable thing - => thing -- where the role appeared - -> Role -- expected - -> Role -- actual - -> LintM () -lintRole co r1 r2 - = lintL (r1 == r2) - (text "Role incompatibility: expected" <+> ppr r1 <> comma <+> - text "got" <+> ppr r2 $$ - text "in" <+> ppr co) - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) - -dumpLoc (RhsOf v) - = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v]) - -dumpLoc (LambdaBodyOf b) - = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b) - -dumpLoc (UnfoldingOf b) - = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b) - -dumpLoc (BodyOfLetRec []) - = (noSrcLoc, text "In body of a letrec with no binders") - -dumpLoc (BodyOfLetRec bs@(_:_)) - = ( getSrcLoc (head bs), text "In the body of letrec with binders" <+> pp_binders bs) - -dumpLoc (AnExpr e) - = (noSrcLoc, text "In the expression:" <+> ppr e) - -dumpLoc (CaseAlt (con, args, _)) - = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) - -dumpLoc (CasePat (con, args, _)) - = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) - -dumpLoc (CaseTy scrut) - = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:") - 2 (ppr scrut)) - -dumpLoc (IdTy b) - = (getSrcLoc b, text "In the type of a binder:" <+> ppr b) - -dumpLoc (ImportedUnfolding locn) - = (locn, text "In an imported unfolding") -dumpLoc TopLevelBindings - = (noSrcLoc, Outputable.empty) -dumpLoc (InType ty) - = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) -dumpLoc (InKind ty ki) - = (noSrcLoc, text "In the kind of" <+> parens (ppr ty <+> dcolon <+> ppr ki)) -dumpLoc (InCo co) - = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) - -pp_binders :: [Var] -> SDoc -pp_binders bs = sep (punctuate comma (map pp_binder bs)) - -pp_binder :: Var -> SDoc -pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] - | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] - ------------------------------------------------------- --- Messages for case expressions - -mkDefaultArgsMsg :: [Var] -> MsgDoc -mkDefaultArgsMsg args - = hang (text "DEFAULT case with binders") - 4 (ppr args) - -mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc -mkCaseAltMsg e ty1 ty2 - = hang (text "Type of case alternatives not the same as the annotation on case:") - 4 (vcat [ text "Actual type:" <+> ppr ty1, - text "Annotation on case:" <+> ppr ty2, - text "Alt Rhs:" <+> ppr e ]) - -mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc -mkScrutMsg var var_ty scrut_ty subst - = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, - text "Result binder type:" <+> ppr var_ty,--(idType var), - text "Scrutinee type:" <+> ppr scrut_ty, - hsep [text "Current TCv subst", ppr subst]] - -mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc -mkNonDefltMsg e - = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e) -mkNonIncreasingAltsMsg e - = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) - -nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc -nonExhaustiveAltsMsg e - = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) - -mkBadConMsg :: TyCon -> DataCon -> MsgDoc -mkBadConMsg tycon datacon - = vcat [ - text "In a case alternative, data constructor isn't in scrutinee type:", - text "Scrutinee type constructor:" <+> ppr tycon, - text "Data con:" <+> ppr datacon - ] - -mkBadPatMsg :: Type -> Type -> MsgDoc -mkBadPatMsg con_result_ty scrut_ty - = vcat [ - text "In a case alternative, pattern result type doesn't match scrutinee type:", - text "Pattern result type:" <+> ppr con_result_ty, - text "Scrutinee type:" <+> ppr scrut_ty - ] - -integerScrutinisedMsg :: MsgDoc -integerScrutinisedMsg - = text "In a LitAlt, the literal is lifted (probably Integer)" - -mkBadAltMsg :: Type -> CoreAlt -> MsgDoc -mkBadAltMsg scrut_ty alt - = vcat [ text "Data alternative when scrutinee is not a tycon application", - text "Scrutinee type:" <+> ppr scrut_ty, - text "Alternative:" <+> pprCoreAlt alt ] - -mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc -mkNewTyDataConAltMsg scrut_ty alt - = vcat [ text "Data alternative for newtype datacon", - text "Scrutinee type:" <+> ppr scrut_ty, - text "Alternative:" <+> pprCoreAlt alt ] - - ------------------------------------------------------- --- Other error messages - -mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc -mkAppMsg fun_ty arg_ty arg - = vcat [text "Argument value doesn't match argument type:", - hang (text "Fun type:") 4 (ppr fun_ty), - hang (text "Arg type:") 4 (ppr arg_ty), - hang (text "Arg:") 4 (ppr arg)] - -mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc -mkNonFunAppMsg fun_ty arg_ty arg - = vcat [text "Non-function type in function position", - hang (text "Fun type:") 4 (ppr fun_ty), - hang (text "Arg type:") 4 (ppr arg_ty), - hang (text "Arg:") 4 (ppr arg)] - -mkLetErr :: TyVar -> CoreExpr -> MsgDoc -mkLetErr bndr rhs - = vcat [text "Bad `let' binding:", - hang (text "Variable:") - 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), - hang (text "Rhs:") - 4 (ppr rhs)] - -mkTyAppMsg :: Type -> Type -> MsgDoc -mkTyAppMsg ty arg_ty - = vcat [text "Illegal type application:", - hang (text "Exp type:") - 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), - hang (text "Arg type:") - 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] - -emptyRec :: CoreExpr -> MsgDoc -emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) - -mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc -mkRhsMsg binder what ty - = vcat - [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon, - ppr binder], - hsep [text "Binder's type:", ppr (idType binder)], - hsep [text "Rhs type:", ppr ty]] - -mkLetAppMsg :: CoreExpr -> MsgDoc -mkLetAppMsg e - = hang (text "This argument does not satisfy the let/app invariant:") - 2 (ppr e) - -badBndrTyMsg :: Id -> SDoc -> MsgDoc -badBndrTyMsg binder what - = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder - , text "Binder's type:" <+> ppr (idType binder) ] - -mkStrictMsg :: Id -> MsgDoc -mkStrictMsg binder - = vcat [hsep [text "Recursive or top-level binder has strict demand info:", - ppr binder], - hsep [text "Binder's demand info:", ppr (idDemandInfo binder)] - ] - -mkNonTopExportedMsg :: Id -> MsgDoc -mkNonTopExportedMsg binder - = hsep [text "Non-top-level binder is marked as exported:", ppr binder] - -mkNonTopExternalNameMsg :: Id -> MsgDoc -mkNonTopExternalNameMsg binder - = hsep [text "Non-top-level binder has an external name:", ppr binder] - -mkTopNonLitStrMsg :: Id -> MsgDoc -mkTopNonLitStrMsg binder - = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] - -mkKindErrMsg :: TyVar -> Type -> MsgDoc -mkKindErrMsg tyvar arg_ty - = vcat [text "Kinds don't match in type application:", - hang (text "Type variable:") - 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (text "Arg type:") - 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] - -mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc -mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) - -mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> MsgDoc -mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty) - -mk_cast_err :: String -- ^ What sort of casted thing this is - -- (\"expression\" or \"type\"). - -> String -- ^ What sort of coercion is being used - -- (\"type\" or \"kind\"). - -> SDoc -- ^ The thing being casted. - -> Coercion -> Type -> Type -> MsgDoc -mk_cast_err thing_str co_str pp_thing co from_ty thing_ty - = vcat [from_msg <+> text "of Cast differs from" <+> co_msg - <+> text "of" <+> enclosed_msg, - from_msg <> colon <+> ppr from_ty, - text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon - <+> ppr thing_ty, - text "Actual" <+> enclosed_msg <> colon <+> pp_thing, - text "Coercion used in cast:" <+> ppr co - ] - where - co_msg, from_msg, enclosed_msg :: SDoc - co_msg = text co_str - from_msg = text "From-" <> co_msg - enclosed_msg = text "enclosed" <+> text thing_str - -mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc -mkBadUnivCoMsg lr co - = text "Kind mismatch on the" <+> pprLeftOrRight lr <+> - text "side of a UnivCo:" <+> ppr co - -mkBadProofIrrelMsg :: Type -> Coercion -> SDoc -mkBadProofIrrelMsg ty co - = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:") - 2 (vcat [ text "type:" <+> ppr ty - , text "co:" <+> ppr co ]) - -mkBadTyVarMsg :: Var -> SDoc -mkBadTyVarMsg tv - = text "Non-tyvar used in TyVarTy:" - <+> ppr tv <+> dcolon <+> ppr (varType tv) - -mkBadJoinBindMsg :: Var -> SDoc -mkBadJoinBindMsg var - = vcat [ text "Bad join point binding:" <+> ppr var - , text "Join points can be bound only by a non-top-level let" ] - -mkInvalidJoinPointMsg :: Var -> Type -> SDoc -mkInvalidJoinPointMsg var ty - = hang (text "Join point has invalid type:") - 2 (ppr var <+> dcolon <+> ppr ty) - -mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc -mkBadJoinArityMsg var ar nlams rhs - = vcat [ text "Join point has too few lambdas", - text "Join var:" <+> ppr var, - text "Join arity:" <+> ppr ar, - text "Number of lambdas:" <+> ppr nlams, - text "Rhs = " <+> ppr rhs - ] - -invalidJoinOcc :: Var -> SDoc -invalidJoinOcc var - = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var - , text "The binder is either not a join point, or not valid here" ] - -mkBadJumpMsg :: Var -> Int -> Int -> SDoc -mkBadJumpMsg var ar nargs - = vcat [ text "Join point invoked with wrong number of arguments", - text "Join var:" <+> ppr var, - text "Join arity:" <+> ppr ar, - text "Number of arguments:" <+> int nargs ] - -mkInconsistentRecMsg :: [Var] -> SDoc -mkInconsistentRecMsg bndrs - = vcat [ text "Recursive let binders mix values and join points", - text "Binders:" <+> hsep (map ppr_with_details bndrs) ] - where - ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr) - -mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc -mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ - = vcat [ text "Mismatch in join point arity between binder and occurrence" - , text "Var:" <+> ppr bndr - , text "Arity at binding site:" <+> ppr join_arity_bndr - , text "Arity at occurrence: " <+> ppr join_arity_occ ] - -mkBndrOccTypeMismatchMsg :: Var -> Var -> OutType -> OutType -> SDoc -mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty - = vcat [ text "Mismatch in type between binder and occurrence" - , text "Binder:" <+> ppr bndr <+> dcolon <+> ppr bndr_ty - , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr var_ty - , text " Before subst:" <+> ppr (idType var) ] - -mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc -mkBadJoinPointRuleMsg bndr join_arity rule - = vcat [ text "Join point has rule with wrong number of arguments" - , text "Var:" <+> ppr bndr - , text "Join arity:" <+> ppr join_arity - , text "Rule:" <+> ppr rule ] - -pprLeftOrRight :: LeftOrRight -> MsgDoc -pprLeftOrRight CLeft = text "left" -pprLeftOrRight CRight = text "right" - -dupVars :: [NonEmpty Var] -> MsgDoc -dupVars vars - = hang (text "Duplicate variables brought into scope") - 2 (ppr (map toList vars)) - -dupExtVars :: [NonEmpty Name] -> MsgDoc -dupExtVars vars - = hang (text "Duplicate top-level variables with the same qualified name") - 2 (ppr (map toList vars)) - -{- -************************************************************************ -* * -\subsection{Annotation Linting} -* * -************************************************************************ --} - --- | This checks whether a pass correctly looks through debug --- annotations (@SourceNote@). This works a bit different from other --- consistency checks: We check this by running the given task twice, --- noting all differences between the results. -lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -lintAnnots pname pass guts = do - -- Run the pass as we normally would - dflags <- getDynFlags - when (gopt Opt_DoAnnotationLinting dflags) $ - liftIO $ Err.showPass dflags "Annotation linting - first run" - nguts <- pass guts - -- If appropriate re-run it without debug annotations to make sure - -- that they made no difference. - when (gopt Opt_DoAnnotationLinting dflags) $ do - liftIO $ Err.showPass dflags "Annotation linting - second run" - nguts' <- withoutAnnots pass guts - -- Finally compare the resulting bindings - liftIO $ Err.showPass dflags "Annotation linting - comparison" - let binds = flattenBinds $ mg_binds nguts - binds' = flattenBinds $ mg_binds nguts' - (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' - when (not (null diffs)) $ GHC.Core.Op.Monad.putMsg $ vcat +{-# LANGUAGE ScopedTypeVariables, DeriveFunctor #-} + +module GHC.Core.Lint ( + lintCoreBindings, lintUnfolding, + lintPassResult, lintInteractiveExpr, lintExpr, + lintAnnots, lintTypes, + + -- ** Debug output + endPass, endPassIO, + dumpPassResult, + GHC.Core.Lint.dumpIfSet, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Stats ( coreBindsStats ) +import GHC.Core.Opt.Monad +import GHC.Data.Bag +import GHC.Types.Literal +import GHC.Core.DataCon +import GHC.Builtin.Types.Prim +import GHC.Tc.Utils.TcType ( isFloatingTy ) +import GHC.Types.Var as Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique.Set( nonDetEltsUniqSet ) +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.Ppr +import GHC.Utils.Error +import GHC.Core.Coercion +import GHC.Types.SrcLoc +import GHC.Core.Type as Type +import GHC.Types.RepType +import GHC.Core.TyCo.Rep -- checks validity of types/coercions +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr ( pprTyVar ) +import GHC.Core.TyCon as TyCon +import GHC.Core.Coercion.Axiom +import GHC.Types.Basic +import GHC.Utils.Error as Err +import GHC.Data.List.SetOps +import GHC.Builtin.Names +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Core.InstEnv ( instanceDFunId ) +import GHC.Core.Coercion.Opt ( checkAxInstCo ) +import GHC.Core.Arity ( typeArity ) +import GHC.Types.Demand ( splitStrictSig, isBotDiv ) + +import GHC.Driver.Types +import GHC.Driver.Session +import Control.Monad +import GHC.Utils.Monad +import Data.Foldable ( toList ) +import Data.List.NonEmpty ( NonEmpty ) +import Data.List ( partition ) +import Data.Maybe +import GHC.Data.Pair +import qualified GHC.LanguageExtensions as LangExt + +{- +Note [Core Lint guarantee] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Core Lint is the type-checker for Core. Using it, we get the following guarantee: + +If all of: +1. Core Lint passes, +2. there are no unsafe coercions (i.e. unsafeEqualityProof), +3. all plugin-supplied coercions (i.e. PluginProv) are valid, and +4. all case-matches are complete +then running the compiled program will not seg-fault, assuming no bugs downstream +(e.g. in the code generator). This guarantee is quite powerful, in that it allows us +to decouple the safety of the resulting program from the type inference algorithm. + +However, do note point (4) above. Core Lint does not check for incomplete case-matches; +see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there, +an incomplete case-match might slip by Core Lint and cause trouble at runtime. + +Note [GHC Formalism] +~~~~~~~~~~~~~~~~~~~~ +This file implements the type-checking algorithm for System FC, the "official" +name of the Core language. Type safety of FC is heart of the claim that +executables produced by GHC do not have segmentation faults. Thus, it is +useful to be able to reason about System FC independently of reading the code. +To this purpose, there is a document core-spec.pdf built in docs/core-spec that +contains a formalism of the types and functions dealt with here. If you change +just about anything in this file or you change other types/functions throughout +the Core language (all signposted to this note), you should update that +formalism. See docs/core-spec/README for more info about how to do so. + +Note [check vs lint] +~~~~~~~~~~~~~~~~~~~~ +This file implements both a type checking algorithm and also general sanity +checking. For example, the "sanity checking" checks for TyConApp on the left +of an AppTy, which should never happen. These sanity checks don't really +affect any notion of type soundness. Yet, it is convenient to do the sanity +checks at the same time as the type checks. So, we use the following naming +convention: + +- Functions that begin with 'lint'... are involved in type checking. These + functions might also do some sanity checking. + +- Functions that begin with 'check'... are *not* involved in type checking. + They exist only for sanity checking. + +Issues surrounding variable naming, shadowing, and such are considered *not* +to be part of type checking, as the formalism omits these details. + +Summary of checks +~~~~~~~~~~~~~~~~~ +Checks that a set of core bindings is well-formed. The PprStyle and String +just control what we print in the event of an error. The Bool value +indicates whether we have done any specialisation yet (in which case we do +some extra checks). + +We check for + (a) type errors + (b) Out-of-scope type variables + (c) Out-of-scope local variables + (d) Ill-kinded types + (e) Incorrect unsafe coercions + +If we have done specialisation the we check that there are + (a) No top-level bindings of primitive (unboxed type) + +Outstanding issues: + + -- Things are *not* OK if: + -- + -- * Unsaturated type app before specialisation has been done; + -- + -- * Oversaturated type app after specialisation (eta reduction + -- may well be happening...); + + +Note [Linting function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [Representation of function types], all saturated +applications of funTyCon are represented with the FunTy constructor. We check +this invariant in lintType. + +Note [Linting type lets] +~~~~~~~~~~~~~~~~~~~~~~~~ +In the desugarer, it's very very convenient to be able to say (in effect) + let a = Type Bool in + let x::a = True in +That is, use a type let. See Note [Type let] in CoreSyn. +One place it is used is in mkWwArgs; see Note [Join points and beta-redexes] +in GHC.Core.Opt.WorkWrap.Utils. (Maybe there are other "clients" of this feature; I'm not sure). + +* Hence when linting we need to remember that a=Int, else we + might reject a correct program. So we carry a type substitution (in + this example [a -> Bool]) and apply this substitution before + comparing types. In effect, in Lint, type equality is always + equality-moduolo-le-subst. This is in the le_subst field of + LintEnv. But nota bene: + + (SI1) The le_subst substitution is applied to types and coercions only + + (SI2) The result of that substitution is used only to check for type + equality, to check well-typed-ness, /but is then discarded/. + The result of substittion does not outlive the CoreLint pass. + + (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders. + +* The function + lintInTy :: Type -> LintM (Type, Kind) + returns a substituted type. + +* When we encounter a binder (like x::a) we must apply the substitution + to the type of the binding variable. lintBinders does this. + +* Clearly we need to clone tyvar binders as we go. + +* But take care (#17590)! We must also clone CoVar binders: + let a = TYPE (ty |> cv) + in \cv -> blah + blindly substituting for `a` might capture `cv`. + +* Alas, when cloning a coercion variable we might choose a unique + that happens to clash with an inner Id, thus + \cv_66 -> let wild_X7 = blah in blah + We decide to clone `cv_66` becuase it's already in scope. Fine, + choose a new unique. Aha, X7 looks good. So we check the lambda + body with le_subst of [cv_66 :-> cv_X7] + + This is all fine, even though we use the same unique as wild_X7. + As (SI2) says, we do /not/ return a new lambda + (\cv_X7 -> let wild_X7 = blah in ...) + We simply use the le_subst subsitution in types/coercions only, when + checking for equality. + +* We still need to check that Id occurrences are bound by some + enclosing binding. We do /not/ use the InScopeSet for the le_subst + for this purpose -- it contains only TyCoVars. Instead we have a separate + le_ids for the in-scope Id binders. + +Sigh. We might want to explore getting rid of type-let! + +Note [Bad unsafe coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions +Linter introduces additional rules that checks improper coercion between +different types, called bad coercions. Following coercions are forbidden: + + (a) coercions between boxed and unboxed values; + (b) coercions between unlifted values of the different sizes, here + active size is checked, i.e. size of the actual value but not + the space allocated for value; + (c) coercions between floating and integral boxed values, this check + is not yet supported for unboxed tuples, as no semantics were + specified for that; + (d) coercions from / to vector type + (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be + coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules + (a-e) holds. + +Note [Join points] +~~~~~~~~~~~~~~~~~~ +We check the rules listed in Note [Invariants on join points] in GHC.Core. The +only one that causes any difficulty is the first: All occurrences must be tail +calls. To this end, along with the in-scope set, we remember in le_joins the +subset of in-scope Ids that are valid join ids. For example: + + join j x = ... in + case e of + A -> jump j y -- good + B -> case (jump j z) of -- BAD + C -> join h = jump j w in ... -- good + D -> let x = jump j v in ... -- BAD + +A join point remains valid in case branches, so when checking the A +branch, j is still valid. When we check the scrutinee of the inner +case, however, we set le_joins to empty, and catch the +error. Similarly, join points can occur free in RHSes of other join +points but not the RHSes of value bindings (thunks and functions). + +************************************************************************ +* * + Beginning and ending passes +* * +************************************************************************ + +These functions are not CoreM monad stuff, but they probably ought to +be, and it makes a convenient place for them. They print out stuff +before and after core passes, and do Core Lint when necessary. +-} + +endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () +endPass pass binds rules + = do { hsc_env <- getHscEnv + ; print_unqual <- getPrintUnqualified + ; liftIO $ endPassIO hsc_env print_unqual pass binds rules } + +endPassIO :: HscEnv -> PrintUnqualified + -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () +-- Used by the IO-is CorePrep too +endPassIO hsc_env print_unqual pass binds rules + = do { dumpPassResult dflags print_unqual mb_flag + (ppr pass) (pprPassDetails pass) binds rules + ; lintPassResult hsc_env pass binds } + where + dflags = hsc_dflags hsc_env + mb_flag = case coreDumpFlag pass of + Just flag | dopt flag dflags -> Just flag + | dopt Opt_D_verbose_core2core dflags -> Just flag + _ -> Nothing + +dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO () +dumpIfSet dflags dump_me pass extra_info doc + = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc + +dumpPassResult :: DynFlags + -> PrintUnqualified + -> Maybe DumpFlag -- Just df => show details in a file whose + -- name is specified by df + -> SDoc -- Header + -> SDoc -- Extra info to appear after header + -> CoreProgram -> [CoreRule] + -> IO () +dumpPassResult dflags unqual mb_flag hdr extra_info binds rules + = do { forM_ mb_flag $ \flag -> do + let sty = mkDumpStyle dflags unqual + dumpAction dflags sty (dumpOptionsFromFlag flag) + (showSDoc dflags hdr) FormatCore dump_doc + + -- Report result size + -- This has the side effect of forcing the intermediate to be evaluated + -- if it's not already forced by a -ddump flag. + ; Err.debugTraceMsg dflags 2 size_doc + } + + where + size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] + + dump_doc = vcat [ nest 2 extra_info + , size_doc + , blankLine + , pprCoreBindingsWithSize binds + , ppUnless (null rules) pp_rules ] + pp_rules = vcat [ blankLine + , text "------ Local rules for imported ids --------" + , pprRules rules ] + +coreDumpFlag :: CoreToDo -> Maybe DumpFlag +coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core +coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core +coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core +coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity +coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify +coreDumpFlag CoreDoDemand = Just Opt_D_dump_stranal +coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal +coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper +coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec +coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec +coreDumpFlag CoreCSE = Just Opt_D_dump_cse +coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt +coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds +coreDumpFlag CoreTidy = Just Opt_D_dump_simpl +coreDumpFlag CorePrep = Just Opt_D_dump_prep +coreDumpFlag CoreOccurAnal = Just Opt_D_dump_occur_anal + +coreDumpFlag CoreDoPrintCore = Nothing +coreDumpFlag (CoreDoRuleCheck {}) = Nothing +coreDumpFlag CoreDoNothing = Nothing +coreDumpFlag (CoreDoPasses {}) = Nothing + +{- +************************************************************************ +* * + Top-level interfaces +* * +************************************************************************ +-} + +lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO () +lintPassResult hsc_env pass binds + | not (gopt Opt_DoCoreLinting dflags) + = return () + | otherwise + = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds + ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass) + ; displayLintResults dflags pass warns errs binds } + where + dflags = hsc_dflags hsc_env + +displayLintResults :: DynFlags -> CoreToDo + -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram + -> IO () +displayLintResults dflags pass warns errs binds + | not (isEmptyBag errs) + = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan + (defaultDumpStyle dflags) + (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs + , text "*** Offending Program ***" + , pprCoreBindings binds + , text "*** End of Offense ***" ]) + ; Err.ghcExit dflags 1 } + + | not (isEmptyBag warns) + , not (hasNoDebugOutput dflags) + , showLintWarnings pass + -- If the Core linter encounters an error, output to stderr instead of + -- stdout (#13342) + = putLogMsg dflags NoReason Err.SevInfo noSrcSpan + (defaultDumpStyle dflags) + (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) + + | otherwise = return () + where + +lint_banner :: String -> SDoc -> SDoc +lint_banner string pass = text "*** Core Lint" <+> text string + <+> text ": in result of" <+> pass + <+> text "***" + +showLintWarnings :: CoreToDo -> Bool +-- Disable Lint warnings on the first simplifier pass, because +-- there may be some INLINE knots still tied, which is tiresomely noisy +showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False +showLintWarnings _ = True + +lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO () +lintInteractiveExpr what hsc_env expr + | not (gopt Opt_DoCoreLinting dflags) + = return () + | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr + = do { display_lint_err err + ; Err.ghcExit dflags 1 } + | otherwise + = return () + where + dflags = hsc_dflags hsc_env + + display_lint_err err + = do { putLogMsg dflags NoReason Err.SevDump + noSrcSpan (defaultDumpStyle dflags) + (vcat [ lint_banner "errors" (text what) + , err + , text "*** Offending Program ***" + , pprCoreExpr expr + , text "*** End of Offense ***" ]) + ; Err.ghcExit dflags 1 } + +interactiveInScope :: HscEnv -> [Var] +-- In GHCi we may lint expressions, or bindings arising from 'deriving' +-- clauses, that mention variables bound in the interactive context. +-- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types). +-- So we have to tell Lint about them, lest it reports them as out of scope. +-- +-- We do this by find local-named things that may appear free in interactive +-- context. This function is pretty revolting and quite possibly not quite right. +-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty +-- so this is a (cheap) no-op. +-- +-- See #8215 for an example +interactiveInScope hsc_env + = tyvars ++ ids + where + -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr + ictxt = hsc_IC hsc_env + (cls_insts, _fam_insts) = ic_instances ictxt + te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) + te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts) + ids = typeEnvIds te + tyvars = tyCoVarsOfTypesList $ map idType ids + -- Why the type variables? How can the top level envt have free tyvars? + -- I think it's because of the GHCi debugger, which can bind variables + -- f :: [t] -> [t] + -- where t is a RuntimeUnk (see TcType) + +-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. +lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc) +-- Returns (warnings, errors) +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreBindings dflags pass local_in_scope binds + = initL dflags flags local_in_scope $ + addLoc TopLevelBindings $ + do { checkL (null dups) (dupVars dups) + ; checkL (null ext_dups) (dupExtVars ext_dups) + ; lintRecBindings TopLevel all_pairs $ + return () } + where + all_pairs = flattenBinds binds + -- Put all the top-level binders in scope at the start + -- This is because transformation rules can bring something + -- into use 'unexpectedly'; see Note [Glomming] in OccurAnal + binders = map fst all_pairs + + flags = defaultLintFlags + { lf_check_global_ids = check_globals + , lf_check_inline_loop_breakers = check_lbs + , lf_check_static_ptrs = check_static_ptrs } + + -- See Note [Checking for global Ids] + check_globals = case pass of + CoreTidy -> False + CorePrep -> False + _ -> True + + -- See Note [Checking for INLINE loop breakers] + check_lbs = case pass of + CoreDesugar -> False + CoreDesugarOpt -> False + _ -> True + + -- See Note [Checking StaticPtrs] + check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere + | otherwise = case pass of + CoreDoFloatOutwards _ -> AllowAtTopLevel + CoreTidy -> RejectEverywhere + CorePrep -> AllowAtTopLevel + _ -> AllowAnywhere + + (_, dups) = removeDups compare binders + + -- dups_ext checks for names with different uniques + -- but but the same External name M.n. We don't + -- allow this at top level: + -- M.n{r3} = ... + -- M.n{r29} = ... + -- because they both get the same linker symbol + ext_dups = snd (removeDups ord_ext (map Var.varName binders)) + ord_ext n1 n2 | Just m1 <- nameModule_maybe n1 + , Just m2 <- nameModule_maybe n2 + = compare (m1, nameOccName n1) (m2, nameOccName n2) + | otherwise = LT + +{- +************************************************************************ +* * +\subsection[lintUnfolding]{lintUnfolding} +* * +************************************************************************ + +Note [Linting Unfoldings from Interfaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We use this to check all top-level unfoldings that come in from interfaces +(it is very painful to catch errors otherwise). + +We do not need to call lintUnfolding on unfoldings that are nested within +top-level unfoldings; they are linted when we lint the top-level unfolding; +hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore. + +-} + +lintUnfolding :: Bool -- True <=> is a compulsory unfolding + -> DynFlags + -> SrcLoc + -> VarSet -- Treat these as in scope + -> CoreExpr + -> Maybe MsgDoc -- Nothing => OK + +lintUnfolding is_compulsory dflags locn var_set expr + | isEmptyBag errs = Nothing + | otherwise = Just (pprMessageBag errs) + where + vars = nonDetEltsUniqSet var_set + (_warns, errs) = initL dflags defaultLintFlags vars $ + if is_compulsory + -- See Note [Checking for levity polymorphism] + then noLPChecks linter + else linter + linter = addLoc (ImportedUnfolding locn) $ + lintCoreExpr expr + +lintExpr :: DynFlags + -> [Var] -- Treat these as in scope + -> CoreExpr + -> Maybe MsgDoc -- Nothing => OK + +lintExpr dflags vars expr + | isEmptyBag errs = Nothing + | otherwise = Just (pprMessageBag errs) + where + (_warns, errs) = initL dflags defaultLintFlags vars linter + linter = addLoc TopLevelBindings $ + lintCoreExpr expr + +{- +************************************************************************ +* * +\subsection[lintCoreBinding]{lintCoreBinding} +* * +************************************************************************ + +Check a core binding, returning the list of variables bound. +-} + +lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)] + -> LintM a -> LintM a +lintRecBindings top_lvl pairs thing_inside + = lintIdBndrs top_lvl bndrs $ \ bndrs' -> + do { zipWithM_ lint_pair bndrs' rhss + ; thing_inside } + where + (bndrs, rhss) = unzip pairs + lint_pair bndr' rhs + = addLoc (RhsOf bndr') $ + do { rhs_ty <- lintRhs bndr' rhs -- Check the rhs + ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty } + +lintLetBind :: TopLevelFlag -> RecFlag -> LintedId + -> CoreExpr -> LintedType -> LintM () +-- Binder's type, and the RHS, have already been linted +-- This function checks other invariants +lintLetBind top_lvl rec_flag binder rhs rhs_ty + = do { let binder_ty = idType binder + ; ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty) + + -- If the binding is for a CoVar, the RHS should be (Coercion co) + -- See Note [Core type and coercion invariant] in GHC.Core + ; checkL (not (isCoVar binder) || isCoArg rhs) + (mkLetErr binder rhs) + + -- Check the let/app invariant + -- See Note [Core let/app invariant] in GHC.Core + ; checkL ( isJoinId binder + || not (isUnliftedType binder_ty) + || (isNonRec rec_flag && exprOkForSpeculation rhs) + || exprIsTickedString rhs) + (badBndrTyMsg binder (text "unlifted")) + + -- Check that if the binder is top-level or recursive, it's not + -- demanded. Primitive string literals are exempt as there is no + -- computation to perform, see Note [Core top-level string literals]. + ; checkL (not (isStrictId binder) + || (isNonRec rec_flag && not (isTopLevel top_lvl)) + || exprIsTickedString rhs) + (mkStrictMsg binder) + + -- Check that if the binder is at the top level and has type Addr#, + -- that it is a string literal, see + -- Note [Core top-level string literals]. + ; checkL (not (isTopLevel top_lvl && binder_ty `eqType` addrPrimTy) + || exprIsTickedString rhs) + (mkTopNonLitStrMsg binder) + + ; flags <- getLintFlags + + -- Check that a join-point binder has a valid type + -- NB: lintIdBinder has checked that it is not top-level bound + ; case isJoinId_maybe binder of + Nothing -> return () + Just arity -> checkL (isValidJoinPointType arity binder_ty) + (mkInvalidJoinPointMsg binder binder_ty) + + ; when (lf_check_inline_loop_breakers flags + && isStableUnfolding (realIdUnfolding binder) + && isStrongLoopBreaker (idOccInfo binder) + && isInlinePragma (idInlinePragma binder)) + (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder)) + -- Only non-rule loop breakers inhibit inlining + + -- We used to check that the dmdTypeDepth of a demand signature never + -- exceeds idArity, but that is an unnecessary complication, see + -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Opt.DmdAnal + + -- Check that the binder's arity is within the bounds imposed by + -- the type and the strictness signature. See Note [exprArity invariant] + -- and Note [Trimming arity] + ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder) + (text "idArity" <+> ppr (idArity binder) <+> + text "exceeds typeArity" <+> + ppr (length (typeArity (idType binder))) <> colon <+> + ppr binder) + + ; case splitStrictSig (idStrictness binder) of + (demands, result_info) | isBotDiv result_info -> + checkL (demands `lengthAtLeast` idArity binder) + (text "idArity" <+> ppr (idArity binder) <+> + text "exceeds arity imposed by the strictness signature" <+> + ppr (idStrictness binder) <> colon <+> + ppr binder) + _ -> return () + + ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) + + ; addLoc (UnfoldingOf binder) $ + lintIdUnfolding binder binder_ty (idUnfolding binder) } + + -- We should check the unfolding, if any, but this is tricky because + -- the unfolding is a SimplifiableCoreExpr. Give up for now. + +-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' +-- in that it doesn't reject occurrences of the function 'makeStatic' when they +-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and +-- for join points, it skips the outer lambdas that take arguments to the +-- join point. +-- +-- See Note [Checking StaticPtrs]. +lintRhs :: Id -> CoreExpr -> LintM LintedType +-- NB: the Id can be Linted or not -- it's only used for +-- its OccInfo and join-pointer-hood +lintRhs bndr rhs + | Just arity <- isJoinId_maybe bndr + = lint_join_lams arity arity True rhs + | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr) + = lint_join_lams arity arity False rhs + where + lint_join_lams 0 _ _ rhs + = lintCoreExpr rhs + + lint_join_lams n tot enforce (Lam var expr) + = lintLambda var $ lint_join_lams (n-1) tot enforce expr + + lint_join_lams n tot True _other + = failWithL $ mkBadJoinArityMsg bndr tot (tot-n) rhs + lint_join_lams _ _ False rhs + = markAllJoinsBad $ lintCoreExpr rhs + -- Future join point, not yet eta-expanded + -- Body is not a tail position + +-- Allow applications of the data constructor @StaticPtr@ at the top +-- but produce errors otherwise. +lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go + where + -- Allow occurrences of 'makeStatic' at the top-level but produce errors + -- otherwise. + go AllowAtTopLevel + | (binders0, rhs') <- collectTyBinders rhs + , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' + = markAllJoinsBad $ + foldr + -- imitate @lintCoreExpr (Lam ...)@ + lintLambda + -- imitate @lintCoreExpr (App ...)@ + (do fun_ty <- lintCoreExpr fun + lintCoreArgs fun_ty [Type t, info, e] + ) + binders0 + go _ = markAllJoinsBad $ lintCoreExpr rhs + +lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () +lintIdUnfolding bndr bndr_ty uf + | isStableUnfolding uf + , Just rhs <- maybeUnfoldingTemplate uf + = do { ty <- if isCompulsoryUnfolding uf + then noLPChecks $ lintRhs bndr rhs + -- See Note [Checking for levity polymorphism] + else lintRhs bndr rhs + ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } +lintIdUnfolding _ _ _ + = return () -- Do not Lint unstable unfoldings, because that leads + -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars + +{- +Note [Checking for INLINE loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very suspicious if a strong loop breaker is marked INLINE. + +However, the desugarer generates instance methods with INLINE pragmas +that form a mutually recursive group. Only after a round of +simplification are they unravelled. So we suppress the test for +the desugarer. + +Note [Checking for levity polymorphism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We ordinarily want to check for bad levity polymorphism. See +Note [Levity polymorphism invariants] in GHC.Core. However, we do *not* +want to do this in a compulsory unfolding. Compulsory unfoldings arise +only internally, for things like newtype wrappers, dictionaries, and +(notably) unsafeCoerce#. These might legitimately be levity-polymorphic; +indeed levity-polyorphic unfoldings are a primary reason for the +very existence of compulsory unfoldings (we can't compile code for +the original, levity-poly, binding). + +It is vitally important that we do levity-polymorphism checks *after* +performing the unfolding, but not beforehand. This is all safe because +we will check any unfolding after it has been unfolded; checking the +unfolding beforehand is merely an optimization, and one that actively +hurts us here. + +************************************************************************ +* * +\subsection[lintCoreExpr]{lintCoreExpr} +* * +************************************************************************ +-} + +-- Linted things: substitution applied, and type is linted +type LintedType = Type +type LintedKind = Kind +type LintedCoercion = Coercion +type LintedTyCoVar = TyCoVar +type LintedId = Id + +lintCoreExpr :: CoreExpr -> LintM LintedType +-- The returned type has the substitution from the monad +-- already applied to it: +-- lintCoreExpr e subst = exprType (subst e) +-- +-- The returned "type" can be a kind, if the expression is (Type ty) + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] + +lintCoreExpr (Var var) + = lintIdOcc var 0 + +lintCoreExpr (Lit lit) + = return (literalType lit) + +lintCoreExpr (Cast expr co) + = do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr + ; co' <- lintCoercion co + ; let (Pair from_ty to_ty, role) = coercionKindRole co' + ; checkValueType to_ty $ + text "target of cast" <+> quotes (ppr co') + ; lintRole co' Representational role + ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) + ; return to_ty } + +lintCoreExpr (Tick tickish expr) + = do case tickish of + Breakpoint _ ids -> forM_ ids $ \id -> do + checkDeadIdOcc id + lookupIdInScope id + _ -> return () + markAllJoinsBadIf block_joins $ lintCoreExpr expr + where + block_joins = not (tickish `tickishScopesLike` SoftScope) + -- TODO Consider whether this is the correct rule. It is consistent with + -- the simplifier's behaviour - cost-centre-scoped ticks become part of + -- the continuation, and thus they behave like part of an evaluation + -- context, but soft-scoped and non-scoped ticks simply wrap the result + -- (see Simplify.simplTick). + +lintCoreExpr (Let (NonRec tv (Type ty)) body) + | isTyVar tv + = -- See Note [Linting type lets] + do { ty' <- lintType ty + ; lintTyBndr tv $ \ tv' -> + do { addLoc (RhsOf tv) $ lintTyKind tv' ty' + -- Now extend the substitution so we + -- take advantage of it in the body + ; extendTvSubstL tv ty' $ + addLoc (BodyOfLetRec [tv]) $ + lintCoreExpr body } } + +lintCoreExpr (Let (NonRec bndr rhs) body) + | isId bndr + = do { -- First Lint the RHS, before bringing the binder into scope + rhs_ty <- lintRhs bndr rhs + + -- Now lint the binder + ; lintBinder LetBind bndr $ \bndr' -> + do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty + ; addLoc (BodyOfLetRec [bndr]) (lintCoreExpr body) } } + + | otherwise + = failWithL (mkLetErr bndr rhs) -- Not quite accurate + +lintCoreExpr e@(Let (Rec pairs) body) + = do { -- Check that the list of pairs is non-empty + checkL (not (null pairs)) (emptyRec e) + + -- Check that there are no duplicated binders + ; let (_, dups) = removeDups compare bndrs + ; checkL (null dups) (dupVars dups) + + -- Check that either all the binders are joins, or none + ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $ + mkInconsistentRecMsg bndrs + + ; lintRecBindings NotTopLevel pairs $ + addLoc (BodyOfLetRec bndrs) $ + lintCoreExpr body } + where + bndrs = map fst pairs + +lintCoreExpr e@(App _ _) + = do { fun_ty <- lintCoreFun fun (length args) + ; lintCoreArgs fun_ty args } + where + (fun, args) = collectArgs e + +lintCoreExpr (Lam var expr) + = markAllJoinsBad $ + lintLambda var $ lintCoreExpr expr + +lintCoreExpr (Case scrut var alt_ty alts) + = lintCaseExpr scrut var alt_ty alts + +-- This case can't happen; linting types in expressions gets routed through +-- lintCoreArgs +lintCoreExpr (Type ty) + = failWithL (text "Type found as expression" <+> ppr ty) + +lintCoreExpr (Coercion co) + = do { co' <- addLoc (InCo co) $ + lintCoercion co + ; return (coercionType co') } + +---------------------- +lintIdOcc :: Var -> Int -- Number of arguments (type or value) being passed + -> LintM LintedType -- returns type of the *variable* +lintIdOcc var nargs + = addLoc (OccOf var) $ + do { checkL (isNonCoVarId var) + (text "Non term variable" <+> ppr var) + -- See GHC.Core Note [Variable occurrences in Core] + + -- Check that the type of the occurrence is the same + -- as the type of the binding site. The inScopeIds are + -- /un-substituted/, so this checks that the occurrence type + -- is identical to the binder type. + -- This makes things much easier for things like: + -- /\a. \(x::Maybe a). /\a. ...(x::Maybe a)... + -- The "::Maybe a" on the occurrence is referring to the /outer/ a. + -- If we compared /substituted/ types we'd risk comparing + -- (Maybe a) from the binding site with bogus (Maybe a1) from + -- the occurrence site. Comparing un-substituted types finesses + -- this altogether + ; (bndr, linted_bndr_ty) <- lookupIdInScope var + ; let occ_ty = idType var + bndr_ty = idType bndr + ; ensureEqTys occ_ty bndr_ty $ + mkBndrOccTypeMismatchMsg bndr var bndr_ty occ_ty + + -- Check for a nested occurrence of the StaticPtr constructor. + -- See Note [Checking StaticPtrs]. + ; lf <- getLintFlags + ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $ + checkL (idName var /= makeStaticName) $ + text "Found makeStatic nested in an expression" + + ; checkDeadIdOcc var + ; checkJoinOcc var nargs + + ; return linted_bndr_ty } + +lintCoreFun :: CoreExpr + -> Int -- Number of arguments (type or val) being passed + -> LintM LintedType -- Returns type of the *function* +lintCoreFun (Var var) nargs + = lintIdOcc var nargs + +lintCoreFun (Lam var body) nargs + -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; see + -- Note [Beta redexes] + | nargs /= 0 + = lintLambda var $ lintCoreFun body (nargs - 1) + +lintCoreFun expr nargs + = markAllJoinsBadIf (nargs /= 0) $ + -- See Note [Join points are less general than the paper] + lintCoreExpr expr +------------------ +lintLambda :: Var -> LintM Type -> LintM Type +lintLambda var lintBody = + addLoc (LambdaBodyOf var) $ + lintBinder LambdaBind var $ \ var' -> + do { body_ty <- lintBody + ; return (mkLamType var' body_ty) } +------------------ +checkDeadIdOcc :: Id -> LintM () +-- Occurrences of an Id should never be dead.... +-- except when we are checking a case pattern +checkDeadIdOcc id + | isDeadOcc (idOccInfo id) + = do { in_case <- inCasePat + ; checkL in_case + (text "Occurrence of a dead Id" <+> ppr id) } + | otherwise + = return () + +------------------ +checkJoinOcc :: Id -> JoinArity -> LintM () +-- Check that if the occurrence is a JoinId, then so is the +-- binding site, and it's a valid join Id +checkJoinOcc var n_args + | Just join_arity_occ <- isJoinId_maybe var + = do { mb_join_arity_bndr <- lookupJoinId var + ; case mb_join_arity_bndr of { + Nothing -> -- Binder is not a join point + do { join_set <- getValidJoins + ; addErrL (text "join set " <+> ppr join_set $$ + invalidJoinOcc var) } ; + + Just join_arity_bndr -> + + do { checkL (join_arity_bndr == join_arity_occ) $ + -- Arity differs at binding site and occurrence + mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ + + ; checkL (n_args == join_arity_occ) $ + -- Arity doesn't match #args + mkBadJumpMsg var join_arity_occ n_args } } } + + | otherwise + = return () + +{- +Note [No alternatives lint check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case expressions with no alternatives are odd beasts, and it would seem +like they would worth be looking at in the linter (cf #10180). We +used to check two things: + +* exprIsHNF is false: it would *seem* to be terribly wrong if + the scrutinee was already in head normal form. + +* exprIsBottom is true: we should be able to see why GHC believes the + scrutinee is diverging for sure. + +It was already known that the second test was not entirely reliable. +Unfortunately (#13990), the first test turned out not to be reliable +either. Getting the checks right turns out to be somewhat complicated. + +For example, suppose we have (comment 8) + + data T a where + TInt :: T Int + + absurdTBool :: T Bool -> a + absurdTBool v = case v of + + data Foo = Foo !(T Bool) + + absurdFoo :: Foo -> a + absurdFoo (Foo x) = absurdTBool x + +GHC initially accepts the empty case because of the GADT conditions. But then +we inline absurdTBool, getting + + absurdFoo (Foo x) = case x of + +x is in normal form (because the Foo constructor is strict) but the +case is empty. To avoid this problem, GHC would have to recognize +that matching on Foo x is already absurd, which is not so easy. + +More generally, we don't really know all the ways that GHC can +lose track of why an expression is bottom, so we shouldn't make too +much fuss when that happens. + + +Note [Beta redexes] +~~~~~~~~~~~~~~~~~~~ +Consider: + + join j @x y z = ... in + (\@x y z -> jump j @x y z) @t e1 e2 + +This is clearly ill-typed, since the jump is inside both an application and a +lambda, either of which is enough to disqualify it as a tail call (see Note +[Invariants on join points] in GHC.Core). However, strictly from a +lambda-calculus perspective, the term doesn't go wrong---after the two beta +reductions, the jump *is* a tail call and everything is fine. + +Why would we want to allow this when we have let? One reason is that a compound +beta redex (that is, one with more than one argument) has different scoping +rules: naively reducing the above example using lets will capture any free +occurrence of y in e2. More fundamentally, type lets are tricky; many passes, +such as Float Out, tacitly assume that the incoming program's type lets have +all been dealt with by the simplifier. Thus we don't want to let-bind any types +in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately +before Float Out. + +All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this +loophole, doing so to avoid re-traversing large functions (beta-reducing a type +lambda without introducing a type let requires a substitution). TODO: Improve +simpleOptPgm so that we can forget all this ever happened. + +************************************************************************ +* * +\subsection[lintCoreArgs]{lintCoreArgs} +* * +************************************************************************ + +The basic version of these functions checks that the argument is a +subtype of the required type, as one would expect. +-} + + +lintCoreArgs :: LintedType -> [CoreArg] -> LintM LintedType +lintCoreArgs fun_ty args = foldM lintCoreArg fun_ty args + +lintCoreArg :: LintedType -> CoreArg -> LintM LintedType +lintCoreArg fun_ty (Type arg_ty) + = do { checkL (not (isCoercionTy arg_ty)) + (text "Unnecessary coercion-to-type injection:" + <+> ppr arg_ty) + ; arg_ty' <- lintType arg_ty + ; lintTyApp fun_ty arg_ty' } + +lintCoreArg fun_ty arg + = do { arg_ty <- markAllJoinsBad $ lintCoreExpr arg + -- See Note [Levity polymorphism invariants] in GHC.Core + ; flags <- getLintFlags + ; lintL (not (lf_check_levity_poly flags) || not (isTypeLevPoly arg_ty)) + (text "Levity-polymorphic argument:" <+> + (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty)))) + -- check for levity polymorphism first, because otherwise isUnliftedType panics + + ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg) + (mkLetAppMsg arg) + + ; lintValApp arg fun_ty arg_ty } + +----------------- +lintAltBinders :: LintedType -- Scrutinee type + -> LintedType -- Constructor type + -> [OutVar] -- Binders + -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintAltBinders scrut_ty con_ty [] + = ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) +lintAltBinders scrut_ty con_ty (bndr:bndrs) + | isTyVar bndr + = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) + ; lintAltBinders scrut_ty con_ty' bndrs } + | otherwise + = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr) + ; lintAltBinders scrut_ty con_ty' bndrs } + +----------------- +lintTyApp :: LintedType -> LintedType -> LintM LintedType +lintTyApp fun_ty arg_ty + | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty + = do { lintTyKind tv arg_ty + ; in_scope <- getInScope + -- substTy needs the set of tyvars in scope to avoid generating + -- uniques that are already in scope. + -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst + ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) } + + | otherwise + = failWithL (mkTyAppMsg fun_ty arg_ty) + +----------------- +lintValApp :: CoreExpr -> LintedType -> LintedType -> LintM LintedType +lintValApp arg fun_ty arg_ty + | Just (arg,res) <- splitFunTy_maybe fun_ty + = do { ensureEqTys arg arg_ty err1 + ; return res } + | otherwise + = failWithL err2 + where + err1 = mkAppMsg fun_ty arg_ty arg + err2 = mkNonFunAppMsg fun_ty arg_ty arg + +lintTyKind :: OutTyVar -> LintedType -> LintM () +-- Both args have had substitution applied + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintTyKind tyvar arg_ty + = unless (arg_kind `eqType` tyvar_kind) $ + addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind)) + where + tyvar_kind = tyVarKind tyvar + arg_kind = typeKind arg_ty + +{- +************************************************************************ +* * +\subsection[lintCoreAlts]{lintCoreAlts} +* * +************************************************************************ +-} + +lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM LintedType +lintCaseExpr scrut var alt_ty alts = + do { let e = Case scrut var alt_ty alts -- Just for error messages + + -- Check the scrutinee + ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut + -- See Note [Join points are less general than the paper] + -- in GHC.Core + + ; alt_ty <- addLoc (CaseTy scrut) $ + lintValueType alt_ty + ; var_ty <- addLoc (IdTy var) $ + lintValueType (idType var) + + -- We used to try to check whether a case expression with no + -- alternatives was legitimate, but this didn't work. + -- See Note [No alternatives lint check] for details. + + -- Check that the scrutinee is not a floating-point type + -- if there are any literal alternatives + -- See GHC.Core Note [Case expression invariants] item (5) + -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold + ; let isLitPat (LitAlt _, _ , _) = True + isLitPat _ = False + ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts) + (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++ + "expression with literal pattern in case " ++ + "analysis (see #9238).") + $$ text "scrut" <+> ppr scrut) + + ; case tyConAppTyCon_maybe (idType var) of + Just tycon + | debugIsOn + , isAlgTyCon tycon + , not (isAbstractTyCon tycon) + , null (tyConDataCons tycon) + , not (exprIsBottom scrut) + -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) + -- This can legitimately happen for type families + $ return () + _otherwise -> return () + + -- Don't use lintIdBndr on var, because unboxed tuple is legitimate + + ; subst <- getTCvSubst + ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) + -- See GHC.Core Note [Case expression invariants] item (7) + + ; lintBinder CaseBind var $ \_ -> + do { -- Check the alternatives + mapM_ (lintCoreAlt scrut_ty alt_ty) alts + ; checkCaseAlts e scrut_ty alts + ; return alt_ty } } + +checkCaseAlts :: CoreExpr -> LintedType -> [CoreAlt] -> LintM () +-- a) Check that the alts are non-empty +-- b1) Check that the DEFAULT comes first, if it exists +-- b2) Check that the others are in increasing order +-- c) Check that there's a default for infinite types +-- NB: Algebraic cases are not necessarily exhaustive, because +-- the simplifier correctly eliminates case that can't +-- possibly match. + +checkCaseAlts e ty alts = + do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) + -- See GHC.Core Note [Case expression invariants] item (2) + + ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) + -- See GHC.Core Note [Case expression invariants] item (3) + + -- For types Int#, Word# with an infinite (well, large!) number of + -- possible values, there should usually be a DEFAULT case + -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to + -- have *no* case alternatives. + -- In effect, this is a kind of partial test. I suppose it's possible + -- that we might *know* that 'x' was 1 or 2, in which case + -- case x of { 1 -> e1; 2 -> e2 } + -- would be fine. + ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts) + (nonExhaustiveAltsMsg e) } + where + (con_alts, maybe_deflt) = findDefault alts + + -- Check that successive alternatives have strictly increasing tags + increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest + increasing_tag _ = True + + non_deflt (DEFAULT, _, _) = False + non_deflt _ = True + + is_infinite_ty = case tyConAppTyCon_maybe ty of + Nothing -> False + Just tycon -> isPrimTyCon tycon + +lintAltExpr :: CoreExpr -> LintedType -> LintM () +lintAltExpr expr ann_ty + = do { actual_ty <- lintCoreExpr expr + ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) } + -- See GHC.Core Note [Case expression invariants] item (6) + +lintCoreAlt :: LintedType -- Type of scrutinee + -> LintedType -- Type of the alternative + -> CoreAlt + -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreAlt _ alt_ty (DEFAULT, args, rhs) = + do { lintL (null args) (mkDefaultArgsMsg args) + ; lintAltExpr rhs alt_ty } + +lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) + | litIsLifted lit + = failWithL integerScrutinisedMsg + | otherwise + = do { lintL (null args) (mkDefaultArgsMsg args) + ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) + ; lintAltExpr rhs alt_ty } + where + lit_ty = literalType lit + +lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) + | isNewTyCon (dataConTyCon con) + = addErrL (mkNewTyDataConAltMsg scrut_ty alt) + | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty + = addLoc (CaseAlt alt) $ do + { -- First instantiate the universally quantified + -- type variables of the data constructor + -- We've already check + lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) + ; let con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys + + -- And now bring the new binders into scope + ; lintBinders CasePatBind args $ \ args' -> do + { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args') + ; lintAltExpr rhs alt_ty } } + + | otherwise -- Scrut-ty is wrong shape + = addErrL (mkBadAltMsg scrut_ty alt) + +{- +************************************************************************ +* * +\subsection[lint-types]{Types} +* * +************************************************************************ +-} + +-- When we lint binders, we (one at a time and in order): +-- 1. Lint var types or kinds (possibly substituting) +-- 2. Add the binder to the in scope set, and if its a coercion var, +-- we may extend the substitution to reflect its (possibly) new kind +lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a +lintBinders _ [] linterF = linterF [] +lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> + lintBinders site vars $ \ vars' -> + linterF (var':vars') + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a +lintBinder site var linterF + | isTyCoVar var = lintTyCoBndr var linterF + | otherwise = lintIdBndr NotTopLevel site var linterF + +lintTyBndr :: TyVar -> (LintedTyCoVar -> LintM a) -> LintM a +lintTyBndr = lintTyCoBndr -- We could specialise it, I guess + +-- lintCoBndr :: CoVar -> (LintedTyCoVar -> LintM a) -> LintM a +-- lintCoBndr = lintTyCoBndr -- We could specialise it, I guess + +lintTyCoBndr :: TyCoVar -> (LintedTyCoVar -> LintM a) -> LintM a +lintTyCoBndr tcv thing_inside + = do { subst <- getTCvSubst + ; kind' <- lintType (varType tcv) + ; let tcv' = uniqAway (getTCvInScope subst) $ + setVarType tcv kind' + subst' = extendTCvSubstWithClone subst tcv tcv' + ; when (isCoVar tcv) $ + lintL (isCoVarType kind') + (text "CoVar with non-coercion type:" <+> pprTyVar tcv) + ; updateTCvSubst subst' (thing_inside tcv') } + +lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> ([LintedId] -> LintM a) -> LintM a +lintIdBndrs top_lvl ids thing_inside + = go ids thing_inside + where + go :: [Id] -> ([Id] -> LintM a) -> LintM a + go [] thing_inside = thing_inside [] + go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id $ \id' -> + go ids $ \ids' -> + thing_inside (id' : ids') + +lintIdBndr :: TopLevelFlag -> BindingSite + -> InVar -> (OutVar -> LintM a) -> LintM a +-- Do substitution on the type of a binder and add the var with this +-- new type to the in-scope set of the second argument +-- ToDo: lint its rules +lintIdBndr top_lvl bind_site id thing_inside + = ASSERT2( isId id, ppr id ) + do { flags <- getLintFlags + ; checkL (not (lf_check_global_ids flags) || isLocalId id) + (text "Non-local Id binder" <+> ppr id) + -- See Note [Checking for global Ids] + + -- Check that if the binder is nested, it is not marked as exported + ; checkL (not (isExportedId id) || is_top_lvl) + (mkNonTopExportedMsg id) + + -- Check that if the binder is nested, it does not have an external name + ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl) + (mkNonTopExternalNameMsg id) + + -- See Note [Levity polymorphism invariants] in GHC.Core + ; lintL (isJoinId id || not (lf_check_levity_poly flags) + || not (isTypeLevPoly id_ty)) $ + text "Levity-polymorphic binder:" <+> ppr id <+> dcolon <+> + parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty)) + + -- Check that a join-id is a not-top-level let-binding + ; when (isJoinId id) $ + checkL (not is_top_lvl && is_let_bind) $ + mkBadJoinBindMsg id + + -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2); + -- if so, it should be a CoVar, and checked by lintCoVarBndr + ; lintL (not (isCoVarType id_ty)) + (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty) + + ; linted_ty <- addLoc (IdTy id) (lintValueType id_ty) + + ; addInScopeId id linted_ty $ + thing_inside (setIdType id linted_ty) } + where + id_ty = idType id + + is_top_lvl = isTopLevel top_lvl + is_let_bind = case bind_site of + LetBind -> True + _ -> False + +{- +%************************************************************************ +%* * + Types +%* * +%************************************************************************ +-} + +lintTypes :: DynFlags + -> [TyCoVar] -- Treat these as in scope + -> [Type] + -> Maybe MsgDoc -- Nothing => OK +lintTypes dflags vars tys + | isEmptyBag errs = Nothing + | otherwise = Just (pprMessageBag errs) + where + (_warns, errs) = initL dflags defaultLintFlags vars linter + linter = lintBinders LambdaBind vars $ \_ -> + mapM_ lintType tys + +lintValueType :: Type -> LintM LintedType +-- Types only, not kinds +-- Check the type, and apply the substitution to it +-- See Note [Linting type lets] +lintValueType ty + = addLoc (InType ty) $ + do { ty' <- lintType ty + ; let sk = typeKind ty' + ; lintL (classifiesTypeWithValues sk) $ + hang (text "Ill-kinded type:" <+> ppr ty) + 2 (text "has kind:" <+> ppr sk) + ; return ty' } + +checkTyCon :: TyCon -> LintM () +checkTyCon tc + = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) + +------------------- +lintType :: LintedType -> LintM LintedType + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintType (TyVarTy tv) + | not (isTyVar tv) + = failWithL (mkBadTyVarMsg tv) + + | otherwise + = do { subst <- getTCvSubst + ; case lookupTyVar subst tv of + Just linted_ty -> return linted_ty + + -- In GHCi we may lint an expression with a free + -- type variable. Then it won't be in the + -- substitution, but it should be in scope + Nothing | tv `isInScope` subst + -> return (TyVarTy tv) + | otherwise + -> failWithL $ + hang (text "The type variable" <+> pprBndr LetBind tv) + 2 (text "is out of scope") + } + +lintType ty@(AppTy t1 t2) + | TyConApp {} <- t1 + = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty + | otherwise + = do { t1' <- lintType t1 + ; t2' <- lintType t2 + ; lint_ty_app ty (typeKind t1') [t2'] + ; return (AppTy t1' t2') } + +lintType ty@(TyConApp tc tys) + | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc + = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags + ; lintTySynFamApp report_unsat ty tc tys } + + | isFunTyCon tc + , tys `lengthIs` 4 + -- We should never see a saturated application of funTyCon; such + -- applications should be represented with the FunTy constructor. + -- See Note [Linting function types] and + -- Note [Representation of function types]. + = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty)) + + | otherwise -- Data types, data families, primitive types + = do { checkTyCon tc + ; tys' <- mapM lintType tys + ; lint_ty_app ty (tyConKind tc) tys' + ; return (TyConApp tc tys') } + +-- arrows can related *unlifted* kinds, so this has to be separate from +-- a dependent forall. +lintType ty@(FunTy af t1 t2) + = do { t1' <- lintType t1 + ; t2' <- lintType t2 + ; lintArrow (text "type or kind" <+> quotes (ppr ty)) t1' t2' + ; return (FunTy af t1' t2') } + +lintType ty@(ForAllTy (Bndr tcv vis) body_ty) + | not (isTyCoVar tcv) + = failWithL (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr ty) + | otherwise + = lintTyCoBndr tcv $ \tcv' -> + do { body_ty' <- lintType body_ty + ; lintForAllBody tcv' body_ty' + + ; when (isCoVar tcv) $ + lintL (tcv `elemVarSet` tyCoVarsOfType body_ty) $ + text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty) + -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] + -- and cf GHC.Core.Coercion Note [Unused coercion variable in ForAllCo] + + ; return (ForAllTy (Bndr tcv' vis) body_ty') } + +lintType ty@(LitTy l) + = do { lintTyLit l; return ty } + +lintType (CastTy ty co) + = do { ty' <- lintType ty + ; co' <- lintStarCoercion co + ; let tyk = typeKind ty' + cok = coercionLKind co' + ; ensureEqTys tyk cok (mkCastTyErr ty co tyk cok) + ; return (CastTy ty' co') } + +lintType (CoercionTy co) + = do { co' <- lintCoercion co + ; return (CoercionTy co') } + +----------------- +lintForAllBody :: LintedTyCoVar -> LintedType -> LintM () +-- Do the checks for the body of a forall-type +lintForAllBody tcv body_ty + = do { checkValueType body_ty (text "the body of forall:" <+> ppr body_ty) + + -- For type variables, check for skolem escape + -- See Note [Phantom type variables in kinds] in GHC.Core.Type + -- The kind of (forall cv. th) is liftedTypeKind, so no + -- need to check for skolem-escape in the CoVar case + ; let body_kind = typeKind body_ty + ; when (isTyVar tcv) $ + case occCheckExpand [tcv] body_kind of + Just {} -> return () + Nothing -> failWithL $ + hang (text "Variable escape in forall:") + 2 (vcat [ text "tyvar:" <+> ppr tcv + , text "type:" <+> ppr body_ty + , text "kind:" <+> ppr body_kind ]) + } + +----------------- +lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM LintedType +-- The TyCon is a type synonym or a type family (not a data family) +-- See Note [Linting type synonym applications] +-- c.f. GHC.Tc.Validity.check_syn_tc_app +lintTySynFamApp report_unsat ty tc tys + | report_unsat -- Report unsaturated only if report_unsat is on + , tys `lengthLessThan` tyConArity tc + = failWithL (hang (text "Un-saturated type application") 2 (ppr ty)) + + -- Deal with type synonyms + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' + = do { -- Kind-check the argument types, but without reporting + -- un-saturated type families/synonyms + tys' <- setReportUnsat False (mapM lintType tys) + + ; when report_unsat $ + do { _ <- lintType expanded_ty + ; return () } + + ; lint_ty_app ty (tyConKind tc) tys' + ; return (TyConApp tc tys') } + + -- Otherwise this must be a type family + | otherwise + = do { tys' <- mapM lintType tys + ; lint_ty_app ty (tyConKind tc) tys' + ; return (TyConApp tc tys') } + +----------------- +-- Confirms that a type is really *, #, Constraint etc +checkValueType :: LintedType -> SDoc -> LintM () +checkValueType ty doc + = lintL (classifiesTypeWithValues kind) + (text "Non-*-like kind when *-like expected:" <+> ppr kind $$ + text "when checking" <+> doc) + where + kind = typeKind ty + +----------------- +lintArrow :: SDoc -> LintedType -> LintedType -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintArrow what t1 t2 -- Eg lintArrow "type or kind `blah'" k1 k2 + -- or lintArrow "coercion `blah'" k1 k2 + = do { unless (classifiesTypeWithValues k1) (addErrL (msg (text "argument") k1)) + ; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result") k2)) } + where + k1 = typeKind t1 + k2 = typeKind t2 + msg ar k + = vcat [ hang (text "Ill-kinded" <+> ar) + 2 (text "in" <+> what) + , what <+> text "kind:" <+> ppr k ] + +----------------- +lint_ty_app :: Type -> LintedKind -> [LintedType] -> LintM () +lint_ty_app ty k tys + = lint_app (text "type" <+> quotes (ppr ty)) k tys + +---------------- +lint_co_app :: Coercion -> LintedKind -> [LintedType] -> LintM () +lint_co_app ty k tys + = lint_app (text "coercion" <+> quotes (ppr ty)) k tys + +---------------- +lintTyLit :: TyLit -> LintM () +lintTyLit (NumTyLit n) + | n >= 0 = return () + | otherwise = failWithL msg + where msg = text "Negative type literal:" <+> integer n +lintTyLit (StrTyLit _) = return () + +lint_app :: SDoc -> LintedKind -> [LintedType] -> LintM () +-- (lint_app d fun_kind arg_tys) +-- We have an application (f arg_ty1 .. arg_tyn), +-- where f :: fun_kind + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lint_app doc kfn arg_tys + = do { in_scope <- getInScope + -- We need the in_scope set to satisfy the invariant in + -- Note [The substitution invariant] in GHC.Core.TyCo.Subst + ; _ <- foldlM (go_app in_scope) kfn arg_tys + ; return () } + where + fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc + , nest 2 (text "Function kind =" <+> ppr kfn) + , nest 2 (text "Arg types =" <+> ppr arg_tys) + , extra ] + + go_app in_scope kfn ta + | Just kfn' <- coreView kfn + = go_app in_scope kfn' ta + + go_app _ fun_kind@(FunTy _ kfa kfb) ta + = do { let ka = typeKind ta + ; unless (ka `eqType` kfa) $ + addErrL (fail_msg (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka))) + ; return kfb } + + go_app in_scope (ForAllTy (Bndr kv _vis) kfn) ta + = do { let kv_kind = varType kv + ka = typeKind ta + ; unless (ka `eqType` kv_kind) $ + addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ + ppr ta <+> dcolon <+> ppr ka))) + ; return $ substTy (extendTCvSubst (mkEmptyTCvSubst in_scope) kv ta) kfn } + + go_app _ kfn ta + = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ta))) + +{- ********************************************************************* +* * + Linting rules +* * +********************************************************************* -} + +lintCoreRule :: OutVar -> LintedType -> CoreRule -> LintM () +lintCoreRule _ _ (BuiltinRule {}) + = return () -- Don't bother + +lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs + , ru_args = args, ru_rhs = rhs }) + = lintBinders LambdaBind bndrs $ \ _ -> + do { lhs_ty <- lintCoreArgs fun_ty args + ; rhs_ty <- case isJoinId_maybe fun of + Just join_arity + -> do { checkL (args `lengthIs` join_arity) $ + mkBadJoinPointRuleMsg fun join_arity rule + -- See Note [Rules for join points] + ; lintCoreExpr rhs } + _ -> markAllJoinsBad $ lintCoreExpr rhs + ; ensureEqTys lhs_ty rhs_ty $ + (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty + , text "rhs type:" <+> ppr rhs_ty + , text "fun_ty:" <+> ppr fun_ty ]) + ; let bad_bndrs = filter is_bad_bndr bndrs + + ; checkL (null bad_bndrs) + (rule_doc <+> text "unbound" <+> ppr bad_bndrs) + -- See Note [Linting rules] + } + where + rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon + + lhs_fvs = exprsFreeVars args + rhs_fvs = exprFreeVars rhs + + is_bad_bndr :: Var -> Bool + -- See Note [Unbound RULE binders] in GHC.Core.Rules + is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs) + && bndr `elemVarSet` rhs_fvs + && isNothing (isReflCoVar_maybe bndr) + + +{- Note [Linting rules] +~~~~~~~~~~~~~~~~~~~~~~~ +It's very bad if simplifying a rule means that one of the template +variables (ru_bndrs) that /is/ mentioned on the RHS becomes +not-mentioned in the LHS (ru_args). How can that happen? Well, in +#10602, SpecConstr stupidly constructed a rule like + + forall x,c1,c2. + f (x |> c1 |> c2) = .... + +But simplExpr collapses those coercions into one. (Indeed in +#10602, it collapsed to the identity and was removed altogether.) + +We don't have a great story for what to do here, but at least +this check will nail it. + +NB (#11643): it's possible that a variable listed in the +binders becomes not-mentioned on both LHS and RHS. Here's a silly +example: + RULE forall x y. f (g x y) = g (x+1) (y-1) +And suppose worker/wrapper decides that 'x' is Absent. Then +we'll end up with + RULE forall x y. f ($gw y) = $gw (x+1) +This seems sufficiently obscure that there isn't enough payoff to +try to trim the forall'd binder list. + +Note [Rules for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A join point cannot be partially applied. However, the left-hand side of a rule +for a join point is effectively a *pattern*, not a piece of code, so there's an +argument to be made for allowing a situation like this: + + join $sj :: Int -> Int -> String + $sj n m = ... + j :: forall a. Eq a => a -> a -> String + {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-} + j @a $dEq x y = ... + +Applying this rule can't turn a well-typed program into an ill-typed one, so +conceivably we could allow it. But we can always eta-expand such an +"undersaturated" rule (see 'GHC.Core.Arity.etaExpandToJoinPointRule'), and in fact +the simplifier would have to in order to deal with the RHS. So we take a +conservative view and don't allow undersaturated rules for join points. See +Note [Rules and join points] in OccurAnal for further discussion. +-} + +{- +************************************************************************ +* * + Linting coercions +* * +************************************************************************ +-} + +{- Note [Asymptotic efficiency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When linting coercions (and types actually) we return a linted +(substituted) coercion. Then we often have to take the coercionKind of +that returned coercion. If we get long chains, that can be asymptotically +inefficient, notably in +* TransCo +* InstCo +* NthCo (cf #9233) +* LRCo + +But the code is simple. And this is only Lint. Let's wait to see if +the bad perf bites us in practice. + +A solution would be to return the kind and role of the coercion, +as well as the linted coercion. Or perhaps even *only* the kind and role, +which is what used to happen. But that proved tricky and error prone +(#17923), so now we return the coercion. +-} + + +-- lints a coercion, confirming that its lh kind and its rh kind are both * +-- also ensures that the role is Nominal +lintStarCoercion :: InCoercion -> LintM LintedCoercion +lintStarCoercion g + = do { g' <- lintCoercion g + ; let Pair t1 t2 = coercionKind g' + ; checkValueType t1 (text "the kind of the left type in" <+> ppr g) + ; checkValueType t2 (text "the kind of the right type in" <+> ppr g) + ; lintRole g Nominal (coercionRole g) + ; return g' } + +lintCoercion :: InCoercion -> LintM LintedCoercion +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] + +lintCoercion (CoVarCo cv) + | not (isCoVar cv) + = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv) + 2 (text "With offending type:" <+> ppr (varType cv))) + + | otherwise + = do { subst <- getTCvSubst + ; case lookupCoVar subst cv of + Just linted_co -> return linted_co ; + Nothing -> -- lintCoBndr always extends the substitition + failWithL $ + hang (text "The coercion variable" <+> pprBndr LetBind cv) + 2 (text "is out of scope") + } + + +lintCoercion (Refl ty) + = do { ty' <- lintType ty + ; return (Refl ty') } + +lintCoercion (GRefl r ty MRefl) + = do { ty' <- lintType ty + ; return (GRefl r ty' MRefl) } + +lintCoercion (GRefl r ty (MCo co)) + = do { ty' <- lintType ty + ; co' <- lintCoercion co + ; let tk = typeKind ty' + tl = coercionLKind co' + ; ensureEqTys tk tl $ + hang (text "GRefl coercion kind mis-match:" <+> ppr co) + 2 (vcat [ppr ty', ppr tk, ppr tl]) + ; lintRole co' Nominal (coercionRole co') + ; return (GRefl r ty' (MCo co')) } + +lintCoercion co@(TyConAppCo r tc cos) + | tc `hasKey` funTyConKey + , [_rep1,_rep2,_co1,_co2] <- cos + = failWithL (text "Saturated TyConAppCo (->):" <+> ppr co) + -- All saturated TyConAppCos should be FunCos + + | Just {} <- synTyConDefn_maybe tc + = failWithL (text "Synonym in TyConAppCo:" <+> ppr co) + + | otherwise + = do { checkTyCon tc + ; cos' <- mapM lintCoercion cos + ; let (co_kinds, co_roles) = unzip (map coercionKindRole cos') + ; lint_co_app co (tyConKind tc) (map pFst co_kinds) + ; lint_co_app co (tyConKind tc) (map pSnd co_kinds) + ; zipWithM_ (lintRole co) (tyConRolesX r tc) co_roles + ; return (TyConAppCo r tc cos') } + +lintCoercion co@(AppCo co1 co2) + | TyConAppCo {} <- co1 + = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co) + | Just (TyConApp {}, _) <- isReflCo_maybe co1 + = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co) + | otherwise + = do { co1' <- lintCoercion co1 + ; co2' <- lintCoercion co2 + ; let (Pair lk1 rk1, r1) = coercionKindRole co1' + (Pair lk2 rk2, r2) = coercionKindRole co2' + ; lint_co_app co (typeKind lk1) [lk2] + ; lint_co_app co (typeKind rk1) [rk2] + + ; if r1 == Phantom + then lintL (r2 == Phantom || r2 == Nominal) + (text "Second argument in AppCo cannot be R:" $$ + ppr co) + else lintRole co Nominal r2 + + ; return (AppCo co1' co2') } + +---------- +lintCoercion co@(ForAllCo tcv kind_co body_co) + | not (isTyCoVar tcv) + = failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co) + | otherwise + = do { kind_co' <- lintStarCoercion kind_co + ; lintTyCoBndr tcv $ \tcv' -> + do { body_co' <- lintCoercion body_co + ; ensureEqTys (varType tcv') (coercionLKind kind_co') $ + text "Kind mis-match in ForallCo" <+> ppr co + + -- Assuming kind_co :: k1 ~ k2 + -- Need to check that + -- (forall (tcv:k1). lty) and + -- (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv]) + -- are both well formed. Easiest way is to call lintForAllBody + -- for each; there is actually no need to do the funky substitution + ; let Pair lty rty = coercionKind body_co' + ; lintForAllBody tcv' lty + ; lintForAllBody tcv' rty + + ; when (isCoVar tcv) $ + lintL (almostDevoidCoVarOfCo tcv body_co) $ + text "Covar can only appear in Refl and GRefl: " <+> ppr co + -- See "last wrinkle" in GHC.Core.Coercion + -- Note [Unused coercion variable in ForAllCo] + -- and c.f. GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] + + ; return (ForAllCo tcv' kind_co' body_co') } } + +lintCoercion co@(FunCo r co1 co2) + = do { co1' <- lintCoercion co1 + ; co2' <- lintCoercion co2 + ; let Pair lt1 rt1 = coercionKind co1 + Pair lt2 rt2 = coercionKind co2 + ; lintArrow (text "coercion" <+> quotes (ppr co)) lt1 lt2 + ; lintArrow (text "coercion" <+> quotes (ppr co)) rt1 rt2 + ; lintRole co1 r (coercionRole co1) + ; lintRole co2 r (coercionRole co2) + ; return (FunCo r co1' co2') } + +-- See Note [Bad unsafe coercion] +lintCoercion co@(UnivCo prov r ty1 ty2) + = do { ty1' <- lintType ty1 + ; ty2' <- lintType ty2 + ; let k1 = typeKind ty1' + k2 = typeKind ty2' + ; prov' <- lint_prov k1 k2 prov + + ; when (r /= Phantom && classifiesTypeWithValues k1 + && classifiesTypeWithValues k2) + (checkTypes ty1 ty2) + + ; return (UnivCo prov' r ty1' ty2') } + where + report s = hang (text $ "Unsafe coercion: " ++ s) + 2 (vcat [ text "From:" <+> ppr ty1 + , text " To:" <+> ppr ty2]) + isUnBoxed :: PrimRep -> Bool + isUnBoxed = not . isGcPtrRep + + -- see #9122 for discussion of these checks + checkTypes t1 t2 + = do { checkWarnL (not lev_poly1) + (report "left-hand type is levity-polymorphic") + ; checkWarnL (not lev_poly2) + (report "right-hand type is levity-polymorphic") + ; when (not (lev_poly1 || lev_poly2)) $ + do { checkWarnL (reps1 `equalLength` reps2) + (report "between values with different # of reps") + ; zipWithM_ validateCoercion reps1 reps2 }} + where + lev_poly1 = isTypeLevPoly t1 + lev_poly2 = isTypeLevPoly t2 + + -- don't look at these unless lev_poly1/2 are False + -- Otherwise, we get #13458 + reps1 = typePrimRep t1 + reps2 = typePrimRep t2 + + validateCoercion :: PrimRep -> PrimRep -> LintM () + validateCoercion rep1 rep2 + = do { platform <- targetPlatform <$> getDynFlags + ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2) + (report "between unboxed and boxed value") + ; checkWarnL (TyCon.primRepSizeB platform rep1 + == TyCon.primRepSizeB platform rep2) + (report "between unboxed values of different size") + ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1) + (TyCon.primRepIsFloat rep2) + ; case fl of + Nothing -> addWarnL (report "between vector types") + Just False -> addWarnL (report "between float and integral values") + _ -> return () + } + + lint_prov k1 k2 (PhantomProv kco) + = do { kco' <- lintStarCoercion kco + ; lintRole co Phantom r + ; check_kinds kco' k1 k2 + ; return (PhantomProv kco') } + + lint_prov k1 k2 (ProofIrrelProv kco) + = do { lintL (isCoercionTy ty1) (mkBadProofIrrelMsg ty1 co) + ; lintL (isCoercionTy ty2) (mkBadProofIrrelMsg ty2 co) + ; kco' <- lintStarCoercion kco + ; check_kinds kco k1 k2 + ; return (ProofIrrelProv kco') } + + lint_prov _ _ prov@(PluginProv _) = return prov + + check_kinds kco k1 k2 + = do { let Pair k1' k2' = coercionKind kco + ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft co) + ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) } + + +lintCoercion (SymCo co) + = do { co' <- lintCoercion co + ; return (SymCo co') } + +lintCoercion co@(TransCo co1 co2) + = do { co1' <- lintCoercion co1 + ; co2' <- lintCoercion co2 + ; let ty1b = coercionRKind co1' + ty2a = coercionLKind co2' + ; ensureEqTys ty1b ty2a + (hang (text "Trans coercion mis-match:" <+> ppr co) + 2 (vcat [ppr (coercionKind co1'), ppr (coercionKind co2')])) + ; lintRole co (coercionRole co1) (coercionRole co2) + ; return (TransCo co1' co2') } + +lintCoercion the_co@(NthCo r0 n co) + = do { co' <- lintCoercion co + ; let (Pair s t, r) = coercionKindRole co' + ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of + { (Just _, Just _) + -- works for both tyvar and covar + | n == 0 + , (isForAllTy_ty s && isForAllTy_ty t) + || (isForAllTy_co s && isForAllTy_co t) + -> do { lintRole the_co Nominal r0 + ; return (NthCo r0 n co') } + + ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of + { (Just (tc_s, tys_s), Just (tc_t, tys_t)) + | tc_s == tc_t + , isInjectiveTyCon tc_s r + -- see Note [NthCo and newtypes] in GHC.Core.TyCo.Rep + , tys_s `equalLength` tys_t + , tys_s `lengthExceeds` n + -> do { lintRole the_co tr r0 + ; return (NthCo r0 n co') } + where + tr = nthRole r tc_s n + + ; _ -> failWithL (hang (text "Bad getNth:") + 2 (ppr the_co $$ ppr s $$ ppr t)) }}} + +lintCoercion the_co@(LRCo lr co) + = do { co' <- lintCoercion co + ; let Pair s t = coercionKind co' + r = coercionRole co' + ; lintRole co Nominal r + ; case (splitAppTy_maybe s, splitAppTy_maybe t) of + (Just _, Just _) -> return (LRCo lr co') + _ -> failWithL (hang (text "Bad LRCo:") + 2 (ppr the_co $$ ppr s $$ ppr t)) } + +lintCoercion (InstCo co arg) + = do { co' <- lintCoercion co + ; arg' <- lintCoercion arg + ; let Pair t1 t2 = coercionKind co' + Pair s1 s2 = coercionKind arg' + + ; lintRole arg Nominal (coercionRole arg') + + ; case (splitForAllTy_ty_maybe t1, splitForAllTy_ty_maybe t2) of + -- forall over tvar + { (Just (tv1,_), Just (tv2,_)) + | typeKind s1 `eqType` tyVarKind tv1 + , typeKind s2 `eqType` tyVarKind tv2 + -> return (InstCo co' arg') + | otherwise + -> failWithL (text "Kind mis-match in inst coercion1" <+> ppr co) + + ; _ -> case (splitForAllTy_co_maybe t1, splitForAllTy_co_maybe t2) of + -- forall over covar + { (Just (cv1, _), Just (cv2, _)) + | typeKind s1 `eqType` varType cv1 + , typeKind s2 `eqType` varType cv2 + , CoercionTy _ <- s1 + , CoercionTy _ <- s2 + -> return (InstCo co' arg') + | otherwise + -> failWithL (text "Kind mis-match in inst coercion2" <+> ppr co) + + ; _ -> failWithL (text "Bad argument of inst") }}} + +lintCoercion co@(AxiomInstCo con ind cos) + = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con)) + (bad_ax (text "index out of range")) + ; let CoAxBranch { cab_tvs = ktvs + , cab_cvs = cvs + , cab_roles = roles } = coAxiomNthBranch con ind + ; unless (cos `equalLength` (ktvs ++ cvs)) $ + bad_ax (text "lengths") + ; cos' <- mapM lintCoercion cos + ; subst <- getTCvSubst + ; let empty_subst = zapTCvSubst subst + ; _ <- foldlM check_ki (empty_subst, empty_subst) + (zip3 (ktvs ++ cvs) roles cos') + ; let fam_tc = coAxiomTyCon con + ; case checkAxInstCo co of + Just bad_branch -> bad_ax $ text "inconsistent with" <+> + pprCoAxBranch fam_tc bad_branch + Nothing -> return () + ; return (AxiomInstCo con ind cos') } + where + bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what) + 2 (ppr co)) + + check_ki (subst_l, subst_r) (ktv, role, arg') + = do { let Pair s' t' = coercionKind arg' + sk' = typeKind s' + tk' = typeKind t' + ; lintRole arg' role (coercionRole arg') + ; let ktv_kind_l = substTy subst_l (tyVarKind ktv) + ktv_kind_r = substTy subst_r (tyVarKind ktv) + ; unless (sk' `eqType` ktv_kind_l) + (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr sk', ppr ktv, ppr ktv_kind_l ] )) + ; unless (tk' `eqType` ktv_kind_r) + (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr tk', ppr ktv, ppr ktv_kind_r ] )) + ; return (extendTCvSubst subst_l ktv s', + extendTCvSubst subst_r ktv t') } + +lintCoercion (KindCo co) + = do { co' <- lintCoercion co + ; return (KindCo co') } + +lintCoercion (SubCo co') + = do { co' <- lintCoercion co' + ; lintRole co' Nominal (coercionRole co') + ; return (SubCo co') } + +lintCoercion this@(AxiomRuleCo ax cos) + = do { cos' <- mapM lintCoercion cos + ; lint_roles 0 (coaxrAsmpRoles ax) cos' + ; case coaxrProves ax (map coercionKind cos') of + Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ] + Just _ -> return (AxiomRuleCo ax cos') } + where + err m xs = failWithL $ + hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName ax) : xs) + + lint_roles n (e : es) (co : cos) + | e == coercionRole co = lint_roles (n+1) es cos + | otherwise = err "Argument roles mismatch" + [ text "In argument:" <+> int (n+1) + , text "Expected:" <+> ppr e + , text "Found:" <+> ppr (coercionRole co) ] + lint_roles _ [] [] = return () + lint_roles n [] rs = err "Too many coercion arguments" + [ text "Expected:" <+> int n + , text "Provided:" <+> int (n + length rs) ] + + lint_roles n es [] = err "Not enough coercion arguments" + [ text "Expected:" <+> int (n + length es) + , text "Provided:" <+> int n ] + +lintCoercion (HoleCo h) + = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h + ; lintCoercion (CoVarCo (coHoleCoVar h)) } + + +{- +************************************************************************ +* * +\subsection[lint-monad]{The Lint monad} +* * +************************************************************************ +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] +data LintEnv + = LE { le_flags :: LintFlags -- Linting the result of this pass + , le_loc :: [LintLocInfo] -- Locations + + , le_subst :: TCvSubst -- Current TyCo substitution + -- See Note [Linting type lets] + -- /Only/ substitutes for type variables; + -- but might clone CoVars + -- We also use le_subst to keep track of + -- in-scope TyVars and CoVars (but not Ids) + -- Range of the TCvSubst is LintedType/LintedCo + + , le_ids :: VarEnv (Id, LintedType) -- In-scope Ids + -- Used to check that occurrences have an enclosing binder. + -- The Id is /pre-substitution/, used to check that + -- the occurrence has an identical type to the binder + -- The LintedType is used to return the type of the occurrence, + -- without having to lint it again. + + , le_joins :: IdSet -- Join points in scope that are valid + -- A subset of the InScopeSet in le_subst + -- See Note [Join points] + + , le_dynflags :: DynFlags -- DynamicFlags + } + +data LintFlags + = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids] + , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers] + , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs] + , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications] + , lf_check_levity_poly :: Bool -- See Note [Checking for levity polymorphism] + } + +-- See Note [Checking StaticPtrs] +data StaticPtrCheck + = AllowAnywhere + -- ^ Allow 'makeStatic' to occur anywhere. + | AllowAtTopLevel + -- ^ Allow 'makeStatic' calls at the top-level only. + | RejectEverywhere + -- ^ Reject any 'makeStatic' occurrence. + deriving Eq + +defaultLintFlags :: LintFlags +defaultLintFlags = LF { lf_check_global_ids = False + , lf_check_inline_loop_breakers = True + , lf_check_static_ptrs = AllowAnywhere + , lf_report_unsat_syns = True + , lf_check_levity_poly = True + } + +newtype LintM a = + LintM { unLintM :: + LintEnv -> + WarnsAndErrs -> -- Warning and error messages so far + (Maybe a, WarnsAndErrs) } -- Result and messages (if any) + deriving (Functor) + +type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) + +{- Note [Checking for global Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before CoreTidy, all locally-bound Ids must be LocalIds, even +top-level ones. See Note [Exported LocalIds] and #9857. + +Note [Checking StaticPtrs] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. + +Every occurrence of the function 'makeStatic' should be moved to the +top level by the FloatOut pass. It's vital that we don't have nested +'makeStatic' occurrences after CorePrep, because we populate the Static +Pointer Table from the top-level bindings. See SimplCore Note [Grand +plan for static forms]. + +The linter checks that no occurrence is left behind, nested within an +expression. The check is enabled only after the FloatOut, CorePrep, +and CoreTidy passes and only if the module uses the StaticPointers +language extension. Checking more often doesn't help since the condition +doesn't hold until after the first FloatOut pass. + +Note [Type substitution] +~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we need a type substitution? Consider + /\(a:*). \(x:a). /\(a:*). id a x +This is ill typed, because (renaming variables) it is really + /\(a:*). \(x:a). /\(b:*). id b x +Hence, when checking an application, we can't naively compare x's type +(at its binding site) with its expected type (at a use site). So we +rename type binders as we go, maintaining a substitution. + +The same substitution also supports let-type, current expressed as + (/\(a:*). body) ty +Here we substitute 'ty' for 'a' in 'body', on the fly. + +Note [Linting type synonym applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When linting a type-synonym, or type-family, application + S ty1 .. tyn +we behave as follows (#15057, #T15664): + +* If lf_report_unsat_syns = True, and S has arity < n, + complain about an unsaturated type synonym or type family + +* Switch off lf_report_unsat_syns, and lint ty1 .. tyn. + + Reason: catch out of scope variables or other ill-kinded gubbins, + even if S discards that argument entirely. E.g. (#15012): + type FakeOut a = Int + type family TF a + type instance TF Int = FakeOut a + Here 'a' is out of scope; but if we expand FakeOut, we conceal + that out-of-scope error. + + Reason for switching off lf_report_unsat_syns: with + LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they + are saturated when the type is expanded. Example + type T f = f Int + type S a = a -> a + type Z = T S + In Z's RHS, S appears unsaturated, but it is saturated when T is expanded. + +* If lf_report_unsat_syns is on, expand the synonym application and + lint the result. Reason: want to check that synonyms are saturated + when the type is expanded. +-} + +instance Applicative LintM where + pure x = LintM $ \ _ errs -> (Just x, errs) + (<*>) = ap + +instance Monad LintM where + m >>= k = LintM (\ env errs -> + let (res, errs') = unLintM m env errs in + case res of + Just r -> unLintM (k r) env errs' + Nothing -> (Nothing, errs')) + +instance MonadFail LintM where + fail err = failWithL (text err) + +instance HasDynFlags LintM where + getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs)) + +data LintLocInfo + = RhsOf Id -- The variable bound + | OccOf Id -- Occurrence of id + | LambdaBodyOf Id -- The lambda-binder + | UnfoldingOf Id -- Unfolding of a binder + | BodyOfLetRec [Id] -- One of the binders + | CaseAlt CoreAlt -- Case alternative + | CasePat CoreAlt -- The *pattern* of the case alternative + | CaseTy CoreExpr -- The type field of a case expression + -- with this scrutinee + | IdTy Id -- The type field of an Id binder + | AnExpr CoreExpr -- Some expression + | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) + | TopLevelBindings + | InType Type -- Inside a type + | InCo Coercion -- Inside a coercion + +initL :: DynFlags -> LintFlags -> [Var] + -> LintM a -> WarnsAndErrs -- Warnings and errors +initL dflags flags vars m + = case unLintM m env (emptyBag, emptyBag) of + (Just _, errs) -> errs + (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs + | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++ + "without reporting an error message") empty + where + (tcvs, ids) = partition isTyCoVar vars + env = LE { le_flags = flags + , le_subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet tcvs)) + , le_ids = mkVarEnv [(id, (id,idType id)) | id <- ids] + , le_joins = emptyVarSet + , le_loc = [] + , le_dynflags = dflags } + +setReportUnsat :: Bool -> LintM a -> LintM a +-- Switch off lf_report_unsat_syns +setReportUnsat ru thing_inside + = LintM $ \ env errs -> + let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } } + in unLintM thing_inside env' errs + +-- See Note [Checking for levity polymorphism] +noLPChecks :: LintM a -> LintM a +noLPChecks thing_inside + = LintM $ \env errs -> + let env' = env { le_flags = (le_flags env) { lf_check_levity_poly = False } } + in unLintM thing_inside env' errs + +getLintFlags :: LintM LintFlags +getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs) + +checkL :: Bool -> MsgDoc -> LintM () +checkL True _ = return () +checkL False msg = failWithL msg + +-- like checkL, but relevant to type checking +lintL :: Bool -> MsgDoc -> LintM () +lintL = checkL + +checkWarnL :: Bool -> MsgDoc -> LintM () +checkWarnL True _ = return () +checkWarnL False msg = addWarnL msg + +failWithL :: MsgDoc -> LintM a +failWithL msg = LintM $ \ env (warns,errs) -> + (Nothing, (warns, addMsg True env errs msg)) + +addErrL :: MsgDoc -> LintM () +addErrL msg = LintM $ \ env (warns,errs) -> + (Just (), (warns, addMsg True env errs msg)) + +addWarnL :: MsgDoc -> LintM () +addWarnL msg = LintM $ \ env (warns,errs) -> + (Just (), (addMsg False env warns msg, errs)) + +addMsg :: Bool -> LintEnv -> Bag MsgDoc -> MsgDoc -> Bag MsgDoc +addMsg is_error env msgs msg + = ASSERT2( notNull loc_msgs, msg ) + msgs `snocBag` mk_msg msg + where + loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first + loc_msgs = map dumpLoc (le_loc env) + + cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs + , text "Substitution:" <+> ppr (le_subst env) ] + context | is_error = cxt_doc + | otherwise = whenPprDebug cxt_doc + -- Print voluminous info for Lint errors + -- but not for warnings + + msg_span = case [ span | (loc,_) <- loc_msgs + , let span = srcLocSpan loc + , isGoodSrcSpan span ] of + [] -> noSrcSpan + (s:_) -> s + mk_msg msg = mkLocMessage SevWarning msg_span + (msg $$ context) + +addLoc :: LintLocInfo -> LintM a -> LintM a +addLoc extra_loc m + = LintM $ \ env errs -> + unLintM m (env { le_loc = extra_loc : le_loc env }) errs + +inCasePat :: LintM Bool -- A slight hack; see the unique call site +inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs) + where + is_case_pat (LE { le_loc = CasePat {} : _ }) = True + is_case_pat _other = False + +addInScopeId :: Id -> LintedType -> LintM a -> LintM a +addInScopeId id linted_ty m + = LintM $ \ env@(LE { le_ids = id_set, le_joins = join_set }) errs -> + unLintM m (env { le_ids = extendVarEnv id_set id (id, linted_ty) + , le_joins = add_joins join_set }) errs + where + add_joins join_set + | isJoinId id = extendVarSet join_set id -- Overwrite with new arity + | otherwise = delVarSet join_set id -- Remove any existing binding + +getInScopeIds :: LintM (VarEnv (Id,LintedType)) +getInScopeIds = LintM (\env errs -> (Just (le_ids env), errs)) + +extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a +extendTvSubstL tv ty m + = LintM $ \ env errs -> + unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs + +updateTCvSubst :: TCvSubst -> LintM a -> LintM a +updateTCvSubst subst' m + = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs + +markAllJoinsBad :: LintM a -> LintM a +markAllJoinsBad m + = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs + +markAllJoinsBadIf :: Bool -> LintM a -> LintM a +markAllJoinsBadIf True m = markAllJoinsBad m +markAllJoinsBadIf False m = m + +getValidJoins :: LintM IdSet +getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs)) + +getTCvSubst :: LintM TCvSubst +getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs)) + +getInScope :: LintM InScopeSet +getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs)) + +lookupIdInScope :: Id -> LintM (Id, LintedType) +lookupIdInScope id_occ + = do { in_scope_ids <- getInScopeIds + ; case lookupVarEnv in_scope_ids id_occ of + Just (id_bndr, linted_ty) + -> do { checkL (not (bad_global id_bndr)) global_in_scope + ; return (id_bndr, linted_ty) } + Nothing -> do { checkL (not is_local) local_out_of_scope + ; return (id_occ, idType id_occ) } } + -- We don't bother to lint the type + -- of global (i.e. imported) Ids + where + is_local = mustHaveLocalBinding id_occ + local_out_of_scope = text "Out of scope:" <+> pprBndr LetBind id_occ + global_in_scope = hang (text "Occurrence is GlobalId, but binding is LocalId") + 2 (pprBndr LetBind id_occ) + bad_global id_bnd = isGlobalId id_occ + && isLocalId id_bnd + && not (isWiredIn id_occ) + -- 'bad_global' checks for the case where an /occurrence/ is + -- a GlobalId, but there is an enclosing binding fora a LocalId. + -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr, + -- but GHCi adds GlobalIds from the interactive context. These + -- are fine; hence the test (isLocalId id == isLocalId v) + -- NB: when compiling Control.Exception.Base, things like absentError + -- are defined locally, but appear in expressions as (global) + -- wired-in Ids after worker/wrapper + -- So we simply disable the test in this case + +lookupJoinId :: Id -> LintM (Maybe JoinArity) +-- Look up an Id which should be a join point, valid here +-- If so, return its arity, if not return Nothing +lookupJoinId id + = do { join_set <- getValidJoins + ; case lookupVarSet join_set id of + Just id' -> return (isJoinId_maybe id') + Nothing -> return Nothing } + +ensureEqTys :: LintedType -> LintedType -> MsgDoc -> LintM () +-- check ty2 is subtype of ty1 (ie, has same structure but usage +-- annotations need only be consistent, not equal) +-- Assumes ty1,ty2 are have already had the substitution applied +ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg + +lintRole :: Outputable thing + => thing -- where the role appeared + -> Role -- expected + -> Role -- actual + -> LintM () +lintRole co r1 r2 + = lintL (r1 == r2) + (text "Role incompatibility: expected" <+> ppr r1 <> comma <+> + text "got" <+> ppr r2 $$ + text "in" <+> ppr co) + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) + +dumpLoc (RhsOf v) + = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v]) + +dumpLoc (OccOf v) + = (getSrcLoc v, text "In an occurrence of" <+> pp_binder v) + +dumpLoc (LambdaBodyOf b) + = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b) + +dumpLoc (UnfoldingOf b) + = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b) + +dumpLoc (BodyOfLetRec []) + = (noSrcLoc, text "In body of a letrec with no binders") + +dumpLoc (BodyOfLetRec bs@(_:_)) + = ( getSrcLoc (head bs), text "In the body of letrec with binders" <+> pp_binders bs) + +dumpLoc (AnExpr e) + = (noSrcLoc, text "In the expression:" <+> ppr e) + +dumpLoc (CaseAlt (con, args, _)) + = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (CasePat (con, args, _)) + = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (CaseTy scrut) + = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:") + 2 (ppr scrut)) + +dumpLoc (IdTy b) + = (getSrcLoc b, text "In the type of a binder:" <+> ppr b) + +dumpLoc (ImportedUnfolding locn) + = (locn, text "In an imported unfolding") +dumpLoc TopLevelBindings + = (noSrcLoc, Outputable.empty) +dumpLoc (InType ty) + = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) +dumpLoc (InCo co) + = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) + +pp_binders :: [Var] -> SDoc +pp_binders bs = sep (punctuate comma (map pp_binder bs)) + +pp_binder :: Var -> SDoc +pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] + | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] + +------------------------------------------------------ +-- Messages for case expressions + +mkDefaultArgsMsg :: [Var] -> MsgDoc +mkDefaultArgsMsg args + = hang (text "DEFAULT case with binders") + 4 (ppr args) + +mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc +mkCaseAltMsg e ty1 ty2 + = hang (text "Type of case alternatives not the same as the annotation on case:") + 4 (vcat [ text "Actual type:" <+> ppr ty1, + text "Annotation on case:" <+> ppr ty2, + text "Alt Rhs:" <+> ppr e ]) + +mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc +mkScrutMsg var var_ty scrut_ty subst + = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, + text "Result binder type:" <+> ppr var_ty,--(idType var), + text "Scrutinee type:" <+> ppr scrut_ty, + hsep [text "Current TCv subst", ppr subst]] + +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc +mkNonDefltMsg e + = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e) +mkNonIncreasingAltsMsg e + = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) + +nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc +nonExhaustiveAltsMsg e + = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) + +mkBadConMsg :: TyCon -> DataCon -> MsgDoc +mkBadConMsg tycon datacon + = vcat [ + text "In a case alternative, data constructor isn't in scrutinee type:", + text "Scrutinee type constructor:" <+> ppr tycon, + text "Data con:" <+> ppr datacon + ] + +mkBadPatMsg :: Type -> Type -> MsgDoc +mkBadPatMsg con_result_ty scrut_ty + = vcat [ + text "In a case alternative, pattern result type doesn't match scrutinee type:", + text "Pattern result type:" <+> ppr con_result_ty, + text "Scrutinee type:" <+> ppr scrut_ty + ] + +integerScrutinisedMsg :: MsgDoc +integerScrutinisedMsg + = text "In a LitAlt, the literal is lifted (probably Integer)" + +mkBadAltMsg :: Type -> CoreAlt -> MsgDoc +mkBadAltMsg scrut_ty alt + = vcat [ text "Data alternative when scrutinee is not a tycon application", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + +mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc +mkNewTyDataConAltMsg scrut_ty alt + = vcat [ text "Data alternative for newtype datacon", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + + +------------------------------------------------------ +-- Other error messages + +mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc +mkAppMsg fun_ty arg_ty arg + = vcat [text "Argument value doesn't match argument type:", + hang (text "Fun type:") 4 (ppr fun_ty), + hang (text "Arg type:") 4 (ppr arg_ty), + hang (text "Arg:") 4 (ppr arg)] + +mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc +mkNonFunAppMsg fun_ty arg_ty arg + = vcat [text "Non-function type in function position", + hang (text "Fun type:") 4 (ppr fun_ty), + hang (text "Arg type:") 4 (ppr arg_ty), + hang (text "Arg:") 4 (ppr arg)] + +mkLetErr :: TyVar -> CoreExpr -> MsgDoc +mkLetErr bndr rhs + = vcat [text "Bad `let' binding:", + hang (text "Variable:") + 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), + hang (text "Rhs:") + 4 (ppr rhs)] + +mkTyAppMsg :: Type -> Type -> MsgDoc +mkTyAppMsg ty arg_ty + = vcat [text "Illegal type application:", + hang (text "Exp type:") + 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), + hang (text "Arg type:") + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +emptyRec :: CoreExpr -> MsgDoc +emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) + +mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc +mkRhsMsg binder what ty + = vcat + [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon, + ppr binder], + hsep [text "Binder's type:", ppr (idType binder)], + hsep [text "Rhs type:", ppr ty]] + +mkLetAppMsg :: CoreExpr -> MsgDoc +mkLetAppMsg e + = hang (text "This argument does not satisfy the let/app invariant:") + 2 (ppr e) + +badBndrTyMsg :: Id -> SDoc -> MsgDoc +badBndrTyMsg binder what + = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder + , text "Binder's type:" <+> ppr (idType binder) ] + +mkStrictMsg :: Id -> MsgDoc +mkStrictMsg binder + = vcat [hsep [text "Recursive or top-level binder has strict demand info:", + ppr binder], + hsep [text "Binder's demand info:", ppr (idDemandInfo binder)] + ] + +mkNonTopExportedMsg :: Id -> MsgDoc +mkNonTopExportedMsg binder + = hsep [text "Non-top-level binder is marked as exported:", ppr binder] + +mkNonTopExternalNameMsg :: Id -> MsgDoc +mkNonTopExternalNameMsg binder + = hsep [text "Non-top-level binder has an external name:", ppr binder] + +mkTopNonLitStrMsg :: Id -> MsgDoc +mkTopNonLitStrMsg binder + = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] + +mkKindErrMsg :: TyVar -> Type -> MsgDoc +mkKindErrMsg tyvar arg_ty + = vcat [text "Kinds don't match in type application:", + hang (text "Type variable:") + 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), + hang (text "Arg type:") + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc +mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) + +mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> MsgDoc +mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty) + +mk_cast_err :: String -- ^ What sort of casted thing this is + -- (\"expression\" or \"type\"). + -> String -- ^ What sort of coercion is being used + -- (\"type\" or \"kind\"). + -> SDoc -- ^ The thing being casted. + -> Coercion -> Type -> Type -> MsgDoc +mk_cast_err thing_str co_str pp_thing co from_ty thing_ty + = vcat [from_msg <+> text "of Cast differs from" <+> co_msg + <+> text "of" <+> enclosed_msg, + from_msg <> colon <+> ppr from_ty, + text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon + <+> ppr thing_ty, + text "Actual" <+> enclosed_msg <> colon <+> pp_thing, + text "Coercion used in cast:" <+> ppr co + ] + where + co_msg, from_msg, enclosed_msg :: SDoc + co_msg = text co_str + from_msg = text "From-" <> co_msg + enclosed_msg = text "enclosed" <+> text thing_str + +mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc +mkBadUnivCoMsg lr co + = text "Kind mismatch on the" <+> pprLeftOrRight lr <+> + text "side of a UnivCo:" <+> ppr co + +mkBadProofIrrelMsg :: Type -> Coercion -> SDoc +mkBadProofIrrelMsg ty co + = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:") + 2 (vcat [ text "type:" <+> ppr ty + , text "co:" <+> ppr co ]) + +mkBadTyVarMsg :: Var -> SDoc +mkBadTyVarMsg tv + = text "Non-tyvar used in TyVarTy:" + <+> ppr tv <+> dcolon <+> ppr (varType tv) + +mkBadJoinBindMsg :: Var -> SDoc +mkBadJoinBindMsg var + = vcat [ text "Bad join point binding:" <+> ppr var + , text "Join points can be bound only by a non-top-level let" ] + +mkInvalidJoinPointMsg :: Var -> Type -> SDoc +mkInvalidJoinPointMsg var ty + = hang (text "Join point has invalid type:") + 2 (ppr var <+> dcolon <+> ppr ty) + +mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc +mkBadJoinArityMsg var ar nlams rhs + = vcat [ text "Join point has too few lambdas", + text "Join var:" <+> ppr var, + text "Join arity:" <+> ppr ar, + text "Number of lambdas:" <+> ppr nlams, + text "Rhs = " <+> ppr rhs + ] + +invalidJoinOcc :: Var -> SDoc +invalidJoinOcc var + = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var + , text "The binder is either not a join point, or not valid here" ] + +mkBadJumpMsg :: Var -> Int -> Int -> SDoc +mkBadJumpMsg var ar nargs + = vcat [ text "Join point invoked with wrong number of arguments", + text "Join var:" <+> ppr var, + text "Join arity:" <+> ppr ar, + text "Number of arguments:" <+> int nargs ] + +mkInconsistentRecMsg :: [Var] -> SDoc +mkInconsistentRecMsg bndrs + = vcat [ text "Recursive let binders mix values and join points", + text "Binders:" <+> hsep (map ppr_with_details bndrs) ] + where + ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr) + +mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc +mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ + = vcat [ text "Mismatch in join point arity between binder and occurrence" + , text "Var:" <+> ppr bndr + , text "Arity at binding site:" <+> ppr join_arity_bndr + , text "Arity at occurrence: " <+> ppr join_arity_occ ] + +mkBndrOccTypeMismatchMsg :: Var -> Var -> LintedType -> LintedType -> SDoc +mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty + = vcat [ text "Mismatch in type between binder and occurrence" + , text "Binder:" <+> ppr bndr <+> dcolon <+> ppr bndr_ty + , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr var_ty + , text " Before subst:" <+> ppr (idType var) ] + +mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc +mkBadJoinPointRuleMsg bndr join_arity rule + = vcat [ text "Join point has rule with wrong number of arguments" + , text "Var:" <+> ppr bndr + , text "Join arity:" <+> ppr join_arity + , text "Rule:" <+> ppr rule ] + +pprLeftOrRight :: LeftOrRight -> MsgDoc +pprLeftOrRight CLeft = text "left" +pprLeftOrRight CRight = text "right" + +dupVars :: [NonEmpty Var] -> MsgDoc +dupVars vars + = hang (text "Duplicate variables brought into scope") + 2 (ppr (map toList vars)) + +dupExtVars :: [NonEmpty Name] -> MsgDoc +dupExtVars vars + = hang (text "Duplicate top-level variables with the same qualified name") + 2 (ppr (map toList vars)) + +{- +************************************************************************ +* * +\subsection{Annotation Linting} +* * +************************************************************************ +-} + +-- | This checks whether a pass correctly looks through debug +-- annotations (@SourceNote@). This works a bit different from other +-- consistency checks: We check this by running the given task twice, +-- noting all differences between the results. +lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts +lintAnnots pname pass guts = do + -- Run the pass as we normally would + dflags <- getDynFlags + when (gopt Opt_DoAnnotationLinting dflags) $ + liftIO $ Err.showPass dflags "Annotation linting - first run" + nguts <- pass guts + -- If appropriate re-run it without debug annotations to make sure + -- that they made no difference. + when (gopt Opt_DoAnnotationLinting dflags) $ do + liftIO $ Err.showPass dflags "Annotation linting - second run" + nguts' <- withoutAnnots pass guts + -- Finally compare the resulting bindings + liftIO $ Err.showPass dflags "Annotation linting - comparison" + let binds = flattenBinds $ mg_binds nguts + binds' = flattenBinds $ mg_binds nguts' + (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' + when (not (null diffs)) $ GHC.Core.Opt.Monad.putMsg $ vcat [ lint_banner "warning" pname , text "Core changes with annotations:" , withPprStyle (defaultDumpStyle dflags) $ nest 2 $ vcat diffs diff --git a/compiler/GHC/Core/Op/CSE.hs b/compiler/GHC/Core/Op/CSE.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/CSE.hs +++ /dev/null @@ -1,799 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section{Common subexpression} --} - -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module GHC.Core.Op.CSE (cseProgram, cseOneExpr) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Core.Subst -import GHC.Types.Var ( Var ) -import GHC.Types.Var.Env ( mkInScopeSet ) -import GHC.Types.Id ( Id, idType, idHasRules - , idInlineActivation, setInlineActivation - , zapIdOccInfo, zapIdUsageInfo, idInlinePragma - , isJoinId, isJoinId_maybe ) -import GHC.Core.Utils ( mkAltExpr, eqExpr - , exprIsTickedString - , stripTicksE, stripTicksT, mkTicks ) -import GHC.Core.FVs ( exprFreeVars ) -import GHC.Core.Type ( tyConAppArgs ) -import GHC.Core -import Outputable -import GHC.Types.Basic -import GHC.Core.Map -import Util ( filterOut, equalLength, debugIsOn ) -import Data.List ( mapAccumL ) - -{- - Simple common sub-expression - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we see - x1 = C a b - x2 = C x1 b -we build up a reverse mapping: C a b -> x1 - C x1 b -> x2 -and apply that to the rest of the program. - -When we then see - y1 = C a b - y2 = C y1 b -we replace the C a b with x1. But then we *dont* want to -add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1 -so that a subsequent binding - y2 = C y1 b -will get transformed to C x1 b, and then to x2. - -So we carry an extra var->var substitution which we apply *before* looking up in the -reverse mapping. - - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -We have to be careful about shadowing. -For example, consider - f = \x -> let y = x+x in - h = \x -> x+x - in ... - -Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no -shadowing, but it doesn't any more (it proved too hard), so we clone as we go. -We can simply add clones to the substitution already described. - - -Note [CSE for bindings] -~~~~~~~~~~~~~~~~~~~~~~~ -Let-bindings have two cases, implemented by addBinding. - -* SUBSTITUTE: applies when the RHS is a variable - - let x = y in ...(h x).... - - Here we want to extend the /substitution/ with x -> y, so that the - (h x) in the body might CSE with an enclosing (let v = h y in ...). - NB: the substitution maps InIds, so we extend the substitution with - a binding for the original InId 'x' - - How can we have a variable on the RHS? Doesn't the simplifier inline them? - - - First, the original RHS might have been (g z) which has CSE'd - with an enclosing (let y = g z in ...). This is super-important. - See #5996: - x1 = C a b - x2 = C x1 b - y1 = C a b - y2 = C y1 b - Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to - the substitution so that we can CSE the binding for y2. - - - Second, we use addBinding for case expression scrutinees too; - see Note [CSE for case expressions] - -* EXTEND THE REVERSE MAPPING: applies in all other cases - - let x = h y in ...(h y)... - - Here we want to extend the /reverse mapping (cs_map)/ so that - we CSE the (h y) call to x. - - Note that we use EXTEND even for a trivial expression, provided it - is not a variable or literal. In particular this /includes/ type - applications. This can be important (#13156); e.g. - case f @ Int of { r1 -> - case f @ Int of { r2 -> ... - Here we want to common-up the two uses of (f @ Int) so we can - remove one of the case expressions. - - See also Note [Corner case for case expressions] for another - reason not to use SUBSTITUTE for all trivial expressions. - -Notice that - - The SUBSTITUTE situation extends the substitution (cs_subst) - - The EXTEND situation extends the reverse mapping (cs_map) - -Notice also that in the SUBSTITUTE case we leave behind a binding - x = y -even though we /also/ carry a substitution x -> y. Can we just drop -the binding instead? Well, not at top level! See Note [Top level and -postInlineUnconditionally] in GHC.Core.Op.Simplify.Utils; and in any -case CSE applies only to the /bindings/ of the program, and we leave -it to the simplifier to propate effects to the RULES. Finally, it -doesn't seem worth the effort to discard the nested bindings because -the simplifier will do it next. - -Note [CSE for case expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - case scrut_expr of x { ...alts... } -This is very like a strict let-binding - let !x = scrut_expr in ... -So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a -result all the stuff under Note [CSE for bindings] applies directly. - -For example: - -* Trivial scrutinee - f = \x -> case x of wild { - (a:as) -> case a of wild1 { - (p,q) -> ...(wild1:as)... - - Here, (wild1:as) is morally the same as (a:as) and hence equal to - wild. But that's not quite obvious. In the rest of the compiler we - want to keep it as (wild1:as), but for CSE purpose that's a bad - idea. - - By using addBinding we add the binding (wild1 -> a) to the substitution, - which does exactly the right thing. - - (Notice this is exactly backwards to what the simplifier does, which - is to try to replaces uses of 'a' with uses of 'wild1'.) - - This is the main reason that addBinding is called with a trivial rhs. - -* Non-trivial scrutinee - case (f x) of y { pat -> ...let z = f x in ... } - - By using addBinding we'll add (f x :-> y) to the cs_map, and - thereby CSE the inner (f x) to y. - -Note [CSE for INLINE and NOINLINE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are some subtle interactions of CSE with functions that the user -has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.) -Consider - - yes :: Int {-# NOINLINE yes #-} - yes = undefined - - no :: Int {-# NOINLINE no #-} - no = undefined - - foo :: Int -> Int -> Int {-# NOINLINE foo #-} - foo m n = n - - {-# RULES "foo/no" foo no = id #-} - - bar :: Int -> Int - bar = foo yes - -We do not expect the rule to fire. But if we do CSE, then we risk -getting yes=no, and the rule does fire. Actually, it won't because -NOINLINE means that 'yes' will never be inlined, not even if we have -yes=no. So that's fine (now; perhaps in the olden days, yes=no would -have substituted even if 'yes' was NOINLINE). - -But we do need to take care. Consider - - {-# NOINLINE bar #-} - bar = -- Same rhs as foo - - foo = - -If CSE produces - foo = bar -then foo will never be inlined to (when it should be, if -is small). The conclusion here is this: - - We should not add - :-> bar - to the CSEnv if 'bar' has any constraints on when it can inline; - that is, if its 'activation' not always active. Otherwise we - might replace by 'bar', and then later be unable to see that it - really was . - -An except to the rule is when the INLINE pragma is not from the user, e.g. from -WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec -is then true. - -Note that we do not (currently) do CSE on the unfolding stored inside -an Id, even if it is a 'stable' unfolding. That means that when an -unfolding happens, it is always faithful to what the stable unfolding -originally was. - -Note [CSE for stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - {-# Unf = Stable (\pq. build blah) #-} - foo = x - -Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial. -(Turns out that this actually happens for the enumFromTo method of -the Integer instance of Enum in GHC.Enum.) Suppose moreover that foo's -stable unfolding originates from an INLINE or INLINEABLE pragma on foo. -Then we obviously do NOT want to extend the substitution with (foo->x), -because we promised to inline foo as what the user wrote. See similar Note -[Stable unfoldings and postInlineUnconditionally] in GHC.Core.Op.Simplify.Utils. - -Nor do we want to change the reverse mapping. Suppose we have - - {-# Unf = Stable (\pq. build blah) #-} - foo = - bar = - -There could conceivably be merit in rewriting the RHS of bar: - bar = foo -but now bar's inlining behaviour will change, and importing -modules might see that. So it seems dodgy and we don't do it. - -Stable unfoldings are also created during worker/wrapper when we decide -that a function's definition is so small that it should always inline. -In this case we still want to do CSE (#13340). Hence the use of -isAnyInlinePragma rather than isStableUnfolding. - -Note [Corner case for case expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is another reason that we do not use SUBSTITUTE for -all trivial expressions. Consider - case x |> co of (y::Array# Int) { ... } - -We do not want to extend the substitution with (y -> x |> co); since y -is of unlifted type, this would destroy the let/app invariant if (x |> -co) was not ok-for-speculation. - -But surely (x |> co) is ok-for-speculation, because it's a trivial -expression, and x's type is also unlifted, presumably. Well, maybe -not if you are using unsafe casts. I actually found a case where we -had - (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int) - -Note [CSE for join points?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must not be naive about join points in CSE: - join j = e in - if b then jump j else 1 + e -The expression (1 + jump j) is not good (see Note [Invariants on join points] in -GHC.Core). This seems to come up quite seldom, but it happens (first seen -compiling ppHtml in Haddock.Backends.Xhtml). - -We could try and be careful by tracking which join points are still valid at -each subexpression, but since join points aren't allocated or shared, there's -less to gain by trying to CSE them. (#13219) - -Note [Look inside join-point binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Another way how CSE for join points is tricky is - - let join foo x = (x, 42) - join bar x = (x, 42) - in … jump foo 1 … jump bar 2 … - -naively, CSE would turn this into - - let join foo x = (x, 42) - join bar = foo - in … jump foo 1 … jump bar 2 … - -but now bar is a join point that claims arity one, but its right-hand side -is not a lambda, breaking the join-point invariant (this was #15002). - -So `cse_bind` must zoom past the lambdas of a join point (using -`collectNBinders`) and resume searching for CSE opportunities only in -the body of the join point. - -Note [CSE for recursive bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f = \x ... f.... - g = \y ... g ... -where the "..." are identical. Could we CSE them? In full generality -with mutual recursion it's quite hard; but for self-recursive bindings -(which are very common) it's rather easy: - -* Maintain a separate cs_rec_map, that maps - (\f. (\x. ...f...) ) -> f - Note the \f in the domain of the mapping! - -* When we come across the binding for 'g', look up (\g. (\y. ...g...)) - Bingo we get a hit. So we can replace the 'g' binding with - g = f - -We can't use cs_map for this, because the key isn't an expression of -the program; it's a kind of synthetic key for recursive bindings. - - -************************************************************************ -* * -\section{Common subexpression} -* * -************************************************************************ --} - -cseProgram :: CoreProgram -> CoreProgram -cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds) - -cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind) -cseBind toplevel env (NonRec b e) - = (env2, NonRec b2 e2) - where - (env1, b1) = addBinder env b - (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1 - -cseBind toplevel env (Rec [(in_id, rhs)]) - | noCSE in_id - = (env1, Rec [(out_id, rhs')]) - - -- See Note [CSE for recursive bindings] - | Just previous <- lookupCSRecEnv env out_id rhs'' - , let previous' = mkTicks ticks previous - out_id' = delayInlining toplevel out_id - = -- We have a hit in the recursive-binding cache - (extendCSSubst env1 in_id previous', NonRec out_id' previous') - - | otherwise - = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')]) - - where - (env1, [out_id]) = addRecBinders env [in_id] - rhs' = cseExpr env1 rhs - rhs'' = stripTicksE tickishFloatable rhs' - ticks = stripTicksT tickishFloatable rhs' - id_expr' = varToCoreExpr out_id - zapped_id = zapIdUsageInfo out_id - -cseBind toplevel env (Rec pairs) - = (env2, Rec pairs') - where - (env1, bndrs1) = addRecBinders env (map fst pairs) - (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1) - - do_one env (pr, b1) = cse_bind toplevel env pr b1 - --- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer --- to @in_id@ (@out_id@, created from addBinder or addRecBinders), --- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd) --- binding to the 'CSEnv', so that we attempt to CSE any expressions --- which are equal to @out_rhs@. -cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr)) -cse_bind toplevel env (in_id, in_rhs) out_id - | isTopLevel toplevel, exprIsTickedString in_rhs - -- See Note [Take care with literal strings] - = (env', (out_id', in_rhs)) - - | Just arity <- isJoinId_maybe in_id - -- See Note [Look inside join-point binders] - = let (params, in_body) = collectNBinders arity in_rhs - (env', params') = addBinders env params - out_body = tryForCSE env' in_body - in (env, (out_id, mkLams params' out_body)) - - | otherwise - = (env', (out_id'', out_rhs)) - where - (env', out_id') = addBinding env in_id out_id out_rhs - (cse_done, out_rhs) = try_for_cse env in_rhs - out_id'' | cse_done = delayInlining toplevel out_id' - | otherwise = out_id' - -delayInlining :: TopLevelFlag -> Id -> Id --- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already --- See Note [Delay inlining after CSE] -delayInlining top_lvl bndr - | isTopLevel top_lvl - , isAlwaysActive (idInlineActivation bndr) - , idHasRules bndr -- Only if the Id has some RULES, - -- which might otherwise get lost - -- These rules are probably auto-generated specialisations, - -- since Ids with manual rules usually have manually-inserted - -- delayed inlining anyway - = bndr `setInlineActivation` activeAfterInitial - | otherwise - = bndr - -addBinding :: CSEnv -- Includes InId->OutId cloning - -> InVar -- Could be a let-bound type - -> OutId -> OutExpr -- Processed binding - -> (CSEnv, OutId) -- Final env, final bndr --- Extend the CSE env with a mapping [rhs -> out-id] --- unless we can instead just substitute [in-id -> rhs] --- --- It's possible for the binder to be a type variable (see --- Note [Type-let] in GHC.Core), in which case we can just substitute. -addBinding env in_id out_id rhs' - | not (isId in_id) = (extendCSSubst env in_id rhs', out_id) - | noCSE in_id = (env, out_id) - | use_subst = (extendCSSubst env in_id rhs', out_id) - | otherwise = (extendCSEnv env rhs' id_expr', zapped_id) - where - id_expr' = varToCoreExpr out_id - zapped_id = zapIdUsageInfo out_id - -- Putting the Id into the cs_map makes it possible that - -- it'll become shared more than it is now, which would - -- invalidate (the usage part of) its demand info. - -- This caused #100218. - -- Easiest thing is to zap the usage info; subsequently - -- performing late demand-analysis will restore it. Don't zap - -- the strictness info; it's not necessary to do so, and losing - -- it is bad for performance if you don't do late demand - -- analysis - - -- Should we use SUBSTITUTE or EXTEND? - -- See Note [CSE for bindings] - use_subst = case rhs' of - Var {} -> True - _ -> False - --- | Given a binder `let x = e`, this function --- determines whether we should add `e -> x` to the cs_map -noCSE :: InId -> Bool -noCSE id = not (isAlwaysActive (idInlineActivation id)) && - not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id))) - -- See Note [CSE for INLINE and NOINLINE] - || isAnyInlinePragma (idInlinePragma id) - -- See Note [CSE for stable unfoldings] - || isJoinId id - -- See Note [CSE for join points?] - - -{- Note [Take care with literal strings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this example: - - x = "foo"# - y = "foo"# - ...x...y...x...y.... - -We would normally turn this into: - - x = "foo"# - y = x - ...x...x...x...x.... - -But this breaks an invariant of Core, namely that the RHS of a top-level binding -of type Addr# must be a string literal, not another variable. See Note -[Core top-level string literals] in GHC.Core. - -For this reason, we special case top-level bindings to literal strings and leave -the original RHS unmodified. This produces: - - x = "foo"# - y = "foo"# - ...x...x...x...x.... - -Now 'y' will be discarded as dead code, and we are done. - -The net effect is that for the y-binding we want to - - Use SUBSTITUTE, by extending the substitution with y :-> x - - but leave the original binding for y undisturbed - -This is done by cse_bind. I got it wrong the first time (#13367). - -Note [Delay inlining after CSE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose (#15445) we have - f,g :: Num a => a -> a - f x = ...f (x-1)..... - g y = ...g (y-1) .... - -and we make some specialisations of 'g', either automatically, or via -a SPECIALISE pragma. Then CSE kicks in and notices that the RHSs of -'f' and 'g' are identical, so we get - f x = ...f (x-1)... - g = f - {-# RULES g @Int _ = $sg #-} - -Now there is terrible danger that, in an importing module, we'll inline -'g' before we have a chance to run its specialisation! - -Solution: during CSE, after a "hit" in the CSE cache - * when adding a binding - g = f - * for a top-level function g - * and g has specialisation RULES -add a NOINLINE[2] activation to it, to ensure it's not inlined -right away. - -Notes: -* Why top level only? Because for nested bindings we are already past - phase 2 and will never return there. - -* Why "only if g has RULES"? Because there is no point in - doing this if there are no RULES; and other things being - equal it delays optimisation to delay inlining (#17409) - - ----- Historical note --- - -This patch is simpler and more direct than an earlier -version: - - commit 2110738b280543698407924a16ac92b6d804dc36 - Author: Simon Peyton Jones - Date: Mon Jul 30 13:43:56 2018 +0100 - - Don't inline functions with RULES too early - -We had to revert this patch because it made GHC itself slower. - -Why? It delayed inlining of /all/ functions with RULES, and that was -very bad in TcFlatten.flatten_ty_con_app - -* It delayed inlining of liftM -* That delayed the unravelling of the recursion in some dictionary - bindings. -* That delayed some eta expansion, leaving - flatten_ty_con_app = \x y. let in \z. blah -* That allowed the float-out pass to put sguff between - the \y and \z. -* And that permanently stopped eta expansion of the function, - even once was simplified. - --} - -tryForCSE :: CSEnv -> InExpr -> OutExpr -tryForCSE env expr = snd (try_for_cse env expr) - -try_for_cse :: CSEnv -> InExpr -> (Bool, OutExpr) --- (False, e') => We did not CSE the entire expression, --- but we might have CSE'd some sub-expressions, --- yielding e' --- --- (True, te') => We CSE'd the entire expression, --- yielding the trivial expression te' -try_for_cse env expr - | Just e <- lookupCSEnv env expr'' = (True, mkTicks ticks e) - | otherwise = (False, expr') - -- The varToCoreExpr is needed if we have - -- case e of xco { ...case e of yco { ... } ... } - -- Then CSE will substitute yco -> xco; - -- but these are /coercion/ variables - where - expr' = cseExpr env expr - expr'' = stripTicksE tickishFloatable expr' - ticks = stripTicksT tickishFloatable expr' - -- We don't want to lose the source notes when a common sub - -- expression gets eliminated. Hence we push all (!) of them on - -- top of the replaced sub-expression. This is probably not too - -- useful in practice, but upholds our semantics. - --- | Runs CSE on a single expression. --- --- This entry point is not used in the compiler itself, but is provided --- as a convenient entry point for users of the GHC API. -cseOneExpr :: InExpr -> OutExpr -cseOneExpr e = cseExpr env e - where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) } - -cseExpr :: CSEnv -> InExpr -> OutExpr -cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) -cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) -cseExpr _ (Lit lit) = Lit lit -cseExpr env (Var v) = lookupSubst env v -cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) -cseExpr env (Tick t e) = Tick t (cseExpr env e) -cseExpr env (Cast e co) = Cast (tryForCSE env e) (substCo (csEnvSubst env) co) -cseExpr env (Lam b e) = let (env', b') = addBinder env b - in Lam b' (cseExpr env' e) -cseExpr env (Let bind e) = let (env', bind') = cseBind NotTopLevel env bind - in Let bind' (cseExpr env' e) -cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts - -cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr -cseCase env scrut bndr ty alts - = Case scrut1 bndr3 ty' $ - combineAlts alt_env (map cse_alt alts) - where - ty' = substTy (csEnvSubst env) ty - scrut1 = tryForCSE env scrut - - bndr1 = zapIdOccInfo bndr - -- Zapping the OccInfo is needed because the extendCSEnv - -- in cse_alt may mean that a dead case binder - -- becomes alive, and Lint rejects that - (env1, bndr2) = addBinder env bndr1 - (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1 - -- addBinding: see Note [CSE for case expressions] - - con_target :: OutExpr - con_target = lookupSubst alt_env bndr - - arg_tys :: [OutType] - arg_tys = tyConAppArgs (idType bndr3) - - -- See Note [CSE for case alternatives] - cse_alt (DataAlt con, args, rhs) - = (DataAlt con, args', tryForCSE new_env rhs) - where - (env', args') = addBinders alt_env args - new_env = extendCSEnv env' con_expr con_target - con_expr = mkAltExpr (DataAlt con) args' arg_tys - - cse_alt (con, args, rhs) - = (con, args', tryForCSE env' rhs) - where - (env', args') = addBinders alt_env args - -combineAlts :: CSEnv -> [OutAlt] -> [OutAlt] --- See Note [Combine case alternatives] -combineAlts env alts - | (Just alt1, rest_alts) <- find_bndr_free_alt alts - , (_,bndrs1,rhs1) <- alt1 - , let filtered_alts = filterOut (identical_alt rhs1) rest_alts - , not (equalLength rest_alts filtered_alts) - = ASSERT2( null bndrs1, ppr alts ) - (DEFAULT, [], rhs1) : filtered_alts - - | otherwise - = alts - where - in_scope = substInScope (csEnvSubst env) - - find_bndr_free_alt :: [CoreAlt] -> (Maybe CoreAlt, [CoreAlt]) - -- The (Just alt) is a binder-free alt - -- See Note [Combine case alts: awkward corner] - find_bndr_free_alt [] - = (Nothing, []) - find_bndr_free_alt (alt@(_,bndrs,_) : alts) - | null bndrs = (Just alt, alts) - | otherwise = case find_bndr_free_alt alts of - (mb_bf, alts) -> (mb_bf, alt:alts) - - identical_alt rhs1 (_,_,rhs) = eqExpr in_scope rhs1 rhs - -- Even if this alt has binders, they will have been cloned - -- If any of these binders are mentioned in 'rhs', then - -- 'rhs' won't compare equal to 'rhs1' (which is from an - -- alt with no binders). - -{- Note [CSE for case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider case e of x - K1 y -> ....(K1 y)... - K2 -> ....K2.... - -We definitely want to CSE that (K1 y) into just x. - -But what about the lone K2? At first you would think "no" because -turning K2 into 'x' increases the number of live variables. But - -* Turning K2 into x increases the chance of combining identical alts. - Example case xs of - (_:_) -> f xs - [] -> f [] - See #17901 and simplCore/should_compile/T17901 for more examples - of this kind. - -* The next run of the simplifier will turn 'x' back into K2, so we won't - permanently bloat the free-var count. - - -Note [Combine case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -combineAlts is just a more heavyweight version of the use of -combineIdenticalAlts in GHC.Core.Op.Simplify.Utils.prepareAlts. The basic idea is -to transform - - DEFAULT -> e1 - K x -> e1 - W y z -> e2 -===> - DEFAULT -> e1 - W y z -> e2 - -In the simplifier we use cheapEqExpr, because it is called a lot. -But here in CSE we use the full eqExpr. After all, two alternatives usually -differ near the root, so it probably isn't expensive to compare the full -alternative. It seems like the same kind of thing that CSE is supposed -to be doing, which is why I put it here. - -I actually saw some examples in the wild, where some inlining made e1 too -big for cheapEqExpr to catch it. - -Note [Combine case alts: awkward corner] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We would really like to check isDeadBinder on the binders in the -alternative. But alas, the simplifer zaps occ-info on binders in case -alternatives; see Note [Case alternative occ info] in GHC.Core.Op.Simplify. - -* One alternative (perhaps a good one) would be to do OccAnal - just before CSE. Then perhaps we could get rid of combineIdenticalAlts - in the Simplifier, which might save work. - -* Another would be for CSE to return free vars as it goes. - -* But the current solution is to find a nullary alternative (including - the DEFAULT alt, if any). This will not catch - case x of - A y -> blah - B z p -> blah - where no alternative is nullary or DEFAULT. But the current - solution is at least cheap. - - -************************************************************************ -* * -\section{The CSE envt} -* * -************************************************************************ --} - -data CSEnv - = CS { cs_subst :: Subst -- Maps InBndrs to OutExprs - -- The substitution variables to - -- /trivial/ OutExprs, not arbitrary expressions - - , cs_map :: CoreMap OutExpr -- The reverse mapping - -- Maps a OutExpr to a /trivial/ OutExpr - -- The key of cs_map is stripped of all Ticks - - , cs_rec_map :: CoreMap OutExpr - -- See Note [CSE for recursive bindings] - } - -emptyCSEnv :: CSEnv -emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap - , cs_subst = emptySubst } - -lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr -lookupCSEnv (CS { cs_map = csmap }) expr - = lookupCoreMap csmap expr - -extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv -extendCSEnv cse expr triv_expr - = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr } - where - sexpr = stripTicksE tickishFloatable expr - -extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv --- See Note [CSE for recursive bindings] -extendCSRecEnv cse bndr expr triv_expr - = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr } - -lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr --- See Note [CSE for recursive bindings] -lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr - = lookupCoreMap csmap (Lam bndr expr) - -csEnvSubst :: CSEnv -> Subst -csEnvSubst = cs_subst - -lookupSubst :: CSEnv -> Id -> OutExpr -lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x - -extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv -extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs } - --- | Add clones to the substitution to deal with shadowing. See --- Note [Shadowing] for more details. You should call this whenever --- you go under a binder. -addBinder :: CSEnv -> Var -> (CSEnv, Var) -addBinder cse v = (cse { cs_subst = sub' }, v') - where - (sub', v') = substBndr (cs_subst cse) v - -addBinders :: CSEnv -> [Var] -> (CSEnv, [Var]) -addBinders cse vs = (cse { cs_subst = sub' }, vs') - where - (sub', vs') = substBndrs (cs_subst cse) vs - -addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) -addRecBinders cse vs = (cse { cs_subst = sub' }, vs') - where - (sub', vs') = substRecBndrs (cs_subst cse) vs diff --git a/compiler/GHC/Core/Op/CallArity.hs b/compiler/GHC/Core/Op/CallArity.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/CallArity.hs +++ /dev/null @@ -1,763 +0,0 @@ --- --- Copyright (c) 2014 Joachim Breitner --- - -module GHC.Core.Op.CallArity - ( callArityAnalProgram - , callArityRHS -- for testing - ) where - -import GhcPrelude - -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Driver.Session ( DynFlags ) - -import GHC.Types.Basic -import GHC.Core -import GHC.Types.Id -import GHC.Core.Arity ( typeArity ) -import GHC.Core.Utils ( exprIsCheap, exprIsTrivial ) -import UnVarGraph -import GHC.Types.Demand -import Util - -import Control.Arrow ( first, second ) - - -{- -%************************************************************************ -%* * - Call Arity Analysis -%* * -%************************************************************************ - -Note [Call Arity: The goal] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The goal of this analysis is to find out if we can eta-expand a local function, -based on how it is being called. The motivating example is this code, -which comes up when we implement foldl using foldr, and do list fusion: - - let go = \x -> let d = case ... of - False -> go (x+1) - True -> id - in \z -> d (x + z) - in go 1 0 - -If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of -partial function applications, which would be bad. - -The function `go` has a type of arity two, but only one lambda is manifest. -Furthermore, an analysis that only looks at the RHS of go cannot be sufficient -to eta-expand go: If `go` is ever called with one argument (and the result used -multiple times), we would be doing the work in `...` multiple times. - -So `callArityAnalProgram` looks at the whole let expression to figure out if -all calls are nice, i.e. have a high enough arity. It then stores the result in -the `calledArity` field of the `IdInfo` of `go`, which the next simplifier -phase will eta-expand. - -The specification of the `calledArity` field is: - - No work will be lost if you eta-expand me to the arity in `calledArity`. - -What we want to know for a variable ------------------------------------ - -For every let-bound variable we'd like to know: - 1. A lower bound on the arity of all calls to the variable, and - 2. whether the variable is being called at most once or possible multiple - times. - -It is always ok to lower the arity, or pretend that there are multiple calls. -In particular, "Minimum arity 0 and possible called multiple times" is always -correct. - - -What we want to know from an expression ---------------------------------------- - -In order to obtain that information for variables, we analyze expression and -obtain bits of information: - - I. The arity analysis: - For every variable, whether it is absent, or called, - and if called, which what arity. - - II. The Co-Called analysis: - For every two variables, whether there is a possibility that both are being - called. - We obtain as a special case: For every variables, whether there is a - possibility that it is being called twice. - -For efficiency reasons, we gather this information only for a set of -*interesting variables*, to avoid spending time on, e.g., variables from pattern matches. - -The two analysis are not completely independent, as a higher arity can improve -the information about what variables are being called once or multiple times. - -Note [Analysis I: The arity analysis] ------------------------------------- - -The arity analysis is quite straight forward: The information about an -expression is an - VarEnv Arity -where absent variables are bound to Nothing and otherwise to a lower bound to -their arity. - -When we analyze an expression, we analyze it with a given context arity. -Lambdas decrease and applications increase the incoming arity. Analysizing a -variable will put that arity in the environment. In lets or cases all the -results from the various subexpressions are lubed, which takes the point-wise -minimum (considering Nothing an infinity). - - -Note [Analysis II: The Co-Called analysis] ------------------------------------------- - -The second part is more sophisticated. For reasons explained below, it is not -sufficient to simply know how often an expression evaluates a variable. Instead -we need to know which variables are possibly called together. - -The data structure here is an undirected graph of variables, which is provided -by the abstract - UnVarGraph - -It is safe to return a larger graph, i.e. one with more edges. The worst case -(i.e. the least useful and always correct result) is the complete graph on all -free variables, which means that anything can be called together with anything -(including itself). - -Notation for the following: -C(e) is the co-called result for e. -G₁∪G₂ is the union of two graphs -fv is the set of free variables (conveniently the domain of the arity analysis result) -S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ } -S² is the complete graph on the set of variables S, S² = S×S -C'(e) is a variant for bound expression: - If e is called at most once, or it is and stays a thunk (after the analysis), - it is simply C(e). Otherwise, the expression can be called multiple times - and we return (fv e)² - -The interesting cases of the analysis: - * Var v: - No other variables are being called. - Return {} (the empty graph) - * Lambda v e, under arity 0: - This means that e can be evaluated many times and we cannot get - any useful co-call information. - Return (fv e)² - * Case alternatives alt₁,alt₂,...: - Only one can be execuded, so - Return (alt₁ ∪ alt₂ ∪...) - * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂: - We get the results from both sides, with the argument evaluated at most once. - Additionally, anything called by e₁ can possibly be called with anything - from e₂. - Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂) - * App e₁ x: - As this is already in A-normal form, CorePrep will not separately lambda - bind (and hence share) x. So we conservatively assume multiple calls to x here - Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)} - * Let v = rhs in body: - In addition to the results from the subexpressions, add all co-calls from - everything that the body calls together with v to everything that is called - by v. - Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)} - * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body - Tricky. - We assume that it is really mutually recursive, i.e. that every variable - calls one of the others, and that this is strongly connected (otherwise we - return an over-approximation, so that's ok), see note [Recursion and fixpointing]. - - Let V = {v₁,...vₙ}. - Assume that the vs have been analysed with an incoming demand and - cardinality consistent with the final result (this is the fixed-pointing). - Again we can use the results from all subexpressions. - In addition, for every variable vᵢ, we need to find out what it is called - with (call this set Sᵢ). There are two cases: - * If vᵢ is a function, we need to go through all right-hand-sides and bodies, - and collect every variable that is called together with any variable from V: - Sᵢ = {v' | j ∈ {1,...,n}, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) } - * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to - exclude it from this set: - Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) } - Finally, combine all this: - Return: C(body) ∪ - C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ - (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ) - -Using the result: Eta-Expansion -------------------------------- - -We use the result of these two analyses to decide whether we can eta-expand the -rhs of a let-bound variable. - -If the variable is already a function (exprIsCheap), and all calls to the -variables have a higher arity than the current manifest arity (i.e. the number -of lambdas), expand. - -If the variable is a thunk we must be careful: Eta-Expansion will prevent -sharing of work, so this is only safe if there is at most one call to the -function. Therefore, we check whether {v,v} ∈ G. - - Example: - - let n = case .. of .. -- A thunk! - in n 0 + n 1 - - vs. - - let n = case .. of .. - in case .. of T -> n 0 - F -> n 1 - - We are only allowed to eta-expand `n` if it is going to be called at most - once in the body of the outer let. So we need to know, for each variable - individually, that it is going to be called at most once. - - -Why the co-call graph? ----------------------- - -Why is it not sufficient to simply remember which variables are called once and -which are called multiple times? It would be in the previous example, but consider - - let n = case .. of .. - in case .. of - True -> let go = \y -> case .. of - True -> go (y + n 1) - False > n - in go 1 - False -> n - -vs. - - let n = case .. of .. - in case .. of - True -> let go = \y -> case .. of - True -> go (y+1) - False > n - in go 1 - False -> n - -In both cases, the body and the rhs of the inner let call n at most once. -But only in the second case that holds for the whole expression! The -crucial difference is that in the first case, the rhs of `go` can call -*both* `go` and `n`, and hence can call `n` multiple times as it recurses, -while in the second case find out that `go` and `n` are not called together. - - -Why co-call information for functions? --------------------------------------- - -Although for eta-expansion we need the information only for thunks, we still -need to know whether functions are being called once or multiple times, and -together with what other functions. - - Example: - - let n = case .. of .. - f x = n (x+1) - in f 1 + f 2 - - vs. - - let n = case .. of .. - f x = n (x+1) - in case .. of T -> f 0 - F -> f 1 - - Here, the body of f calls n exactly once, but f itself is being called - multiple times, so eta-expansion is not allowed. - - -Note [Analysis type signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The work-hourse of the analysis is the function `callArityAnal`, with the -following type: - - type CallArityRes = (UnVarGraph, VarEnv Arity) - callArityAnal :: - Arity -> -- The arity this expression is called with - VarSet -> -- The set of interesting variables - CoreExpr -> -- The expression to analyse - (CallArityRes, CoreExpr) - -and the following specification: - - ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr - - <=> - - Assume the expression `expr` is being passed `arity` arguments. Then it holds that - * The domain of `callArityEnv` is a subset of `interestingIds`. - * Any variable from `interestingIds` that is not mentioned in the `callArityEnv` - is absent, i.e. not called at all. - * Every call from `expr` to a variable bound to n in `callArityEnv` has at - least n value arguments. - * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`, - then in no execution of `expr` both are being called. - Furthermore, expr' is expr with the callArity field of the `IdInfo` updated. - - -Note [Which variables are interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The analysis would quickly become prohibitive expensive if we would analyse all -variables; for most variables we simply do not care about how often they are -called, i.e. variables bound in a pattern match. So interesting are variables that are - * top-level or let bound - * and possibly functions (typeArity > 0) - -Note [Taking boring variables into account] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -If we decide that the variable bound in `let x = e1 in e2` is not interesting, -the analysis of `e2` will not report anything about `x`. To ensure that -`callArityBind` does still do the right thing we have to take that into account -every time we would be lookup up `x` in the analysis result of `e2`. - * Instead of calling lookupCallArityRes, we return (0, True), indicating - that this variable might be called many times with no arguments. - * Instead of checking `calledWith x`, we assume that everything can be called - with it. - * In the recursive case, when calclulating the `cross_calls`, if there is - any boring variable in the recursive group, we ignore all co-call-results - and directly go to a very conservative assumption. - -The last point has the nice side effect that the relatively expensive -integration of co-call results in a recursive groups is often skipped. This -helped to avoid the compile time blowup in some real-world code with large -recursive groups (#10293). - -Note [Recursion and fixpointing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -For a mutually recursive let, we begin by - 1. analysing the body, using the same incoming arity as for the whole expression. - 2. Then we iterate, memoizing for each of the bound variables the last - analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes. - 3. We combine the analysis result from the body and the memoized results for - the arguments (if already present). - 4. For each variable, we find out the incoming arity and whether it is called - once, based on the current analysis result. If this differs from the - memoized results, we re-analyse the rhs and update the memoized table. - 5. If nothing had to be reanalyzed, we are done. - Otherwise, repeat from step 3. - - -Note [Thunks in recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We never eta-expand a thunk in a recursive group, on the grounds that if it is -part of a recursive group, then it will be called multiple times. - -This is not necessarily true, e.g. it would be safe to eta-expand t2 (but not -t1) in the following code: - - let go x = t1 - t1 = if ... then t2 else ... - t2 = if ... then go 1 else ... - in go 0 - -Detecting this would require finding out what variables are only ever called -from thunks. While this is certainly possible, we yet have to see this to be -relevant in the wild. - - -Note [Analysing top-level binds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We can eta-expand top-level-binds if they are not exported, as we see all calls -to them. The plan is as follows: Treat the top-level binds as nested lets around -a body representing “all external calls”, which returns a pessimistic -CallArityRes (the co-call graph is the complete graph, all arityies 0). - -Note [Trimming arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In the Call Arity papers, we are working on an untyped lambda calculus with no -other id annotations, where eta-expansion is always possible. But this is not -the case for Core! - 1. We need to ensure the invariant - callArity e <= typeArity (exprType e) - for the same reasons that exprArity needs this invariant (see Note - [exprArity invariant] in GHC.Core.Arity). - - If we are not doing that, a too-high arity annotation will be stored with - the id, confusing the simplifier later on. - - 2. Eta-expanding a right hand side might invalidate existing annotations. In - particular, if an id has a strictness annotation of <...><...>b, then - passing two arguments to it will definitely bottom out, so the simplifier - will throw away additional parameters. This conflicts with Call Arity! So - we ensure that we never eta-expand such a value beyond the number of - arguments mentioned in the strictness signature. - See #10176 for a real-world-example. - -Note [What is a thunk] -~~~~~~~~~~~~~~~~~~~~~~ - -Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a -thunk, not eta-expanded, to avoid losing any sharing. This is also how the -published papers on Call Arity describe it. - -In practice, there are thunks that do a just little work, such as -pattern-matching on a variable, and the benefits of eta-expansion likely -outweigh the cost of doing that repeatedly. Therefore, this implementation of -Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk. - -Note [Call Arity and Join Points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The Call Arity analysis does not care about join points, and treats them just -like normal functions. This is ok. - -The analysis *could* make use of the fact that join points are always evaluated -in the same context as the join-binding they are defined in and are always -one-shot, and handle join points separately, as suggested in -https://gitlab.haskell.org/ghc/ghc/issues/13479#note_134870. -This *might* be more efficient (for example, join points would not have to be -considered interesting variables), but it would also add redundant code. So for -now we do not do that. - -The simplifier never eta-expands join points (it instead pushes extra arguments from -an eta-expanded context into the join point’s RHS), so the call arity -annotation on join points is not actually used. As it would be equally valid -(though less efficient) to eta-expand join points, this is the simplifier's -choice, and hence Call Arity sets the call arity for join points as well. --} - --- Main entry point - -callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram -callArityAnalProgram _dflags binds = binds' - where - (_, binds') = callArityTopLvl [] emptyVarSet binds - --- See Note [Analysing top-level-binds] -callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind]) -callArityTopLvl exported _ [] - = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported]) - , [] ) -callArityTopLvl exported int1 (b:bs) - = (ae2, b':bs') - where - int2 = bindersOf b - exported' = filter isExportedId int2 ++ exported - int' = int1 `addInterestingBinds` b - (ae1, bs') = callArityTopLvl exported' int' bs - (ae2, b') = callArityBind (boringBinds b) ae1 int1 b - - -callArityRHS :: CoreExpr -> CoreExpr -callArityRHS = snd . callArityAnal 0 emptyVarSet - --- The main analysis function. See Note [Analysis type signature] -callArityAnal :: - Arity -> -- The arity this expression is called with - VarSet -> -- The set of interesting variables - CoreExpr -> -- The expression to analyse - (CallArityRes, CoreExpr) - -- How this expression uses its interesting variables - -- and the expression with IdInfo updated - --- The trivial base cases -callArityAnal _ _ e@(Lit _) - = (emptyArityRes, e) -callArityAnal _ _ e@(Type _) - = (emptyArityRes, e) -callArityAnal _ _ e@(Coercion _) - = (emptyArityRes, e) --- The transparent cases -callArityAnal arity int (Tick t e) - = second (Tick t) $ callArityAnal arity int e -callArityAnal arity int (Cast e co) - = second (\e -> Cast e co) $ callArityAnal arity int e - --- The interesting case: Variables, Lambdas, Lets, Applications, Cases -callArityAnal arity int e@(Var v) - | v `elemVarSet` int - = (unitArityRes v arity, e) - | otherwise - = (emptyArityRes, e) - --- Non-value lambdas are ignored -callArityAnal arity int (Lam v e) | not (isId v) - = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e - --- We have a lambda that may be called multiple times, so its free variables --- can all be co-called. -callArityAnal 0 int (Lam v e) - = (ae', Lam v e') - where - (ae, e') = callArityAnal 0 (int `delVarSet` v) e - ae' = calledMultipleTimes ae --- We have a lambda that we are calling. decrease arity. -callArityAnal arity int (Lam v e) - = (ae, Lam v e') - where - (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e - --- Application. Increase arity for the called expression, nothing to know about --- the second -callArityAnal arity int (App e (Type t)) - = second (\e -> App e (Type t)) $ callArityAnal arity int e -callArityAnal arity int (App e1 e2) - = (final_ae, App e1' e2') - where - (ae1, e1') = callArityAnal (arity + 1) int e1 - (ae2, e2') = callArityAnal 0 int e2 - -- If the argument is trivial (e.g. a variable), then it will _not_ be - -- let-bound in the Core to STG transformation (CorePrep actually), - -- so no sharing will happen here, and we have to assume many calls. - ae2' | exprIsTrivial e2 = calledMultipleTimes ae2 - | otherwise = ae2 - final_ae = ae1 `both` ae2' - --- Case expression. -callArityAnal arity int (Case scrut bndr ty alts) - = -- pprTrace "callArityAnal:Case" - -- (vcat [ppr scrut, ppr final_ae]) - (final_ae, Case scrut' bndr ty alts') - where - (alt_aes, alts') = unzip $ map go alts - go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e - in (ae, (dc, bndrs, e')) - alt_ae = lubRess alt_aes - (scrut_ae, scrut') = callArityAnal 0 int scrut - final_ae = scrut_ae `both` alt_ae - --- For lets, use callArityBind -callArityAnal arity int (Let bind e) - = -- pprTrace "callArityAnal:Let" - -- (vcat [ppr v, ppr arity, ppr n, ppr final_ae ]) - (final_ae, Let bind' e') - where - int_body = int `addInterestingBinds` bind - (ae_body, e') = callArityAnal arity int_body e - (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind - --- Which bindings should we look at? --- See Note [Which variables are interesting] -isInteresting :: Var -> Bool -isInteresting v = not $ null (typeArity (idType v)) - -interestingBinds :: CoreBind -> [Var] -interestingBinds = filter isInteresting . bindersOf - -boringBinds :: CoreBind -> VarSet -boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf - -addInterestingBinds :: VarSet -> CoreBind -> VarSet -addInterestingBinds int bind - = int `delVarSetList` bindersOf bind -- Possible shadowing - `extendVarSetList` interestingBinds bind - --- Used for both local and top-level binds --- Second argument is the demand from the body -callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind) --- Non-recursive let -callArityBind boring_vars ae_body int (NonRec v rhs) - | otherwise - = -- pprTrace "callArityBind:NonRec" - -- (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity]) - (final_ae, NonRec v' rhs') - where - is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk] - -- If v is boring, we will not find it in ae_body, but always assume (0, False) - boring = v `elemVarSet` boring_vars - - (arity, called_once) - | boring = (0, False) -- See Note [Taking boring variables into account] - | otherwise = lookupCallArityRes ae_body v - safe_arity | called_once = arity - | is_thunk = 0 -- A thunk! Do not eta-expand - | otherwise = arity - - -- See Note [Trimming arity] - trimmed_arity = trimArity v safe_arity - - (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs - - - ae_rhs'| called_once = ae_rhs - | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once - | otherwise = calledMultipleTimes ae_rhs - - called_by_v = domRes ae_rhs' - called_with_v - | boring = domRes ae_body - | otherwise = calledWith ae_body v `delUnVarSet` v - final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body - - v' = v `setIdCallArity` trimmed_arity - - --- Recursive let. See Note [Recursion and fixpointing] -callArityBind boring_vars ae_body int b@(Rec binds) - = -- (if length binds > 300 then - -- pprTrace "callArityBind:Rec" - -- (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $ - (final_ae, Rec binds') - where - -- See Note [Taking boring variables into account] - any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds] - - int_body = int `addInterestingBinds` b - (ae_rhs, binds') = fix initial_binds - final_ae = bindersOf b `resDelList` ae_rhs - - initial_binds = [(i,Nothing,e) | (i,e) <- binds] - - fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)]) - fix ann_binds - | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $ - any_change - = fix ann_binds' - | otherwise - = (ae, map (\(i, _, e) -> (i, e)) ann_binds') - where - aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ] - ae = callArityRecEnv any_boring aes_old ae_body - - rerun (i, mbLastRun, rhs) - | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae) - -- No call to this yet, so do nothing - = (False, (i, Nothing, rhs)) - - | Just (old_called_once, old_arity, _) <- mbLastRun - , called_once == old_called_once - , new_arity == old_arity - -- No change, no need to re-analyze - = (False, (i, mbLastRun, rhs)) - - | otherwise - -- We previously analyzed this with a different arity (or not at all) - = let is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk] - - safe_arity | is_thunk = 0 -- See Note [Thunks in recursive groups] - | otherwise = new_arity - - -- See Note [Trimming arity] - trimmed_arity = trimArity i safe_arity - - (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs - - ae_rhs' | called_once = ae_rhs - | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once - | otherwise = calledMultipleTimes ae_rhs - - i' = i `setIdCallArity` trimmed_arity - - in (True, (i', Just (called_once, new_arity, ae_rhs'), rhs')) - where - -- See Note [Taking boring variables into account] - (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False) - | otherwise = lookupCallArityRes ae i - - (changes, ann_binds') = unzip $ map rerun ann_binds - any_change = or changes - --- Combining the results from body and rhs, (mutually) recursive case --- See Note [Analysis II: The Co-Called analysis] -callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes -callArityRecEnv any_boring ae_rhss ae_body - = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $ - ae_new - where - vars = map fst ae_rhss - - ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body - - cross_calls - -- See Note [Taking boring variables into account] - | any_boring = completeGraph (domRes ae_combined) - -- Also, calculating cross_calls is expensive. Simply be conservative - -- if the mutually recursive group becomes too large. - | lengthExceeds ae_rhss 25 = completeGraph (domRes ae_combined) - | otherwise = unionUnVarGraphs $ map cross_call ae_rhss - cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v - where - is_thunk = idCallArity v == 0 - -- What rhs are relevant as happening before (or after) calling v? - -- If v is a thunk, everything from all the _other_ variables - -- If v is not a thunk, everything can happen. - ae_before_v | is_thunk = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body - | otherwise = ae_combined - -- What do we want to know from these? - -- Which calls can happen next to any recursive call. - called_with_v - = unionUnVarSets $ map (calledWith ae_before_v) vars - called_by_v = domRes ae_rhs - - ae_new = first (cross_calls `unionUnVarGraph`) ae_combined - --- See Note [Trimming arity] -trimArity :: Id -> Arity -> Arity -trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig] - where - max_arity_by_type = length (typeArity (idType v)) - max_arity_by_strsig - | isBotDiv result_info = length demands - | otherwise = a - - (demands, result_info) = splitStrictSig (idStrictness v) - ---------------------------------------- --- Functions related to CallArityRes -- ---------------------------------------- - --- Result type for the two analyses. --- See Note [Analysis I: The arity analysis] --- and Note [Analysis II: The Co-Called analysis] -type CallArityRes = (UnVarGraph, VarEnv Arity) - -emptyArityRes :: CallArityRes -emptyArityRes = (emptyUnVarGraph, emptyVarEnv) - -unitArityRes :: Var -> Arity -> CallArityRes -unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity) - -resDelList :: [Var] -> CallArityRes -> CallArityRes -resDelList vs ae = foldr resDel ae vs - -resDel :: Var -> CallArityRes -> CallArityRes -resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v) - -domRes :: CallArityRes -> UnVarSet -domRes (_, ae) = varEnvDom ae - --- In the result, find out the minimum arity and whether the variable is called --- at most once. -lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool) -lookupCallArityRes (g, ae) v - = case lookupVarEnv ae v of - Just a -> (a, not (g `hasLoopAt` v)) - Nothing -> (0, False) - -calledWith :: CallArityRes -> Var -> UnVarSet -calledWith (g, _) v = neighbors g v - -addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes -addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`) - --- Replaces the co-call graph by a complete graph (i.e. no information) -calledMultipleTimes :: CallArityRes -> CallArityRes -calledMultipleTimes res = first (const (completeGraph (domRes res))) res - --- Used for application and cases -both :: CallArityRes -> CallArityRes -> CallArityRes -both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2 - --- Used when combining results from alternative cases; take the minimum -lubRes :: CallArityRes -> CallArityRes -> CallArityRes -lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2) - -lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity -lubArityEnv = plusVarEnv_C min - -lubRess :: [CallArityRes] -> CallArityRes -lubRess = foldl' lubRes emptyArityRes diff --git a/compiler/GHC/Core/Op/CprAnal.hs b/compiler/GHC/Core/Op/CprAnal.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/CprAnal.hs +++ /dev/null @@ -1,653 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Constructed Product Result analysis. Identifies functions that surely --- return heap-allocated records on every code path, so that we can eliminate --- said heap allocation by performing a worker/wrapper split. --- --- See https://www.microsoft.com/en-us/research/publication/constructed-product-result-analysis-haskell/. --- CPR analysis should happen after strictness analysis. --- See Note [Phase ordering]. -module GHC.Core.Op.CprAnal ( cprAnalProgram ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Driver.Session -import GHC.Types.Demand -import GHC.Types.Cpr -import GHC.Core -import GHC.Core.Seq -import Outputable -import GHC.Types.Var.Env -import GHC.Types.Basic -import Data.List -import GHC.Core.DataCon -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram ) -import GHC.Core.TyCon -import GHC.Core.Type -import GHC.Core.FamInstEnv -import GHC.Core.Op.WorkWrap.Lib -import Util -import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) ) -import Maybes ( isJust, isNothing ) - -{- Note [Constructed Product Result] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The goal of Constructed Product Result analysis is to identify functions that -surely return heap-allocated records on every code path, so that we can -eliminate said heap allocation by performing a worker/wrapper split. - -@swap@ below is such a function: - - swap (a, b) = (b, a) - -A @case@ on an application of @swap@, like -@case swap (10, 42) of (a, b) -> a + b@ could cancel away -(by case-of-known-constructor) if we "inlined" @swap@ and simplified. We then -say that @swap@ has the CPR property. - -We can't inline recursive functions, but similar reasoning applies there: - - f x n = case n of - 0 -> (x, 0) - _ -> f (x+1) (n-1) - -Inductively, @case f 1 2 of (a, b) -> a + b@ could cancel away the constructed -product with the case. So @f@, too, has the CPR property. But we can't really -"inline" @f@, because it's recursive. Also, non-recursive functions like @swap@ -might be too big to inline (or even marked NOINLINE). We still want to exploit -the CPR property, and that is exactly what the worker/wrapper transformation -can do for us: - - $wf x n = case n of - 0 -> case (x, 0) of -> (a, b) -> (# a, b #) - _ -> case f (x+1) (n-1) of (a, b) -> (# a, b #) - f x n = case $wf x n of (# a, b #) -> (a, b) - -where $wf readily simplifies (by case-of-known-constructor and inlining @f@) to: - - $wf x n = case n of - 0 -> (# x, 0 #) - _ -> $wf (x+1) (n-1) - -Now, a call site like @case f 1 2 of (a, b) -> a + b@ can inline @f@ and -eliminate the heap-allocated pair constructor. - -Note [Phase ordering] -~~~~~~~~~~~~~~~~~~~~~ -We need to perform strictness analysis before CPR analysis, because that might -unbox some arguments, in turn leading to more constructed products. -Ideally, we would want the following pipeline: - -1. Strictness -2. worker/wrapper (for strictness) -3. CPR -4. worker/wrapper (for CPR) - -Currently, we omit 2. and anticipate the results of worker/wrapper. -See Note [CPR in a DataAlt case alternative] -and Note [CPR for binders that will be unboxed]. -An additional w/w pass would simplify things, but probably add slight overhead. -So currently we have - -1. Strictness -2. CPR -3. worker/wrapper (for strictness and CPR) --} - --- --- * Analysing programs --- - -cprAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram -cprAnalProgram dflags fam_envs binds = do - let env = emptyAnalEnv fam_envs - let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds - dumpIfSet_dyn dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ - dumpIdInfoOfProgram (ppr . cprInfo) binds_plus_cpr - -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Op.DmdAnal - seqBinds binds_plus_cpr `seq` return binds_plus_cpr - --- Analyse a (group of) top-level binding(s) -cprAnalTopBind :: AnalEnv - -> CoreBind - -> (AnalEnv, CoreBind) -cprAnalTopBind env (NonRec id rhs) - = (extendAnalEnv env id' (idCprInfo id'), NonRec id' rhs') - where - (id', rhs') = cprAnalBind TopLevel env id rhs - -cprAnalTopBind env (Rec pairs) - = (env', Rec pairs') - where - (env', pairs') = cprFix TopLevel env pairs - --- --- * Analysing expressions --- - --- | The abstract semantic function ⟦_⟧ : Expr -> Env -> A from --- "Constructed Product Result Analysis for Haskell" -cprAnal, cprAnal' - :: AnalEnv - -> CoreExpr -- ^ expression to be denoted by a 'CprType' - -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType' - -cprAnal env e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $ - cprAnal' env e - -cprAnal' _ (Lit lit) = (topCprType, Lit lit) -cprAnal' _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact -cprAnal' _ (Coercion co) = (topCprType, Coercion co) - -cprAnal' env (Var var) = (cprTransform env var, Var var) - -cprAnal' env (Cast e co) - = (cpr_ty, Cast e' co) - where - (cpr_ty, e') = cprAnal env e - -cprAnal' env (Tick t e) - = (cpr_ty, Tick t e') - where - (cpr_ty, e') = cprAnal env e - -cprAnal' env (App fun (Type ty)) - = (fun_ty, App fun' (Type ty)) - where - (fun_ty, fun') = cprAnal env fun - -cprAnal' env (App fun arg) - = (res_ty, App fun' arg') - where - (fun_ty, fun') = cprAnal env fun - -- In contrast to DmdAnal, there is no useful (non-nested) CPR info to be - -- had by looking into the CprType of arg. - (_, arg') = cprAnal env arg - res_ty = applyCprTy fun_ty - -cprAnal' env (Lam var body) - | isTyVar var - , (body_ty, body') <- cprAnal env body - = (body_ty, Lam var body') - | otherwise - = (lam_ty, Lam var body') - where - env' = extendAnalEnvForDemand env var (idDemandInfo var) - (body_ty, body') = cprAnal env' body - lam_ty = abstractCprTy body_ty - -cprAnal' env (Case scrut case_bndr ty alts) - = (res_ty, Case scrut' case_bndr ty alts') - where - (_, scrut') = cprAnal env scrut - -- Regardless whether scrut had the CPR property or not, the case binder - -- certainly has it. See 'extendEnvForDataAlt'. - (alt_tys, alts') = mapAndUnzip (cprAnalAlt env scrut case_bndr) alts - res_ty = foldl' lubCprType botCprType alt_tys - -cprAnal' env (Let (NonRec id rhs) body) - = (body_ty, Let (NonRec id' rhs') body') - where - (id', rhs') = cprAnalBind NotTopLevel env id rhs - env' = extendAnalEnv env id' (idCprInfo id') - (body_ty, body') = cprAnal env' body - -cprAnal' env (Let (Rec pairs) body) - = body_ty `seq` (body_ty, Let (Rec pairs') body') - where - (env', pairs') = cprFix NotTopLevel env pairs - (body_ty, body') = cprAnal env' body - -cprAnalAlt - :: AnalEnv - -> CoreExpr -- ^ scrutinee - -> Id -- ^ case binder - -> Alt Var -- ^ current alternative - -> (CprType, Alt Var) -cprAnalAlt env scrut case_bndr (con@(DataAlt dc),bndrs,rhs) - -- See 'extendEnvForDataAlt' and Note [CPR in a DataAlt case alternative] - = (rhs_ty, (con, bndrs, rhs')) - where - env_alt = extendEnvForDataAlt env scrut case_bndr dc bndrs - (rhs_ty, rhs') = cprAnal env_alt rhs -cprAnalAlt env _ _ (con,bndrs,rhs) - = (rhs_ty, (con, bndrs, rhs')) - where - (rhs_ty, rhs') = cprAnal env rhs - --- --- * CPR transformer --- - -cprTransform :: AnalEnv -- ^ The analysis environment - -> Id -- ^ The function - -> CprType -- ^ The demand type of the function -cprTransform env id - = -- pprTrace "cprTransform" (vcat [ppr id, ppr sig]) - sig - where - sig - | isGlobalId id -- imported function or data con worker - = getCprSig (idCprInfo id) - | Just sig <- lookupSigEnv env id -- local let-bound - = getCprSig sig - | otherwise - = topCprType - --- --- * Bindings --- - --- Recursive bindings -cprFix :: TopLevelFlag - -> AnalEnv -- Does not include bindings for this binding - -> [(Id,CoreExpr)] - -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info - -cprFix top_lvl env orig_pairs - = loop 1 initial_pairs - where - bot_sig = mkCprSig 0 botCpr - -- See Note [Initialising strictness] in GHC.Core.Op.DmdAnal - initial_pairs | ae_virgin env = [(setIdCprInfo id bot_sig, rhs) | (id, rhs) <- orig_pairs ] - | otherwise = orig_pairs - - -- The fixed-point varies the idCprInfo field of the binders, and terminates if that - -- annotation does not change any more. - loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)]) - loop n pairs - | found_fixpoint = (final_anal_env, pairs') - | otherwise = loop (n+1) pairs' - where - found_fixpoint = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs - first_round = n == 1 - pairs' = step first_round pairs - final_anal_env = extendAnalEnvs env (map fst pairs') - - step :: Bool -> [(Id, CoreExpr)] -> [(Id, CoreExpr)] - step first_round pairs = pairs' - where - -- In all but the first iteration, delete the virgin flag - start_env | first_round = env - | otherwise = nonVirgin env - - start = extendAnalEnvs start_env (map fst pairs) - - (_, pairs') = mapAccumL my_downRhs start pairs - - my_downRhs env (id,rhs) - = (env', (id', rhs')) - where - (id', rhs') = cprAnalBind top_lvl env id rhs - env' = extendAnalEnv env id (idCprInfo id') - --- | Process the RHS of the binding for a sensible arity, add the CPR signature --- to the Id, and augment the environment with the signature as well. -cprAnalBind - :: TopLevelFlag - -> AnalEnv - -> Id - -> CoreExpr - -> (Id, CoreExpr) -cprAnalBind top_lvl env id rhs - = (id', rhs') - where - (rhs_ty, rhs') = cprAnal env rhs - -- possibly trim thunk CPR info - rhs_ty' - -- See Note [CPR for thunks] - | stays_thunk = trimCprTy rhs_ty - -- See Note [CPR for sum types] - | returns_sum = trimCprTy rhs_ty - | otherwise = rhs_ty - -- See Note [Arity trimming for CPR signatures] - sig = mkCprSigForArity (idArity id) rhs_ty' - id' = setIdCprInfo id sig - - -- See Note [CPR for thunks] - stays_thunk = is_thunk && not_strict - is_thunk = not (exprIsHNF rhs) && not (isJoinId id) - not_strict = not (isStrictDmd (idDemandInfo id)) - -- See Note [CPR for sum types] - (_, ret_ty) = splitPiTys (idType id) - not_a_prod = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty) - returns_sum = not (isTopLevel top_lvl) && not_a_prod - -{- Note [Arity trimming for CPR signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Although it doesn't affect correctness of the analysis per se, we have to trim -CPR signatures to idArity. Here's what might happen if we don't: - - f x = if expensive - then \y. Box y - else \z. Box z - g a b = f a b - -The two lambdas will have a CPR type of @1m@ (so construct a product after -applied to one argument). Thus, @f@ will have a CPR signature of @2m@ -(constructs a product after applied to two arguments). -But WW will never eta-expand @f@! In this case that would amount to possibly -duplicating @expensive@ work. - -(Side note: Even if @f@'s 'idArity' happened to be 2, it would not do so, see -Note [Don't eta expand in w/w].) - -So @f@ will not be worker/wrappered. But @g@ also inherited its CPR signature -from @f@'s, so it *will* be WW'd: - - f x = if expensive - then \y. Box y - else \z. Box z - $wg a b = case f a b of Box x -> x - g a b = Box ($wg a b) - -And the case in @g@ can never cancel away, thus we introduced extra reboxing. -Hence we always trim the CPR signature of a binding to idArity. --} - -data AnalEnv - = AE - { ae_sigs :: SigEnv - -- ^ Current approximation of signatures for local ids - , ae_virgin :: Bool - -- ^ True only on every first iteration in a fixed-point - -- iteration. See Note [Initialising strictness] in "DmdAnal" - , ae_fam_envs :: FamInstEnvs - -- ^ Needed when expanding type families and synonyms of product types. - } - -type SigEnv = VarEnv CprSig - -instance Outputable AnalEnv where - ppr (AE { ae_sigs = env, ae_virgin = virgin }) - = text "AE" <+> braces (vcat - [ text "ae_virgin =" <+> ppr virgin - , text "ae_sigs =" <+> ppr env ]) - -emptyAnalEnv :: FamInstEnvs -> AnalEnv -emptyAnalEnv fam_envs - = AE - { ae_sigs = emptyVarEnv - , ae_virgin = True - , ae_fam_envs = fam_envs - } - --- | Extend an environment with the strictness IDs attached to the id -extendAnalEnvs :: AnalEnv -> [Id] -> AnalEnv -extendAnalEnvs env ids - = env { ae_sigs = sigs' } - where - sigs' = extendVarEnvList (ae_sigs env) [ (id, idCprInfo id) | id <- ids ] - -extendAnalEnv :: AnalEnv -> Id -> CprSig -> AnalEnv -extendAnalEnv env id sig - = env { ae_sigs = extendVarEnv (ae_sigs env) id sig } - -lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig -lookupSigEnv env id = lookupVarEnv (ae_sigs env) id - -nonVirgin :: AnalEnv -> AnalEnv -nonVirgin env = env { ae_virgin = False } - --- | A version of 'extendAnalEnv' for a binder of which we don't see the RHS --- needed to compute a 'CprSig' (e.g. lambdas and DataAlt field binders). --- In this case, we can still look at their demand to attach CPR signatures --- anticipating the unboxing done by worker/wrapper. --- See Note [CPR for binders that will be unboxed]. -extendAnalEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv -extendAnalEnvForDemand env id dmd - | isId id - , Just (_, DataConAppContext { dcac_dc = dc }) - <- wantToUnbox (ae_fam_envs env) has_inlineable_prag (idType id) dmd - = extendAnalEnv env id (CprSig (conCprType (dataConTag dc))) - | otherwise - = env - where - -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE - -- function, we just assume that we aren't. That flag is only relevant - -- to Note [Do not unpack class dictionaries], the few unboxing - -- opportunities on dicts it prohibits are probably irrelevant to CPR. - has_inlineable_prag = False - -extendEnvForDataAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv --- See Note [CPR in a DataAlt case alternative] -extendEnvForDataAlt env scrut case_bndr dc bndrs - = foldl' do_con_arg env' ids_w_strs - where - env' = extendAnalEnv env case_bndr (CprSig case_bndr_ty) - - ids_w_strs = filter isId bndrs `zip` dataConRepStrictness dc - - tycon = dataConTyCon dc - is_product = isJust (isDataProductTyCon_maybe tycon) - is_sum = isJust (isDataSumTyCon_maybe tycon) - case_bndr_ty - | is_product || is_sum = conCprType (dataConTag dc) - -- Any of the constructors had existentials. This is a little too - -- conservative (after all, we only care about the particular data con), - -- but there is no easy way to write is_sum and this won't happen much. - | otherwise = topCprType - - -- We could have much deeper CPR info here with Nested CPR, which could - -- propagate available unboxed things from the scrutinee, getting rid of - -- the is_var_scrut heuristic. See Note [CPR in a DataAlt case alternative]. - -- Giving strict binders the CPR property only makes sense for products, as - -- the arguments in Note [CPR for binders that will be unboxed] don't apply - -- to sums (yet); we lack WW for strict binders of sum type. - do_con_arg env (id, str) - | is_var scrut - -- See Note [Add demands for strict constructors] in WorkWrap.Lib - , let dmd = applyWhen (isMarkedStrict str) strictifyDmd (idDemandInfo id) - = extendAnalEnvForDemand env id dmd - | otherwise - = env - - is_var (Cast e _) = is_var e - is_var (Var v) = isLocalId v - is_var _ = False - -{- Note [Safe abortion in the fixed-point iteration] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Fixed-point iteration may fail to terminate. But we cannot simply give up and -return the environment and code unchanged! We still need to do one additional -round, to ensure that all expressions have been traversed at least once, and any -unsound CPR annotations have been updated. - -Note [CPR in a DataAlt case alternative] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a case alternative, we want to give some of the binders the CPR property. -Specifically - - * The case binder; inside the alternative, the case binder always has - the CPR property, meaning that a case on it will successfully cancel. - Example: - f True x = case x of y { I# x' -> if x' ==# 3 - then y - else I# 8 } - f False x = I# 3 - - By giving 'y' the CPR property, we ensure that 'f' does too, so we get - f b x = case fw b x of { r -> I# r } - fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } - fw False x = 3 - - Of course there is the usual risk of re-boxing: we have 'x' available - boxed and unboxed, but we return the unboxed version for the wrapper to - box. If the wrapper doesn't cancel with its caller, we'll end up - re-boxing something that we did have available in boxed form. - - * Any strict binders with product type, can use - Note [CPR for binders that will be unboxed] - to anticipate worker/wrappering for strictness info. - But we can go a little further. Consider - - data T = MkT !Int Int - - f2 (MkT x y) | y>0 = f2 (MkT x (y-1)) - | otherwise = x - - For $wf2 we are going to unbox the MkT *and*, since it is strict, the - first argument of the MkT; see Note [Add demands for strict constructors]. - But then we don't want box it up again when returning it! We want - 'f2' to have the CPR property, so we give 'x' the CPR property. - - * It's a bit delicate because we're brittly anticipating worker/wrapper here. - If the case above is scrutinising something other than an argument the - original function, we really don't have the unboxed version available. E.g - g v = case foo v of - MkT x y | y>0 -> ... - | otherwise -> x - Here we don't have the unboxed 'x' available. Hence the - is_var_scrut test when making use of the strictness annotation. - Slightly ad-hoc, because even if the scrutinee *is* a variable it - might not be a onre of the arguments to the original function, or a - sub-component thereof. But it's simple, and nothing terrible - happens if we get it wrong. e.g. Trac #10694. - -Note [CPR for binders that will be unboxed] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a lambda-bound variable will be unboxed by worker/wrapper (so it must be -demanded strictly), then give it a CPR signature. Here's a concrete example -('f1' in test T10482a), assuming h is strict: - - f1 :: Int -> Int - f1 x = case h x of - A -> x - B -> f1 (x-1) - C -> x+1 - -If we notice that 'x' is used strictly, we can give it the CPR -property; and hence f1 gets the CPR property too. It's sound (doesn't -change strictness) to give it the CPR property because by the time 'x' -is returned (case A above), it'll have been evaluated (by the wrapper -of 'h' in the example). - -Moreover, if f itself is strict in x, then we'll pass x unboxed to -f1, and so the boxed version *won't* be available; in that case it's -very helpful to give 'x' the CPR property. - -Note that - - * We only want to do this for something that definitely - has product type, else we may get over-optimistic CPR results - (e.g. from \x -> x!). - - * This also (approximately) applies to DataAlt field binders; - See Note [CPR in a DataAlt case alternative]. - - * See Note [CPR examples] - -Note [CPR for sum types] -~~~~~~~~~~~~~~~~~~~~~~~~ -At the moment we do not do CPR for let-bindings that - * non-top level - * bind a sum type -Reason: I found that in some benchmarks we were losing let-no-escapes, -which messed it all up. Example - let j = \x. .... - in case y of - True -> j False - False -> j True -If we w/w this we get - let j' = \x. .... - in case y of - True -> case j' False of { (# a #) -> Just a } - False -> case j' True of { (# a #) -> Just a } -Notice that j' is not a let-no-escape any more. - -However this means in turn that the *enclosing* function -may be CPR'd (via the returned Justs). But in the case of -sums, there may be Nothing alternatives; and that messes -up the sum-type CPR. - -Conclusion: only do this for products. It's still not -guaranteed OK for products, but sums definitely lose sometimes. - -Note [CPR for thunks] -~~~~~~~~~~~~~~~~~~~~~ -If the rhs is a thunk, we usually forget the CPR info, because -it is presumably shared (else it would have been inlined, and -so we'd lose sharing if w/w'd it into a function). E.g. - - let r = case expensive of - (a,b) -> (b,a) - in ... - -If we marked r as having the CPR property, then we'd w/w into - - let $wr = \() -> case expensive of - (a,b) -> (# b, a #) - r = case $wr () of - (# b,a #) -> (b,a) - in ... - -But now r is a thunk, which won't be inlined, so we are no further ahead. -But consider - - f x = let r = case expensive of (a,b) -> (b,a) - in if foo r then r else (x,x) - -Does f have the CPR property? Well, no. - -However, if the strictness analyser has figured out (in a previous -iteration) that it's strict, then we DON'T need to forget the CPR info. -Instead we can retain the CPR info and do the thunk-splitting transform -(see WorkWrap.splitThunk). - -This made a big difference to PrelBase.modInt, which had something like - modInt = \ x -> let r = ... -> I# v in - ...body strict in r... -r's RHS isn't a value yet; but modInt returns r in various branches, so -if r doesn't have the CPR property then neither does modInt -Another case I found in practice (in Complex.magnitude), looks like this: - let k = if ... then I# a else I# b - in ... body strict in k .... -(For this example, it doesn't matter whether k is returned as part of -the overall result; but it does matter that k's RHS has the CPR property.) -Left to itself, the simplifier will make a join point thus: - let $j k = ...body strict in k... - if ... then $j (I# a) else $j (I# b) -With thunk-splitting, we get instead - let $j x = let k = I#x in ...body strict in k... - in if ... then $j a else $j b -This is much better; there's a good chance the I# won't get allocated. - -But what about botCpr? Consider - lvl = error "boom" - fac -1 = lvl - fac 0 = 1 - fac n = n * fac (n-1) -fac won't have the CPR property here when we trim every thunk! But the -assumption is that error cases are rarely entered and we are diverging anyway, -so WW doesn't hurt. - -Note [CPR examples] -~~~~~~~~~~~~~~~~~~~~ -Here are some examples (stranal/should_compile/T10482a) of the -usefulness of Note [CPR in a DataAlt case alternative]. The main -point: all of these functions can have the CPR property. - - ------- f1 ----------- - -- x is used strictly by h, so it'll be available - -- unboxed before it is returned in the True branch - - f1 :: Int -> Int - f1 x = case h x x of - True -> x - False -> f1 (x-1) - - ------- f3 ----------- - -- h is strict in x, so x will be unboxed before it - -- is rerturned in the otherwise case. - - data T3 = MkT3 Int Int - - f1 :: T3 -> Int - f1 (MkT3 x y) | h x y = f3 (MkT3 x (y-1)) - | otherwise = x --} diff --git a/compiler/GHC/Core/Op/DmdAnal.hs b/compiler/GHC/Core/Op/DmdAnal.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/DmdAnal.hs +++ /dev/null @@ -1,1259 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - - - ----------------- - A demand analysis - ----------------- --} - -{-# LANGUAGE CPP #-} - -module GHC.Core.Op.DmdAnal ( dmdAnalProgram ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Driver.Session -import GHC.Core.Op.WorkWrap.Lib ( findTypeShape ) -import GHC.Types.Demand -- All of it -import GHC.Core -import GHC.Core.Seq ( seqBinds ) -import Outputable -import GHC.Types.Var.Env -import GHC.Types.Basic -import Data.List ( mapAccumL ) -import GHC.Core.DataCon -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Core.Utils -import GHC.Core.TyCon -import GHC.Core.Type -import GHC.Core.Coercion ( Coercion, coVarsOfCo ) -import GHC.Core.FamInstEnv -import Util -import Maybes ( isJust ) -import TysWiredIn -import TysPrim ( realWorldStatePrimTy ) -import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) ) -import GHC.Types.Unique.Set - -{- -************************************************************************ -* * -\subsection{Top level stuff} -* * -************************************************************************ --} - -dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram -dmdAnalProgram dflags fam_envs binds = do - let env = emptyAnalEnv dflags fam_envs - let binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds - dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $ - dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds - -- See Note [Stamp out space leaks in demand analysis] - seqBinds binds_plus_dmds `seq` return binds_plus_dmds - --- Analyse a (group of) top-level binding(s) -dmdAnalTopBind :: AnalEnv - -> CoreBind - -> (AnalEnv, CoreBind) -dmdAnalTopBind env (NonRec id rhs) - = (extendAnalEnv TopLevel env id' (idStrictness id'), NonRec id' rhs') - where - ( _, id', rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs - -dmdAnalTopBind env (Rec pairs) - = (env', Rec pairs') - where - (env', _, pairs') = dmdFix TopLevel env cleanEvalDmd pairs - -- We get two iterations automatically - -- c.f. the NonRec case above - -{- Note [Stamp out space leaks in demand analysis] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The demand analysis pass outputs a new copy of the Core program in -which binders have been annotated with demand and strictness -information. It's tiresome to ensure that this information is fully -evaluated everywhere that we produce it, so we just run a single -seqBinds over the output before returning it, to ensure that there are -no references holding on to the input Core program. - -This makes a ~30% reduction in peak memory usage when compiling -DynFlags (cf #9675 and #13426). - -This is particularly important when we are doing late demand analysis, -since we don't do a seqBinds at any point thereafter. Hence code -generation would hold on to an extra copy of the Core program, via -unforced thunks in demand or strictness information; and it is the -most memory-intensive part of the compilation process, so this added -seqBinds makes a big difference in peak memory usage. --} - - -{- -************************************************************************ -* * -\subsection{The analyser itself} -* * -************************************************************************ - -Note [Ensure demand is strict] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important not to analyse e with a lazy demand because -a) When we encounter case s of (a,b) -> - we demand s with U(d1d2)... but if the overall demand is lazy - that is wrong, and we'd need to reduce the demand on s, - which is inconvenient -b) More important, consider - f (let x = R in x+x), where f is lazy - We still want to mark x as demanded, because it will be when we - enter the let. If we analyse f's arg with a Lazy demand, we'll - just mark x as Lazy -c) The application rule wouldn't be right either - Evaluating (f x) in a L demand does *not* cause - evaluation of f in a C(L) demand! --} - --- If e is complicated enough to become a thunk, its contents will be evaluated --- at most once, so oneify it. -dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand -dmdTransformThunkDmd e - | exprIsTrivial e = id - | otherwise = oneifyDmd - --- Do not process absent demands --- Otherwise act like in a normal demand analysis --- See ↦* relation in the Cardinality Analysis paper -dmdAnalStar :: AnalEnv - -> Demand -- This one takes a *Demand* - -> CoreExpr -- Should obey the let/app invariant - -> (BothDmdArg, CoreExpr) -dmdAnalStar env dmd e - | (dmd_shell, cd) <- toCleanDmd dmd - , (dmd_ty, e') <- dmdAnal env cd e - = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e ) - -- The argument 'e' should satisfy the let/app invariant - -- See Note [Analysing with absent demand] in GHC.Types.Demand - (postProcessDmdType dmd_shell dmd_ty, e') - --- Main Demand Analsysis machinery -dmdAnal, dmdAnal' :: AnalEnv - -> CleanDemand -- The main one takes a *CleanDemand* - -> CoreExpr -> (DmdType, CoreExpr) - --- The CleanDemand is always strict and not absent --- See Note [Ensure demand is strict] - -dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ - dmdAnal' env d e - -dmdAnal' _ _ (Lit lit) = (nopDmdType, Lit lit) -dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact -dmdAnal' _ _ (Coercion co) - = (unitDmdType (coercionDmdEnv co), Coercion co) - -dmdAnal' env dmd (Var var) - = (dmdTransform env var dmd, Var var) - -dmdAnal' env dmd (Cast e co) - = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co) - where - (dmd_ty, e') = dmdAnal env dmd e - -dmdAnal' env dmd (Tick t e) - = (dmd_ty, Tick t e') - where - (dmd_ty, e') = dmdAnal env dmd e - -dmdAnal' env dmd (App fun (Type ty)) - = (fun_ty, App fun' (Type ty)) - where - (fun_ty, fun') = dmdAnal env dmd fun - --- Lots of the other code is there to make this --- beautiful, compositional, application rule :-) -dmdAnal' env dmd (App fun arg) - = -- This case handles value arguments (type args handled above) - -- Crucially, coercions /are/ handled here, because they are - -- value arguments (#10288) - let - call_dmd = mkCallDmd dmd - (fun_ty, fun') = dmdAnal env call_dmd fun - (arg_dmd, res_ty) = splitDmdTy fun_ty - (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg - in --- pprTrace "dmdAnal:app" (vcat --- [ text "dmd =" <+> ppr dmd --- , text "expr =" <+> ppr (App fun arg) --- , text "fun dmd_ty =" <+> ppr fun_ty --- , text "arg dmd =" <+> ppr arg_dmd --- , text "arg dmd_ty =" <+> ppr arg_ty --- , text "res dmd_ty =" <+> ppr res_ty --- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ]) - (res_ty `bothDmdType` arg_ty, App fun' arg') - -dmdAnal' env dmd (Lam var body) - | isTyVar var - = let - (body_ty, body') = dmdAnal env dmd body - in - (body_ty, Lam var body') - - | otherwise - = let (body_dmd, defer_and_use) = peelCallDmd dmd - -- body_dmd: a demand to analyze the body - - (body_ty, body') = dmdAnal env body_dmd body - (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty var - in - (postProcessUnsat defer_and_use lam_ty, Lam var' body') - -dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)]) - -- Only one alternative with a product constructor - | let tycon = dataConTyCon dc - , isJust (isDataProductTyCon_maybe tycon) - , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon - = let - env_alt = env { ae_rec_tc = rec_tc' } - (rhs_ty, rhs') = dmdAnal env_alt dmd rhs - (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs - (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr - id_dmds = addCaseBndrDmd case_bndr_dmd dmds - alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2 - | otherwise = alt_ty2 - - -- Compute demand on the scrutinee - -- See Note [Demand on scrutinee of a product case] - scrut_dmd = mkProdDmd id_dmds - (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut - res_ty = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty - case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd - bndrs' = setBndrsDemandInfo bndrs id_dmds - in --- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut --- , text "dmd" <+> ppr dmd --- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') --- , text "id_dmds" <+> ppr id_dmds --- , text "scrut_dmd" <+> ppr scrut_dmd --- , text "scrut_ty" <+> ppr scrut_ty --- , text "alt_ty" <+> ppr alt_ty2 --- , text "res_ty" <+> ppr res_ty ]) $ - (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')]) - -dmdAnal' env dmd (Case scrut case_bndr ty alts) - = let -- Case expression with multiple alternatives - (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts - (scrut_ty, scrut') = dmdAnal env cleanEvalDmd scrut - (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr - -- NB: Base case is botDmdType, for empty case alternatives - -- This is a unit for lubDmdType, and the right result - -- when there really are no alternatives - res_ty = alt_ty `bothDmdType` toBothDmdArg scrut_ty - in --- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut --- , text "scrut_ty" <+> ppr scrut_ty --- , text "alt_tys" <+> ppr alt_tys --- , text "alt_ty" <+> ppr alt_ty --- , text "res_ty" <+> ppr res_ty ]) $ - (res_ty, Case scrut' case_bndr' ty alts') - --- Let bindings can be processed in two ways: --- Down (RHS before body) or Up (body before RHS). --- The following case handle the up variant. --- --- It is very simple. For let x = rhs in body --- * Demand-analyse 'body' in the current environment --- * Find the demand, 'rhs_dmd' placed on 'x' by 'body' --- * Demand-analyse 'rhs' in 'rhs_dmd' --- --- This is used for a non-recursive local let without manifest lambdas. --- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnal' env dmd (Let (NonRec id rhs) body) - | useLetUp id - = (final_ty, Let (NonRec id' rhs') body') - where - (body_ty, body') = dmdAnal env dmd body - (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id - id' = setIdDemandInfo id id_dmd - - (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs - final_ty = body_ty' `bothDmdType` rhs_ty - -dmdAnal' env dmd (Let (NonRec id rhs) body) - = (body_ty2, Let (NonRec id2 rhs') body') - where - (lazy_fv, id1, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs - env1 = extendAnalEnv NotTopLevel env id1 (idStrictness id1) - (body_ty, body') = dmdAnal env1 dmd body - (body_ty1, id2) = annotateBndr env body_ty id1 - body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables] - - -- If the actual demand is better than the vanilla call - -- demand, you might think that we might do better to re-analyse - -- the RHS with the stronger demand. - -- But (a) That seldom happens, because it means that *every* path in - -- the body of the let has to use that stronger demand - -- (b) It often happens temporarily in when fixpointing, because - -- the recursive function at first seems to place a massive demand. - -- But we don't want to go to extra work when the function will - -- probably iterate to something less demanding. - -- In practice, all the times the actual demand on id2 is more than - -- the vanilla call demand seem to be due to (b). So we don't - -- bother to re-analyse the RHS. - -dmdAnal' env dmd (Let (Rec pairs) body) - = let - (env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs - (body_ty, body') = dmdAnal env' dmd body - body_ty1 = deleteFVs body_ty (map fst pairs) - body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables] - in - body_ty2 `seq` - (body_ty2, Let (Rec pairs') body') - -io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool --- See Note [IO hack in the demand analyser] -io_hack_reqd scrut con bndrs - | (bndr:_) <- bndrs - , con == tupleDataCon Unboxed 2 - , idType bndr `eqType` realWorldStatePrimTy - , (fun, _) <- collectArgs scrut - = case fun of - Var f -> not (isPrimOpId f) - _ -> True - | otherwise - = False - -dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var) -dmdAnalAlt env dmd case_bndr (con,bndrs,rhs) - | null bndrs -- Literals, DEFAULT, and nullary constructors - , (rhs_ty, rhs') <- dmdAnal env dmd rhs - = (rhs_ty, (con, [], rhs')) - - | otherwise -- Non-nullary data constructors - , (rhs_ty, rhs') <- dmdAnal env dmd rhs - , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs - , let case_bndr_dmd = findIdDemand alt_ty case_bndr - id_dmds = addCaseBndrDmd case_bndr_dmd dmds - = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs')) - - -{- Note [IO hack in the demand analyser] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's a hack here for I/O operations. Consider - - case foo x s of { (# s', r #) -> y } - -Is this strict in 'y'? Often not! If foo x s performs some observable action -(including raising an exception with raiseIO#, modifying a mutable variable, or -even ending the program normally), then we must not force 'y' (which may fail -to terminate) until we have performed foo x s. - -Hackish solution: spot the IO-like situation and add a virtual branch, -as if we had - case foo x s of - (# s, r #) -> y - other -> return () -So the 'y' isn't necessarily going to be evaluated - -A more complete example (#148, #1592) where this shows up is: - do { let len = ; - ; when (...) (exitWith ExitSuccess) - ; print len } - -However, consider - f x s = case getMaskingState# s of - (# s, r #) -> - case x of I# x2 -> ... - -Here it is terribly sad to make 'f' lazy in 's'. After all, -getMaskingState# is not going to diverge or throw an exception! This -situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle -(on an MVar not an Int), and made a material difference. - -So if the scrutinee is a primop call, we *don't* apply the -state hack: - - If it is a simple, terminating one like getMaskingState, - applying the hack is over-conservative. - - If the primop is raise# then it returns bottom, so - the case alternatives are already discarded. - - If the primop can raise a non-IO exception, like - divide by zero or seg-fault (eg writing an array - out of bounds) then we don't mind evaluating 'x' first. - -Note [Demand on the scrutinee of a product case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When figuring out the demand on the scrutinee of a product case, -we use the demands of the case alternative, i.e. id_dmds. -But note that these include the demand on the case binder; -see Note [Demand on case-alternative binders] in GHC.Types.Demand. -This is crucial. Example: - f x = case x of y { (a,b) -> k y a } -If we just take scrut_demand = U(L,A), then we won't pass x to the -worker, so the worker will rebuild - x = (a, absent-error) -and that'll crash. - -Note [Aggregated demand for cardinality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use different strategies for strictness and usage/cardinality to -"unleash" demands captured on free variables by bindings. Let us -consider the example: - -f1 y = let {-# NOINLINE h #-} - h = y - in (h, h) - -We are interested in obtaining cardinality demand U1 on |y|, as it is -used only in a thunk, and, therefore, is not going to be updated any -more. Therefore, the demand on |y|, captured and unleashed by usage of -|h| is U1. However, if we unleash this demand every time |h| is used, -and then sum up the effects, the ultimate demand on |y| will be U1 + -U1 = U. In order to avoid it, we *first* collect the aggregate demand -on |h| in the body of let-expression, and only then apply the demand -transformer: - -transf[x](U) = {y |-> U1} - -so the resulting demand on |y| is U1. - -The situation is, however, different for strictness, where this -aggregating approach exhibits worse results because of the nature of -|both| operation for strictness. Consider the example: - -f y c = - let h x = y |seq| x - in case of - True -> h True - False -> y - -It is clear that |f| is strict in |y|, however, the suggested analysis -will infer from the body of |let| that |h| is used lazily (as it is -used in one branch only), therefore lazy demand will be put on its -free variable |y|. Conversely, if the demand on |h| is unleashed right -on the spot, we will get the desired result, namely, that |f| is -strict in |y|. - - -************************************************************************ -* * - Demand transformer -* * -************************************************************************ --} - -dmdTransform :: AnalEnv -- The strictness environment - -> Id -- The function - -> CleanDemand -- The demand on the function - -> DmdType -- The demand type of the function in this context - -- Returned DmdEnv includes the demand on - -- this function plus demand on its free variables - -dmdTransform env var dmd - | isDataConWorkId var -- Data constructor - = dmdTransformDataConSig (idArity var) (idStrictness var) dmd - - | gopt Opt_DmdTxDictSel (ae_dflags env), - Just _ <- isClassOpId_maybe var -- Dictionary component selector - = dmdTransformDictSelSig (idStrictness var) dmd - - | isGlobalId var -- Imported function - , let res = dmdTransformSig (idStrictness var) dmd - = -- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) - res - - | Just (sig, top_lvl) <- lookupSigEnv env var -- Local letrec bound thing - , let fn_ty = dmdTransformSig sig dmd - = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $ - if isTopLevel top_lvl - then fn_ty -- Don't record top level things - else addVarDmd fn_ty var (mkOnceUsedDmd dmd) - - | otherwise -- Local non-letrec-bound thing - = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd)) - -{- -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ --} - --- Recursive bindings -dmdFix :: TopLevelFlag - -> AnalEnv -- Does not include bindings for this binding - -> CleanDemand - -> [(Id,CoreExpr)] - -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info - -dmdFix top_lvl env let_dmd orig_pairs - = loop 1 initial_pairs - where - bndrs = map fst orig_pairs - - -- See Note [Initialising strictness] - initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ] - | otherwise = orig_pairs - - -- If fixed-point iteration does not yield a result we use this instead - -- See Note [Safe abortion in the fixed-point iteration] - abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)]) - abort = (env, lazy_fv', zapped_pairs) - where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs) - -- Note [Lazy and unleashable free variables] - non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs' - lazy_fv' = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs - zapped_pairs = zapIdStrictness pairs' - - -- The fixed-point varies the idStrictness field of the binders, and terminates if that - -- annotation does not change any more. - loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) - loop n pairs - | found_fixpoint = (final_anal_env, lazy_fv, pairs') - | n == 10 = abort - | otherwise = loop (n+1) pairs' - where - found_fixpoint = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs - first_round = n == 1 - (lazy_fv, pairs') = step first_round pairs - final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') - - step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) - step first_round pairs = (lazy_fv, pairs') - where - -- In all but the first iteration, delete the virgin flag - start_env | first_round = env - | otherwise = nonVirgin env - - start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv) - - ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs - -- mapAccumL: Use the new signature to do the next pair - -- The occurrence analyser has arranged them in a good order - -- so this can significantly reduce the number of iterations needed - - my_downRhs (env, lazy_fv) (id,rhs) - = ((env', lazy_fv'), (id', rhs')) - where - (lazy_fv1, id', rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs - lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1 - env' = extendAnalEnv top_lvl env id (idStrictness id') - - - zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] - zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ] - -{- -Note [Safe abortion in the fixed-point iteration] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Fixed-point iteration may fail to terminate. But we cannot simply give up and -return the environment and code unchanged! We still need to do one additional -round, for two reasons: - - * To get information on used free variables (both lazy and strict!) - (see Note [Lazy and unleashable free variables]) - * To ensure that all expressions have been traversed at least once, and any left-over - strictness annotations have been updated. - -This final iteration does not add the variables to the strictness signature -environment, which effectively assigns them 'nopSig' (see "getStrictness") - --} - --- Let bindings can be processed in two ways: --- Down (RHS before body) or Up (body before RHS). --- dmdAnalRhsLetDown implements the Down variant: --- * assuming a demand of --- * looking at the definition --- * determining a strictness signature --- --- It is used for toplevel definition, recursive definitions and local --- non-recursive definitions that have manifest lambdas. --- Local non-recursive definitions without a lambda are handled with LetUp. --- --- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnalRhsLetDown - :: Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive - -> AnalEnv -> CleanDemand - -> Id -> CoreExpr - -> (DmdEnv, Id, CoreExpr) --- Process the RHS of the binding, add the strictness signature --- to the Id, and augment the environment with the signature as well. -dmdAnalRhsLetDown rec_flag env let_dmd id rhs - = (lazy_fv, id', rhs') - where - rhs_arity = idArity id - rhs_dmd - -- See Note [Demand analysis for join points] - -- See Note [Invariants on join points] invariant 2b, in GHC.Core - -- rhs_arity matches the join arity of the join point - | isJoinId id - = mkCallDmds rhs_arity let_dmd - | otherwise - -- NB: rhs_arity - -- See Note [Demand signatures are computed for a threshold demand based on idArity] - = mkRhsDmd env rhs_arity rhs - (DmdType rhs_fv rhs_dmds rhs_div, rhs') - = dmdAnal env rhs_dmd rhs - -- TODO: Won't the following line unnecessarily trim down arity for join - -- points returning a lambda in a C(S) context? - sig = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div) - id' = setIdStrictness id sig - -- See Note [NOINLINE and strictness] - - - -- See Note [Aggregated demand for cardinality] - rhs_fv1 = case rec_flag of - Just bs -> reuseEnv (delVarEnvList rhs_fv bs) - Nothing -> rhs_fv - - -- See Note [Lazy and unleashable free variables] - (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1 - is_thunk = not (exprIsHNF rhs) && not (isJoinId id) - --- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for --- unleashing on the given function's @rhs@, by creating --- a call demand of @rhs_arity@ --- See Historical Note [Product demands for function body] -mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand -mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity cleanEvalDmd - --- | If given the let-bound 'Id', 'useLetUp' determines whether we should --- process the binding up (body before rhs) or down (rhs before body). --- --- We use LetDown if there is a chance to get a useful strictness signature to --- unleash at call sites. LetDown is generally more precise than LetUp if we can --- correctly guess how it will be used in the body, that is, for which incoming --- demand the strictness signature should be computed, which allows us to --- unleash higher-order demands on arguments at call sites. This is mostly the --- case when --- --- * The binding takes any arguments before performing meaningful work (cf. --- 'idArity'), in which case we are interested to see how it uses them. --- * The binding is a join point, hence acting like a function, not a value. --- As a big plus, we know *precisely* how it will be used in the body; since --- it's always tail-called, we can directly unleash the incoming demand of --- the let binding on its RHS when computing a strictness signature. See --- [Demand analysis for join points]. --- --- Thus, if the binding is not a join point and its arity is 0, we have a thunk --- and use LetUp, implying that we have no usable demand signature available --- when we analyse the let body. --- --- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free --- vars at most once, regardless of how many times it was forced in the body. --- This makes a real difference wrt. usage demands. The other reason is being --- able to unleash a more precise product demand on its RHS once we know how the --- thunk was used in the let body. --- --- Characteristic examples, always assuming a single evaluation: --- --- * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that --- the expression uses @y@ at most once. --- * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that --- @b@ is absent. --- * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that --- the expression uses @y@ strictly, because we have @f@'s demand signature --- available at the call site. --- * @join exit = 2*y in if a then exit else if b then exit else 3*y@ => --- LetDown. Compared to LetUp, we find out that the expression uses @y@ --- strictly, because we can unleash @exit@'s signature at each call site. --- * For a more convincing example with join points, see Note [Demand analysis --- for join points]. --- -useLetUp :: Var -> Bool -useLetUp f = idArity f == 0 && not (isJoinId f) - -{- Note [Demand analysis for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - g :: (Int,Int) -> Int - g (p,q) = p+q - - f :: T -> Int -> Int - f x p = g (join j y = (p,y) - in case x of - A -> j 3 - B -> j 4 - C -> (p,7)) - -If j was a vanilla function definition, we'd analyse its body with -evalDmd, and think that it was lazy in p. But for join points we can -do better! We know that j's body will (if called at all) be evaluated -with the demand that consumes the entire join-binding, in this case -the argument demand from g. Whizzo! g evaluates both components of -its argument pair, so p will certainly be evaluated if j is called. - -For f to be strict in p, we need /all/ paths to evaluate p; in this -case the C branch does so too, so we are fine. So, as usual, we need -to transport demands on free variables to the call site(s). Compare -Note [Lazy and unleashable free variables]. - -The implementation is easy. When analysing a join point, we can -analyse its body with the demand from the entire join-binding (written -let_dmd here). - -Another win for join points! #13543. - -However, note that the strictness signature for a join point can -look a little puzzling. E.g. - - (join j x = \y. error "urk") - (in case v of ) - ( A -> j 3 ) x - ( B -> j 4 ) - ( C -> \y. blah ) - -The entire thing is in a C(S) context, so j's strictness signature -will be [A]b -meaning one absent argument, returns bottom. That seems odd because -there's a \y inside. But it's right because when consumed in a C(1) -context the RHS of the join point is indeed bottom. - -Note [Demand signatures are computed for a threshold demand based on idArity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We compute demand signatures assuming idArity incoming arguments to approximate -behavior for when we have a call site with at least that many arguments. 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]). - -Because idArity of a function varies independently of its cardinality properties -(cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode -the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth' -(cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand). It is unsound to -unleash a demand signature when the incoming number of arguments is less than -that. See Note [What are demand signatures?] for more details on soundness. - -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. - -There might be functions for which we might want to analyse for more incoming -arguments than idArity. Example: - - f x = - if expensive - then \y -> ... y ... - else \y -> ... y ... - -We'd analyse `f` under a unary call demand C(S), corresponding to idArity -being 1. That's enough to look under the manifest lambda and find out how a -unary call would use `x`, but not enough to look into the lambdas in the if -branches. - -On the other hand, if we analysed for call demand C(C(S)), we'd get useful -strictness info for `y` (and more precise info on `x`) and possibly CPR -information, but - - * We would no longer be able to unleash the signature at unary call sites - * Performing the worker/wrapper split based on this information would be - implicitly eta-expanding `f`, playing fast and loose with divergence and - even being unsound in the presence of newtypes, so we refrain from doing so. - Also see Note [Don't eta expand in w/w] in GHC.Core.Op.WorkWrap. - -Since we only compute one signature, we do so for arity 1. Computing multiple -signatures for different arities (i.e., polyvariance) would be entirely -possible, if it weren't for the additional runtime and implementation -complexity. - -Note [idArity varies independently of dmdTypeDepth] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to check in GHC.Core.Lint that dmdTypeDepth <= idArity for a let-bound -identifier. But that means we would have to zap demand signatures every time we -reset or decrease arity. That's an unnecessary dependency, because - - * The demand signature captures a semantic property that is independent of - what the binding's current arity is - * idArity is analysis information itself, thus volatile - * We already *have* dmdTypeDepth, wo why not just use it to encode the - threshold for when to unleash the signature - (cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand) - -Consider the following expression, for example: - - (let go x y = `x` seq ... in go) |> co - -`go` might have a strictness signature of ``. The simplifier will identify -`go` as a nullary join point through `joinPointBinding_maybe` and float the -coercion into the binding, leading to an arity decrease: - - join go = (\x y -> `x` seq ...) |> co in go - -With the CoreLint check, we would have to zap `go`'s perfectly viable strictness -signature. - -Note [What are demand signatures?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Demand analysis interprets expressions in the abstract domain of demand -transformers. Given an incoming demand we put an expression under, its abstract -transformer gives us back a demand type denoting how other things (like -arguments and free vars) were used when the expression was evaluated. -Here's an example: - - f x y = - if x + expensive - then \z -> z + y * ... - else \z -> z * ... - -The abstract transformer (let's call it F_e) of the if expression (let's call it -e) would transform an incoming head demand into a demand type like -{x->,y->}. In pictures: - - Demand ---F_e---> DmdType - {x->,y->} - -Let's assume that the demand transformers we compute for an expression are -correct wrt. to some concrete semantics for Core. How do demand signatures fit -in? They are strange beasts, given that they come with strict rules when to -it's sound to unleash them. - -Fortunately, we can formalise the rules with Galois connections. Consider -f's strictness signature, {}. It's a single-point approximation of -the actual abstract transformer of f's RHS for arity 2. So, what happens is that -we abstract *once more* from the abstract domain we already are in, replacing -the incoming Demand by a simple lattice with two elements denoting incoming -arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom -element). Here's the diagram: - - A_2 -----f_f----> DmdType - ^ | - | α γ | - | v - Demand ---F_f---> DmdType - -With - α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness - α(_) = <2 - γ(ty) = ty -and F_f being the abstract transformer of f's RHS and f_f being the abstracted -abstract transformer computable from our demand signature simply by - - f_f(>=2) = {} - f_f(<2) = postProcessUnsat {} - -where postProcessUnsat makes a proper top element out of the given demand type. - -Note [Demand analysis for trivial right-hand sides] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - foo = plusInt |> co -where plusInt is an arity-2 function with known strictness. Clearly -we want plusInt's strictness to propagate to foo! But because it has -no manifest lambdas, it won't do so automatically, and indeed 'co' might -have type (Int->Int->Int) ~ T. - -Fortunately, GHC.Core.Arity gives 'foo' arity 2, which is enough for LetDown to -forward plusInt's demand signature, and all is well (see Note [Newtype arity] in -GHC.Core.Arity)! A small example is the test case NewtypeArity. - - -Historical Note [Product demands for function body] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In 2013 I spotted this example, in shootout/binary_trees: - - Main.check' = \ b z ds. case z of z' { I# ip -> - case ds_d13s of - Main.Nil -> z' - Main.Node s14k s14l s14m -> - Main.check' (not b) - (Main.check' b - (case b { - False -> I# (-# s14h s14k); - True -> I# (+# s14h s14k) - }) - s14l) - s14m } } } - -Here we *really* want to unbox z, even though it appears to be used boxed in -the Nil case. Partly the Nil case is not a hot path. But more specifically, -the whole function gets the CPR property if we do. - -That motivated using a demand of C(C(C(S(L,L)))) for the RHS, where -(solely because the result was a product) we used a product demand -(albeit with lazy components) for the body. But that gives very silly -behaviour -- see #17932. Happily it turns out now to be entirely -unnecessary: we get good results with C(C(C(S))). So I simply -deleted the special case. - -************************************************************************ -* * -\subsection{Strictness signatures and types} -* * -************************************************************************ --} - -unitDmdType :: DmdEnv -> DmdType -unitDmdType dmd_env = DmdType dmd_env [] topDiv - -coercionDmdEnv :: Coercion -> DmdEnv -coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co) - -- The VarSet from coVarsOfCo is really a VarEnv Var - -addVarDmd :: DmdType -> Var -> Demand -> DmdType -addVarDmd (DmdType fv ds res) var dmd - = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res - -addLazyFVs :: DmdType -> DmdEnv -> DmdType -addLazyFVs dmd_ty lazy_fvs - = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs - -- Using bothDmdType (rather than just both'ing the envs) - -- is vital. Consider - -- let f = \x -> (x,y) - -- in error (f 3) - -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L - -- demand with the bottom coming up from 'error' - -- - -- I got a loop in the fixpointer without this, due to an interaction - -- with the lazy_fv filtering in dmdAnalRhsLetDown. Roughly, it was - -- letrec f n x - -- = letrec g y = x `fatbar` - -- letrec h z = z + ...g... - -- in h (f (n-1) x) - -- in ... - -- In the initial iteration for f, f=Bot - -- Suppose h is found to be strict in z, but the occurrence of g in its RHS - -- is lazy. Now consider the fixpoint iteration for g, esp the demands it - -- places on its free variables. Suppose it places none. Then the - -- x `fatbar` ...call to h... - -- will give a x->V demand for x. That turns into a L demand for x, - -- which floats out of the defn for h. Without the modifyEnv, that - -- L demand doesn't get both'd with the Bot coming up from the inner - -- call to f. So we just get an L demand for x for g. - -{- -Note [Do not strictify the argument dictionaries of a dfun] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker can tie recursive knots involving dfuns, so we do the -conservative thing and refrain from strictifying a dfun's argument -dictionaries. --} - -setBndrsDemandInfo :: [Var] -> [Demand] -> [Var] -setBndrsDemandInfo (b:bs) (d:ds) - | isTyVar b = b : setBndrsDemandInfo bs (d:ds) - | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds -setBndrsDemandInfo [] ds = ASSERT( null ds ) [] -setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) - -annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var) --- The returned env has the var deleted --- The returned var is annotated with demand info --- according to the result demand of the provided demand type --- No effect on the argument demands -annotateBndr env dmd_ty var - | isId var = (dmd_ty', setIdDemandInfo var dmd) - | otherwise = (dmd_ty, var) - where - (dmd_ty', dmd) = findBndrDmd env False dmd_ty var - -annotateLamIdBndr :: AnalEnv - -> DFunFlag -- is this lambda at the top of the RHS of a dfun? - -> DmdType -- Demand type of body - -> Id -- Lambda binder - -> (DmdType, -- Demand type of lambda - Id) -- and binder annotated with demand - -annotateLamIdBndr env arg_of_dfun dmd_ty id --- For lambdas we add the demand to the argument demands --- Only called for Ids - = ASSERT( isId id ) - -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $ - (final_ty, setIdDemandInfo id dmd) - where - -- Watch out! See note [Lambda-bound unfoldings] - final_ty = case maybeUnfoldingTemplate (idUnfolding id) of - Nothing -> main_ty - Just unf -> main_ty `bothDmdType` unf_ty - where - (unf_ty, _) = dmdAnalStar env dmd unf - - main_ty = addDemand dmd dmd_ty' - (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id - -deleteFVs :: DmdType -> [Var] -> DmdType -deleteFVs (DmdType fvs dmds res) bndrs - = DmdType (delVarEnvList fvs bndrs) dmds res - -{- -Note [NOINLINE and strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The strictness analyser used to have a HACK which ensured that NOINLNE -things were not strictness-analysed. The reason was unsafePerformIO. -Left to itself, the strictness analyser would discover this strictness -for unsafePerformIO: - unsafePerformIO: C(U(AV)) -But then consider this sub-expression - unsafePerformIO (\s -> let r = f x in - case writeIORef v r s of (# s1, _ #) -> - (# s1, r #) -The strictness analyser will now find that r is sure to be eval'd, -and may then hoist it out. This makes tests/lib/should_run/memo002 -deadlock. - -Solving this by making all NOINLINE things have no strictness info is overkill. -In particular, it's overkill for runST, which is perfectly respectable. -Consider - f x = runST (return x) -This should be strict in x. - -So the new plan is to define unsafePerformIO using the 'lazy' combinator: - - unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) - -Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is -magically NON-STRICT, and is inlined after strictness analysis. So -unsafePerformIO will look non-strict, and that's what we want. - -Now we don't need the hack in the strictness analyser. HOWEVER, this -decision does mean that even a NOINLINE function is not entirely -opaque: some aspect of its implementation leaks out, notably its -strictness. For example, if you have a function implemented by an -error stub, but which has RULES, you may want it not to be eliminated -in favour of error! - -Note [Lazy and unleashable free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We put the strict and once-used FVs in the DmdType of the Id, so -that at its call sites we unleash demands on its strict fvs. -An example is 'roll' in imaginary/wheel-sieve2 -Something like this: - roll x = letrec - go y = if ... then roll (x-1) else x+1 - in - go ms -We want to see that roll is strict in x, which is because -go is called. So we put the DmdEnv for x in go's DmdType. - -Another example: - - f :: Int -> Int -> Int - f x y = let t = x+1 - h z = if z==0 then t else - if z==1 then x+1 else - x + h (z-1) - in h y - -Calling h does indeed evaluate x, but we can only see -that if we unleash a demand on x at the call site for t. - -Incidentally, here's a place where lambda-lifting h would -lose the cigar --- we couldn't see the joint strictness in t/x - - ON THE OTHER HAND - -We don't want to put *all* the fv's from the RHS into the -DmdType. Because - - * it makes the strictness signatures larger, and hence slows down fixpointing - -and - - * it is useless information at the call site anyways: - For lazy, used-many times fv's we will never get any better result than - that, no matter how good the actual demand on the function at the call site - is (unless it is always absent, but then the whole binder is useless). - -Therefore we exclude lazy multiple-used fv's from the environment in the -DmdType. - -But now the signature lies! (Missing variables are assumed to be absent.) To -make up for this, the code that analyses the binding keeps the demand on those -variable separate (usually called "lazy_fv") and adds it to the demand of the -whole binding later. - -What if we decide _not_ to store a strictness signature for a binding at all, as -we do when aborting a fixed-point iteration? The we risk losing the information -that the strict variables are being used. In that case, we take all free variables -mentioned in the (unsound) strictness signature, conservatively approximate the -demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix". - - -Note [Lambda-bound unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow a lambda-bound variable to carry an unfolding, a facility that is used -exclusively for join points; see Note [Case binders and join points]. If so, -we must be careful to demand-analyse the RHS of the unfolding! Example - \x. \y{=Just x}. -Then if uses 'y', then transitively it uses 'x', and we must not -forget that fact, otherwise we might make 'x' absent when it isn't. - - -************************************************************************ -* * -\subsection{Strictness signatures} -* * -************************************************************************ --} - -type DFunFlag = Bool -- indicates if the lambda being considered is in the - -- sequence of lambdas at the top of the RHS of a dfun -notArgOfDfun :: DFunFlag -notArgOfDfun = False - -data AnalEnv - = AE { ae_dflags :: DynFlags - , ae_sigs :: SigEnv - , ae_virgin :: Bool -- True on first iteration only - -- See Note [Initialising strictness] - , ae_rec_tc :: RecTcChecker - , ae_fam_envs :: FamInstEnvs - } - - -- We use the se_env to tell us whether to - -- record info about a variable in the DmdEnv - -- We do so if it's a LocalId, but not top-level - -- - -- The DmdEnv gives the demand on the free vars of the function - -- when it is given enough args to satisfy the strictness signature - -type SigEnv = VarEnv (StrictSig, TopLevelFlag) - -instance Outputable AnalEnv where - ppr (AE { ae_sigs = env, ae_virgin = virgin }) - = text "AE" <+> braces (vcat - [ text "ae_virgin =" <+> ppr virgin - , text "ae_sigs =" <+> ppr env ]) - -emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv -emptyAnalEnv dflags fam_envs - = AE { ae_dflags = dflags - , ae_sigs = emptySigEnv - , ae_virgin = True - , ae_rec_tc = initRecTc - , ae_fam_envs = fam_envs - } - -emptySigEnv :: SigEnv -emptySigEnv = emptyVarEnv - --- | Extend an environment with the strictness IDs attached to the id -extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv -extendAnalEnvs top_lvl env vars - = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } - -extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv -extendSigEnvs top_lvl sigs vars - = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars] - -extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv -extendAnalEnv top_lvl env var sig - = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig } - -extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv -extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) - -lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag) -lookupSigEnv env id = lookupVarEnv (ae_sigs env) id - -nonVirgin :: AnalEnv -> AnalEnv -nonVirgin env = env { ae_virgin = False } - -findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand]) --- Return the demands on the Ids in the [Var] -findBndrsDmds env dmd_ty bndrs - = go dmd_ty bndrs - where - go dmd_ty [] = (dmd_ty, []) - go dmd_ty (b:bs) - | isId b = let (dmd_ty1, dmds) = go dmd_ty bs - (dmd_ty2, dmd) = findBndrDmd env False dmd_ty1 b - in (dmd_ty2, dmd : dmds) - | otherwise = go dmd_ty bs - -findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand) --- See Note [Trimming a demand to a type] in GHC.Types.Demand -findBndrDmd env arg_of_dfun dmd_ty id - = (dmd_ty', dmd') - where - dmd' = strictify $ - trimToType starting_dmd (findTypeShape fam_envs id_ty) - - (dmd_ty', starting_dmd) = peelFV dmd_ty id - - id_ty = idType id - - strictify dmd - | gopt Opt_DictsStrict (ae_dflags env) - -- We never want to strictify a recursive let. At the moment - -- annotateBndr is only call for non-recursive lets; if that - -- changes, we need a RecFlag parameter and another guard here. - , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun] - = strictifyDictDmd id_ty dmd - | otherwise - = dmd - - fam_envs = ae_fam_envs env - -{- Note [Initialising strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See section 9.2 (Finding fixpoints) of the paper. - -Our basic plan is to initialise the strictness of each Id in a -recursive group to "bottom", and find a fixpoint from there. However, -this group B might be inside an *enclosing* recursive group A, in -which case we'll do the entire fixpoint shebang on for each iteration -of A. This can be illustrated by the following example: - -Example: - - f [] = [] - f (x:xs) = let g [] = f xs - g (y:ys) = y+1 : g ys - in g (h x) - -At each iteration of the fixpoint for f, the analyser has to find a -fixpoint for the enclosed function g. In the meantime, the demand -values for g at each iteration for f are *greater* than those we -encountered in the previous iteration for f. Therefore, we can begin -the fixpoint for g not with the bottom value but rather with the -result of the previous analysis. I.e., when beginning the fixpoint -process for g, we can start from the demand signature computed for g -previously and attached to the binding occurrence of g. - -To speed things up, we initialise each iteration of A (the enclosing -one) from the result of the last one, which is neatly recorded in each -binder. That way we make use of earlier iterations of the fixpoint -algorithm. (Cunning plan.) - -But on the *first* iteration we want to *ignore* the current strictness -of the Id, and start from "bottom". Nowadays the Id can have a current -strictness, because interface files record strictness for nested bindings. -To know when we are in the first iteration, we look at the ae_virgin -field of the AnalEnv. - - -Note [Final Demand Analyser run] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some of the information that the demand analyser determines is not always -preserved by the simplifier. For example, the simplifier will happily rewrite - \y [Demand=1*U] let x = y in x + x -to - \y [Demand=1*U] y + y -which is quite a lie. - -The once-used information is (currently) only used by the code -generator, though. So: - - * We zap the used-once info in the worker-wrapper; - see Note [Zapping Used Once info in WorkWrap] in - GHC.Core.Op.WorkWrap. - If it's not reliable, it's better not to have it at all. - - * Just before TidyCore, we add a pass of the demand analyser, - but WITHOUT subsequent worker/wrapper and simplifier, - right before TidyCore. See SimplCore.getCoreToDo. - - This way, correct information finds its way into the module interface - (strictness signatures!) and the code generator (single-entry thunks!) - -Note that, in contrast, the single-call information (C1(..)) /can/ be -relied upon, as the simplifier tends to be very careful about not -duplicating actual function calls. - -Also see #11731. --} diff --git a/compiler/GHC/Core/Op/Exitify.hs b/compiler/GHC/Core/Op/Exitify.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/Exitify.hs +++ /dev/null @@ -1,499 +0,0 @@ -module GHC.Core.Op.Exitify ( exitifyProgram ) where - -{- -Note [Exitification] -~~~~~~~~~~~~~~~~~~~~ - -This module implements Exitification. The goal is to pull as much code out of -recursive functions as possible, as the simplifier is better at inlining into -call-sites that are not in recursive functions. - -Example: - - let t = foo bar - joinrec go 0 x y = t (x*x) - go (n-1) x y = jump go (n-1) (x+y) - in … - -We’d like to inline `t`, but that does not happen: Because t is a thunk and is -used in a recursive function, doing so might lose sharing in general. In -this case, however, `t` is on the _exit path_ of `go`, so called at most once. -How do we make this clearly visible to the simplifier? - -A code path (i.e., an expression in a tail-recursive position) in a recursive -function is an exit path if it does not contain a recursive call. We can bind -this expression outside the recursive function, as a join-point. - -Example result: - - let t = foo bar - join exit x = t (x*x) - joinrec go 0 x y = jump exit x - go (n-1) x y = jump go (n-1) (x+y) - in … - -Now `t` is no longer in a recursive function, and good things happen! --} - -import GhcPrelude -import GHC.Types.Var -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Core -import GHC.Core.Utils -import State -import GHC.Types.Unique -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Core.FVs -import FastString -import GHC.Core.Type -import Util( mapSnd ) - -import Data.Bifunctor -import Control.Monad - --- | Traverses the AST, simply to find all joinrecs and call 'exitify' on them. --- The really interesting function is exitifyRec -exitifyProgram :: CoreProgram -> CoreProgram -exitifyProgram binds = map goTopLvl binds - where - goTopLvl (NonRec v e) = NonRec v (go in_scope_toplvl e) - goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs) - -- Top-level bindings are never join points - - in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds - - go :: InScopeSet -> CoreExpr -> CoreExpr - go _ e@(Var{}) = e - go _ e@(Lit {}) = e - go _ e@(Type {}) = e - go _ e@(Coercion {}) = e - go in_scope (Cast e' c) = Cast (go in_scope e') c - go in_scope (Tick t e') = Tick t (go in_scope e') - go in_scope (App e1 e2) = App (go in_scope e1) (go in_scope e2) - - go in_scope (Lam v e') - = Lam v (go in_scope' e') - where in_scope' = in_scope `extendInScopeSet` v - - go in_scope (Case scrut bndr ty alts) - = Case (go in_scope scrut) bndr ty (map go_alt alts) - where - in_scope1 = in_scope `extendInScopeSet` bndr - go_alt (dc, pats, rhs) = (dc, pats, go in_scope' rhs) - where in_scope' = in_scope1 `extendInScopeSetList` pats - - go in_scope (Let (NonRec bndr rhs) body) - = Let (NonRec bndr (go in_scope rhs)) (go in_scope' body) - where - in_scope' = in_scope `extendInScopeSet` bndr - - go in_scope (Let (Rec pairs) body) - | is_join_rec = mkLets (exitifyRec in_scope' pairs') body' - | otherwise = Let (Rec pairs') body' - where - is_join_rec = any (isJoinId . fst) pairs - in_scope' = in_scope `extendInScopeSetList` bindersOf (Rec pairs) - pairs' = mapSnd (go in_scope') pairs - body' = go in_scope' body - - --- | State Monad used inside `exitify` -type ExitifyM = State [(JoinId, CoreExpr)] - --- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as --- join-points outside the joinrec. -exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind] -exitifyRec in_scope pairs - = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs'] - where - -- We need the set of free variables of many subexpressions here, so - -- annotate the AST with them - -- see Note [Calculating free variables] - ann_pairs = map (second freeVars) pairs - - -- Which are the recursive calls? - recursive_calls = mkVarSet $ map fst pairs - - (pairs',exits) = (`runState` []) $ do - forM ann_pairs $ \(x,rhs) -> do - -- go past the lambdas of the join point - let (args, body) = collectNAnnBndrs (idJoinArity x) rhs - body' <- go args body - let rhs' = mkLams args body' - return (x, rhs') - - --------------------- - -- 'go' is the main working function. - -- It goes through the RHS (tail-call positions only), - -- checks if there are no more recursive calls, if so, abstracts over - -- variables bound on the way and lifts it out as a join point. - -- - -- ExitifyM is a state monad to keep track of floated binds - go :: [Var] -- ^ Variables that are in-scope here, but - -- not in scope at the joinrec; that is, - -- we must potentially abstract over them. - -- Invariant: they are kept in dependency order - -> CoreExprWithFVs -- ^ Current expression in tail position - -> ExitifyM CoreExpr - - -- We first look at the expression (no matter what it shape is) - -- and determine if we can turn it into a exit join point - go captured ann_e - | -- An exit expression has no recursive calls - let fvs = dVarSetToVarSet (freeVarsOf ann_e) - , disjointVarSet fvs recursive_calls - = go_exit captured (deAnnotate ann_e) fvs - - -- We could not turn it into a exit join point. So now recurse - -- into all expression where eligible exit join points might sit, - -- i.e. into all tail-call positions: - - -- Case right hand sides are in tail-call position - go captured (_, AnnCase scrut bndr ty alts) = do - alts' <- forM alts $ \(dc, pats, rhs) -> do - rhs' <- go (captured ++ [bndr] ++ pats) rhs - return (dc, pats, rhs') - return $ Case (deAnnotate scrut) bndr ty alts' - - go captured (_, AnnLet ann_bind body) - -- join point, RHS and body are in tail-call position - | AnnNonRec j rhs <- ann_bind - , Just join_arity <- isJoinId_maybe j - = do let (params, join_body) = collectNAnnBndrs join_arity rhs - join_body' <- go (captured ++ params) join_body - let rhs' = mkLams params join_body' - body' <- go (captured ++ [j]) body - return $ Let (NonRec j rhs') body' - - -- rec join point, RHSs and body are in tail-call position - | AnnRec pairs <- ann_bind - , isJoinId (fst (head pairs)) - = do let js = map fst pairs - pairs' <- forM pairs $ \(j,rhs) -> do - let join_arity = idJoinArity j - (params, join_body) = collectNAnnBndrs join_arity rhs - join_body' <- go (captured ++ js ++ params) join_body - let rhs' = mkLams params join_body' - return (j, rhs') - body' <- go (captured ++ js) body - return $ Let (Rec pairs') body' - - -- normal Let, only the body is in tail-call position - | otherwise - = do body' <- go (captured ++ bindersOf bind ) body - return $ Let bind body' - where bind = deAnnBind ann_bind - - -- Cannot be turned into an exit join point, but also has no - -- tail-call subexpression. Nothing to do here. - go _ ann_e = return (deAnnotate ann_e) - - --------------------- - go_exit :: [Var] -- Variables captured locally - -> CoreExpr -- An exit expression - -> VarSet -- Free vars of the expression - -> ExitifyM CoreExpr - -- go_exit deals with a tail expression that is floatable - -- out as an exit point; that is, it mentions no recursive calls - go_exit captured e fvs - -- Do not touch an expression that is already a join jump where all arguments - -- are captured variables. See Note [Idempotency] - -- But _do_ float join jumps with interesting arguments. - -- See Note [Jumps can be interesting] - | (Var f, args) <- collectArgs e - , isJoinId f - , all isCapturedVarArg args - = return e - - -- Do not touch a boring expression (see Note [Interesting expression]) - | not is_interesting - = return e - - -- Cannot float out if local join points are used, as - -- we cannot abstract over them - | captures_join_points - = return e - - -- We have something to float out! - | otherwise - = do { -- Assemble the RHS of the exit join point - let rhs = mkLams abs_vars e - avoid = in_scope `extendInScopeSetList` captured - -- Remember this binding under a suitable name - ; v <- addExit avoid (length abs_vars) rhs - -- And jump to it from here - ; return $ mkVarApps (Var v) abs_vars } - - where - -- Used to detect exit expressions that are already proper exit jumps - isCapturedVarArg (Var v) = v `elem` captured - isCapturedVarArg _ = False - - -- An interesting exit expression has free, non-imported - -- variables from outside the recursive group - -- See Note [Interesting expression] - is_interesting = anyVarSet isLocalId $ - fvs `minusVarSet` mkVarSet captured - - -- The arguments of this exit join point - -- See Note [Picking arguments to abstract over] - abs_vars = snd $ foldr pick (fvs, []) captured - where - pick v (fvs', acc) | v `elemVarSet` fvs' = (fvs' `delVarSet` v, zap v : acc) - | otherwise = (fvs', acc) - - -- We are going to abstract over these variables, so we must - -- zap any IdInfo they have; see #15005 - -- cf. GHC.Core.Op.SetLevels.abstractVars - zap v | isId v = setIdInfo v vanillaIdInfo - | otherwise = v - - -- We cannot abstract over join points - captures_join_points = any isJoinId abs_vars - - --- Picks a new unique, which is disjoint from --- * the free variables of the whole joinrec --- * any bound variables (captured) --- * any exit join points created so far. -mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId -mkExitJoinId in_scope ty join_arity = do - fs <- get - let avoid = in_scope `extendInScopeSetList` (map fst fs) - `extendInScopeSet` exit_id_tmpl -- just cosmetics - return (uniqAway avoid exit_id_tmpl) - where - exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ty - `asJoinId` join_arity - -addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId -addExit in_scope join_arity rhs = do - -- Pick a suitable name - let ty = exprType rhs - v <- mkExitJoinId in_scope ty join_arity - fs <- get - put ((v,rhs):fs) - return v - -{- -Note [Interesting expression] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not want this to happen: - - joinrec go 0 x y = x - go (n-1) x y = jump go (n-1) (x+y) - in … -==> - join exit x = x - joinrec go 0 x y = jump exit x - go (n-1) x y = jump go (n-1) (x+y) - in … - -because the floated exit path (`x`) is simply a parameter of `go`; there are -not useful interactions exposed this way. - -Neither do we want this to happen - - joinrec go 0 x y = x+x - go (n-1) x y = jump go (n-1) (x+y) - in … -==> - join exit x = x+x - joinrec go 0 x y = jump exit x - go (n-1) x y = jump go (n-1) (x+y) - in … - -where the floated expression `x+x` is a bit more complicated, but still not -intersting. - -Expressions are interesting when they move an occurrence of a variable outside -the recursive `go` that can benefit from being obviously called once, for example: - * a local thunk that can then be inlined (see example in note [Exitification]) - * the parameter of a function, where the demand analyzer then can then - see that it is called at most once, and hence improve the function’s - strictness signature - -So we only hoist an exit expression out if it mentiones at least one free, -non-imported variable. - -Note [Jumps can be interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A jump to a join point can be interesting, if its arguments contain free -non-exported variables (z in the following example): - - joinrec go 0 x y = jump j (x+z) - go (n-1) x y = jump go (n-1) (x+y) - in … -==> - join exit x y = jump j (x+z) - joinrec go 0 x y = jump exit x - go (n-1) x y = jump go (n-1) (x+y) - - -The join point itself can be interesting, even if none if its -arguments have free variables free in the joinrec. For example - - join j p = case p of (x,y) -> x+y - joinrec go 0 x y = jump j (x,y) - go (n-1) x y = jump go (n-1) (x+y) y - in … - -Here, `j` would not be inlined because we do not inline something that looks -like an exit join point (see Note [Do not inline exit join points]). But -if we exitify the 'jump j (x,y)' we get - - join j p = case p of (x,y) -> x+y - join exit x y = jump j (x,y) - joinrec go 0 x y = jump exit x y - go (n-1) x y = jump go (n-1) (x+y) y - in … - -and now 'j' can inline, and we get rid of the pair. Here's another -example (assume `g` to be an imported function that, on its own, -does not make this interesting): - - join j y = map f y - joinrec go 0 x y = jump j (map g x) - go (n-1) x y = jump go (n-1) (x+y) - in … - -Again, `j` would not be inlined because we do not inline something that looks -like an exit join point (see Note [Do not inline exit join points]). - -But after exitification we have - - join j y = map f y - join exit x = jump j (map g x) - joinrec go 0 x y = jump j (map g x) - go (n-1) x y = jump go (n-1) (x+y) - in … - -and now we can inline `j` and this will allow `map/map` to fire. - - -Note [Idempotency] -~~~~~~~~~~~~~~~~~~ - -We do not want this to happen, where we replace the floated expression with -essentially the same expression: - - join exit x = t (x*x) - joinrec go 0 x y = jump exit x - go (n-1) x y = jump go (n-1) (x+y) - in … -==> - join exit x = t (x*x) - join exit' x = jump exit x - joinrec go 0 x y = jump exit' x - go (n-1) x y = jump go (n-1) (x+y) - in … - -So when the RHS is a join jump, and all of its arguments are captured variables, -then we leave it in place. - -Note that `jump exit x` in this example looks interesting, as `exit` is a free -variable. Therefore, idempotency does not simply follow from floating only -interesting expressions. - -Note [Calculating free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have two options where to annotate the tree with free variables: - - A) The whole tree. - B) Each individual joinrec as we come across it. - -Downside of A: We pay the price on the whole module, even outside any joinrecs. -Downside of B: We pay the price per joinrec, possibly multiple times when -joinrecs are nested. - -Further downside of A: If the exitify function returns annotated expressions, -it would have to ensure that the annotations are correct. - -We therefore choose B, and calculate the free variables in `exitify`. - - -Note [Do not inline exit join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have - - let t = foo bar - join exit x = t (x*x) - joinrec go 0 x y = jump exit x - go (n-1) x y = jump go (n-1) (x+y) - in … - -we do not want the simplifier to simply inline `exit` back in (which it happily -would). - -To prevent this, we need to recognize exit join points, and then disable -inlining. - -Exit join points, recognizeable using `isExitJoinId` are join points with an -occurrence in a recursive group, and can be recognized (after the occurrence -analyzer ran!) using `isExitJoinId`. -This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`, -because the lambdas of a non-recursive join point are not considered for -`occ_in_lam`. For example, in the following code, `j1` is /not/ marked -occ_in_lam, because `j2` is called only once. - - join j1 x = x+1 - join j2 y = join j1 (y+2) - -To prevent inlining, we check for isExitJoinId -* In `preInlineUnconditionally` directly. -* In `simplLetUnfolding` we simply give exit join points no unfolding, which - prevents inlining in `postInlineUnconditionally` and call sites. - -Note [Placement of the exitification pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -I (Joachim) experimented with multiple positions for the Exitification pass in -the Core2Core pipeline: - - A) Before the `simpl_phases` - B) Between the `simpl_phases` and the "main" simplifier pass - C) After demand_analyser - D) Before the final simplification phase - -Here is the table (this is without inlining join exit points in the final -simplifier run): - - Program | Allocs | Instrs - | ABCD.log A.log B.log C.log D.log | ABCD.log A.log B.log C.log D.log -----------------|---------------------------------------------------|------------------------------------------------- - fannkuch-redux | -99.9% +0.0% -99.9% -99.9% -99.9% | -3.9% +0.5% -3.0% -3.9% -3.9% - fasta | -0.0% +0.0% +0.0% -0.0% -0.0% | -8.5% +0.0% +0.0% -0.0% -8.5% - fem | 0.0% 0.0% 0.0% 0.0% +0.0% | -2.2% -0.1% -0.1% -2.1% -2.1% - fish | 0.0% 0.0% 0.0% 0.0% +0.0% | -3.1% +0.0% -1.1% -1.1% -0.0% - k-nucleotide | -91.3% -91.0% -91.0% -91.3% -91.3% | -6.3% +11.4% +11.4% -6.3% -6.2% - scs | -0.0% -0.0% -0.0% -0.0% -0.0% | -3.4% -3.0% -3.1% -3.3% -3.3% - simple | -6.0% 0.0% -6.0% -6.0% +0.0% | -3.4% +0.0% -5.2% -3.4% -0.1% - spectral-norm | -0.0% 0.0% 0.0% -0.0% +0.0% | -2.7% +0.0% -2.7% -5.4% -5.4% -----------------|---------------------------------------------------|------------------------------------------------- - Min | -95.0% -91.0% -95.0% -95.0% -95.0% | -8.5% -3.0% -5.2% -6.3% -8.5% - Max | +0.2% +0.2% +0.2% +0.2% +1.5% | +0.4% +11.4% +11.4% +0.4% +1.5% - Geometric Mean | -4.7% -2.1% -4.7% -4.7% -4.6% | -0.4% +0.1% -0.1% -0.3% -0.2% - -Position A is disqualified, as it does not get rid of the allocations in -fannkuch-redux. -Position A and B are disqualified because it increases instructions in k-nucleotide. -Positions C and D have their advantages: C decreases allocations in simpl, but D instructions in fasta. - -Assuming we have a budget of _one_ run of Exitification, then C wins (but we -could get more from running it multiple times, as seen in fish). - -Note [Picking arguments to abstract over] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When we create an exit join point, so we need to abstract over those of its -free variables that are be out-of-scope at the destination of the exit join -point. So we go through the list `captured` and pick those that are actually -free variables of the join point. - -We do not just `filter (`elemVarSet` fvs) captured`, as there might be -shadowing, and `captured` may contain multiple variables with the same Unique. I -these cases we want to abstract only over the last occurrence, hence the `foldr` -(with emphasis on the `r`). This is #15110. - --} diff --git a/compiler/GHC/Core/Op/FloatIn.hs b/compiler/GHC/Core/Op/FloatIn.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/FloatIn.hs +++ /dev/null @@ -1,774 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -************************************************************************ -* * -\section[FloatIn]{Floating Inwards pass} -* * -************************************************************************ - -The main purpose of @floatInwards@ is floating into branches of a -case, so that we don't allocate things, save them on the stack, and -then discover that they aren't needed in the chosen branch. --} - -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fprof-auto #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module GHC.Core.Op.FloatIn ( floatInwards ) where - -#include "HsVersions.h" - -import GhcPrelude -import GHC.Platform - -import GHC.Core -import GHC.Core.Make hiding ( wrapFloats ) -import GHC.Driver.Types ( ModGuts(..) ) -import GHC.Core.Utils -import GHC.Core.FVs -import GHC.Core.Op.Monad ( CoreM ) -import GHC.Types.Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) -import GHC.Types.Var -import GHC.Core.Type -import GHC.Types.Var.Set -import Util -import GHC.Driver.Session -import Outputable --- import Data.List ( mapAccumL ) -import GHC.Types.Basic ( RecFlag(..), isRec ) - -{- -Top-level interface function, @floatInwards@. Note that we do not -actually float any bindings downwards from the top-level. --} - -floatInwards :: ModGuts -> CoreM ModGuts -floatInwards pgm@(ModGuts { mg_binds = binds }) - = do { dflags <- getDynFlags - ; let platform = targetPlatform dflags - ; return (pgm { mg_binds = map (fi_top_bind platform) binds }) } - where - fi_top_bind platform (NonRec binder rhs) - = NonRec binder (fiExpr platform [] (freeVars rhs)) - fi_top_bind platform (Rec pairs) - = Rec [ (b, fiExpr platform [] (freeVars rhs)) | (b, rhs) <- pairs ] - - -{- -************************************************************************ -* * -\subsection{Mail from Andr\'e [edited]} -* * -************************************************************************ - -{\em Will wrote: What??? I thought the idea was to float as far -inwards as possible, no matter what. This is dropping all bindings -every time it sees a lambda of any kind. Help! } - -You are assuming we DO DO full laziness AFTER floating inwards! We -have to [not float inside lambdas] if we don't. - -If we indeed do full laziness after the floating inwards (we could -check the compilation flags for that) then I agree we could be more -aggressive and do float inwards past lambdas. - -Actually we are not doing a proper full laziness (see below), which -was another reason for not floating inwards past a lambda. - -This can easily be fixed. The problem is that we float lets outwards, -but there are a few expressions which are not let bound, like case -scrutinees and case alternatives. After floating inwards the -simplifier could decide to inline the let and the laziness would be -lost, e.g. - -\begin{verbatim} -let a = expensive ==> \b -> case expensive of ... -in \ b -> case a of ... -\end{verbatim} -The fix is -\begin{enumerate} -\item -to let bind the algebraic case scrutinees (done, I think) and -the case alternatives (except the ones with an -unboxed type)(not done, I think). This is best done in the -GHC.Core.Op.SetLevels.hs module, which tags things with their level numbers. -\item -do the full laziness pass (floating lets outwards). -\item -simplify. The simplifier inlines the (trivial) lets that were - created but were not floated outwards. -\end{enumerate} - -With the fix I think Will's suggestion that we can gain even more from -strictness by floating inwards past lambdas makes sense. - -We still gain even without going past lambdas, as things may be -strict in the (new) context of a branch (where it was floated to) or -of a let rhs, e.g. -\begin{verbatim} -let a = something case x of -in case x of alt1 -> case something of a -> a + a - alt1 -> a + a ==> alt2 -> b - alt2 -> b - -let a = something let b = case something of a -> a + a -in let b = a + a ==> in (b,b) -in (b,b) -\end{verbatim} -Also, even if a is not found to be strict in the new context and is -still left as a let, if the branch is not taken (or b is not entered) -the closure for a is not built. - -************************************************************************ -* * -\subsection{Main floating-inwards code} -* * -************************************************************************ --} - -type FreeVarSet = DIdSet -type BoundVarSet = DIdSet - -data FloatInBind = FB BoundVarSet FreeVarSet FloatBind - -- The FreeVarSet is the free variables of the binding. In the case - -- of recursive bindings, the set doesn't include the bound - -- variables. - -type FloatInBinds = [FloatInBind] - -- In reverse dependency order (innermost binder first) - -fiExpr :: Platform - -> FloatInBinds -- Binds we're trying to drop - -- as far "inwards" as possible - -> CoreExprWithFVs -- Input expr - -> CoreExpr -- Result - -fiExpr _ to_drop (_, AnnLit lit) = wrapFloats to_drop (Lit lit) - -- See Note [Dead bindings] -fiExpr _ to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty -fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) -fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) -fiExpr platform to_drop (_, AnnCast expr (co_ann, co)) - = wrapFloats (drop_here ++ co_drop) $ - Cast (fiExpr platform e_drop expr) co - where - [drop_here, e_drop, co_drop] - = sepBindsByDropPoint platform False - [freeVarsOf expr, freeVarsOfAnn co_ann] - to_drop - -{- -Applications: we do float inside applications, mainly because we -need to get at all the arguments. The next simplifier run will -pull out any silly ones. --} - -fiExpr platform to_drop ann_expr@(_,AnnApp {}) - = wrapFloats drop_here $ wrapFloats extra_drop $ - mkTicks ticks $ - mkApps (fiExpr platform fun_drop ann_fun) - (zipWith (fiExpr platform) arg_drops ann_args) - where - (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr - fun_ty = exprType (deAnnotate ann_fun) - fun_fvs = freeVarsOf ann_fun - arg_fvs = map freeVarsOf ann_args - - (drop_here : extra_drop : fun_drop : arg_drops) - = sepBindsByDropPoint platform False - (extra_fvs : fun_fvs : arg_fvs) - to_drop - -- Shortcut behaviour: if to_drop is empty, - -- sepBindsByDropPoint returns a suitable bunch of empty - -- lists without evaluating extra_fvs, and hence without - -- peering into each argument - - (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args - extra_fvs0 = case ann_fun of - (_, AnnVar _) -> fun_fvs - _ -> emptyDVarSet - -- Don't float the binding for f into f x y z; see Note [Join points] - -- for why we *can't* do it when f is a join point. (If f isn't a - -- join point, floating it in isn't especially harmful but it's - -- useless since the simplifier will immediately float it back out.) - - add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet) - add_arg (fun_ty, extra_fvs) (_, AnnType ty) - = (piResultTy fun_ty ty, extra_fvs) - - add_arg (fun_ty, extra_fvs) (arg_fvs, arg) - | noFloatIntoArg arg arg_ty - = (res_ty, extra_fvs `unionDVarSet` arg_fvs) - | otherwise - = (res_ty, extra_fvs) - where - (arg_ty, res_ty) = splitFunTy fun_ty - -{- Note [Dead bindings] -~~~~~~~~~~~~~~~~~~~~~~~ -At a literal we won't usually have any floated bindings; the -only way that can happen is if the binding wrapped the literal -/in the original input program/. e.g. - case x of { DEFAULT -> 1# } -But, while this may be unusual it is not actually wrong, and it did -once happen (#15696). - -Note [Do not destroy the let/app invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Watch out for - f (x +# y) -We don't want to float bindings into here - f (case ... of { x -> x +# y }) -because that might destroy the let/app invariant, which requires -unlifted function arguments to be ok-for-speculation. - -Note [Join points] -~~~~~~~~~~~~~~~~~~ -Generally, we don't need to worry about join points - there are places we're -not allowed to float them, but since they can't have occurrences in those -places, we're not tempted. - -We do need to be careful about jumps, however: - - joinrec j x y z = ... in - jump j a b c - -Previous versions often floated the definition of a recursive function into its -only non-recursive occurrence. But for a join point, this is a disaster: - - (joinrec j x y z = ... in - jump j) a b c -- wrong! - -Every jump must be exact, so the jump to j must have three arguments. Hence -we're careful not to float into the target of a jump (though we can float into -the arguments just fine). - -Note [Floating in past a lambda group] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* We must be careful about floating inside a value lambda. - That risks losing laziness. - The float-out pass might rescue us, but then again it might not. - -* We must be careful about type lambdas too. At one time we did, and - there is no risk of duplicating work thereby, but we do need to be - careful. In particular, here is a bad case (it happened in the - cichelli benchmark: - let v = ... - in let f = /\t -> \a -> ... - ==> - let f = /\t -> let v = ... in \a -> ... - This is bad as now f is an updatable closure (update PAP) - and has arity 0. - -* Hack alert! We only float in through one-shot lambdas, - not (as you might guess) through lone big lambdas. - Reason: we float *out* past big lambdas (see the test in the Lam - case of FloatOut.floatExpr) and we don't want to float straight - back in again. - - It *is* important to float into one-shot lambdas, however; - see the remarks with noFloatIntoRhs. - -So we treat lambda in groups, using the following rule: - - Float in if (a) there is at least one Id, - and (b) there are no non-one-shot Ids - - Otherwise drop all the bindings outside the group. - -This is what the 'go' function in the AnnLam case is doing. - -(Join points are handled similarly: a join point is considered one-shot iff -it's non-recursive, so we float only into non-recursive join points.) - -Urk! if all are tyvars, and we don't float in, we may miss an - opportunity to float inside a nested case branch - - -Note [Floating coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We could, in principle, have a coercion binding like - case f x of co { DEFAULT -> e1 e2 } -It's not common to have a function that returns a coercion, but nothing -in Core prohibits it. If so, 'co' might be mentioned in e1 or e2 -/only in a type/. E.g. suppose e1 was - let (x :: Int |> co) = blah in blah2 - - -But, with coercions appearing in types, there is a complication: we -might be floating in a "strict let" -- that is, a case. Case expressions -mention their return type. We absolutely can't float a coercion binding -inward to the point that the type of the expression it's about to wrap -mentions the coercion. So we include the union of the sets of free variables -of the types of all the drop points involved. If any of the floaters -bind a coercion variable mentioned in any of the types, that binder must -be dropped right away. - --} - -fiExpr platform to_drop lam@(_, AnnLam _ _) - | noFloatIntoLam bndrs -- Dump it all here - -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088 - = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body)) - - | otherwise -- Float inside - = mkLams bndrs (fiExpr platform to_drop body) - - where - (bndrs, body) = collectAnnBndrs lam - -{- -We don't float lets inwards past an SCC. - ToDo: keep info on current cc, and when passing - one, if it is not the same, annotate all lets in binds with current - cc, change current cc to the new one and float binds into expr. --} - -fiExpr platform to_drop (_, AnnTick tickish expr) - | tickish `tickishScopesLike` SoftScope - = Tick tickish (fiExpr platform to_drop expr) - - | otherwise -- Wimp out for now - we could push values in - = wrapFloats to_drop (Tick tickish (fiExpr platform [] expr)) - -{- -For @Lets@, the possible ``drop points'' for the \tr{to_drop} -bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding, -or~(b2), in each of the RHSs of the pairs of a @Rec@. - -Note that we do {\em weird things} with this let's binding. Consider: -\begin{verbatim} -let - w = ... -in { - let v = ... w ... - in ... v .. w ... -} -\end{verbatim} -Look at the inner \tr{let}. As \tr{w} is used in both the bind and -body of the inner let, we could panic and leave \tr{w}'s binding where -it is. But \tr{v} is floatable further into the body of the inner let, and -{\em then} \tr{w} will also be only in the body of that inner let. - -So: rather than drop \tr{w}'s binding here, we add it onto the list of -things to drop in the outer let's body, and let nature take its -course. - -Note [extra_fvs (1): avoid floating into RHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider let x=\y....t... in body. We do not necessarily want to float -a binding for t into the RHS, because it'll immediately be floated out -again. (It won't go inside the lambda else we risk losing work.) -In letrec, we need to be more careful still. We don't want to transform - let x# = y# +# 1# - in - letrec f = \z. ...x#...f... - in ... -into - letrec f = let x# = y# +# 1# in \z. ...x#...f... in ... -because now we can't float the let out again, because a letrec -can't have unboxed bindings. - -So we make "extra_fvs" which is the rhs_fvs of such bindings, and -arrange to dump bindings that bind extra_fvs before the entire let. - -Note [extra_fvs (2): free variables of rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let x{rule mentioning y} = rhs in body -Here y is not free in rhs or body; but we still want to dump bindings -that bind y outside the let. So we augment extra_fvs with the -idRuleAndUnfoldingVars of x. No need for type variables, hence not using -idFreeVars. --} - -fiExpr platform to_drop (_,AnnLet bind body) - = fiExpr platform (after ++ new_float : before) body - -- to_drop is in reverse dependency order - where - (before, new_float, after) = fiBind platform to_drop bind body_fvs - body_fvs = freeVarsOf body - -{- Note [Floating primops] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We try to float-in a case expression over an unlifted type. The -motivating example was #5658: in particular, this change allows -array indexing operations, which have a single DEFAULT alternative -without any binders, to be floated inward. - -SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed -scalars also need to be floated inward, but unpacks have a single non-DEFAULT -alternative that binds the elements of the tuple. We now therefore also support -floating in cases with a single alternative that may bind values. - -But there are wrinkles - -* Which unlifted cases do we float? See PrimOp.hs - Note [PrimOp can_fail and has_side_effects] which explains: - - We can float-in can_fail primops, but we can't float them out. - - But we can float a has_side_effects primop, but NOT inside a lambda, - so for now we don't float them at all. - Hence exprOkForSideEffects - -* Because we can float can-fail primops (array indexing, division) inwards - but not outwards, we must be careful not to transform - case a /# b of r -> f (F# r) - ===> - f (case a /# b of r -> F# r) - because that creates a new thunk that wasn't there before. And - because it can't be floated out (can_fail), the thunk will stay - there. Disaster! (This happened in nofib 'simple' and 'scs'.) - - Solution: only float cases into the branches of other cases, and - not into the arguments of an application, or the RHS of a let. This - is somewhat conservative, but it's simple. And it still hits the - cases like #5658. This is implemented in sepBindsByJoinPoint; - if is_case is False we dump all floating cases right here. - -* #14511 is another example of why we want to restrict float-in - of case-expressions. Consider - case indexArray# a n of (# r #) -> writeArray# ma i (f r) - Now, floating that indexing operation into the (f r) thunk will - not create any new thunks, but it will keep the array 'a' alive - for much longer than the programmer expected. - - So again, not floating a case into a let or argument seems like - the Right Thing - -For @Case@, the possible drop points for the 'to_drop' -bindings are: - (a) inside the scrutinee - (b) inside one of the alternatives/default (default FVs always /first/!). - --} - -fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) - | isUnliftedType (idType case_bndr) - , exprOkForSideEffects (deAnnotate scrut) - -- See Note [Floating primops] - = wrapFloats shared_binds $ - fiExpr platform (case_float : rhs_binds) rhs - where - case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs - (FloatCase scrut' case_bndr con alt_bndrs) - scrut' = fiExpr platform scrut_binds scrut - rhs_fvs = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs) - scrut_fvs = freeVarsOf scrut - - [shared_binds, scrut_binds, rhs_binds] - = sepBindsByDropPoint platform False - [scrut_fvs, rhs_fvs] - to_drop - -fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts) - = wrapFloats drop_here1 $ - wrapFloats drop_here2 $ - Case (fiExpr platform scrut_drops scrut) case_bndr ty - (zipWith fi_alt alts_drops_s alts) - where - -- Float into the scrut and alts-considered-together just like App - [drop_here1, scrut_drops, alts_drops] - = sepBindsByDropPoint platform False - [scrut_fvs, all_alts_fvs] - to_drop - - -- Float into the alts with the is_case flag set - (drop_here2 : alts_drops_s) - | [ _ ] <- alts = [] : [alts_drops] - | otherwise = sepBindsByDropPoint platform True alts_fvs alts_drops - - scrut_fvs = freeVarsOf scrut - alts_fvs = map alt_fvs alts - all_alts_fvs = unionDVarSets alts_fvs - alt_fvs (_con, args, rhs) - = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args) - -- Delete case_bndr and args from free vars of rhs - -- to get free vars of alt - - fi_alt to_drop (con, args, rhs) = (con, args, fiExpr platform to_drop rhs) - ------------------- -fiBind :: Platform - -> FloatInBinds -- Binds we're trying to drop - -- as far "inwards" as possible - -> CoreBindWithFVs -- Input binding - -> DVarSet -- Free in scope of binding - -> ( FloatInBinds -- Land these before - , FloatInBind -- The binding itself - , FloatInBinds) -- Land these after - -fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs - = ( extra_binds ++ shared_binds -- Land these before - -- See Note [extra_fvs (1,2)] - , FB (unitDVarSet id) rhs_fvs' -- The new binding itself - (FloatLet (NonRec id rhs')) - , body_binds ) -- Land these after - - where - body_fvs2 = body_fvs `delDVarSet` id - - rule_fvs = bndrRuleAndUnfoldingVarsDSet id -- See Note [extra_fvs (2): free variables of rules] - extra_fvs | noFloatIntoRhs NonRecursive id rhs - = rule_fvs `unionDVarSet` rhs_fvs - | otherwise - = rule_fvs - -- See Note [extra_fvs (1): avoid floating into RHS] - -- No point in floating in only to float straight out again - -- We *can't* float into ok-for-speculation unlifted RHSs - -- But do float into join points - - [shared_binds, extra_binds, rhs_binds, body_binds] - = sepBindsByDropPoint platform False - [extra_fvs, rhs_fvs, body_fvs2] - to_drop - - -- Push rhs_binds into the right hand side of the binding - rhs' = fiRhs platform rhs_binds id ann_rhs - rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs - -- Don't forget the rule_fvs; the binding mentions them! - -fiBind platform to_drop (AnnRec bindings) body_fvs - = ( extra_binds ++ shared_binds - , FB (mkDVarSet ids) rhs_fvs' - (FloatLet (Rec (fi_bind rhss_binds bindings))) - , body_binds ) - where - (ids, rhss) = unzip bindings - rhss_fvs = map freeVarsOf rhss - - -- See Note [extra_fvs (1,2)] - rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids - extra_fvs = rule_fvs `unionDVarSet` - unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings - , noFloatIntoRhs Recursive bndr rhs ] - - (shared_binds:extra_binds:body_binds:rhss_binds) - = sepBindsByDropPoint platform False - (extra_fvs:body_fvs:rhss_fvs) - to_drop - - rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet` - unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet` - rule_fvs -- Don't forget the rule variables! - - -- Push rhs_binds into the right hand side of the binding - fi_bind :: [FloatInBinds] -- one per "drop pt" conjured w/ fvs_of_rhss - -> [(Id, CoreExprWithFVs)] - -> [(Id, CoreExpr)] - - fi_bind to_drops pairs - = [ (binder, fiRhs platform to_drop binder rhs) - | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] - ------------------- -fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr -fiRhs platform to_drop bndr rhs - | Just join_arity <- isJoinId_maybe bndr - , let (bndrs, body) = collectNAnnBndrs join_arity rhs - = mkLams bndrs (fiExpr platform to_drop body) - | otherwise - = fiExpr platform to_drop rhs - ------------------- -noFloatIntoLam :: [Var] -> Bool -noFloatIntoLam bndrs = any bad bndrs - where - bad b = isId b && not (isOneShotBndr b) - -- Don't float inside a non-one-shot lambda - -noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool --- ^ True if it's a bad idea to float bindings into this RHS -noFloatIntoRhs is_rec bndr rhs - | isJoinId bndr - = isRec is_rec -- Joins are one-shot iff non-recursive - - | otherwise - = noFloatIntoArg rhs (idType bndr) - -noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool -noFloatIntoArg expr expr_ty - | isUnliftedType expr_ty - = True -- See Note [Do not destroy the let/app invariant] - - | AnnLam bndr e <- expr - , (bndrs, _) <- collectAnnBndrs e - = noFloatIntoLam (bndr:bndrs) -- Wrinkle 1 (a) - || all isTyVar (bndr:bndrs) -- Wrinkle 1 (b) - -- See Note [noFloatInto considerations] wrinkle 2 - - | otherwise -- Note [noFloatInto considerations] wrinkle 2 - = exprIsTrivial deann_expr || exprIsHNF deann_expr - where - deann_expr = deAnnotate' expr - -{- Note [noFloatInto considerations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When do we want to float bindings into - - noFloatIntoRHs: the RHS of a let-binding - - noFloatIntoArg: the argument of a function application - -Definitely don't float in if it has unlifted type; that -would destroy the let/app invariant. - -* Wrinkle 1: do not float in if - (a) any non-one-shot value lambdas - or (b) all type lambdas - In both cases we'll float straight back out again - NB: Must line up with fiExpr (AnnLam...); see #7088 - - (a) is important: we /must/ float into a one-shot lambda group - (which includes join points). This makes a big difference - for things like - f x# = let x = I# x# - in let j = \() -> ...x... - in if then normal-path else j () - If x is used only in the error case join point, j, we must float the - boxing constructor into it, else we box it every time which is very - bad news indeed. - -* Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right - back out again... not tragic, but a waste of time. - - For function arguments we will still end up with this - in-then-out stuff; consider - letrec x = e in f x - Here x is not a HNF, so we'll produce - f (letrec x = e in x) - which is OK... it's not that common, and we'll end up - floating out again, in CorePrep if not earlier. - Still, we use exprIsTrivial to catch this case (sigh) - - -************************************************************************ -* * -\subsection{@sepBindsByDropPoint@} -* * -************************************************************************ - -This is the crucial function. The idea is: We have a wad of bindings -that we'd like to distribute inside a collection of {\em drop points}; -insides the alternatives of a \tr{case} would be one example of some -drop points; the RHS and body of a non-recursive \tr{let} binding -would be another (2-element) collection. - -So: We're given a list of sets-of-free-variables, one per drop point, -and a list of floating-inwards bindings. If a binding can go into -only one drop point (without suddenly making something out-of-scope), -in it goes. If a binding is used inside {\em multiple} drop points, -then it has to go in a you-must-drop-it-above-all-these-drop-points -point. - -We have to maintain the order on these drop-point-related lists. --} - --- pprFIB :: FloatInBinds -> SDoc --- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs] - -sepBindsByDropPoint - :: Platform - -> Bool -- True <=> is case expression - -> [FreeVarSet] -- One set of FVs per drop point - -- Always at least two long! - -> FloatInBinds -- Candidate floaters - -> [FloatInBinds] -- FIRST one is bindings which must not be floated - -- inside any drop point; the rest correspond - -- one-to-one with the input list of FV sets - --- Every input floater is returned somewhere in the result; --- none are dropped, not even ones which don't seem to be --- free in *any* of the drop-point fvs. Why? Because, for example, --- a binding (let x = E in B) might have a specialised version of --- x (say x') stored inside x, but x' isn't free in E or B. - -type DropBox = (FreeVarSet, FloatInBinds) - -sepBindsByDropPoint platform is_case drop_pts floaters - | null floaters -- Shortcut common case - = [] : [[] | _ <- drop_pts] - - | otherwise - = ASSERT( drop_pts `lengthAtLeast` 2 ) - go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts)) - where - n_alts = length drop_pts - - go :: FloatInBinds -> [DropBox] -> [FloatInBinds] - -- The *first* one in the argument list is the drop_here set - -- The FloatInBinds in the lists are in the reverse of - -- the normal FloatInBinds order; that is, they are the right way round! - - go [] drop_boxes = map (reverse . snd) drop_boxes - - go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes) - = go binds new_boxes - where - -- "here" means the group of bindings dropped at the top of the fork - - (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs - | (fvs, _) <- drop_boxes] - - drop_here = used_here || cant_push - - n_used_alts = count id used_in_flags -- returns number of Trues in list. - - cant_push - | is_case = n_used_alts == n_alts -- Used in all, don't push - -- Remember n_alts > 1 - || (n_used_alts > 1 && not (floatIsDupable platform bind)) - -- floatIsDupable: see Note [Duplicating floats] - - | otherwise = floatIsCase bind || n_used_alts > 1 - -- floatIsCase: see Note [Floating primops] - - new_boxes | drop_here = (insert here_box : fork_boxes) - | otherwise = (here_box : new_fork_boxes) - - new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe - fork_boxes used_in_flags - - insert :: DropBox -> DropBox - insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops) - - insert_maybe box True = insert box - insert_maybe box False = box - - go _ _ = panic "sepBindsByDropPoint/go" - - -{- Note [Duplicating floats] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -For case expressions we duplicate the binding if it is reasonably -small, and if it is not used in all the RHSs This is good for -situations like - let x = I# y in - case e of - C -> error x - D -> error x - E -> ...not mentioning x... - -If the thing is used in all RHSs there is nothing gained, -so we don't duplicate then. --} - -floatedBindsFVs :: FloatInBinds -> FreeVarSet -floatedBindsFVs binds = mapUnionDVarSet fbFVs binds - -fbFVs :: FloatInBind -> DVarSet -fbFVs (FB _ fvs _) = fvs - -wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr --- Remember FloatInBinds is in *reverse* dependency order -wrapFloats [] e = e -wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e) - -floatIsDupable :: Platform -> FloatBind -> Bool -floatIsDupable platform (FloatCase scrut _ _ _) = exprIsDupable platform scrut -floatIsDupable platform (FloatLet (Rec prs)) = all (exprIsDupable platform . snd) prs -floatIsDupable platform (FloatLet (NonRec _ r)) = exprIsDupable platform r - -floatIsCase :: FloatBind -> Bool -floatIsCase (FloatCase {}) = True -floatIsCase (FloatLet {}) = False diff --git a/compiler/GHC/Core/Op/FloatOut.hs b/compiler/GHC/Core/Op/FloatOut.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/FloatOut.hs +++ /dev/null @@ -1,757 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[FloatOut]{Float bindings outwards (towards the top level)} - -``Long-distance'' floating of bindings towards the top level. --} - -{-# LANGUAGE CPP #-} - -module GHC.Core.Op.FloatOut ( floatOutwards ) where - -import GhcPrelude - -import GHC.Core -import GHC.Core.Utils -import GHC.Core.Make -import GHC.Core.Arity ( etaExpand ) -import GHC.Core.Op.Monad ( FloatOutSwitches(..) ) - -import GHC.Driver.Session -import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) ) -import GHC.Types.Id ( Id, idArity, idType, isBottomingId, - isJoinId, isJoinId_maybe ) -import GHC.Core.Op.SetLevels -import GHC.Types.Unique.Supply ( UniqSupply ) -import Bag -import Util -import Maybes -import Outputable -import GHC.Core.Type -import qualified Data.IntMap as M - -import Data.List ( partition ) - -#include "HsVersions.h" - -{- - ----------------- - Overall game plan - ----------------- - -The Big Main Idea is: - - To float out sub-expressions that can thereby get outside - a non-one-shot value lambda, and hence may be shared. - - -To achieve this we may need to do two things: - - a) Let-bind the sub-expression: - - f (g x) ==> let lvl = f (g x) in lvl - - Now we can float the binding for 'lvl'. - - b) More than that, we may need to abstract wrt a type variable - - \x -> ... /\a -> let v = ...a... in .... - - Here the binding for v mentions 'a' but not 'x'. So we - abstract wrt 'a', to give this binding for 'v': - - vp = /\a -> ...a... - v = vp a - - Now the binding for vp can float out unimpeded. - I can't remember why this case seemed important enough to - deal with, but I certainly found cases where important floats - didn't happen if we did not abstract wrt tyvars. - -With this in mind we can also achieve another goal: lambda lifting. -We can make an arbitrary (function) binding float to top level by -abstracting wrt *all* local variables, not just type variables, leaving -a binding that can be floated right to top level. Whether or not this -happens is controlled by a flag. - - -Random comments -~~~~~~~~~~~~~~~ - -At the moment we never float a binding out to between two adjacent -lambdas. For example: - -@ - \x y -> let t = x+x in ... -===> - \x -> let t = x+x in \y -> ... -@ -Reason: this is less efficient in the case where the original lambda -is never partially applied. - -But there's a case I've seen where this might not be true. Consider: -@ -elEm2 x ys - = elem' x ys - where - elem' _ [] = False - elem' x (y:ys) = x==y || elem' x ys -@ -It turns out that this generates a subexpression of the form -@ - \deq x ys -> let eq = eqFromEqDict deq in ... -@ -which might usefully be separated to -@ - \deq -> let eq = eqFromEqDict deq in \xy -> ... -@ -Well, maybe. We don't do this at the moment. - -Note [Join points] -~~~~~~~~~~~~~~~~~~ -Every occurrence of a join point must be a tail call (see Note [Invariants on -join points] in GHC.Core), so we must be careful with how far we float them. The -mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling] -in GHC.Core.Op.SetLevels. For us, the significance is that a binder might be marked to be -dropped at the nearest boundary between tail calls and non-tail calls. For -example: - - (< join j = ... in - let x = < ... > in - case < ... > of - A -> ... - B -> ... - >) < ... > < ... > - -Here the join ceilings are marked with angle brackets. Either side of an -application is a join ceiling, as is the scrutinee position of a case -expression or the RHS of a let binding (but not a join point). - -Why do we *want* do float join points at all? After all, they're never -allocated, so there's no sharing to be gained by floating them. However, the -other benefit of floating is making RHSes small, and this can have a significant -impact. In particular, stream fusion has been known to produce nested loops like -this: - - joinrec j1 x1 = - joinrec j2 x2 = - joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ... - in jump j3 x2 - in jump j2 x1 - in jump j1 x - -(Assume x1 and x2 do *not* occur free in j3.) - -Here j1 and j2 are wholly superfluous---each of them merely forwards its -argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make -everything one big mutual recursion: - - joinrec j1 x1 = jump j2 x1 - j2 x2 = jump j3 x2 - j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ... - in jump j1 x - -Now the simplifier will happily inline the trivial j1 and j2, leaving only j3. -Without floating, we're stuck with three loops instead of one. - -************************************************************************ -* * -\subsection[floatOutwards]{@floatOutwards@: let-floating interface function} -* * -************************************************************************ --} - -floatOutwards :: FloatOutSwitches - -> DynFlags - -> UniqSupply - -> CoreProgram -> IO CoreProgram - -floatOutwards float_sws dflags us pgm - = do { - let { annotated_w_levels = setLevels float_sws pgm us ; - (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) - } ; - - dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:" - FormatCore - (vcat (map ppr annotated_w_levels)); - - let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; - - dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:" - FormatText - (hcat [ int tlets, text " Lets floated to top level; ", - int ntlets, text " Lets floated elsewhere; from ", - int lams, text " Lambda groups"]); - - return (bagToList (unionManyBags binds_s')) - } - -floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind) -floatTopBind bind - = case (floatBind bind) of { (fs, floats, bind') -> - let float_bag = flattenTopFloats floats - in case bind' of - -- bind' can't have unlifted values or join points, so can only be one - -- value bind, rec or non-rec (see comment on floatBind) - [Rec prs] -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs))) - [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e) - _ -> pprPanic "floatTopBind" (ppr bind') } - -{- -************************************************************************ -* * -\subsection[FloatOut-Bind]{Floating in a binding (the business end)} -* * -************************************************************************ --} - -floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind]) - -- Returns a list with either - -- * A single non-recursive binding (value or join point), or - -- * The following, in order: - -- * Zero or more non-rec unlifted bindings - -- * One or both of: - -- * A recursive group of join binds - -- * A recursive group of value binds - -- See Note [Floating out of Rec rhss] for why things get arranged this way. -floatBind (NonRec (TB var _) rhs) - = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') -> - - -- A tiresome hack: - -- see Note [Bottoming floats: eta expansion] in GHC.Core.Op.SetLevels - let rhs'' | isBottomingId var = etaExpand (idArity var) rhs' - | otherwise = rhs' - - in (fs, rhs_floats, [NonRec var rhs'']) } - -floatBind (Rec pairs) - = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) -> - let (new_ul_pairss, new_other_pairss) = unzip new_pairs - (new_join_pairs, new_l_pairs) = partition (isJoinId . fst) - (concat new_other_pairss) - -- Can't put the join points and the values in the same rec group - new_rec_binds | null new_join_pairs = [ Rec new_l_pairs ] - | null new_l_pairs = [ Rec new_join_pairs ] - | otherwise = [ Rec new_l_pairs - , Rec new_join_pairs ] - new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ] - in - (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) } - where - do_pair :: (LevelledBndr, LevelledExpr) - -> (FloatStats, FloatBinds, - ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings - [(Id,CoreExpr)])) -- Join points and lifted value bindings - do_pair (TB name spec, rhs) - | isTopLvl dest_lvl -- See Note [floatBind for top level] - = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') -> - (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats) - [(name, rhs')]))} - | otherwise -- Note [Floating out of Rec rhss] - = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') -> - case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) -> - case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) -> - let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in - (fs, rhs_floats', (ul_pairs, pairs')) }}} - where - dest_lvl = floatSpecLevel spec - -splitRecFloats :: Bag FloatBind - -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings - [(Id,CoreExpr)], -- Join points and lifted value bindings - Bag FloatBind) -- A tail of further bindings --- The "tail" begins with a case --- See Note [Floating out of Rec rhss] -splitRecFloats fs - = go [] [] (bagToList fs) - where - go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b) - , not (isJoinId b) - = go ((b,r):ul_prs) prs fs - | otherwise - = go ul_prs ((b,r):prs) fs - go ul_prs prs (FloatLet (Rec prs') : fs) = go ul_prs (prs' ++ prs) fs - go ul_prs prs fs = (reverse ul_prs, prs, - listToBag fs) - -- Order only matters for - -- non-rec - -installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr --- Note [Floating out of Rec rhss] -installUnderLambdas floats e - | isEmptyBag floats = e - | otherwise = go e - where - go (Lam b e) = Lam b (go e) - go e = install floats e - ---------------- -floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b]) -floatList _ [] = (zeroStats, emptyFloats, []) -floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> - case floatList f as of { (fs_as, binds_as, bs) -> - (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }} - -{- -Note [Floating out of Rec rhss] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider Rec { f<1,0> = \xy. body } -From the body we may get some floats. The ones with level <1,0> must -stay here, since they may mention f. Ideally we'd like to make them -part of the Rec block pairs -- but we can't if there are any -FloatCases involved. - -Nor is it a good idea to dump them in the rhs, but outside the lambda - f = case x of I# y -> \xy. body -because now f's arity might get worse, which is Not Good. (And if -there's an SCC around the RHS it might not get better again. -See #5342.) - -So, gruesomely, we split the floats into - * the outer FloatLets, which can join the Rec, and - * an inner batch starting in a FloatCase, which are then - pushed *inside* the lambdas. -This loses full-laziness the rare situation where there is a -FloatCase and a Rec interacting. - -If there are unlifted FloatLets (that *aren't* join points) among the floats, -we can't add them to the recursive group without angering Core Lint, but since -they must be ok-for-speculation, they can't actually be making any recursive -calls, so we can safely pull them out and keep them non-recursive. - -(Why is something getting floated to <1,0> that doesn't make a recursive call? -The case that came up in testing was that f *and* the unlifted binding were -getting floated *to the same place*: - - \x<2,0> -> - ... <3,0> - letrec { f> = - ... let x'> = x +# 1# in ... - } in ... - -Everything gets labeled "float to <2,0>" because it all depends on x, but this -makes f and x' look mutually recursive when they're not. - -The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the -wip/join-points branch. - -TODO: This can probably be solved somehow in GHC.Core.Op.SetLevels. The difference between -"this *is at* level <2,0>" and "this *depends on* level <2,0>" is very -important.) - -Note [floatBind for top level] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus - letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... } -The binding for bar will be in the "tops" part of the floating binds, -and thus not partioned by floatBody. - -We could perhaps get rid of the 'tops' component of the floating binds, -but this case works just as well. - - -************************************************************************ - -\subsection[FloatOut-Expr]{Floating in expressions} -* * -************************************************************************ --} - -floatBody :: Level - -> LevelledExpr - -> (FloatStats, FloatBinds, CoreExpr) - -floatBody lvl arg -- Used rec rhss, and case-alternative rhss - = case (floatExpr arg) of { (fsa, floats, arg') -> - case (partitionByLevel lvl floats) of { (floats', heres) -> - -- Dump bindings are bound here - (fsa, floats', install heres arg') }} - ------------------ - -{- Note [Floating past breakpoints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We used to disallow floating out of breakpoint ticks (see #10052). However, I -think this is too restrictive. - -Consider the case of an expression scoped over by a breakpoint tick, - - tick<...> (let x = ... in f x) - -In this case it is completely legal to float out x, despite the fact that -breakpoint ticks are scoped, - - let x = ... in (tick<...> f x) - -The reason here is that we know that the breakpoint will still be hit when the -expression is entered since the tick still scopes over the RHS. - --} - -floatExpr :: LevelledExpr - -> (FloatStats, FloatBinds, CoreExpr) -floatExpr (Var v) = (zeroStats, emptyFloats, Var v) -floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty) -floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co) -floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit) - -floatExpr (App e a) - = case (atJoinCeiling $ floatExpr e) of { (fse, floats_e, e') -> - case (atJoinCeiling $ floatExpr a) of { (fsa, floats_a, a') -> - (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }} - -floatExpr lam@(Lam (TB _ lam_spec) _) - = let (bndrs_w_lvls, body) = collectBinders lam - bndrs = [b | TB b _ <- bndrs_w_lvls] - bndr_lvl = asJoinCeilLvl (floatSpecLevel lam_spec) - -- All the binders have the same level - -- See GHC.Core.Op.SetLevels.lvlLamBndrs - -- Use asJoinCeilLvl to make this the join ceiling - in - case (floatBody bndr_lvl body) of { (fs, floats, body') -> - (add_to_stats fs floats, floats, mkLams bndrs body') } - -floatExpr (Tick tickish expr) - | tickish `tickishScopesLike` SoftScope -- not scoped, can just float - = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> - (fs, floating_defns, Tick tickish expr') } - - | not (tickishCounts tickish) || tickishCanSplit tickish - = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> - let -- Annotate bindings floated outwards past an scc expression - -- with the cc. We mark that cc as "duplicated", though. - annotated_defns = wrapTick (mkNoCount tickish) floating_defns - in - (fs, annotated_defns, Tick tickish expr') } - - -- Note [Floating past breakpoints] - | Breakpoint{} <- tickish - = case (floatExpr expr) of { (fs, floating_defns, expr') -> - (fs, floating_defns, Tick tickish expr') } - - | otherwise - = pprPanic "floatExpr tick" (ppr tickish) - -floatExpr (Cast expr co) - = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> - (fs, floating_defns, Cast expr' co) } - -floatExpr (Let bind body) - = case bind_spec of - FloatMe dest_lvl - -> case (floatBind bind) of { (fsb, bind_floats, binds') -> - case (floatExpr body) of { (fse, body_floats, body') -> - let new_bind_floats = foldr plusFloats emptyFloats - (map (unitLetFloat dest_lvl) binds') in - ( add_stats fsb fse - , bind_floats `plusFloats` new_bind_floats - `plusFloats` body_floats - , body') }} - - StayPut bind_lvl -- See Note [Avoiding unnecessary floating] - -> case (floatBind bind) of { (fsb, bind_floats, binds') -> - case (floatBody bind_lvl body) of { (fse, body_floats, body') -> - ( add_stats fsb fse - , bind_floats `plusFloats` body_floats - , foldr Let body' binds' ) }} - where - bind_spec = case bind of - NonRec (TB _ s) _ -> s - Rec ((TB _ s, _) : _) -> s - Rec [] -> panic "floatExpr:rec" - -floatExpr (Case scrut (TB case_bndr case_spec) ty alts) - = case case_spec of - FloatMe dest_lvl -- Case expression moves - | [(con@(DataAlt {}), bndrs, rhs)] <- alts - -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') -> - case floatExpr rhs of { (fsb, fdb, rhs') -> - let - float = unitCaseFloat dest_lvl scrut' - case_bndr con [b | TB b _ <- bndrs] - in - (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }} - | otherwise - -> pprPanic "Floating multi-case" (ppr alts) - - StayPut bind_lvl -- Case expression stays put - -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') -> - case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts') -> - (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') - }} - where - float_alt bind_lvl (con, bs, rhs) - = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') -> - (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) } - -floatRhs :: CoreBndr - -> LevelledExpr - -> (FloatStats, FloatBinds, CoreExpr) -floatRhs bndr rhs - | Just join_arity <- isJoinId_maybe bndr - , Just (bndrs, body) <- try_collect join_arity rhs [] - = case bndrs of - [] -> floatExpr rhs - (TB _ lam_spec):_ -> - let lvl = floatSpecLevel lam_spec in - case floatBody lvl body of { (fs, floats, body') -> - (fs, floats, mkLams [b | TB b _ <- bndrs] body') } - | otherwise - = atJoinCeiling $ floatExpr rhs - where - try_collect 0 expr acc = Just (reverse acc, expr) - try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc) - try_collect _ _ _ = Nothing - -{- -Note [Avoiding unnecessary floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we want to avoid floating a let unnecessarily, because -it might worsen strictness: - let - x = ...(let y = e in y+y).... -Here y is demanded. If we float it outside the lazy 'x=..' then -we'd have to zap its demand info, and it may never be restored. - -So at a 'let' we leave the binding right where the are unless -the binding will escape a value lambda, e.g. - -(\x -> let y = fac 100 in y) - -That's what the partitionByMajorLevel does in the floatExpr (Let ...) -case. - -Notice, though, that we must take care to drop any bindings -from the body of the let that depend on the staying-put bindings. - -We used instead to do the partitionByMajorLevel on the RHS of an '=', -in floatRhs. But that was quite tiresome. We needed to test for -values or trivial rhss, because (in particular) we don't want to insert -new bindings between the "=" and the "\". E.g. - f = \x -> let in -We do not want - f = let in \x -> -(a) The simplifier will immediately float it further out, so we may - as well do so right now; in general, keeping rhss as manifest - values is good -(b) If a float-in pass follows immediately, it might add yet more - bindings just after the '='. And some of them might (correctly) - be strict even though the 'let f' is lazy, because f, being a value, - gets its demand-info zapped by the simplifier. -And even all that turned out to be very fragile, and broke -altogether when profiling got in the way. - -So now we do the partition right at the (Let..) itself. - -************************************************************************ -* * -\subsection{Utility bits for floating stats} -* * -************************************************************************ - -I didn't implement this with unboxed numbers. I don't want to be too -strict in this stuff, as it is rarely turned on. (WDP 95/09) --} - -data FloatStats - = FlS Int -- Number of top-floats * lambda groups they've been past - Int -- Number of non-top-floats * lambda groups they've been past - Int -- Number of lambda (groups) seen - -get_stats :: FloatStats -> (Int, Int, Int) -get_stats (FlS a b c) = (a, b, c) - -zeroStats :: FloatStats -zeroStats = FlS 0 0 0 - -sum_stats :: [FloatStats] -> FloatStats -sum_stats xs = foldr add_stats zeroStats xs - -add_stats :: FloatStats -> FloatStats -> FloatStats -add_stats (FlS a1 b1 c1) (FlS a2 b2 c2) - = FlS (a1 + a2) (b1 + b2) (c1 + c2) - -add_to_stats :: FloatStats -> FloatBinds -> FloatStats -add_to_stats (FlS a b c) (FB tops ceils others) - = FlS (a + lengthBag tops) - (b + lengthBag ceils + lengthBag (flattenMajor others)) - (c + 1) - -{- -************************************************************************ -* * -\subsection{Utility bits for floating} -* * -************************************************************************ - -Note [Representation of FloatBinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The FloatBinds types is somewhat important. We can get very large numbers -of floating bindings, often all destined for the top level. A typical example -is x = [4,2,5,2,5, .... ] -Then we get lots of small expressions like (fromInteger 4), which all get -lifted to top level. - -The trouble is that - (a) we partition these floating bindings *at every binding site* - (b) GHC.Core.Op.SetLevels introduces a new bindings site for every float -So we had better not look at each binding at each binding site! - -That is why MajorEnv is represented as a finite map. - -We keep the bindings destined for the *top* level separate, because -we float them out even if they don't escape a *value* lambda; see -partitionByMajorLevel. --} - -type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted -type MajorEnv = M.IntMap MinorEnv -- Keyed by major level -type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level - -data FloatBinds = FB !(Bag FloatLet) -- Destined for top level - !(Bag FloatBind) -- Destined for join ceiling - !MajorEnv -- Other levels - -- See Note [Representation of FloatBinds] - -instance Outputable FloatBinds where - ppr (FB fbs ceils defs) - = text "FB" <+> (braces $ vcat - [ text "tops =" <+> ppr fbs - , text "ceils =" <+> ppr ceils - , text "non-tops =" <+> ppr defs ]) - -flattenTopFloats :: FloatBinds -> Bag CoreBind -flattenTopFloats (FB tops ceils defs) - = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs ) - ASSERT2( isEmptyBag ceils, ppr ceils ) - tops - -addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] -addTopFloatPairs float_bag prs - = foldr add prs float_bag - where - add (NonRec b r) prs = (b,r):prs - add (Rec prs1) prs2 = prs1 ++ prs2 - -flattenMajor :: MajorEnv -> Bag FloatBind -flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag - -flattenMinor :: MinorEnv -> Bag FloatBind -flattenMinor = M.foldr unionBags emptyBag - -emptyFloats :: FloatBinds -emptyFloats = FB emptyBag emptyBag M.empty - -unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds -unitCaseFloat (Level major minor t) e b con bs - | t == JoinCeilLvl - = FB emptyBag floats M.empty - | otherwise - = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats)) - where - floats = unitBag (FloatCase e b con bs) - -unitLetFloat :: Level -> FloatLet -> FloatBinds -unitLetFloat lvl@(Level major minor t) b - | isTopLvl lvl = FB (unitBag b) emptyBag M.empty - | t == JoinCeilLvl = FB emptyBag floats M.empty - | otherwise = FB emptyBag emptyBag (M.singleton major - (M.singleton minor floats)) - where - floats = unitBag (FloatLet b) - -plusFloats :: FloatBinds -> FloatBinds -> FloatBinds -plusFloats (FB t1 c1 l1) (FB t2 c2 l2) - = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2) - -plusMajor :: MajorEnv -> MajorEnv -> MajorEnv -plusMajor = M.unionWith plusMinor - -plusMinor :: MinorEnv -> MinorEnv -> MinorEnv -plusMinor = M.unionWith unionBags - -install :: Bag FloatBind -> CoreExpr -> CoreExpr -install defn_groups expr - = foldr wrapFloat expr defn_groups - -partitionByLevel - :: Level -- Partitioning level - -> FloatBinds -- Defns to be divided into 2 piles... - -> (FloatBinds, -- Defns with level strictly < partition level, - Bag FloatBind) -- The rest - -{- --- ---- partitionByMajorLevel ---- --- Float it if we escape a value lambda, --- *or* if we get to the top level --- *or* if it's a case-float and its minor level is < current --- --- If we can get to the top level, say "yes" anyway. This means that --- x = f e --- transforms to --- lvl = e --- x = f lvl --- which is as it should be - -partitionByMajorLevel (Level major _) (FB tops defns) - = (FB tops outer, heres `unionBags` flattenMajor inner) - where - (outer, mb_heres, inner) = M.splitLookup major defns - heres = case mb_heres of - Nothing -> emptyBag - Just h -> flattenMinor h --} - -partitionByLevel (Level major minor typ) (FB tops ceils defns) - = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min), - here_min `unionBags` here_ceil - `unionBags` flattenMinor inner_min - `unionBags` flattenMajor inner_maj) - - where - (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns - (outer_min, mb_here_min, inner_min) = case mb_here_maj of - Nothing -> (M.empty, Nothing, M.empty) - Just min_defns -> M.splitLookup minor min_defns - here_min = mb_here_min `orElse` emptyBag - (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag) - | otherwise = (emptyBag, ceils) - --- Like partitionByLevel, but instead split out the bindings that are marked --- to float to the nearest join ceiling (see Note [Join points]) -partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind) -partitionAtJoinCeiling (FB tops ceils defs) - = (FB tops emptyBag defs, ceils) - --- Perform some action at a join ceiling, i.e., don't let join points float out --- (see Note [Join points]) -atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr) - -> (FloatStats, FloatBinds, CoreExpr) -atJoinCeiling (fs, floats, expr') - = (fs, floats', install ceils expr') - where - (floats', ceils) = partitionAtJoinCeiling floats - -wrapTick :: Tickish Id -> FloatBinds -> FloatBinds -wrapTick t (FB tops ceils defns) - = FB (mapBag wrap_bind tops) (wrap_defns ceils) - (M.map (M.map wrap_defns) defns) - where - wrap_defns = mapBag wrap_one - - wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs) - wrap_bind (Rec pairs) = Rec (mapSnd maybe_tick pairs) - - wrap_one (FloatLet bind) = FloatLet (wrap_bind bind) - wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs - - maybe_tick e | exprIsHNF e = tickHNFArgs t e - | otherwise = mkTick t e - -- we don't need to wrap a tick around an HNF when we float it - -- outside a tick: that is an invariant of the tick semantics - -- Conversely, inlining of HNFs inside an SCC is allowed, and - -- indeed the HNF we're floating here might well be inlined back - -- again, and we don't want to end up with duplicate ticks. diff --git a/compiler/GHC/Core/Op/LiberateCase.hs b/compiler/GHC/Core/Op/LiberateCase.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/LiberateCase.hs +++ /dev/null @@ -1,442 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1994-1998 - -\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} --} - -{-# LANGUAGE CPP #-} -module GHC.Core.Op.LiberateCase ( liberateCase ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Driver.Session -import GHC.Core -import GHC.Core.Unfold ( couldBeSmallEnoughToInline ) -import TysWiredIn ( unitDataConId ) -import GHC.Types.Id -import GHC.Types.Var.Env -import Util ( notNull ) - -{- -The liberate-case transformation -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This module walks over @Core@, and looks for @case@ on free variables. -The criterion is: - if there is case on a free on the route to the recursive call, - then the recursive call is replaced with an unfolding. - -Example - - f = \ t -> case v of - V a b -> a : f t - -=> the inner f is replaced. - - f = \ t -> case v of - V a b -> a : (letrec - f = \ t -> case v of - V a b -> a : f t - in f) t -(note the NEED for shadowing) - -=> Simplify - - f = \ t -> case v of - V a b -> a : (letrec - f = \ t -> a : f t - in f t) - -Better code, because 'a' is free inside the inner letrec, rather -than needing projection from v. - -Note that this deals with *free variables*. SpecConstr deals with -*arguments* that are of known form. E.g. - - last [] = error - last (x:[]) = x - last (x:xs) = last xs - - -Note [Scrutinee with cast] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - f = \ t -> case (v `cast` co) of - V a b -> a : f t - -Exactly the same optimisation (unrolling one call to f) will work here, -despite the cast. See mk_alt_env in the Case branch of libCase. - - -To think about (Apr 94) -~~~~~~~~~~~~~~ -Main worry: duplicating code excessively. At the moment we duplicate -the entire binding group once at each recursive call. But there may -be a group of recursive calls which share a common set of evaluated -free variables, in which case the duplication is a plain waste. - -Another thing we could consider adding is some unfold-threshold thing, -so that we'll only duplicate if the size of the group rhss isn't too -big. - -Data types -~~~~~~~~~~ -The ``level'' of a binder tells how many -recursive defns lexically enclose the binding -A recursive defn "encloses" its RHS, not its -scope. For example: -\begin{verbatim} - letrec f = let g = ... in ... - in - let h = ... - in ... -\end{verbatim} -Here, the level of @f@ is zero, the level of @g@ is one, -and the level of @h@ is zero (NB not one). - - -************************************************************************ -* * - Top-level code -* * -************************************************************************ --} - -liberateCase :: DynFlags -> CoreProgram -> CoreProgram -liberateCase dflags binds = do_prog (initEnv dflags) binds - where - do_prog _ [] = [] - do_prog env (bind:binds) = bind' : do_prog env' binds - where - (env', bind') = libCaseBind env bind - -{- -************************************************************************ -* * - Main payload -* * -************************************************************************ - -Bindings -~~~~~~~~ --} - -libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind) - -libCaseBind env (NonRec binder rhs) - = (addBinders env [binder], NonRec binder (libCase env rhs)) - -libCaseBind env (Rec pairs) - = (env_body, Rec pairs') - where - binders = map fst pairs - - env_body = addBinders env binders - - pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs] - - -- We extend the rec-env by binding each Id to its rhs, first - -- processing the rhs with an *un-extended* environment, so - -- that the same process doesn't occur for ever! - env_rhs | is_dupable_bind = addRecBinds env dup_pairs - | otherwise = env - - dup_pairs = [ (localiseId binder, libCase env_body rhs) - | (binder, rhs) <- pairs ] - -- localiseID : see Note [Need to localiseId in libCaseBind] - - is_dupable_bind = small_enough && all ok_pair pairs - - -- Size: we are going to duplicate dup_pairs; to find their - -- size, build a fake binding (let { dup_pairs } in (), - -- and find the size of that - -- See Note [Small enough] - small_enough = case bombOutSize env of - Nothing -> True -- Infinity - Just size -> couldBeSmallEnoughToInline (lc_dflags env) size $ - Let (Rec dup_pairs) (Var unitDataConId) - - ok_pair (id,_) - = idArity id > 0 -- Note [Only functions!] - && not (isBottomingId id) -- Note [Not bottoming ids] - -{- Note [Not bottoming Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do not specialise error-functions (this is unusual, but I once saw it, -(actually in Data.Typable.Internal) - -Note [Only functions!] -~~~~~~~~~~~~~~~~~~~~~~ -Consider the following code - - f = g (case v of V a b -> a : t f) - -where g is expensive. If we aren't careful, liberate case will turn this into - - f = g (case v of - V a b -> a : t (letrec f = g (case v of V a b -> a : f t) - in f) - ) - -Yikes! We evaluate g twice. This leads to a O(2^n) explosion -if g calls back to the same code recursively. - -Solution: make sure that we only do the liberate-case thing on *functions* - -Note [Small enough] -~~~~~~~~~~~~~~~~~~~ -Consider - \fv. letrec - f = \x. BIG...(case fv of { (a,b) -> ...g.. })... - g = \y. SMALL...f... - -Then we *can* in principle do liberate-case on 'g' (small RHS) but not -for 'f' (too big). But doing so is not profitable, because duplicating -'g' at its call site in 'f' doesn't get rid of any cases. So we just -ask for the whole group to be small enough. - -Note [Need to localiseId in libCaseBind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The call to localiseId is needed for two subtle reasons -(a) Reset the export flags on the binders so - that we don't get name clashes on exported things if the - local binding floats out to top level. This is most unlikely - to happen, since the whole point concerns free variables. - But resetting the export flag is right regardless. - -(b) Make the name an Internal one. External Names should never be - nested; if it were floated to the top level, we'd get a name - clash at code generation time. - -Expressions -~~~~~~~~~~~ --} - -libCase :: LibCaseEnv - -> CoreExpr - -> CoreExpr - -libCase env (Var v) = libCaseApp env v [] -libCase _ (Lit lit) = Lit lit -libCase _ (Type ty) = Type ty -libCase _ (Coercion co) = Coercion co -libCase env e@(App {}) | let (fun, args) = collectArgs e - , Var v <- fun - = libCaseApp env v args -libCase env (App fun arg) = App (libCase env fun) (libCase env arg) -libCase env (Tick tickish body) = Tick tickish (libCase env body) -libCase env (Cast e co) = Cast (libCase env e) co - -libCase env (Lam binder body) - = Lam binder (libCase (addBinders env [binder]) body) - -libCase env (Let bind body) - = Let bind' (libCase env_body body) - where - (env_body, bind') = libCaseBind env bind - -libCase env (Case scrut bndr ty alts) - = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts) - where - env_alts = addBinders (mk_alt_env scrut) [bndr] - mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var - mk_alt_env (Cast scrut _) = mk_alt_env scrut -- Note [Scrutinee with cast] - mk_alt_env _ = env - -libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr) - -> (AltCon, [CoreBndr], CoreExpr) -libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs) - -{- -Ids -~~~ - -To unfold, we can't just wrap the id itself in its binding if it's a join point: - - jump j a b c => (joinrec j x y z = ... in jump j) a b c -- wrong!!! - -Every jump must provide all arguments, so we have to be careful to wrap the -whole jump instead: - - jump j a b c => joinrec j x y z = ... in jump j a b c -- right - --} - -libCaseApp :: LibCaseEnv -> Id -> [CoreExpr] -> CoreExpr -libCaseApp env v args - | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing - , notNull free_scruts -- with free vars scrutinised in RHS - = Let the_bind expr' - - | otherwise - = expr' - - where - rec_id_level = lookupLevel env v - free_scruts = freeScruts env rec_id_level - expr' = mkApps (Var v) (map (libCase env) args) - -freeScruts :: LibCaseEnv - -> LibCaseLevel -- Level of the recursive Id - -> [Id] -- Ids that are scrutinised between the binding - -- of the recursive Id and here -freeScruts env rec_bind_lvl - = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env - , scrut_bind_lvl <= rec_bind_lvl - , scrut_at_lvl > rec_bind_lvl] - -- Note [When to specialise] - -- Note [Avoiding fruitless liberate-case] - -{- -Note [When to specialise] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f = \x. letrec g = \y. case x of - True -> ... (f a) ... - False -> ... (g b) ... - -We get the following levels - f 0 - x 1 - g 1 - y 2 - -Then 'x' is being scrutinised at a deeper level than its binding, so -it's added to lc_sruts: [(x,1)] - -We do *not* want to specialise the call to 'f', because 'x' is not free -in 'f'. So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0). - -We *do* want to specialise the call to 'g', because 'x' is free in g. -Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1). - -Note [Avoiding fruitless liberate-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider also: - f = \x. case top_lvl_thing of - I# _ -> let g = \y. ... g ... - in ... - -Here, top_lvl_thing is scrutinised at a level (1) deeper than its -binding site (0). Nevertheless, we do NOT want to specialise the call -to 'g' because all the structure in its free variables is already -visible at the definition site for g. Hence, when considering specialising -an occurrence of 'g', we want to check that there's a scruted-var v st - - a) v's binding site is *outside* g - b) v's scrutinisation site is *inside* g - - -************************************************************************ -* * - Utility functions -* * -************************************************************************ --} - -addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv -addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders - = env { lc_lvl_env = lvl_env' } - where - lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl) - -addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv -addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env, - lc_rec_env = rec_env}) pairs - = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' } - where - lvl' = lvl + 1 - lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs] - rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs] - -addScrutedVar :: LibCaseEnv - -> Id -- This Id is being scrutinised by a case expression - -> LibCaseEnv - -addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env, - lc_scruts = scruts }) scrut_var - | bind_lvl < lvl - = env { lc_scruts = scruts' } - -- Add to scruts iff the scrut_var is being scrutinised at - -- a deeper level than its defn - - | otherwise = env - where - scruts' = (scrut_var, bind_lvl, lvl) : scruts - bind_lvl = case lookupVarEnv lvl_env scrut_var of - Just lvl -> lvl - Nothing -> topLevel - -lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind -lookupRecId env id = lookupVarEnv (lc_rec_env env) id - -lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel -lookupLevel env id - = case lookupVarEnv (lc_lvl_env env) id of - Just lvl -> lvl - Nothing -> topLevel - -{- -************************************************************************ -* * - The environment -* * -************************************************************************ --} - -type LibCaseLevel = Int - -topLevel :: LibCaseLevel -topLevel = 0 - -data LibCaseEnv - = LibCaseEnv { - lc_dflags :: DynFlags, - - lc_lvl :: LibCaseLevel, -- Current level - -- The level is incremented when (and only when) going - -- inside the RHS of a (sufficiently small) recursive - -- function. - - lc_lvl_env :: IdEnv LibCaseLevel, - -- Binds all non-top-level in-scope Ids (top-level and - -- imported things have a level of zero) - - lc_rec_env :: IdEnv CoreBind, - -- Binds *only* recursively defined ids, to their own - -- binding group, and *only* in their own RHSs - - lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)] - -- Each of these Ids was scrutinised by an enclosing - -- case expression, at a level deeper than its binding - -- level. - -- - -- The first LibCaseLevel is the *binding level* of - -- the scrutinised Id, - -- The second is the level *at which it was scrutinised*. - -- (see Note [Avoiding fruitless liberate-case]) - -- The former is a bit redundant, since you could always - -- look it up in lc_lvl_env, but it's just cached here - -- - -- The order is insignificant; it's a bag really - -- - -- There's one element per scrutinisation; - -- in principle the same Id may appear multiple times, - -- although that'd be unusual: - -- case x of { (a,b) -> ....(case x of ...) .. } - } - -initEnv :: DynFlags -> LibCaseEnv -initEnv dflags - = LibCaseEnv { lc_dflags = dflags, - lc_lvl = 0, - lc_lvl_env = emptyVarEnv, - lc_rec_env = emptyVarEnv, - lc_scruts = [] } - --- Bomb-out size for deciding if --- potential liberatees are too big. --- (passed in from cmd-line args) -bombOutSize :: LibCaseEnv -> Maybe Int -bombOutSize = liberateCaseThreshold . lc_dflags diff --git a/compiler/GHC/Core/Op/SetLevels.hs b/compiler/GHC/Core/Op/SetLevels.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/SetLevels.hs +++ /dev/null @@ -1,1771 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section{GHC.Core.Op.SetLevels} - - *************************** - Overview - *************************** - -1. We attach binding levels to Core bindings, in preparation for floating - outwards (@FloatOut@). - -2. We also let-ify many expressions (notably case scrutinees), so they - will have a fighting chance of being floated sensible. - -3. Note [Need for cloning during float-out] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We clone the binders of any floatable let-binding, so that when it is - floated out it will be unique. Example - (let x=2 in x) + (let x=3 in x) - we must clone before floating so we get - let x1=2 in - let x2=3 in - x1+x2 - - NOTE: this can't be done using the uniqAway idea, because the variable - must be unique in the whole program, not just its current scope, - because two variables in different scopes may float out to the - same top level place - - NOTE: Very tiresomely, we must apply this substitution to - the rules stored inside a variable too. - - We do *not* clone top-level bindings, because some of them must not change, - but we *do* clone bindings that are heading for the top level - -4. Note [Binder-swap during float-out] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - In the expression - case x of wild { p -> ...wild... } - we substitute x for wild in the RHS of the case alternatives: - case x of wild { p -> ...x... } - This means that a sub-expression involving x is not "trapped" inside the RHS. - And it's not inconvenient because we already have a substitution. - - Note that this is EXACTLY BACKWARDS from the what the simplifier does. - The simplifier tries to get rid of occurrences of x, in favour of wild, - in the hope that there will only be one remaining occurrence of x, namely - the scrutinee of the case, and we can inline it. --} - -{-# LANGUAGE CPP, MultiWayIf #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module GHC.Core.Op.SetLevels ( - setLevels, - - Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl, - LevelledBind, LevelledExpr, LevelledBndr, - FloatSpec(..), floatSpecLevel, - - incMinorLvl, ltMajLvl, ltLvl, isTopLvl - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Core -import GHC.Core.Op.Monad ( FloatOutSwitches(..) ) -import GHC.Core.Utils ( exprType, exprIsHNF - , exprOkForSpeculation - , exprIsTopLevelBindable - , isExprLevPoly - , collectMakeStaticArgs - ) -import GHC.Core.Arity ( exprBotStrictness_maybe ) -import GHC.Core.FVs -- all of it -import GHC.Core.Subst -import GHC.Core.Make ( sortQuantVars ) - -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Unique.Set ( nonDetFoldUniqSet ) -import GHC.Types.Unique.DSet ( getUniqDSet ) -import GHC.Types.Var.Env -import GHC.Types.Literal ( litIsTrivial ) -import GHC.Types.Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity ) -import GHC.Types.Cpr ( mkCprSig, botCpr ) -import GHC.Types.Name ( getOccName, mkSystemVarName ) -import GHC.Types.Name.Occurrence ( occNameString ) -import GHC.Core.Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType - , mightBeUnliftedType, closeOverKindsDSet ) -import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) -import GHC.Core.DataCon ( dataConOrigResTy ) -import TysWiredIn -import GHC.Types.Unique.Supply -import Util -import Outputable -import FastString -import GHC.Types.Unique.DFM -import FV -import Data.Maybe -import MonadUtils ( mapAccumLM ) - -{- -************************************************************************ -* * -\subsection{Level numbers} -* * -************************************************************************ --} - -type LevelledExpr = TaggedExpr FloatSpec -type LevelledBind = TaggedBind FloatSpec -type LevelledBndr = TaggedBndr FloatSpec - -data Level = Level Int -- Level number of enclosing lambdas - Int -- Number of big-lambda and/or case expressions and/or - -- context boundaries between - -- here and the nearest enclosing lambda - LevelType -- Binder or join ceiling? -data LevelType = BndrLvl | JoinCeilLvl deriving (Eq) - -data FloatSpec - = FloatMe Level -- Float to just inside the binding - -- tagged with this level - | StayPut Level -- Stay where it is; binding is - -- tagged with this level - -floatSpecLevel :: FloatSpec -> Level -floatSpecLevel (FloatMe l) = l -floatSpecLevel (StayPut l) = l - -{- -The {\em level number} on a (type-)lambda-bound variable is the -nesting depth of the (type-)lambda which binds it. The outermost lambda -has level 1, so (Level 0 0) means that the variable is bound outside any lambda. - -On an expression, it's the maximum level number of its free -(type-)variables. On a let(rec)-bound variable, it's the level of its -RHS. On a case-bound variable, it's the number of enclosing lambdas. - -Top-level variables: level~0. Those bound on the RHS of a top-level -definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown -as ``subscripts'')... -\begin{verbatim} -a_0 = let b_? = ... in - x_1 = ... b ... in ... -\end{verbatim} - -The main function @lvlExpr@ carries a ``context level'' (@le_ctxt_lvl@). -That's meant to be the level number of the enclosing binder in the -final (floated) program. If the level number of a sub-expression is -less than that of the context, then it might be worth let-binding the -sub-expression so that it will indeed float. - -If you can float to level @Level 0 0@ worth doing so because then your -allocation becomes static instead of dynamic. We always start with -context @Level 0 0@. - - -Note [FloatOut inside INLINE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose: -to say "don't float anything out of here". That's exactly what we -want for the body of an INLINE, where we don't want to float anything -out at all. See notes with lvlMFE below. - -But, check this out: - --- At one time I tried the effect of not floating anything out of an InlineMe, --- but it sometimes works badly. For example, consider PrelArr.done. It --- has the form __inline (\d. e) --- where e doesn't mention d. If we float this to --- __inline (let x = e in \d. x) --- things are bad. The inliner doesn't even inline it because it doesn't look --- like a head-normal form. So it seems a lesser evil to let things float. --- In GHC.Core.Op.SetLevels we do set the context to (Level 0 0) when we get to an InlineMe --- which discourages floating out. - -So the conclusion is: don't do any floating at all inside an InlineMe. -(In the above example, don't float the {x=e} out of the \d.) - -One particular case is that of workers: we don't want to float the -call to the worker outside the wrapper, otherwise the worker might get -inlined into the floated expression, and an importing module won't see -the worker at all. - -Note [Join ceiling] -~~~~~~~~~~~~~~~~~~~ -Join points can't float very far; too far, and they can't remain join points -So, suppose we have: - - f x = (joinrec j y = ... x ... in jump j x) + 1 - -One may be tempted to float j out to the top of f's RHS, but then the jump -would not be a tail call. Thus we keep track of a level called the *join -ceiling* past which join points are not allowed to float. - -The troublesome thing is that, unlike most levels to which something might -float, there is not necessarily an identifier to which the join ceiling is -attached. Fortunately, if something is to be floated to a join ceiling, it must -be dropped at the *nearest* join ceiling. Thus each level is marked as to -whether it is a join ceiling, so that FloatOut can tell which binders are being -floated to the nearest join ceiling and which to a particular binder (or set of -binders). --} - -instance Outputable FloatSpec where - ppr (FloatMe l) = char 'F' <> ppr l - ppr (StayPut l) = ppr l - -tOP_LEVEL :: Level -tOP_LEVEL = Level 0 0 BndrLvl - -incMajorLvl :: Level -> Level -incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl - -incMinorLvl :: Level -> Level -incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl - -asJoinCeilLvl :: Level -> Level -asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl - -maxLvl :: Level -> Level -> Level -maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _) - | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1 - | otherwise = l2 - -ltLvl :: Level -> Level -> Bool -ltLvl (Level maj1 min1 _) (Level maj2 min2 _) - = (maj1 < maj2) || (maj1 == maj2 && min1 < min2) - -ltMajLvl :: Level -> Level -> Bool - -- Tells if one level belongs to a difft *lambda* level to another -ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2 - -isTopLvl :: Level -> Bool -isTopLvl (Level 0 0 _) = True -isTopLvl _ = False - -isJoinCeilLvl :: Level -> Bool -isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl - -instance Outputable Level where - ppr (Level maj min typ) - = hcat [ char '<', int maj, char ',', int min, char '>' - , ppWhen (typ == JoinCeilLvl) (char 'C') ] - -instance Eq Level where - (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2 - -{- -************************************************************************ -* * -\subsection{Main level-setting code} -* * -************************************************************************ --} - -setLevels :: FloatOutSwitches - -> CoreProgram - -> UniqSupply - -> [LevelledBind] - -setLevels float_lams binds us - = initLvl us (do_them init_env binds) - where - init_env = initialEnv float_lams - - do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind] - do_them _ [] = return [] - do_them env (b:bs) - = do { (lvld_bind, env') <- lvlTopBind env b - ; lvld_binds <- do_them env' bs - ; return (lvld_bind : lvld_binds) } - -lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv) -lvlTopBind env (NonRec bndr rhs) - = do { rhs' <- lvl_top env NonRecursive bndr rhs - ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr] - ; return (NonRec bndr' rhs', env') } - -lvlTopBind env (Rec pairs) - = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL - (map fst pairs) - ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs - ; return (Rec (bndrs' `zip` rhss'), env') } - -lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr -lvl_top env is_rec bndr rhs - = lvlRhs env is_rec - (isBottomingId bndr) - Nothing -- Not a join point - (freeVars rhs) - -{- -************************************************************************ -* * -\subsection{Setting expression levels} -* * -************************************************************************ - -Note [Floating over-saturated applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see (f x y), and (f x) is a redex (ie f's arity is 1), -we call (f x) an "over-saturated application" - -Should we float out an over-sat app, if can escape a value lambda? -It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2). -But we don't want to do it for class selectors, because the work saved -is minimal, and the extra local thunks allocated cost money. - -Arguably we could float even class-op applications if they were going to -top level -- but then they must be applied to a constant dictionary and -will almost certainly be optimised away anyway. --} - -lvlExpr :: LevelEnv -- Context - -> CoreExprWithFVs -- Input expression - -> LvlM LevelledExpr -- Result expression - -{- -The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing -binder. Here's an example - - v = \x -> ...\y -> let r = case (..x..) of - ..x.. - in .. - -When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's -the level of @r@, even though it's inside a level-2 @\y@. It's -important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we -don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE ---- because it isn't a *maximal* free expression. - -If there were another lambda in @r@'s rhs, it would get level-2 as well. --} - -lvlExpr env (_, AnnType ty) = return (Type (GHC.Core.Subst.substTy (le_subst env) ty)) -lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co)) -lvlExpr env (_, AnnVar v) = return (lookupVar env v) -lvlExpr _ (_, AnnLit lit) = return (Lit lit) - -lvlExpr env (_, AnnCast expr (_, co)) = do - expr' <- lvlNonTailExpr env expr - return (Cast expr' (substCo (le_subst env) co)) - -lvlExpr env (_, AnnTick tickish expr) = do - expr' <- lvlNonTailExpr env expr - let tickish' = substTickish (le_subst env) tickish - return (Tick tickish' expr') - -lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr) - --- We don't split adjacent lambdas. That is, given --- \x y -> (x+1,y) --- we don't float to give --- \x -> let v = x+1 in \y -> (v,y) --- Why not? Because partial applications are fairly rare, and splitting --- lambdas makes them more expensive. - -lvlExpr env expr@(_, AnnLam {}) - = do { new_body <- lvlNonTailMFE new_env True body - ; return (mkLams new_bndrs new_body) } - where - (bndrs, body) = collectAnnBndrs expr - (env1, bndrs1) = substBndrsSL NonRecursive env bndrs - (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1 - -- At one time we called a special version of collectBinders, - -- which ignored coercions, because we don't want to split - -- a lambda like this (\x -> coerce t (\s -> ...)) - -- This used to happen quite a bit in state-transformer programs, - -- but not nearly so much now non-recursive newtypes are transparent. - -- [See GHC.Core.Op.SetLevels rev 1.50 for a version with this approach.] - -lvlExpr env (_, AnnLet bind body) - = do { (bind', new_env) <- lvlBind env bind - ; body' <- lvlExpr new_env body - -- No point in going via lvlMFE here. If the binding is alive - -- (mentioned in body), and the whole let-expression doesn't - -- float, then neither will the body - ; return (Let bind' body') } - -lvlExpr env (_, AnnCase scrut case_bndr ty alts) - = do { scrut' <- lvlNonTailMFE env True scrut - ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts } - -lvlNonTailExpr :: LevelEnv -- Context - -> CoreExprWithFVs -- Input expression - -> LvlM LevelledExpr -- Result expression -lvlNonTailExpr env expr - = lvlExpr (placeJoinCeiling env) expr - -------------------------------------------- -lvlApp :: LevelEnv - -> CoreExprWithFVs - -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application - -> LvlM LevelledExpr -- Result expression -lvlApp env orig_expr ((_,AnnVar fn), args) - | floatOverSat env -- See Note [Floating over-saturated applications] - , arity > 0 - , arity < n_val_args - , Nothing <- isClassOpId_maybe fn - = do { rargs' <- mapM (lvlNonTailMFE env False) rargs - ; lapp' <- lvlNonTailMFE env False lapp - ; return (foldl' App lapp' rargs') } - - | otherwise - = do { (_, args') <- mapAccumLM lvl_arg stricts args - -- Take account of argument strictness; see - -- Note [Floating to the top] - ; return (foldl' App (lookupVar env fn) args') } - where - n_val_args = count (isValArg . deAnnotate) args - arity = idArity fn - - stricts :: [Demand] -- True for strict /value/ arguments - stricts = case splitStrictSig (idStrictness fn) of - (arg_ds, _) | arg_ds `lengthExceeds` n_val_args - -> [] - | otherwise - -> arg_ds - - -- Separate out the PAP that we are floating from the extra - -- arguments, by traversing the spine until we have collected - -- (n_val_args - arity) value arguments. - (lapp, rargs) = left (n_val_args - arity) orig_expr [] - - left 0 e rargs = (e, rargs) - left n (_, AnnApp f a) rargs - | isValArg (deAnnotate a) = left (n-1) f (a:rargs) - | otherwise = left n f (a:rargs) - left _ _ _ = panic "GHC.Core.Op.SetLevels.lvlExpr.left" - - is_val_arg :: CoreExprWithFVs -> Bool - is_val_arg (_, AnnType {}) = False - is_val_arg _ = True - - lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr) - lvl_arg strs arg | (str1 : strs') <- strs - , is_val_arg arg - = do { arg' <- lvlMFE env (isStrictDmd str1) arg - ; return (strs', arg') } - | otherwise - = do { arg' <- lvlMFE env False arg - ; return (strs, arg') } - -lvlApp env _ (fun, args) - = -- No PAPs that we can float: just carry on with the - -- arguments and the function. - do { args' <- mapM (lvlNonTailMFE env False) args - ; fun' <- lvlNonTailExpr env fun - ; return (foldl' App fun' args') } - -------------------------------------------- -lvlCase :: LevelEnv -- Level of in-scope names/tyvars - -> DVarSet -- Free vars of input scrutinee - -> LevelledExpr -- Processed scrutinee - -> Id -> Type -- Case binder and result type - -> [CoreAltWithFVs] -- Input alternatives - -> LvlM LevelledExpr -- Result expression -lvlCase env scrut_fvs scrut' case_bndr ty alts - -- See Note [Floating single-alternative cases] - | [(con@(DataAlt {}), bs, body)] <- alts - , exprIsHNF (deTagExpr scrut') -- See Note [Check the output scrutinee for exprIsHNF] - , not (isTopLvl dest_lvl) -- Can't have top-level cases - , not (floatTopLvlOnly env) -- Can float anywhere - = -- Always float the case if possible - -- Unlike lets we don't insist that it escapes a value lambda - do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs) - ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut' - ; body' <- lvlMFE rhs_env True body - ; let alt' = (con, map (stayPut dest_lvl) bs', body') - ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) } - - | otherwise -- Stays put - = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr] - alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut' - ; alts' <- mapM (lvl_alt alts_env) alts - ; return (Case scrut' case_bndr' ty' alts') } - where - ty' = substTy (le_subst env) ty - - incd_lvl = incMinorLvl (le_ctxt_lvl env) - dest_lvl = maxFvLevel (const True) env scrut_fvs - -- Don't abstract over type variables, hence const True - - lvl_alt alts_env (con, bs, rhs) - = do { rhs' <- lvlMFE new_env True rhs - ; return (con, bs', rhs') } - where - (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs - -{- Note [Floating single-alternative cases] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - data T a = MkT !a - f :: T Int -> blah - f x vs = case x of { MkT y -> - let f vs = ...(case y of I# w -> e)...f.. - in f vs - -Here we can float the (case y ...) out, because y is sure -to be evaluated, to give - f x vs = case x of { MkT y -> - case y of I# w -> - let f vs = ...(e)...f.. - in f vs - -That saves unboxing it every time round the loop. It's important in -some DPH stuff where we really want to avoid that repeated unboxing in -the inner loop. - -Things to note: - - * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation. - - - exrpIsHNF catches the key case of an evaluated variable - - - exprOkForSpeculation is /false/ of an evaluated variable; - See Note [exprOkForSpeculation and evaluated variables] in GHC.Core.Utils - So we'd actually miss the key case! - - - Nothing is gained from the extra generality of exprOkForSpeculation - since we only consider floating a case whose single alternative - is a DataAlt K a b -> rhs - - * We can't float a case to top level - - * It's worth doing this float even if we don't float - the case outside a value lambda. Example - case x of { - MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...) - If we floated the cases out we could eliminate one of them. - - * We only do this with a single-alternative case - - -Note [Setting levels when floating single-alternative cases] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Handling level-setting when floating a single-alternative case binding -is a bit subtle, as evidenced by #16978. In particular, we must keep -in mind that we are merely moving the case and its binders, not the -body. For example, suppose 'a' is known to be evaluated and we have - - \z -> case a of - (x,_) -> - -After floating we may have: - - case a of - (x,_) -> \z -> - {- some expression involving x and z -} - -When analysing we want to use the /ambient/ level, -and /not/ the destination level of the 'case a of (x,-) ->' binding. - -#16978 was caused by us setting the context level to the destination -level of `x` when analysing . This led us to conclude that we -needed to quantify over some of its free variables (e.g. z), resulting -in shadowing and very confusing Core Lint failures. - - -Note [Check the output scrutinee for exprIsHNF] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - case x of y { - A -> ....(case y of alts).... - } - -Because of the binder-swap, the inner case will get substituted to -(case x of ..). So when testing whether the scrutinee is in HNF we -must be careful to test the *result* scrutinee ('x' in this case), not -the *input* one 'y'. The latter *is* in HNF here (because y is -evaluated), but the former is not -- and indeed we can't float the -inner case out, at least not unless x is also evaluated at its binding -site. See #5453. - -That's why we apply exprIsHNF to scrut' and not to scrut. - -See Note [Floating single-alternative cases] for why -we use exprIsHNF in the first place. --} - -lvlNonTailMFE :: LevelEnv -- Level of in-scope names/tyvars - -> Bool -- True <=> strict context [body of case - -- or let] - -> CoreExprWithFVs -- input expression - -> LvlM LevelledExpr -- Result expression -lvlNonTailMFE env strict_ctxt ann_expr - = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr - -lvlMFE :: LevelEnv -- Level of in-scope names/tyvars - -> Bool -- True <=> strict context [body of case or let] - -> CoreExprWithFVs -- input expression - -> LvlM LevelledExpr -- Result expression --- lvlMFE is just like lvlExpr, except that it might let-bind --- the expression, so that it can itself be floated. - -lvlMFE env _ (_, AnnType ty) - = return (Type (GHC.Core.Subst.substTy (le_subst env) ty)) - --- No point in floating out an expression wrapped in a coercion or note --- If we do we'll transform lvl = e |> co --- to lvl' = e; lvl = lvl' |> co --- and then inline lvl. Better just to float out the payload. -lvlMFE env strict_ctxt (_, AnnTick t e) - = do { e' <- lvlMFE env strict_ctxt e - ; let t' = substTickish (le_subst env) t - ; return (Tick t' e') } - -lvlMFE env strict_ctxt (_, AnnCast e (_, co)) - = do { e' <- lvlMFE env strict_ctxt e - ; return (Cast e' (substCo (le_subst env) co)) } - -lvlMFE env strict_ctxt e@(_, AnnCase {}) - | strict_ctxt -- Don't share cases in a strict context - = lvlExpr env e -- See Note [Case MFEs] - -lvlMFE env strict_ctxt ann_expr - | floatTopLvlOnly env && not (isTopLvl dest_lvl) - -- Only floating to the top level is allowed. - || anyDVarSet isJoinId fvs -- If there is a free join, don't float - -- See Note [Free join points] - || isExprLevPoly expr - -- We can't let-bind levity polymorphic expressions - -- See Note [Levity polymorphism invariants] in GHC.Core - || notWorthFloating expr abs_vars - || not float_me - = -- Don't float it out - lvlExpr env ann_expr - - | float_is_new_lam || exprIsTopLevelBindable expr expr_ty - -- No wrapping needed if the type is lifted, or is a literal string - -- or if we are wrapping it in one or more value lambdas - = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive - (isJust mb_bot_str) - join_arity_maybe - ann_expr - -- Treat the expr just like a right-hand side - ; var <- newLvlVar expr1 join_arity_maybe is_mk_static - ; let var2 = annotateBotStr var float_n_lams mb_bot_str - ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1) - (mkVarApps (Var var2) abs_vars)) } - - -- OK, so the float has an unlifted type (not top-level bindable) - -- and no new value lambdas (float_is_new_lam is False) - -- Try for the boxing strategy - -- See Note [Floating MFEs of unlifted type] - | escapes_value_lam - , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions - -- See Note [Test cheapness with exprOkForSpeculation] - , Just (tc, _) <- splitTyConApp_maybe expr_ty - , Just dc <- boxingDataCon_maybe tc - , let dc_res_ty = dataConOrigResTy dc -- No free type variables - [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty] - = do { expr1 <- lvlExpr rhs_env ann_expr - ; let l1r = incMinorLvlFrom rhs_env - float_rhs = mkLams abs_vars_w_lvls $ - Case expr1 (stayPut l1r ubx_bndr) dc_res_ty - [(DEFAULT, [], mkConApp dc [Var ubx_bndr])] - - ; var <- newLvlVar float_rhs Nothing is_mk_static - ; let l1u = incMinorLvlFrom env - use_expr = Case (mkVarApps (Var var) abs_vars) - (stayPut l1u bx_bndr) expr_ty - [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)] - ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs) - use_expr) } - - | otherwise -- e.g. do not float unboxed tuples - = lvlExpr env ann_expr - - where - expr = deAnnotate ann_expr - expr_ty = exprType expr - fvs = freeVarsOf ann_expr - fvs_ty = tyCoVarsOfType expr_ty - is_bot = isBottomThunk mb_bot_str - is_function = isFunction ann_expr - mb_bot_str = exprBotStrictness_maybe expr - -- See Note [Bottoming floats] - -- esp Bottoming floats (2) - expr_ok_for_spec = exprOkForSpeculation expr - dest_lvl = destLevel env fvs fvs_ty is_function is_bot False - abs_vars = abstractVars dest_lvl env fvs - - -- float_is_new_lam: the floated thing will be a new value lambda - -- replacing, say (g (x+4)) by (lvl x). No work is saved, nor is - -- allocation saved. The benefit is to get it to the top level - -- and hence out of the body of this function altogether, making - -- it smaller and more inlinable - float_is_new_lam = float_n_lams > 0 - float_n_lams = count isId abs_vars - - (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars - - join_arity_maybe = Nothing - - is_mk_static = isJust (collectMakeStaticArgs expr) - -- Yuk: See Note [Grand plan for static forms] in main/StaticPtrTable - - -- A decision to float entails let-binding this thing, and we only do - -- that if we'll escape a value lambda, or will go to the top level. - float_me = saves_work || saves_alloc || is_mk_static - - -- We can save work if we can move a redex outside a value lambda - -- But if float_is_new_lam is True, then the redex is wrapped in a - -- a new lambda, so no work is saved - saves_work = escapes_value_lam && not float_is_new_lam - - escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env) - -- See Note [Escaping a value lambda] - - -- See Note [Floating to the top] - saves_alloc = isTopLvl dest_lvl - && floatConsts env - && (not strict_ctxt || is_bot || exprIsHNF expr) - -isBottomThunk :: Maybe (Arity, s) -> Bool --- See Note [Bottoming floats] (2) -isBottomThunk (Just (0, _)) = True -- Zero arity -isBottomThunk _ = False - -{- Note [Floating to the top] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We are keen to float something to the top level, even if it does not -escape a value lambda (and hence save work), for two reasons: - - * Doing so makes the function smaller, by floating out - bottoming expressions, or integer or string literals. That in - turn makes it easier to inline, with less duplication. - - * (Minor) Doing so may turn a dynamic allocation (done by machine - instructions) into a static one. Minor because we are assuming - we are not escaping a value lambda. - -But do not so if: - - the context is a strict, and - - the expression is not a HNF, and - - the expression is not bottoming - -Exammples: - -* Bottoming - f x = case x of - 0 -> error - _ -> x+1 - Here we want to float (error ) to top level, abstracting - over 'x', so as to make f's RHS smaller. - -* HNF - f = case y of - True -> p:q - False -> blah - We may as well float the (p:q) so it becomes a static data structure. - -* Case scrutinee - f = case g True of .... - Don't float (g True) to top level; then we have the admin of a - top-level thunk to worry about, with zero gain. - -* Case alternative - h = case y of - True -> g True - False -> False - Don't float (g True) to the top level - -* Arguments - t = f (g True) - If f is lazy, we /do/ float (g True) because then we can allocate - the thunk statically rather than dynamically. But if f is strict - we don't (see the use of idStrictness in lvlApp). It's not clear - if this test is worth the bother: it's only about CAFs! - -It's controlled by a flag (floatConsts), because doing this too -early loses opportunities for RULES which (needless to say) are -important in some nofib programs (gcd is an example). [SPJ note: -I think this is obsolete; the flag seems always on.] - -Note [Floating join point bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Mostly we only float a join point if it can /stay/ a join point. But -there is one exception: if it can go to the top level (#13286). -Consider - f x = joinrec j y n = <...j y' n'...> - in jump j x 0 - -Here we may just as well produce - j y n = <....j y' n'...> - f x = j x 0 - -and now there is a chance that 'f' will be inlined at its call sites. -It shouldn't make a lot of difference, but these tests - perf/should_run/MethSharing - simplCore/should_compile/spec-inline -and one nofib program, all improve if you do float to top, because -of the resulting inlining of f. So ok, let's do it. - -Note [Free join points] -~~~~~~~~~~~~~~~~~~~~~~~ -We never float a MFE that has a free join-point variable. You might think -this can never occur. After all, consider - join j x = ... - in ....(jump j x).... -How might we ever want to float that (jump j x)? - * If it would escape a value lambda, thus - join j x = ... in (\y. ...(jump j x)... ) - then 'j' isn't a valid join point in the first place. - -But consider - join j x = .... in - joinrec j2 y = ...(jump j x)...(a+b).... - -Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec. -But it is emphatically /not/ good to float the (jump j x) out: - (a) 'j' will stop being a join point - (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no - work would be saved by floating it out of the \y. - -Even if we floated 'j' to top level, (b) would still hold. - -Bottom line: never float a MFE that has a free JoinId. - -Note [Floating MFEs of unlifted type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - case f x of (r::Int#) -> blah -we'd like to float (f x). But it's not trivial because it has type -Int#, and we don't want to evaluate it too early. But we can instead -float a boxed version - y = case f x of r -> I# r -and replace the original (f x) with - case (case y of I# r -> r) of r -> blah - -Being able to float unboxed expressions is sometimes important; see -#12603. I'm not sure how /often/ it is important, but it's -not hard to achieve. - -We only do it for a fixed collection of types for which we have a -convenient boxing constructor (see boxingDataCon_maybe). In -particular we /don't/ do it for unboxed tuples; it's better to float -the components of the tuple individually. - -I did experiment with a form of boxing that works for any type, namely -wrapping in a function. In our example - - let y = case f x of r -> \v. f x - in case y void of r -> blah - -It works fine, but it's 50% slower (based on some crude benchmarking). -I suppose we could do it for types not covered by boxingDataCon_maybe, -but it's more code and I'll wait to see if anyone wants it. - -Note [Test cheapness with exprOkForSpeculation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't want to float very cheap expressions by boxing and unboxing. -But we use exprOkForSpeculation for the test, not exprIsCheap. -Why? Because it's important /not/ to transform - f (a /# 3) -to - f (case bx of I# a -> a /# 3) -and float bx = I# (a /# 3), because the application of f no -longer obeys the let/app invariant. But (a /# 3) is ok-for-spec -due to a special hack that says division operators can't fail -when the denominator is definitely non-zero. And yet that -same expression says False to exprIsCheap. Simplest way to -guarantee the let/app invariant is to use the same function! - -If an expression is okay for speculation, we could also float it out -*without* boxing and unboxing, since evaluating it early is okay. -However, it turned out to usually be better not to float such expressions, -since they tend to be extremely cheap things like (x +# 1#). Even the -cost of spilling the let-bound variable to the stack across a call may -exceed the cost of recomputing such an expression. (And we can't float -unlifted bindings to top-level.) - -We could try to do something smarter here, and float out expensive yet -okay-for-speculation things, such as division by non-zero constants. -But I suspect it's a narrow target. - -Note [Bottoming floats] -~~~~~~~~~~~~~~~~~~~~~~~ -If we see - f = \x. g (error "urk") -we'd like to float the call to error, to get - lvl = error "urk" - f = \x. g lvl - -But, as ever, we need to be careful: - -(1) We want to float a bottoming - expression even if it has free variables: - f = \x. g (let v = h x in error ("urk" ++ v)) - Then we'd like to abstract over 'x' can float the whole arg of g: - lvl = \x. let v = h x in error ("urk" ++ v) - f = \x. g (lvl x) - To achieve this we pass is_bot to destLevel - -(2) We do not do this for lambdas that return - bottom. Instead we treat the /body/ of such a function specially, - via point (1). For example: - f = \x. ....(\y z. if x then error y else error z).... - ===> - lvl = \x z y. if b then error y else error z - f = \x. ...(\y z. lvl x z y)... - (There is no guarantee that we'll choose the perfect argument order.) - -(3) If we have a /binding/ that returns bottom, we want to float it to top - level, even if it has free vars (point (1)), and even it has lambdas. - Example: - ... let { v = \y. error (show x ++ show y) } in ... - We want to abstract over x and float the whole thing to top: - lvl = \xy. errror (show x ++ show y) - ...let {v = lvl x} in ... - - Then of course we don't want to separately float the body (error ...) - as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot - argument. - -See Maessen's paper 1999 "Bottom extraction: factoring error handling out -of functional programs" (unpublished I think). - -When we do this, we set the strictness and arity of the new bottoming -Id, *immediately*, for three reasons: - - * To prevent the abstracted thing being immediately inlined back in again - via preInlineUnconditionally. The latter has a test for bottoming Ids - to stop inlining them, so we'd better make sure it *is* a bottoming Id! - - * So that it's properly exposed as such in the interface file, even if - this is all happening after strictness analysis. - - * In case we do CSE with the same expression that *is* marked bottom - lvl = error "urk" - x{str=bot) = error "urk" - Here we don't want to replace 'x' with 'lvl', else we may get Lint - errors, e.g. via a case with empty alternatives: (case x of {}) - Lint complains unless the scrutinee of such a case is clearly bottom. - - This was reported in #11290. But since the whole bottoming-float - thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure - that it'll nail all such cases. - -Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tiresomely, though, the simplifier has an invariant that the manifest -arity of the RHS should be the same as the arity; but we can't call -etaExpand during GHC.Core.Op.SetLevels because it works over a decorated form of -CoreExpr. So we do the eta expansion later, in GHC.Core.Op.FloatOut. - -Note [Case MFEs] -~~~~~~~~~~~~~~~~ -We don't float a case expression as an MFE from a strict context. Why not? -Because in doing so we share a tiny bit of computation (the switch) but -in exchange we build a thunk, which is bad. This case reduces allocation -by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem. -Doesn't change any other allocation at all. - -We will make a separate decision for the scrutinee and alternatives. - -However this can have a knock-on effect for fusion: consider - \v -> foldr k z (case x of I# y -> build ..y..) -Perhaps we can float the entire (case x of ...) out of the \v. Then -fusion will not happen, but we will get more sharing. But if we don't -float the case (as advocated here) we won't float the (build ...y..) -either, so fusion will happen. It can be a big effect, esp in some -artificial benchmarks (e.g. integer, queens), but there is no perfect -answer. - --} - -annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id --- See Note [Bottoming floats] for why we want to add --- bottoming information right now --- --- n_extra are the number of extra value arguments added during floating -annotateBotStr id n_extra mb_str - = case mb_str of - Nothing -> id - Just (arity, sig) -> id `setIdArity` (arity + n_extra) - `setIdStrictness` (increaseStrictSigArity n_extra sig) - `setIdCprInfo` mkCprSig (arity + n_extra) botCpr - -notWorthFloating :: CoreExpr -> [Var] -> Bool --- Returns True if the expression would be replaced by --- something bigger than it is now. For example: --- abs_vars = tvars only: return True if e is trivial, --- but False for anything bigger --- abs_vars = [x] (an Id): return True for trivial, or an application (f x) --- but False for (f x x) --- --- One big goal is that floating should be idempotent. Eg if --- we replace e with (lvl79 x y) and then run FloatOut again, don't want --- to replace (lvl79 x y) with (lvl83 x y)! - -notWorthFloating e abs_vars - = go e (count isId abs_vars) - where - go (Var {}) n = n >= 0 - go (Lit lit) n = ASSERT( n==0 ) - litIsTrivial lit -- Note [Floating literals] - go (Tick t e) n = not (tickishIsCode t) && go e n - go (Cast e _) n = go e n - go (App e arg) n - -- See Note [Floating applications to coercions] - | Type {} <- arg = go e n - | n==0 = False - | is_triv arg = go e (n-1) - | otherwise = False - go _ _ = False - - is_triv (Lit {}) = True -- Treat all literals as trivial - is_triv (Var {}) = True -- (ie not worth floating) - is_triv (Cast e _) = is_triv e - is_triv (App e (Type {})) = is_triv e -- See Note [Floating applications to coercions] - is_triv (Tick t e) = not (tickishIsCode t) && is_triv e - is_triv _ = False - -{- -Note [Floating literals] -~~~~~~~~~~~~~~~~~~~~~~~~ -It's important to float Integer literals, so that they get shared, -rather than being allocated every time round the loop. -Hence the litIsTrivial. - -Ditto literal strings (LitString), which we'd like to float to top -level, which is now possible. - -Note [Floating applications to coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don’t float out variables applied only to type arguments, since the -extra binding would be pointless: type arguments are completely erased. -But *coercion* arguments aren’t (see Note [Coercion tokens] in -CoreToStg.hs and Note [Count coercion arguments in boring contexts] in -CoreUnfold.hs), so we still want to float out variables applied only to -coercion arguments. - -Note [Escaping a value lambda] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to float even cheap expressions out of value lambdas, -because that saves allocation. Consider - f = \x. .. (\y.e) ... -Then we'd like to avoid allocating the (\y.e) every time we call f, -(assuming e does not mention x). An example where this really makes a -difference is simplrun009. - -Another reason it's good is because it makes SpecContr fire on functions. -Consider - f = \x. ....(f (\y.e)).... -After floating we get - lvl = \y.e - f = \x. ....(f lvl)... -and that is much easier for SpecConstr to generate a robust -specialisation for. - -However, if we are wrapping the thing in extra value lambdas (in -abs_vars), then nothing is saved. E.g. - f = \xyz. ...(e1[y],e2).... -If we float - lvl = \y. (e1[y],e2) - f = \xyz. ...(lvl y)... -we have saved nothing: one pair will still be allocated for each -call of 'f'. Hence the (not float_is_lam) in float_me. - - -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ - -The binding stuff works for top level too. --} - -lvlBind :: LevelEnv - -> CoreBindWithFVs - -> LvlM (LevelledBind, LevelEnv) - -lvlBind env (AnnNonRec bndr rhs) - | isTyVar bndr -- Don't do anything for TyVar binders - -- (simplifier gets rid of them pronto) - || isCoVar bndr -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv) - -- so we will ignore this case for now - || not (profitableFloat env dest_lvl) - || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty)) - -- We can't float an unlifted binding to top level (except - -- literal strings), so we don't float it at all. It's a - -- bit brutal, but unlifted bindings aren't expensive either - - = -- No float - do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs - ; let bind_lvl = incMinorLvl (le_ctxt_lvl env) - (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr] - ; return (NonRec bndr' rhs', env') } - - -- Otherwise we are going to float - | null abs_vars - = do { -- No type abstraction; clone existing binder - rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive - is_bot mb_join_arity rhs - ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr] - ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str - ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } - - | otherwise - = do { -- Yes, type abstraction; create a new binder, extend substitution, etc - rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive - is_bot mb_join_arity rhs - ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr] - ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str - ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } - - where - bndr_ty = idType bndr - ty_fvs = tyCoVarsOfType bndr_ty - rhs_fvs = freeVarsOf rhs - bind_fvs = rhs_fvs `unionDVarSet` dIdFreeVars bndr - abs_vars = abstractVars dest_lvl env bind_fvs - dest_lvl = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join - - deann_rhs = deAnnotate rhs - mb_bot_str = exprBotStrictness_maybe deann_rhs - is_bot = isJust mb_bot_str - -- NB: not isBottomThunk! See Note [Bottoming floats] point (3) - - n_extra = count isId abs_vars - mb_join_arity = isJoinId_maybe bndr - is_join = isJust mb_join_arity - -lvlBind env (AnnRec pairs) - | floatTopLvlOnly env && not (isTopLvl dest_lvl) - -- Only floating to the top level is allowed. - || not (profitableFloat env dest_lvl) - || (isTopLvl dest_lvl && any (mightBeUnliftedType . idType) bndrs) - -- This mightBeUnliftedType stuff is the same test as in the non-rec case - -- You might wonder whether we can have a recursive binding for - -- an unlifted value -- but we can if it's a /join binding/ (#16978) - -- (Ultimately I think we should not use GHC.Core.Op.SetLevels to - -- float join bindings at all, but that's another story.) - = -- No float - do { let bind_lvl = incMinorLvl (le_ctxt_lvl env) - (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs - lvl_rhs (b,r) = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r - ; rhss' <- mapM lvl_rhs pairs - ; return (Rec (bndrs' `zip` rhss'), env') } - - -- Otherwise we are going to float - | null abs_vars - = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs - ; new_rhss <- mapM (do_rhs new_env) pairs - ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) - , new_env) } - --- ToDo: when enabling the floatLambda stuff, --- I think we want to stop doing this - | [(bndr,rhs)] <- pairs - , count isId abs_vars > 1 - = do -- Special case for self recursion where there are - -- several variables carried around: build a local loop: - -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars - -- This just makes the closures a bit smaller. If we don't do - -- this, allocation rises significantly on some programs - -- - -- We could elaborate it for the case where there are several - -- mutually recursive functions, but it's quite a bit more complicated - -- - -- This all seems a bit ad hoc -- sigh - let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars - rhs_lvl = le_ctxt_lvl rhs_env - - (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr] - let - (lam_bndrs, rhs_body) = collectAnnBndrs rhs - (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs - (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1 - new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body - (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr] - return (Rec [(TB poly_bndr (FloatMe dest_lvl) - , mkLams abs_vars_w_lvls $ - mkLams lam_bndrs2 $ - Let (Rec [( TB new_bndr (StayPut rhs_lvl) - , mkLams lam_bndrs2 new_rhs_body)]) - (mkVarApps (Var new_bndr) lam_bndrs1))] - , poly_env) - - | otherwise -- Non-null abs_vars - = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs - ; new_rhss <- mapM (do_rhs new_env) pairs - ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) - , new_env) } - - where - (bndrs,rhss) = unzip pairs - is_join = isJoinId (head bndrs) - -- bndrs is always non-empty and if one is a join they all are - -- Both are checked by Lint - is_fun = all isFunction rhss - is_bot = False -- It's odd to have an unconditionally divergent - -- function in a Rec, and we don't much care what - -- happens to it. False is simple! - - do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive - is_bot (get_join bndr) - rhs - - get_join bndr | need_zap = Nothing - | otherwise = isJoinId_maybe bndr - need_zap = dest_lvl `ltLvl` joinCeilingLevel env - - -- Finding the free vars of the binding group is annoying - bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs]) - `unionDVarSet` - (fvDVarSet $ unionsFV [ idFVs bndr - | (bndr, (_,_)) <- pairs])) - `delDVarSetList` - bndrs - - ty_fvs = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs - dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join - abs_vars = abstractVars dest_lvl env bind_fvs - -profitableFloat :: LevelEnv -> Level -> Bool -profitableFloat env dest_lvl - = (dest_lvl `ltMajLvl` le_ctxt_lvl env) -- Escapes a value lambda - || isTopLvl dest_lvl -- Going all the way to top level - - ----------------------------------------------------- --- Three help functions for the type-abstraction case - -lvlRhs :: LevelEnv - -> RecFlag - -> Bool -- Is this a bottoming function - -> Maybe JoinArity - -> CoreExprWithFVs - -> LvlM LevelledExpr -lvlRhs env rec_flag is_bot mb_join_arity expr - = lvlFloatRhs [] (le_ctxt_lvl env) env - rec_flag is_bot mb_join_arity expr - -lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag - -> Bool -- Binding is for a bottoming function - -> Maybe JoinArity - -> CoreExprWithFVs - -> LvlM (Expr LevelledBndr) --- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline -lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs - = do { body' <- if not is_bot -- See Note [Floating from a RHS] - && any isId bndrs - then lvlMFE body_env True body - else lvlExpr body_env body - ; return (mkLams bndrs' body') } - where - (bndrs, body) | Just join_arity <- mb_join_arity - = collectNAnnBndrs join_arity rhs - | otherwise - = collectAnnBndrs rhs - (env1, bndrs1) = substBndrsSL NonRecursive env bndrs - all_bndrs = abs_vars ++ bndrs1 - (body_env, bndrs') | Just _ <- mb_join_arity - = lvlJoinBndrs env1 dest_lvl rec all_bndrs - | otherwise - = case lvlLamBndrs env1 dest_lvl all_bndrs of - (env2, bndrs') -> (placeJoinCeiling env2, bndrs') - -- The important thing here is that we call lvlLamBndrs on - -- all these binders at once (abs_vars and bndrs), so they - -- all get the same major level. Otherwise we create stupid - -- let-bindings inside, joyfully thinking they can float; but - -- in the end they don't because we never float bindings in - -- between lambdas - -{- Note [Floating from a RHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When floating the RHS of a let-binding, we don't always want to apply -lvlMFE to the body of a lambda, as we usually do, because the entire -binding body is already going to the right place (dest_lvl). - -A particular example is the top level. Consider - concat = /\ a -> foldr ..a.. (++) [] -We don't want to float the body of the lambda to get - lvl = /\ a -> foldr ..a.. (++) [] - concat = /\ a -> lvl a -That would be stupid. - -Previously this was avoided in a much nastier way, by testing strict_ctxt -in float_me in lvlMFE. But that wasn't even right because it would fail -to float out the error sub-expression in - f = \x. case x of - True -> error ("blah" ++ show x) - False -> ... - -But we must be careful: - -* If we had - f = \x -> factorial 20 - we /would/ want to float that (factorial 20) out! Functions are treated - differently: see the use of isFunction in the calls to destLevel. If - there are only type lambdas, then destLevel will say "go to top, and - abstract over the free tyvars" and we don't want that here. - -* But if we had - f = \x -> error (...x....) - we would NOT want to float the bottoming expression out to give - lvl = \x -> error (...x...) - f = \x -> lvl x - -Conclusion: use lvlMFE if there are - * any value lambdas in the original function, and - * this is not a bottoming function (the is_bot argument) -Use lvlExpr otherwise. A little subtle, and I got it wrong at least twice -(e.g. #13369). --} - -{- -************************************************************************ -* * -\subsection{Deciding floatability} -* * -************************************************************************ --} - -substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr]) -substAndLvlBndrs is_rec env lvl bndrs - = lvlBndrs subst_env lvl subst_bndrs - where - (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs - -substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar]) --- So named only to avoid the name clash with GHC.Core.Subst.substBndrs -substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs - = ( env { le_subst = subst' - , le_env = foldl' add_id id_env (bndrs `zip` bndrs') } - , bndrs') - where - (subst', bndrs') = case is_rec of - NonRecursive -> substBndrs subst bndrs - Recursive -> substRecBndrs subst bndrs - -lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr]) --- Compute the levels for the binders of a lambda group -lvlLamBndrs env lvl bndrs - = lvlBndrs env new_lvl bndrs - where - new_lvl | any is_major bndrs = incMajorLvl lvl - | otherwise = incMinorLvl lvl - - is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr) - -- The "probably" part says "don't float things out of a - -- probable one-shot lambda" - -- See Note [Computing one-shot info] in GHC.Types.Demand - -lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar] - -> (LevelEnv, [LevelledBndr]) -lvlJoinBndrs env lvl rec bndrs - = lvlBndrs env new_lvl bndrs - where - new_lvl | isRec rec = incMajorLvl lvl - | otherwise = incMinorLvl lvl - -- Non-recursive join points are one-shot; recursive ones are not - -lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr]) --- The binders returned are exactly the same as the ones passed, --- apart from applying the substitution, but they are now paired --- with a (StayPut level) --- --- The returned envt has le_ctxt_lvl updated to the new_lvl --- --- All the new binders get the same level, because --- any floating binding is either going to float past --- all or none. We never separate binders. -lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs - = ( env { le_ctxt_lvl = new_lvl - , le_join_ceil = new_lvl - , le_lvl_env = addLvls new_lvl lvl_env bndrs } - , map (stayPut new_lvl) bndrs) - -stayPut :: Level -> OutVar -> LevelledBndr -stayPut new_lvl bndr = TB bndr (StayPut new_lvl) - - -- Destination level is the max Id level of the expression - -- (We'll abstract the type variables, if any.) -destLevel :: LevelEnv - -> DVarSet -- Free vars of the term - -> TyCoVarSet -- Free in the /type/ of the term - -- (a subset of the previous argument) - -> Bool -- True <=> is function - -> Bool -- True <=> is bottom - -> Bool -- True <=> is a join point - -> Level --- INVARIANT: if is_join=True then result >= join_ceiling -destLevel env fvs fvs_ty is_function is_bot is_join - | isTopLvl max_fv_id_level -- Float even joins if they get to top level - -- See Note [Floating join point bindings] - = tOP_LEVEL - - | is_join -- Never float a join point past the join ceiling - -- See Note [Join points] in GHC.Core.Op.FloatOut - = if max_fv_id_level `ltLvl` join_ceiling - then join_ceiling - else max_fv_id_level - - | is_bot -- Send bottoming bindings to the top - = as_far_as_poss -- regardless; see Note [Bottoming floats] - -- Esp Bottoming floats (1) - - | Just n_args <- floatLams env - , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case - , is_function - , countFreeIds fvs <= n_args - = as_far_as_poss -- Send functions to top level; see - -- the comments with isFunction - - | otherwise = max_fv_id_level - where - join_ceiling = joinCeilingLevel env - max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the - -- tyvars will be abstracted - - as_far_as_poss = maxFvLevel' isId env fvs_ty - -- See Note [Floating and kind casts] - -{- Note [Floating and kind casts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - case x of - K (co :: * ~# k) -> let v :: Int |> co - v = e - in blah - -Then, even if we are abstracting over Ids, or if e is bottom, we can't -float v outside the 'co' binding. Reason: if we did we'd get - v' :: forall k. (Int ~# Age) => Int |> co -and now 'co' isn't in scope in that type. The underlying reason is -that 'co' is a value-level thing and we can't abstract over that in a -type (else we'd get a dependent type). So if v's /type/ mentions 'co' -we can't float it out beyond the binding site of 'co'. - -That's why we have this as_far_as_poss stuff. Usually as_far_as_poss -is just tOP_LEVEL; but occasionally a coercion variable (which is an -Id) mentioned in type prevents this. - -Example #14270 comment:15. --} - - -isFunction :: CoreExprWithFVs -> Bool --- The idea here is that we want to float *functions* to --- the top level. This saves no work, but --- (a) it can make the host function body a lot smaller, --- and hence inlinable. --- (b) it can also save allocation when the function is recursive: --- h = \x -> letrec f = \y -> ...f...y...x... --- in f x --- becomes --- f = \x y -> ...(f x)...y...x... --- h = \x -> f x x --- No allocation for f now. --- We may only want to do this if there are sufficiently few free --- variables. We certainly only want to do it for values, and not for --- constructors. So the simple thing is just to look for lambdas -isFunction (_, AnnLam b e) | isId b = True - | otherwise = isFunction e --- isFunction (_, AnnTick _ e) = isFunction e -- dubious -isFunction _ = False - -countFreeIds :: DVarSet -> Int -countFreeIds = nonDetFoldUDFM add 0 . getUniqDSet - -- It's OK to use nonDetFoldUDFM here because we're just counting things. - where - add :: Var -> Int -> Int - add v n | isId v = n+1 - | otherwise = n - -{- -************************************************************************ -* * -\subsection{Free-To-Level Monad} -* * -************************************************************************ --} - -data LevelEnv - = LE { le_switches :: FloatOutSwitches - , le_ctxt_lvl :: Level -- The current level - , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids - , le_join_ceil:: Level -- Highest level to which joins float - -- Invariant: always >= le_ctxt_lvl - - -- See Note [le_subst and le_env] - , le_subst :: Subst -- Domain is pre-cloned TyVars and Ids - -- The Id -> CoreExpr in the Subst is ignored - -- (since we want to substitute a LevelledExpr for - -- an Id via le_env) but we do use the Co/TyVar substs - , le_env :: IdEnv ([OutVar], LevelledExpr) -- Domain is pre-cloned Ids - } - -{- Note [le_subst and le_env] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We clone let- and case-bound variables so that they are still distinct -when floated out; hence the le_subst/le_env. (see point 3 of the -module overview comment). We also use these envs when making a -variable polymorphic because we want to float it out past a big -lambda. - -The le_subst and le_env always implement the same mapping, - in_x :-> out_x a b -where out_x is an OutVar, and a,b are its arguments (when -we perform abstraction at the same time as floating). - - le_subst maps to CoreExpr - le_env maps to LevelledExpr - -Since the range is always a variable or application, there is never -any difference between the two, but sadly the types differ. The -le_subst is used when substituting in a variable's IdInfo; the le_env -when we find a Var. - -In addition the le_env records a [OutVar] of variables free in the -OutExpr/LevelledExpr, just so we don't have to call freeVars -repeatedly. This list is always non-empty, and the first element is -out_x - -The domain of the both envs is *pre-cloned* Ids, though - -The domain of the le_lvl_env is the *post-cloned* Ids --} - -initialEnv :: FloatOutSwitches -> LevelEnv -initialEnv float_lams - = LE { le_switches = float_lams - , le_ctxt_lvl = tOP_LEVEL - , le_join_ceil = panic "initialEnv" - , le_lvl_env = emptyVarEnv - , le_subst = emptySubst - , le_env = emptyVarEnv } - -addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level -addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl - -addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level -addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs - -floatLams :: LevelEnv -> Maybe Int -floatLams le = floatOutLambdas (le_switches le) - -floatConsts :: LevelEnv -> Bool -floatConsts le = floatOutConstants (le_switches le) - -floatOverSat :: LevelEnv -> Bool -floatOverSat le = floatOutOverSatApps (le_switches le) - -floatTopLvlOnly :: LevelEnv -> Bool -floatTopLvlOnly le = floatToTopLevelOnly (le_switches le) - -incMinorLvlFrom :: LevelEnv -> Level -incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env) - --- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can --- See Note [Binder-swap during float-out] -extendCaseBndrEnv :: LevelEnv - -> Id -- Pre-cloned case binder - -> Expr LevelledBndr -- Post-cloned scrutinee - -> LevelEnv -extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env }) - case_bndr (Var scrut_var) - = le { le_subst = extendSubstWithVar subst case_bndr scrut_var - , le_env = add_id id_env (case_bndr, scrut_var) } -extendCaseBndrEnv env _ _ = env - --- See Note [Join ceiling] -placeJoinCeiling :: LevelEnv -> LevelEnv -placeJoinCeiling le@(LE { le_ctxt_lvl = lvl }) - = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' } - where - lvl' = asJoinCeilLvl (incMinorLvl lvl) - -maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level -maxFvLevel max_me env var_set - = foldDVarSet (maxIn max_me env) tOP_LEVEL var_set - -maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level --- Same but for TyCoVarSet -maxFvLevel' max_me env var_set - = nonDetFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set - -maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level -maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl - = case lookupVarEnv id_env in_var of - Just (abs_vars, _) -> foldr max_out lvl abs_vars - Nothing -> max_out in_var lvl - where - max_out out_var lvl - | max_me out_var = case lookupVarEnv lvl_env out_var of - Just lvl' -> maxLvl lvl' lvl - Nothing -> lvl - | otherwise = lvl -- Ignore some vars depending on max_me - -lookupVar :: LevelEnv -> Id -> LevelledExpr -lookupVar le v = case lookupVarEnv (le_env le) v of - Just (_, expr) -> expr - _ -> Var v - --- Level to which join points are allowed to float (boundary of current tail --- context). See Note [Join ceiling] -joinCeilingLevel :: LevelEnv -> Level -joinCeilingLevel = le_join_ceil - -abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar] - -- Find the variables in fvs, free vars of the target expression, - -- whose level is greater than the destination level - -- These are the ones we are going to abstract out - -- - -- Note that to get reproducible builds, the variables need to be - -- abstracted in deterministic order, not dependent on the values of - -- Uniques. This is achieved by using DVarSets, deterministic free - -- variable computation and deterministic sort. - -- See Note [Unique Determinism] in GHC.Types.Unique for explanation of why - -- Uniques are not deterministic. -abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs - = -- NB: sortQuantVars might not put duplicates next to each other - map zap $ sortQuantVars $ - filter abstract_me $ - dVarSetElems $ - closeOverKindsDSet $ - substDVarSet subst in_fvs - -- NB: it's important to call abstract_me only on the OutIds the - -- come from substDVarSet (not on fv, which is an InId) - where - abstract_me v = case lookupVarEnv lvl_env v of - Just lvl -> dest_lvl `ltLvl` lvl - Nothing -> False - - -- We are going to lambda-abstract, so nuke any IdInfo, - -- and add the tyvars of the Id (if necessary) - zap v | isId v = WARN( isStableUnfolding (idUnfolding v) || - not (isEmptyRuleInfo (idSpecialisation v)), - text "absVarsOf: discarding info on" <+> ppr v ) - setIdInfo v vanillaIdInfo - | otherwise = v - -type LvlM result = UniqSM result - -initLvl :: UniqSupply -> UniqSM a -> a -initLvl = initUs_ - -newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId] - -> LvlM (LevelEnv, [OutId]) --- The envt is extended to bind the new bndrs to dest_lvl, but --- the le_ctxt_lvl is unaffected -newPolyBndrs dest_lvl - env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) - abs_vars bndrs - = ASSERT( all (not . isCoVar) bndrs ) -- What would we add to the CoSubst in this case. No easy answer. - do { uniqs <- getUniquesM - ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs - bndr_prs = bndrs `zip` new_bndrs - env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs - , le_subst = foldl' add_subst subst bndr_prs - , le_env = foldl' add_id id_env bndr_prs } - ; return (env', new_bndrs) } - where - add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars) - add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) - - mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id - transfer_join_info bndr $ - mkSysLocal (mkFastString str) uniq poly_ty - where - str = "poly_" ++ occNameString (getOccName bndr) - poly_ty = mkLamTypes abs_vars (GHC.Core.Subst.substTy subst (idType bndr)) - - -- If we are floating a join point to top level, it stops being - -- a join point. Otherwise it continues to be a join point, - -- but we may need to adjust its arity - dest_is_top = isTopLvl dest_lvl - transfer_join_info bndr new_bndr - | Just join_arity <- isJoinId_maybe bndr - , not dest_is_top - = new_bndr `asJoinId` join_arity + length abs_vars - | otherwise - = new_bndr - -newLvlVar :: LevelledExpr -- The RHS of the new binding - -> Maybe JoinArity -- Its join arity, if it is a join point - -> Bool -- True <=> the RHS looks like (makeStatic ...) - -> LvlM Id -newLvlVar lvld_rhs join_arity_maybe is_mk_static - = do { uniq <- getUniqueM - ; return (add_join_info (mk_id uniq rhs_ty)) - } - where - add_join_info var = var `asJoinId_maybe` join_arity_maybe - de_tagged_rhs = deTagExpr lvld_rhs - rhs_ty = exprType de_tagged_rhs - - mk_id uniq rhs_ty - -- See Note [Grand plan for static forms] in StaticPtrTable. - | is_mk_static - = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr")) - rhs_ty - | otherwise - = mkSysLocal (mkFastString "lvl") uniq rhs_ty - --- | Clone the binders bound by a single-alternative case. -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 - -- 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' - , le_subst = subst' - , le_env = foldl' add_id id_env (vs `zip` vs') } - - ; return (env', vs') } - -cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar] - -> LvlM (LevelEnv, [OutVar]) --- See Note [Need for cloning during float-out] --- Works for Ids bound by let(rec) --- The dest_lvl is attributed to the binders in the new env, --- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env -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 - -- 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 - env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2 - , le_subst = subst' - , le_env = foldl' add_id id_env prs } - - ; return (env', vs2) } - where - zap :: Var -> Var - zap v | isId v = zap_join (zapIdDemandInfo v) - | otherwise = v - - zap_join | isTopLvl dest_lvl = zapJoinId - | otherwise = id - -add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr) -add_id id_env (v, v1) - | isTyVar v = delVarEnv id_env v - | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1) - -{- -Note [Zapping the demand info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -VERY IMPORTANT: we must zap the demand info if the thing is going to -float out, because it may be less demanded than at its original -binding site. Eg - f :: Int -> Int - f x = let v = 3*4 in v+x -Here v is strict; but if we float v to top level, it isn't any more. - -Similarly, if we're floating a join point, it won't be one anymore, so we zap -join point information as well. --} diff --git a/compiler/GHC/Core/Op/Simplify.hs b/compiler/GHC/Core/Op/Simplify.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/Simplify.hs +++ /dev/null @@ -1,3667 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[Simplify]{The main module of the simplifier} --} - -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -module GHC.Core.Op.Simplify ( simplTopBinds, simplExpr, simplRules ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Platform -import GHC.Driver.Session -import GHC.Core.Op.Simplify.Monad -import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) -import GHC.Core.Op.Simplify.Env -import GHC.Core.Op.Simplify.Utils -import GHC.Core.Op.OccurAnal ( occurAnalyseExpr ) -import GHC.Core.FamInstEnv ( FamInstEnv ) -import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 -import GHC.Types.Id -import GHC.Types.Id.Make ( seqId ) -import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) -import qualified GHC.Core.Make -import GHC.Types.Id.Info -import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) -import GHC.Core.Coercion hiding ( substCo, substCoVar ) -import GHC.Core.Coercion.Opt ( optCoercion ) -import GHC.Core.FamInstEnv ( topNormaliseType_maybe ) -import GHC.Core.DataCon - ( DataCon, dataConWorkId, dataConRepStrictness - , dataConRepArgTys, isUnboxedTupleCon - , StrictnessMark (..) ) -import GHC.Core.Op.Monad ( Tick(..), SimplMode(..) ) -import GHC.Core -import GHC.Types.Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd - , mkClosedStrictSig, topDmd, botDiv ) -import GHC.Types.Cpr ( mkCprSig, botCpr ) -import GHC.Core.Ppr ( pprCoreExpr ) -import GHC.Core.Unfold -import GHC.Core.Utils -import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg - , joinPointBinding_maybe, joinPointBindings_maybe ) -import GHC.Core.Rules ( mkRuleInfo, lookupRule, getRules ) -import GHC.Types.Basic ( TopLevelFlag(..), isNotTopLevel, isTopLevel, - RecFlag(..), Arity ) -import MonadUtils ( mapAccumLM, liftIO ) -import GHC.Types.Var ( isTyCoVar ) -import Maybes ( orElse ) -import Control.Monad -import Outputable -import FastString -import Util -import ErrUtils -import GHC.Types.Module ( moduleName, pprModuleName ) -import PrimOp ( PrimOp (SeqOp) ) - - -{- -The guts of the simplifier is in this module, but the driver loop for -the simplifier is in GHC.Core.Op.Simplify.Driver - -Note [The big picture] -~~~~~~~~~~~~~~~~~~~~~~ -The general shape of the simplifier is this: - - simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) - simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) - - * SimplEnv contains - - Simplifier mode (which includes DynFlags for convenience) - - Ambient substitution - - InScopeSet - - * SimplFloats contains - - Let-floats (which includes ok-for-spec case-floats) - - Join floats - - InScopeSet (including all the floats) - - * Expressions - simplExpr :: SimplEnv -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) - The result of simplifying an /expression/ is (floats, expr) - - A bunch of floats (let bindings, join bindings) - - A simplified expression. - The overall result is effectively (let floats in expr) - - * Bindings - simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) - The result of simplifying a binding is - - A bunch of floats, the last of which is the simplified binding - There may be auxiliary bindings too; see prepareRhs - - An environment suitable for simplifying the scope of the binding - - The floats may also be empty, if the binding is inlined unconditionally; - in that case the returned SimplEnv will have an augmented substitution. - - The returned floats and env both have an in-scope set, and they are - guaranteed to be the same. - - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -The simplifier used to guarantee that the output had no shadowing, but -it does not do so any more. (Actually, it never did!) The reason is -documented with simplifyArgs. - - -Eta expansion -~~~~~~~~~~~~~~ -For eta expansion, we want to catch things like - - case e of (a,b) -> \x -> case a of (p,q) -> \y -> r - -If the \x was on the RHS of a let, we'd eta expand to bring the two -lambdas together. And in general that's a good thing to do. Perhaps -we should eta expand wherever we find a (value) lambda? Then the eta -expansion at a let RHS can concentrate solely on the PAP case. - -Note [In-scope set as a substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As per Note [Lookups in in-scope set], an in-scope set can act as -a substitution. Specifically, it acts as a substitution from variable to -variables /with the same unique/. - -Why do we need this? Well, during the course of the simplifier, we may want to -adjust inessential properties of a variable. For instance, when performing a -beta-reduction, we change - - (\x. e) u ==> let x = u in e - -We typically want to add an unfolding to `x` so that it inlines to (the -simplification of) `u`. - -We do that by adding the unfolding to the binder `x`, which is added to the -in-scope set. When simplifying occurrences of `x` (every occurrence!), they are -replaced by their “updated” version from the in-scope set, hence inherit the -unfolding. This happens in `SimplEnv.substId`. - -Another example. Consider - - case x of y { Node a b -> ...y... - ; Leaf v -> ...y... } - -In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we -want y's unfolding to be (Leaf v). We achieve this by adding the appropriate -unfolding to y, and re-adding it to the in-scope set. See the calls to -`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere. - -It's quite convenient. This way we don't need to manipulate the substitution all -the time: every update to a binder is automatically reflected to its bound -occurrences. - -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ --} - -simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) --- See Note [The big picture] -simplTopBinds env0 binds0 - = do { -- Put all the top-level binders into scope at the start - -- so that if a transformation rule has unexpectedly brought - -- anything into scope, then we don't get a complaint about that. - -- It's rather as if the top-level binders were imported. - -- See note [Glomming] in OccurAnal. - ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0) - ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0 - ; freeTick SimplifierDone - ; return (floats, env2) } - where - -- We need to track the zapped top-level binders, because - -- they should have their fragile IdInfo zapped (notably occurrence info) - -- That's why we run down binds and bndrs' simultaneously. - -- - simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) - simpl_binds env [] = return (emptyFloats env, env) - simpl_binds env (bind:binds) = do { (float, env1) <- simpl_bind env bind - ; (floats, env2) <- simpl_binds env1 binds - ; return (float `addFloats` floats, env2) } - - simpl_bind env (Rec pairs) - = simplRecBind env TopLevel Nothing pairs - simpl_bind env (NonRec b r) - = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing - ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r } - -{- -************************************************************************ -* * - Lazy bindings -* * -************************************************************************ - -simplRecBind is used for - * recursive bindings only --} - -simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont - -> [(InId, InExpr)] - -> SimplM (SimplFloats, SimplEnv) -simplRecBind env0 top_lvl mb_cont pairs0 - = do { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0 - ; (rec_floats, env1) <- go env_with_info triples - ; return (mkRecFloats rec_floats, env1) } - where - add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) - -- Add the (substituted) rules to the binder - add_rules env (bndr, rhs) - = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) mb_cont - ; return (env', (bndr, bndr', rhs)) } - - go env [] = return (emptyFloats env, env) - - go env ((old_bndr, new_bndr, rhs) : pairs) - = do { (float, env1) <- simplRecOrTopPair env top_lvl Recursive mb_cont - old_bndr new_bndr rhs - ; (floats, env2) <- go env1 pairs - ; return (float `addFloats` floats, env2) } - -{- -simplOrTopPair is used for - * recursive bindings (whether top level or not) - * top-level non-recursive bindings - -It assumes the binder has already been simplified, but not its IdInfo. --} - -simplRecOrTopPair :: SimplEnv - -> TopLevelFlag -> RecFlag -> MaybeJoinCont - -> InId -> OutBndr -> InExpr -- Binder and rhs - -> SimplM (SimplFloats, SimplEnv) - -simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs - | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env - = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} - trace_bind "pre-inline-uncond" $ - do { tick (PreInlineUnconditionally old_bndr) - ; return ( emptyFloats env, env' ) } - - | Just cont <- mb_cont - = {-#SCC "simplRecOrTopPair-join" #-} - ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr ) - trace_bind "join" $ - simplJoinBind env cont old_bndr new_bndr rhs env - - | otherwise - = {-#SCC "simplRecOrTopPair-normal" #-} - trace_bind "normal" $ - simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env - - where - dflags = seDynFlags env - - -- trace_bind emits a trace for each top-level binding, which - -- helps to locate the tracing for inlining and rule firing - trace_bind what thing_inside - | not (dopt Opt_D_verbose_core2core dflags) - = thing_inside - | otherwise - = traceAction dflags ("SimplBind " ++ what) - (ppr old_bndr) thing_inside - --------------------------- -simplLazyBind :: SimplEnv - -> TopLevelFlag -> RecFlag - -> InId -> OutId -- Binder, both pre-and post simpl - -- Not a JoinId - -- The OutId has IdInfo, except arity, unfolding - -- Ids only, no TyVars - -> InExpr -> SimplEnv -- The RHS and its environment - -> SimplM (SimplFloats, SimplEnv) --- Precondition: not a JoinId --- Precondition: rhs obeys the let/app invariant --- NOT used for JoinIds -simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se - = ASSERT( isId bndr ) - ASSERT2( not (isJoinId bndr), ppr bndr ) - -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ - do { let rhs_env = rhs_se `setInScopeFromE` env - (tvs, body) = case collectTyAndValBinders rhs of - (tvs, [], body) - | surely_not_lam body -> (tvs, body) - _ -> ([], rhs) - - surely_not_lam (Lam {}) = False - surely_not_lam (Tick t e) - | not (tickishFloatable t) = surely_not_lam e - -- eta-reduction could float - surely_not_lam _ = True - -- Do not do the "abstract tyvar" thing if there's - -- a lambda inside, because it defeats eta-reduction - -- f = /\a. \x. g a x - -- should eta-reduce. - - - ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs - -- See Note [Floating and type abstraction] in GHC.Core.Op.Simplify.Utils - - -- Simplify the RHS - ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) - ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont - - -- Never float join-floats out of a non-join let-binding - -- So wrap the body in the join-floats right now - -- Hence: body_floats1 consists only of let-floats - ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0 - - -- ANF-ise a constructor or PAP rhs - -- We get at most one float per argument here - ; (let_floats, body2) <- {-#SCC "prepareRhs" #-} prepareRhs (getMode env) top_lvl - (getOccFS bndr1) (idInfo bndr1) body1 - ; let body_floats2 = body_floats1 `addLetFloats` let_floats - - ; (rhs_floats, rhs') - <- if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2) - then -- No floating, revert to body1 - {-#SCC "simplLazyBind-no-floating" #-} - do { rhs' <- mkLam env tvs' (wrapFloats body_floats2 body1) rhs_cont - ; return (emptyFloats env, rhs') } - - else if null tvs then -- Simple floating - {-#SCC "simplLazyBind-simple-floating" #-} - do { tick LetFloatFromLet - ; return (body_floats2, body2) } - - else -- Do type-abstraction first - {-#SCC "simplLazyBind-type-abstraction-first" #-} - do { tick LetFloatFromLet - ; (poly_binds, body3) <- abstractFloats (seDynFlags env) top_lvl - tvs' body_floats2 body2 - ; let floats = foldl' extendFloats (emptyFloats env) poly_binds - ; rhs' <- mkLam env tvs' body3 rhs_cont - ; return (floats, rhs') } - - ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) - top_lvl Nothing bndr bndr1 rhs' - ; return (rhs_floats `addFloats` bind_float, env2) } - --------------------------- -simplJoinBind :: SimplEnv - -> SimplCont - -> InId -> OutId -- Binder, both pre-and post simpl - -- The OutId has IdInfo, except arity, - -- unfolding - -> InExpr -> SimplEnv -- The right hand side and its env - -> SimplM (SimplFloats, SimplEnv) -simplJoinBind env cont old_bndr new_bndr rhs rhs_se - = do { let rhs_env = rhs_se `setInScopeFromE` env - ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont - ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' } - --------------------------- -simplNonRecX :: SimplEnv - -> InId -- Old binder; not a JoinId - -> OutExpr -- Simplified RHS - -> SimplM (SimplFloats, SimplEnv) --- A specialised variant of simplNonRec used when the RHS is already --- simplified, notably in knownCon. It uses case-binding where necessary. --- --- Precondition: rhs satisfies the let/app invariant - -simplNonRecX env bndr new_rhs - | ASSERT2( not (isJoinId bndr), ppr bndr ) - isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } - = return (emptyFloats env, env) -- Here c is dead, and we avoid - -- creating the binding c = (a,b) - - | Coercion co <- new_rhs - = return (emptyFloats env, extendCvSubst env bndr co) - - | otherwise - = do { (env', bndr') <- simplBinder env bndr - ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } - -- simplNonRecX is only used for NotTopLevel things - --------------------------- -completeNonRecX :: TopLevelFlag -> SimplEnv - -> Bool - -> InId -- Old binder; not a JoinId - -> OutId -- New binder - -> OutExpr -- Simplified RHS - -> SimplM (SimplFloats, SimplEnv) -- The new binding is in the floats --- Precondition: rhs satisfies the let/app invariant --- See Note [Core let/app invariant] in GHC.Core - -completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs - = ASSERT2( not (isJoinId new_bndr), ppr new_bndr ) - do { (prepd_floats, rhs1) <- prepareRhs (getMode env) top_lvl (getOccFS new_bndr) - (idInfo new_bndr) new_rhs - ; let floats = emptyFloats env `addLetFloats` prepd_floats - ; (rhs_floats, rhs2) <- - if doFloatFromRhs NotTopLevel NonRecursive is_strict floats rhs1 - then -- Add the floats to the main env - do { tick LetFloatFromLet - ; return (floats, rhs1) } - else -- Do not float; wrap the floats around the RHS - return (emptyFloats env, wrapFloats floats rhs1) - - ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) - NotTopLevel Nothing - old_bndr new_bndr rhs2 - ; return (rhs_floats `addFloats` bind_float, env2) } - - -{- ********************************************************************* -* * - prepareRhs, makeTrivial -* * -************************************************************************ - -Note [prepareRhs] -~~~~~~~~~~~~~~~~~ -prepareRhs takes a putative RHS, checks whether it's a PAP or -constructor application and, if so, converts it to ANF, so that the -resulting thing can be inlined more easily. Thus - x = (f a, g b) -becomes - t1 = f a - t2 = g b - x = (t1,t2) - -We also want to deal well cases like this - v = (f e1 `cast` co) e2 -Here we want to make e1,e2 trivial and get - x1 = e1; x2 = e2; v = (f x1 `cast` co) v2 -That's what the 'go' loop in prepareRhs does --} - -prepareRhs :: SimplMode -> TopLevelFlag - -> FastString -- Base for any new variables - -> IdInfo -- IdInfo for the LHS of this binding - -> OutExpr - -> SimplM (LetFloats, OutExpr) --- Transforms a RHS into a better RHS by adding floats --- e.g x = Just e --- becomes a = e --- x = Just a --- See Note [prepareRhs] -prepareRhs mode top_lvl occ info (Cast rhs co) -- Note [Float coercions] - | let ty1 = coercionLKind co -- Do *not* do this if rhs has an unlifted type - , not (isUnliftedType ty1) -- see Note [Float coercions (unlifted)] - = do { (floats, rhs') <- makeTrivialWithInfo mode top_lvl occ sanitised_info rhs - ; return (floats, Cast rhs' co) } - where - sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info - `setCprInfo` cprInfo info - `setDemandInfo` demandInfo info - -prepareRhs mode top_lvl occ _ rhs0 - = do { (_is_exp, floats, rhs1) <- go 0 rhs0 - ; return (floats, rhs1) } - where - go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr) - go n_val_args (Cast rhs co) - = do { (is_exp, floats, rhs') <- go n_val_args rhs - ; return (is_exp, floats, Cast rhs' co) } - go n_val_args (App fun (Type ty)) - = do { (is_exp, floats, rhs') <- go n_val_args fun - ; return (is_exp, floats, App rhs' (Type ty)) } - go n_val_args (App fun arg) - = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun - ; case is_exp of - False -> return (False, emptyLetFloats, App fun arg) - True -> do { (floats2, arg') <- makeTrivial mode top_lvl occ arg - ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } } - go n_val_args (Var fun) - = return (is_exp, emptyLetFloats, Var fun) - where - is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP - -- See Note [CONLIKE pragma] in GHC.Types.Basic - -- The definition of is_exp should match that in - -- OccurAnal.occAnalApp - - go n_val_args (Tick t rhs) - -- We want to be able to float bindings past this - -- tick. Non-scoping ticks don't care. - | tickishScoped t == NoScope - = do { (is_exp, floats, rhs') <- go n_val_args rhs - ; return (is_exp, floats, Tick t rhs') } - - -- On the other hand, for scoping ticks we need to be able to - -- copy them on the floats, which in turn is only allowed if - -- we can obtain non-counting ticks. - | (not (tickishCounts t) || tickishCanSplit t) - = do { (is_exp, floats, rhs') <- go n_val_args rhs - ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) - floats' = mapLetFloats floats tickIt - ; return (is_exp, floats', Tick t rhs') } - - go _ other - = return (False, emptyLetFloats, other) - -{- -Note [Float coercions] -~~~~~~~~~~~~~~~~~~~~~~ -When we find the binding - x = e `cast` co -we'd like to transform it to - x' = e - x = x `cast` co -- A trivial binding -There's a chance that e will be a constructor application or function, or something -like that, so moving the coercion to the usage site may well cancel the coercions -and lead to further optimisation. Example: - - data family T a :: * - data instance T Int = T Int - - foo :: Int -> Int -> Int - foo m n = ... - where - x = T m - go 0 = 0 - go n = case x of { T m -> go (n-m) } - -- This case should optimise - -Note [Preserve strictness when floating coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the Note [Float coercions] transformation, keep the strictness info. -Eg - f = e `cast` co -- f has strictness SSL -When we transform to - f' = e -- f' also has strictness SSL - f = f' `cast` co -- f still has strictness SSL - -Its not wrong to drop it on the floor, but better to keep it. - -Note [Float coercions (unlifted)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -BUT don't do [Float coercions] if 'e' has an unlifted type. -This *can* happen: - - foo :: Int = (error (# Int,Int #) "urk") - `cast` CoUnsafe (# Int,Int #) Int - -If do the makeTrivial thing to the error call, we'll get - foo = case error (# Int,Int #) "urk" of v -> v `cast` ... -But 'v' isn't in scope! - -These strange casts can happen as a result of case-of-case - bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of - (# p,q #) -> p+q --} - -makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec) -makeTrivialArg mode (ValArg e) - = do { (floats, e') <- makeTrivial mode NotTopLevel (fsLit "arg") e - ; return (floats, ValArg e') } -makeTrivialArg _ arg - = return (emptyLetFloats, arg) -- CastBy, TyArg - -makeTrivial :: SimplMode -> TopLevelFlag - -> FastString -- ^ A "friendly name" to build the new binder from - -> OutExpr -- ^ This expression satisfies the let/app invariant - -> SimplM (LetFloats, OutExpr) --- Binds the expression to a variable, if it's not trivial, returning the variable -makeTrivial mode top_lvl context expr - = makeTrivialWithInfo mode top_lvl context vanillaIdInfo expr - -makeTrivialWithInfo :: SimplMode -> TopLevelFlag - -> FastString -- ^ a "friendly name" to build the new binder from - -> IdInfo - -> OutExpr -- ^ This expression satisfies the let/app invariant - -> SimplM (LetFloats, OutExpr) --- Propagate strictness and demand info to the new binder --- Note [Preserve strictness when floating coercions] --- Returned SimplEnv has same substitution as incoming one -makeTrivialWithInfo mode top_lvl occ_fs info expr - | exprIsTrivial expr -- Already trivial - || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise - -- See Note [Cannot trivialise] - = return (emptyLetFloats, expr) - - | otherwise - = do { (floats, expr1) <- prepareRhs mode top_lvl occ_fs info expr - ; if exprIsTrivial expr1 -- See Note [Trivial after prepareRhs] - then return (floats, expr1) - else do - { uniq <- getUniqueM - ; let name = mkSystemVarName uniq occ_fs - var = mkLocalIdWithInfo name expr_ty info - - -- Now something very like completeBind, - -- but without the postInlineUnconditionally part - ; (arity, is_bot, expr2) <- tryEtaExpandRhs mode var expr1 - ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2 - - ; let final_id = addLetBndrInfo var arity is_bot unf - bind = NonRec final_id expr2 - - ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }} - where - expr_ty = exprType expr - -bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool --- True iff we can have a binding of this expression at this level --- Precondition: the type is the type of the expression -bindingOk top_lvl expr expr_ty - | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty - | otherwise = True - -{- Note [Trivial after prepareRhs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we call makeTrival on (e |> co), the recursive use of prepareRhs -may leave us with - { a1 = e } and (a1 |> co) -Now the latter is trivial, so we don't want to let-bind it. - -Note [Cannot trivialise] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - f :: Int -> Addr# - - foo :: Bar - foo = Bar (f 3) - -Then we can't ANF-ise foo, even though we'd like to, because -we can't make a top-level binding for the Addr# (f 3). And if -so we don't want to turn it into - foo = let x = f 3 in Bar x -because we'll just end up inlining x back, and that makes the -simplifier loop. Better not to ANF-ise it at all. - -Literal strings are an exception. - - foo = Ptr "blob"# - -We want to turn this into: - - foo1 = "blob"# - foo = Ptr foo1 - -See Note [Core top-level string literals] in GHC.Core. - -************************************************************************ -* * - Completing a lazy binding -* * -************************************************************************ - -completeBind - * deals only with Ids, not TyVars - * takes an already-simplified binder and RHS - * is used for both recursive and non-recursive bindings - * is used for both top-level and non-top-level bindings - -It does the following: - - tries discarding a dead binding - - tries PostInlineUnconditionally - - add unfolding [this is the only place we add an unfolding] - - add arity - -It does *not* attempt to do let-to-case. Why? Because it is used for - - top-level bindings (when let-to-case is impossible) - - many situations where the "rhs" is known to be a WHNF - (so let-to-case is inappropriate). - -Nor does it do the atomic-argument thing --} - -completeBind :: SimplEnv - -> TopLevelFlag -- Flag stuck into unfolding - -> MaybeJoinCont -- Required only for join point - -> InId -- Old binder - -> OutId -> OutExpr -- New binder and RHS - -> SimplM (SimplFloats, SimplEnv) --- completeBind may choose to do its work --- * by extending the substitution (e.g. let x = y in ...) --- * or by adding to the floats in the envt --- --- Binder /can/ be a JoinId --- Precondition: rhs obeys the let/app invariant -completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs - | isCoVar old_bndr - = case new_rhs of - Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co) - _ -> return (mkFloatBind env (NonRec new_bndr new_rhs)) - - | otherwise - = ASSERT( isId new_bndr ) - do { let old_info = idInfo old_bndr - old_unf = unfoldingInfo old_info - occ_info = occInfo old_info - - -- Do eta-expansion on the RHS of the binding - -- See Note [Eta-expanding at let bindings] in GHC.Core.Op.Simplify.Utils - ; (new_arity, is_bot, final_rhs) <- tryEtaExpandRhs (getMode env) - new_bndr new_rhs - - -- Simplify the unfolding - ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr - final_rhs (idType new_bndr) old_unf - - ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding - -- See Note [In-scope set as a substitution] - - ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs - - then -- Inline and discard the binding - do { tick (PostInlineUnconditionally old_bndr) - ; return ( emptyFloats env - , extendIdSubst env old_bndr $ - DoneEx final_rhs (isJoinId_maybe new_bndr)) } - -- Use the substitution to make quite, quite sure that the - -- substitution will happen, since we are going to discard the binding - - else -- Keep the binding - -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $ - return (mkFloatBind env (NonRec final_bndr final_rhs)) } - -addLetBndrInfo :: OutId -> Arity -> Bool -> Unfolding -> OutId -addLetBndrInfo new_bndr new_arity is_bot new_unf - = new_bndr `setIdInfo` info5 - where - info1 = idInfo new_bndr `setArityInfo` new_arity - - -- Unfolding info: Note [Setting the new unfolding] - info2 = info1 `setUnfoldingInfo` new_unf - - -- Demand info: Note [Setting the demand info] - -- We also have to nuke demand info if for some reason - -- eta-expansion *reduces* the arity of the binding to less - -- than that of the strictness sig. This can happen: see Note [Arity decrease]. - info3 | isEvaldUnfolding new_unf - || (case strictnessInfo info2 of - StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty) - = zapDemandInfo info2 `orElse` info2 - | otherwise - = info2 - - -- Bottoming bindings: see Note [Bottoming bindings] - info4 | is_bot = info3 - `setStrictnessInfo` - mkClosedStrictSig (replicate new_arity topDmd) botDiv - `setCprInfo` mkCprSig new_arity botCpr - | otherwise = info3 - - -- Zap call arity info. We have used it by now (via - -- `tryEtaExpandRhs`), and the simplifier can invalidate this - -- information, leading to broken code later (e.g. #13479) - info5 = zapCallArityInfo info4 - - -{- Note [Arity decrease] -~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking the arity of a binding should not decrease. But it *can* -legitimately happen because of RULES. Eg - f = g Int -where g has arity 2, will have arity 2. But if there's a rewrite rule - g Int --> h -where h has arity 1, then f's arity will decrease. Here's a real-life example, -which is in the output of Specialise: - - Rec { - $dm {Arity 2} = \d.\x. op d - {-# RULES forall d. $dm Int d = $s$dm #-} - - dInt = MkD .... opInt ... - opInt {Arity 1} = $dm dInt - - $s$dm {Arity 0} = \x. op dInt } - -Here opInt has arity 1; but when we apply the rule its arity drops to 0. -That's why Specialise goes to a little trouble to pin the right arity -on specialised functions too. - -Note [Bottoming bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - let x = error "urk" - in ...(case x of )... -or - let f = \x. error (x ++ "urk") - in ...(case f "foo" of )... - -Then we'd like to drop the dead immediately. So it's good to -propagate the info that x's RHS is bottom to x's IdInfo as rapidly as -possible. - -We use tryEtaExpandRhs on every binding, and it turns ou that the -arity computation it performs (via GHC.Core.Arity.findRhsArity) already -does a simple bottoming-expression analysis. So all we need to do -is propagate that info to the binder's IdInfo. - -This showed up in #12150; see comment:16. - -Note [Setting the demand info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the unfolding is a value, the demand info may -go pear-shaped, so we nuke it. Example: - let x = (a,b) in - case x of (p,q) -> h p q x -Here x is certainly demanded. But after we've nuked -the case, we'll get just - let x = (a,b) in h a b x -and now x is not demanded (I'm assuming h is lazy) -This really happens. Similarly - let f = \x -> e in ...f..f... -After inlining f at some of its call sites the original binding may -(for example) be no longer strictly demanded. -The solution here is a bit ad hoc... - - -************************************************************************ -* * -\subsection[Simplify-simplExpr]{The main function: simplExpr} -* * -************************************************************************ - -The reason for this OutExprStuff stuff is that we want to float *after* -simplifying a RHS, not before. If we do so naively we get quadratic -behaviour as things float out. - -To see why it's important to do it after, consider this (real) example: - - let t = f x - in fst t -==> - let t = let a = e1 - b = e2 - in (a,b) - in fst t -==> - let a = e1 - b = e2 - t = (a,b) - in - a -- Can't inline a this round, cos it appears twice -==> - e1 - -Each of the ==> steps is a round of simplification. We'd save a -whole round if we float first. This can cascade. Consider - - let f = g d - in \x -> ...f... -==> - let f = let d1 = ..d.. in \y -> e - in \x -> ...f... -==> - let d1 = ..d.. - in \x -> ...(\y ->e)... - -Only in this second round can the \y be applied, and it -might do the same again. --} - -simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr -simplExpr env (Type ty) - = do { ty' <- simplType env ty -- See Note [Avoiding space leaks in OutType] - ; return (Type ty') } - -simplExpr env expr - = simplExprC env expr (mkBoringStop expr_out_ty) - where - expr_out_ty :: OutType - expr_out_ty = substTy env (exprType expr) - -- NB: Since 'expr' is term-valued, not (Type ty), this call - -- to exprType will succeed. exprType fails on (Type ty). - -simplExprC :: SimplEnv - -> InExpr -- A term-valued expression, never (Type ty) - -> SimplCont - -> SimplM OutExpr - -- Simplify an expression, given a continuation -simplExprC env expr cont - = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $ - do { (floats, expr') <- simplExprF env expr cont - ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ - -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ - -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $ - return (wrapFloats floats expr') } - --------------------------------------------------- -simplExprF :: SimplEnv - -> InExpr -- A term-valued expression, never (Type ty) - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -simplExprF env e cont - = {- pprTrace "simplExprF" (vcat - [ ppr e - , text "cont =" <+> ppr cont - , text "inscope =" <+> ppr (seInScope env) - , text "tvsubst =" <+> ppr (seTvSubst env) - , text "idsubst =" <+> ppr (seIdSubst env) - , text "cvsubst =" <+> ppr (seCvSubst env) - ]) $ -} - simplExprF1 env e cont - -simplExprF1 :: SimplEnv -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -simplExprF1 _ (Type ty) _ - = pprPanic "simplExprF: type" (ppr ty) - -- simplExprF does only with term-valued expressions - -- The (Type ty) case is handled separately by simplExpr - -- and by the other callers of simplExprF - -simplExprF1 env (Var v) cont = {-#SCC "simplIdF" #-} simplIdF env v cont -simplExprF1 env (Lit lit) cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont -simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t expr cont -simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont -simplExprF1 env (Coercion co) cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont - -simplExprF1 env (App fun arg) cont - = {-#SCC "simplExprF1-App" #-} case arg of - Type ty -> do { -- The argument type will (almost) certainly be used - -- in the output program, so just force it now. - -- See Note [Avoiding space leaks in OutType] - arg' <- simplType env ty - - -- But use substTy, not simplType, to avoid forcing - -- the hole type; it will likely not be needed. - -- See Note [The hole type in ApplyToTy] - ; let hole' = substTy env (exprType fun) - - ; simplExprF env fun $ - ApplyToTy { sc_arg_ty = arg' - , sc_hole_ty = hole' - , sc_cont = cont } } - _ -> simplExprF env fun $ - ApplyToVal { sc_arg = arg, sc_env = env - , sc_dup = NoDup, sc_cont = cont } - -simplExprF1 env expr@(Lam {}) cont - = {-#SCC "simplExprF1-Lam" #-} - simplLam env zapped_bndrs body cont - -- The main issue here is under-saturated lambdas - -- (\x1. \x2. e) arg1 - -- Here x1 might have "occurs-once" occ-info, because occ-info - -- is computed assuming that a group of lambdas is applied - -- all at once. If there are too few args, we must zap the - -- occ-info, UNLESS the remaining binders are one-shot - where - (bndrs, body) = collectBinders expr - zapped_bndrs | need_to_zap = map zap bndrs - | otherwise = bndrs - - need_to_zap = any zappable_bndr (drop n_args bndrs) - n_args = countArgs cont - -- NB: countArgs counts all the args (incl type args) - -- and likewise drop counts all binders (incl type lambdas) - - zappable_bndr b = isId b && not (isOneShotBndr b) - zap b | isTyVar b = b - | otherwise = zapLamIdInfo b - -simplExprF1 env (Case scrut bndr _ alts) cont - = {-#SCC "simplExprF1-Case" #-} - simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr - , sc_alts = alts - , sc_env = env, sc_cont = cont }) - -simplExprF1 env (Let (Rec pairs) body) cont - | Just pairs' <- joinPointBindings_maybe pairs - = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont - - | otherwise - = {-#SCC "simplRecE" #-} simplRecE env pairs body cont - -simplExprF1 env (Let (NonRec bndr rhs) body) cont - | Type ty <- rhs -- First deal with type lets (let a = Type ty in e) - = {-#SCC "simplExprF1-NonRecLet-Type" #-} - ASSERT( isTyVar bndr ) - do { ty' <- simplType env ty - ; simplExprF (extendTvSubst env bndr ty') body cont } - - | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs - = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont - - | otherwise - = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) ([], body) cont - -{- Note [Avoiding space leaks in OutType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since the simplifier is run for multiple iterations, we need to ensure -that any thunks in the output of one simplifier iteration are forced -by the evaluation of the next simplifier iteration. Otherwise we may -retain multiple copies of the Core program and leak a terrible amount -of memory (as in #13426). - -The simplifier is naturally strict in the entire "Expr part" of the -input Core program, because any expression may contain binders, which -we must find in order to extend the SimplEnv accordingly. But types -do not contain binders and so it is tempting to write things like - - simplExpr env (Type ty) = return (Type (substTy env ty)) -- Bad! - -This is Bad because the result includes a thunk (substTy env ty) which -retains a reference to the whole simplifier environment; and the next -simplifier iteration will not force this thunk either, because the -line above is not strict in ty. - -So instead our strategy is for the simplifier to fully evaluate -OutTypes when it emits them into the output Core program, for example - - simplExpr env (Type ty) = do { ty' <- simplType env ty -- Good - ; return (Type ty') } - -where the only difference from above is that simplType calls seqType -on the result of substTy. - -However, SimplCont can also contain OutTypes and it's not necessarily -a good idea to force types on the way in to SimplCont, because they -may end up not being used and forcing them could be a lot of wasted -work. T5631 is a good example of this. - -- For ApplyToTy's sc_arg_ty, we force the type on the way in because - the type will almost certainly appear as a type argument in the - output program. - -- For the hole types in Stop and ApplyToTy, we force the type when we - emit it into the output program, after obtaining it from - contResultType. (The hole type in ApplyToTy is only directly used - to form the result type in a new Stop continuation.) --} - ---------------------------------- --- Simplify a join point, adding the context. --- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do: --- \x1 .. xn -> e => \x1 .. xn -> E[e] --- Note that we need the arity of the join point, since e may be a lambda --- (though this is unlikely). See Note [Join points and case-of-case]. -simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont - -> SimplM OutExpr -simplJoinRhs env bndr expr cont - | Just arity <- isJoinId_maybe bndr - = do { let (join_bndrs, join_body) = collectNBinders arity expr - ; (env', join_bndrs') <- simplLamBndrs env join_bndrs - ; join_body' <- simplExprC env' join_body cont - ; return $ mkLams join_bndrs' join_body' } - - | otherwise - = pprPanic "simplJoinRhs" (ppr bndr) - ---------------------------------- -simplType :: SimplEnv -> InType -> SimplM OutType - -- Kept monadic just so we can do the seqType - -- See Note [Avoiding space leaks in OutType] -simplType env ty - = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ - seqType new_ty `seq` return new_ty - where - new_ty = substTy env ty - ---------------------------------- -simplCoercionF :: SimplEnv -> InCoercion -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplCoercionF env co cont - = do { co' <- simplCoercion env co - ; rebuild env (Coercion co') cont } - -simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion -simplCoercion env co - = do { dflags <- getDynFlags - ; let opt_co = optCoercion dflags (getTCvSubst env) co - ; seqCo opt_co `seq` return opt_co } - ------------------------------------ --- | Push a TickIt context outwards past applications and cases, as --- long as this is a non-scoping tick, to let case and application --- optimisations apply. - -simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplTick env tickish expr cont - -- A scoped tick turns into a continuation, so that we can spot - -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do - -- it this way, then it would take two passes of the simplifier to - -- reduce ((scc t (\x . e)) e'). - -- NB, don't do this with counting ticks, because if the expr is - -- bottom, then rebuildCall will discard the continuation. - --- XXX: we cannot do this, because the simplifier assumes that --- the context can be pushed into a case with a single branch. e.g. --- scc case expensive of p -> e --- becomes --- case expensive of p -> scc e --- --- So I'm disabling this for now. It just means we will do more --- simplifier iterations that necessary in some cases. - --- | tickishScoped tickish && not (tickishCounts tickish) --- = simplExprF env expr (TickIt tickish cont) - - -- For unscoped or soft-scoped ticks, we are allowed to float in new - -- cost, so we simply push the continuation inside the tick. This - -- has the effect of moving the tick to the outside of a case or - -- application context, allowing the normal case and application - -- optimisations to fire. - | tickish `tickishScopesLike` SoftScope - = do { (floats, expr') <- simplExprF env expr cont - ; return (floats, mkTick tickish expr') - } - - -- Push tick inside if the context looks like this will allow us to - -- do a case-of-case - see Note [case-of-scc-of-case] - | Select {} <- cont, Just expr' <- push_tick_inside - = simplExprF env expr' cont - - -- We don't want to move the tick, but we might still want to allow - -- floats to pass through with appropriate wrapping (or not, see - -- wrap_floats below) - --- | not (tickishCounts tickish) || tickishCanSplit tickish - -- = wrap_floats - - | otherwise - = no_floating_past_tick - - where - - -- Try to push tick inside a case, see Note [case-of-scc-of-case]. - push_tick_inside = - case expr0 of - Case scrut bndr ty alts - -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts) - _other -> Nothing - where (ticks, expr0) = stripTicksTop movable (Tick tickish expr) - movable t = not (tickishCounts t) || - t `tickishScopesLike` NoScope || - tickishCanSplit t - tickScrut e = foldr mkTick e ticks - -- Alternatives get annotated with all ticks that scope in some way, - -- but we don't want to count entries. - tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope) - ts_scope = map mkNoCount $ - filter (not . (`tickishScopesLike` NoScope)) ticks - - no_floating_past_tick = - do { let (inc,outc) = splitCont cont - ; (floats, expr1) <- simplExprF env expr inc - ; let expr2 = wrapFloats floats expr1 - tickish' = simplTickish env tickish - ; rebuild env (mkTick tickish' expr2) outc - } - --- Alternative version that wraps outgoing floats with the tick. This --- results in ticks being duplicated, as we don't make any attempt to --- eliminate the tick if we re-inline the binding (because the tick --- semantics allows unrestricted inlining of HNFs), so I'm not doing --- this any more. FloatOut will catch any real opportunities for --- floating. --- --- wrap_floats = --- do { let (inc,outc) = splitCont cont --- ; (env', expr') <- simplExprF (zapFloats env) expr inc --- ; let tickish' = simplTickish env tickish --- ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0), --- mkTick (mkNoCount tickish') rhs) --- -- when wrapping a float with mkTick, we better zap the Id's --- -- strictness info and arity, because it might be wrong now. --- ; let env'' = addFloats env (mapFloats env' wrap_float) --- ; rebuild env'' expr' (TickIt tickish' outc) --- } - - - simplTickish env tickish - | Breakpoint n ids <- tickish - = Breakpoint n (map (getDoneId . substId env) ids) - | otherwise = tickish - - -- Push type application and coercion inside a tick - splitCont :: SimplCont -> (SimplCont, SimplCont) - splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc) - where (inc,outc) = splitCont tail - splitCont (CastIt co c) = (CastIt co inc, outc) - where (inc,outc) = splitCont c - splitCont other = (mkBoringStop (contHoleType other), other) - - getDoneId (DoneId id) = id - getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst - getDoneId other = pprPanic "getDoneId" (ppr other) - --- Note [case-of-scc-of-case] --- It's pretty important to be able to transform case-of-case when --- there's an SCC in the way. For example, the following comes up --- in nofib/real/compress/Encode.hs: --- --- case scctick --- case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje --- of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) -> --- (ww1_s13f, ww2_s13g, ww3_s13h) --- } --- of _ { (ww_s12Y, ww1_s12Z, ww2_s130) -> --- tick --- (ww_s12Y, --- ww1_s12Z, --- PTTrees.PT --- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf) --- } --- --- We really want this case-of-case to fire, because then the 3-tuple --- will go away (indeed, the CPR optimisation is relying on this --- happening). But the scctick is in the way - we need to push it --- inside to expose the case-of-case. So we perform this --- transformation on the inner case: --- --- scctick c (case e of { p1 -> e1; ...; pn -> en }) --- ==> --- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en } --- --- So we've moved a constant amount of work out of the scc to expose --- the case. We only do this when the continuation is interesting: in --- for now, it has to be another Case (maybe generalise this later). - -{- -************************************************************************ -* * -\subsection{The main rebuilder} -* * -************************************************************************ --} - -rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) --- At this point the substitution in the SimplEnv should be irrelevant; --- only the in-scope set matters -rebuild env expr cont - = case cont of - Stop {} -> return (emptyFloats env, expr) - TickIt t cont -> rebuild env (mkTick t expr) cont - CastIt co cont -> rebuild env (mkCast expr co) cont - -- NB: mkCast implements the (Coercion co |> g) optimisation - - Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } - -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont - - StrictArg { sc_fun = fun, sc_cont = cont } - -> rebuildCall env (fun `addValArgTo` expr) cont - StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body - , sc_env = se, sc_cont = cont } - -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr - -- expr satisfies let/app since it started life - -- in a call to simplNonRecE - ; (floats2, expr') <- simplLam env' bs body cont - ; return (floats1 `addFloats` floats2, expr') } - - ApplyToTy { sc_arg_ty = ty, sc_cont = cont} - -> rebuild env (App expr (Type ty)) cont - - ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont} - -- See Note [Avoid redundant simplification] - -> do { (_, _, arg') <- simplArg env dup_flag se arg - ; rebuild env (App expr arg') cont } - -{- -************************************************************************ -* * -\subsection{Lambdas} -* * -************************************************************************ --} - -{- Note [Optimising reflexivity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important (for compiler performance) to get rid of reflexivity as soon -as it appears. See #11735, #14737, and #15019. - -In particular, we want to behave well on - - * e |> co1 |> co2 - where the two happen to cancel out entirely. That is quite common; - e.g. a newtype wrapping and unwrapping cancel. - - - * (f |> co) @t1 @t2 ... @tn x1 .. xm - Here we wil use pushCoTyArg and pushCoValArg successively, which - build up NthCo stacks. Silly to do that if co is reflexive. - -However, we don't want to call isReflexiveCo too much, because it uses -type equality which is expensive on big types (#14737 comment:7). - -A good compromise (determined experimentally) seems to be to call -isReflexiveCo - * when composing casts, and - * at the end - -In investigating this I saw missed opportunities for on-the-fly -coercion shrinkage. See #15090. --} - - -simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplCast env body co0 cont0 - = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0 - ; cont1 <- {-#SCC "simplCast-addCoerce" #-} - if isReflCo co1 - then return cont0 -- See Note [Optimising reflexivity] - else addCoerce co1 cont0 - ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } - where - -- If the first parameter is MRefl, then simplifying revealed a - -- reflexive coercion. Omit. - addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont - addCoerceM MRefl cont = return cont - addCoerceM (MCo co) cont = addCoerce co cont - - addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont - addCoerce co1 (CastIt co2 cont) -- See Note [Optimising reflexivity] - | isReflexiveCo co' = return cont - | otherwise = addCoerce co' cont - where - co' = mkTransCo co1 co2 - - addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) - | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty - -- N.B. As mentioned in Note [The hole type in ApplyToTy] this is - -- only needed by `sc_hole_ty` which is often not forced. - -- Consequently it is worthwhile using a lazy pattern match here to - -- avoid unnecessary coercionKind evaluations. - , let hole_ty = coercionLKind co - = {-#SCC "addCoerce-pushCoTyArg" #-} - do { tail' <- addCoerceM m_co' tail - ; return (cont { sc_arg_ty = arg_ty' - , sc_hole_ty = hole_ty -- NB! As the cast goes past, the - -- type of the hole changes (#16312) - , sc_cont = tail' }) } - - addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_dup = dup, sc_cont = tail }) - | Just (co1, m_co2) <- pushCoValArg co - , let new_ty = coercionRKind co1 - , not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg - -- See Note [Levity polymorphism invariants] in GHC.Core - -- test: typecheck/should_run/EtaExpandLevPoly - = {-#SCC "addCoerce-pushCoValArg" #-} - do { tail' <- addCoerceM m_co2 tail - ; if isReflCo co1 - then return (cont { sc_cont = tail' }) - -- Avoid simplifying if possible; - -- See Note [Avoiding exponential behaviour] - else do - { (dup', arg_se', arg') <- simplArg env dup arg_se arg - -- When we build the ApplyTo we can't mix the OutCoercion - -- 'co' with the InExpr 'arg', so we simplify - -- to make it all consistent. It's a bit messy. - -- But it isn't a common case. - -- Example of use: #995 - ; return (ApplyToVal { sc_arg = mkCast arg' co1 - , sc_env = arg_se' - , sc_dup = dup' - , sc_cont = tail' }) } } - - addCoerce co cont - | isReflexiveCo co = return cont -- Having this at the end makes a huge - -- difference in T12227, for some reason - -- See Note [Optimising reflexivity] - | otherwise = return (CastIt co cont) - -simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr - -> SimplM (DupFlag, StaticEnv, OutExpr) -simplArg env dup_flag arg_env arg - | isSimplified dup_flag - = return (dup_flag, arg_env, arg) - | otherwise - = do { arg' <- simplExpr (arg_env `setInScopeFromE` env) arg - ; return (Simplified, zapSubstEnv arg_env, arg') } - -{- -************************************************************************ -* * -\subsection{Lambdas} -* * -************************************************************************ --} - -simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -simplLam env [] body cont - = simplExprF env body cont - -simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) - = do { tick (BetaReduction bndr) - ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont } - -simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_cont = cont, sc_dup = dup }) - | isSimplified dup -- Don't re-simplify if we've simplified it once - -- See Note [Avoiding exponential behaviour] - = do { tick (BetaReduction bndr) - ; (floats1, env') <- simplNonRecX env zapped_bndr arg - ; (floats2, expr') <- simplLam env' bndrs body cont - ; return (floats1 `addFloats` floats2, expr') } - - | otherwise - = do { tick (BetaReduction bndr) - ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont } - where - zapped_bndr -- See Note [Zap unfolding when beta-reducing] - | isId bndr = zapStableUnfolding bndr - | otherwise = bndr - - -- Discard a non-counting tick on a lambda. This may change the - -- cost attribution slightly (moving the allocation of the - -- lambda elsewhere), but we don't care: optimisation changes - -- cost attribution all the time. -simplLam env bndrs body (TickIt tickish cont) - | not (tickishCounts tickish) - = simplLam env bndrs body cont - - -- Not enough args, so there are real lambdas left to put in the result -simplLam env bndrs body cont - = do { (env', bndrs') <- simplLamBndrs env bndrs - ; body' <- simplExpr env' body - ; new_lam <- mkLam env bndrs' body' cont - ; rebuild env' new_lam cont } - -------------- -simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) --- Used for lambda binders. These sometimes have unfoldings added by --- the worker/wrapper pass that must be preserved, because they can't --- be reconstructed from context. For example: --- f x = case x of (a,b) -> fw a b x --- fw a b x{=(a,b)} = ... --- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise. -simplLamBndr env bndr - | isId bndr && isFragileUnfolding old_unf -- Special case - = do { (env1, bndr1) <- simplBinder env bndr - ; unf' <- simplStableUnfolding env1 NotTopLevel Nothing bndr - old_unf (idType bndr1) - ; let bndr2 = bndr1 `setIdUnfolding` unf' - ; return (modifyInScope env1 bndr2, bndr2) } - - | otherwise - = simplBinder env bndr -- Normal case - where - old_unf = idUnfolding bndr - -simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) -simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs - ------------------- -simplNonRecE :: SimplEnv - -> InId -- The binder, always an Id - -- Never a join point - -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) - -> ([InBndr], InExpr) -- Body of the let/lambda - -- \xs.e - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - --- simplNonRecE is used for --- * non-top-level non-recursive non-join-point lets in expressions --- * beta reduction --- --- simplNonRec env b (rhs, rhs_se) (bs, body) k --- = let env in --- cont< let b = rhs_se(rhs) in \bs.body > --- --- It deals with strict bindings, via the StrictBind continuation, --- which may abort the whole process --- --- Precondition: rhs satisfies the let/app invariant --- Note [Core let/app invariant] in GHC.Core --- --- The "body" of the binding comes as a pair of ([InId],InExpr) --- representing a lambda; so we recurse back to simplLam --- Why? Because of the binder-occ-info-zapping done before --- the call to simplLam in simplExprF (Lam ...) - -simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont - | ASSERT( isId bndr && not (isJoinId bndr) ) True - , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se - = do { tick (PreInlineUnconditionally bndr) - ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ - simplLam env' bndrs body cont } - - -- Deal with strict bindings - | isStrictId bndr -- Includes coercions - , sm_case_case (getMode env) - = simplExprF (rhs_se `setInScopeFromE` env) rhs - (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body - , sc_env = env, sc_cont = cont, sc_dup = NoDup }) - - -- Deal with lazy bindings - | otherwise - = ASSERT( not (isTyVar bndr) ) - do { (env1, bndr1) <- simplNonRecBndr env bndr - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing - ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se - ; (floats2, expr') <- simplLam env3 bndrs body cont - ; return (floats1 `addFloats` floats2, expr') } - ------------------- -simplRecE :: SimplEnv - -> [(InId, InExpr)] - -> InExpr - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - --- simplRecE is used for --- * non-top-level recursive lets in expressions -simplRecE env pairs body cont - = do { let bndrs = map fst pairs - ; MASSERT(all (not . isJoinId) bndrs) - ; env1 <- simplRecBndrs env bndrs - -- NB: bndrs' don't have unfoldings or rules - -- We add them as we go down - ; (floats1, env2) <- simplRecBind env1 NotTopLevel Nothing pairs - ; (floats2, expr') <- simplExprF env2 body cont - ; return (floats1 `addFloats` floats2, expr') } - -{- Note [Avoiding exponential behaviour] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One way in which we can get exponential behaviour is if we simplify a -big expression, and the re-simplify it -- and then this happens in a -deeply-nested way. So we must be jolly careful about re-simplifying -an expression. That is why completeNonRecX does not try -preInlineUnconditionally. - -Example: - f BIG, where f has a RULE -Then - * We simplify BIG before trying the rule; but the rule does not fire - * We inline f = \x. x True - * So if we did preInlineUnconditionally we'd re-simplify (BIG True) - -However, if BIG has /not/ already been simplified, we'd /like/ to -simplify BIG True; maybe good things happen. That is why - -* simplLam has - - a case for (isSimplified dup), which goes via simplNonRecX, and - - a case for the un-simplified case, which goes via simplNonRecE - -* We go to some efforts to avoid unnecessarily simplifying ApplyToVal, - in at least two places - - In simplCast/addCoerce, where we check for isReflCo - - In rebuildCall we avoid simplifying arguments before we have to - (see Note [Trying rewrite rules]) - - -Note [Zap unfolding when beta-reducing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Lambda-bound variables can have stable unfoldings, such as - $j = \x. \b{Unf=Just x}. e -See Note [Case binders and join points] below; the unfolding for lets -us optimise e better. However when we beta-reduce it we want to -revert to using the actual value, otherwise we can end up in the -stupid situation of - let x = blah in - let b{Unf=Just x} = y - in ...b... -Here it'd be far better to drop the unfolding and use the actual RHS. - -************************************************************************ -* * - Join points -* * -********************************************************************* -} - -{- Note [Rules and unfolding for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - simplExpr (join j x = rhs ) cont - ( {- RULE j (p:ps) = blah -} ) - ( {- StableUnfolding j = blah -} ) - (in blah ) - -Then we will push 'cont' into the rhs of 'j'. But we should *also* push -'cont' into the RHS of - * Any RULEs for j, e.g. generated by SpecConstr - * Any stable unfolding for j, e.g. the result of an INLINE pragma - -Simplifying rules and stable-unfoldings happens a bit after -simplifying the right-hand side, so we remember whether or not it -is a join point, and what 'cont' is, in a value of type MaybeJoinCont - -#13900 was caused by forgetting to push 'cont' into the RHS -of a SpecConstr-generated RULE for a join point. --} - -type MaybeJoinCont = Maybe SimplCont - -- Nothing => Not a join point - -- Just k => This is a join binding with continuation k - -- See Note [Rules and unfolding for join points] - -simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr - -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplNonRecJoinPoint env bndr rhs body cont - | ASSERT( isJoinId bndr ) True - , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env - = do { tick (PreInlineUnconditionally bndr) - ; simplExprF env' body cont } - - | otherwise - = wrapJoinCont env cont $ \ env cont -> - do { -- We push join_cont into the join RHS and the body; - -- and wrap wrap_cont around the whole thing - ; let res_ty = contResultType cont - ; (env1, bndr1) <- simplNonRecJoinBndr env res_ty bndr - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (Just cont) - ; (floats1, env3) <- simplJoinBind env2 cont bndr bndr2 rhs env - ; (floats2, body') <- simplExprF env3 body cont - ; return (floats1 `addFloats` floats2, body') } - - ------------------- -simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] - -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplRecJoinPoint env pairs body cont - = wrapJoinCont env cont $ \ env cont -> - do { let bndrs = map fst pairs - res_ty = contResultType cont - ; env1 <- simplRecJoinBndrs env res_ty bndrs - -- NB: bndrs' don't have unfoldings or rules - -- We add them as we go down - ; (floats1, env2) <- simplRecBind env1 NotTopLevel (Just cont) pairs - ; (floats2, body') <- simplExprF env2 body cont - ; return (floats1 `addFloats` floats2, body') } - --------------------- -wrapJoinCont :: SimplEnv -> SimplCont - -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) - -> SimplM (SimplFloats, OutExpr) --- Deal with making the continuation duplicable if necessary, --- and with the no-case-of-case situation. -wrapJoinCont env cont thing_inside - | contIsStop cont -- Common case; no need for fancy footwork - = thing_inside env cont - - | not (sm_case_case (getMode env)) - -- See Note [Join points with -fno-case-of-case] - = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) - ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 - ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont - ; return (floats2 `addFloats` floats3, expr3) } - - | otherwise - -- Normal case; see Note [Join points and case-of-case] - = do { (floats1, cont') <- mkDupableCont env cont - ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' - ; return (floats1 `addFloats` floats2, result) } - - --------------------- -trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont --- Drop outer context from join point invocation (jump) --- See Note [Join points and case-of-case] - -trimJoinCont _ Nothing cont - = cont -- Not a jump -trimJoinCont var (Just arity) cont - = trim arity cont - where - trim 0 cont@(Stop {}) - = cont - trim 0 cont - = mkBoringStop (contResultType cont) - trim n cont@(ApplyToVal { sc_cont = k }) - = cont { sc_cont = trim (n-1) k } - trim n cont@(ApplyToTy { sc_cont = k }) - = cont { sc_cont = trim (n-1) k } -- join arity counts types! - trim _ cont - = pprPanic "completeCall" $ ppr var $$ ppr cont - - -{- Note [Join points and case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we perform the case-of-case transform (or otherwise push continuations -inward), we want to treat join points specially. Since they're always -tail-called and we want to maintain this invariant, we can do this (for any -evaluation context E): - - E[join j = e - in case ... of - A -> jump j 1 - B -> jump j 2 - C -> f 3] - - --> - - join j = E[e] - in case ... of - A -> jump j 1 - B -> jump j 2 - C -> E[f 3] - -As is evident from the example, there are two components to this behavior: - - 1. When entering the RHS of a join point, copy the context inside. - 2. When a join point is invoked, discard the outer context. - -We need to be very careful here to remain consistent---neither part is -optional! - -We need do make the continuation E duplicable (since we are duplicating it) -with mkDupableCont. - - -Note [Join points with -fno-case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Supose case-of-case is switched off, and we are simplifying - - case (join j x = in - case y of - A -> j 1 - B -> j 2 - C -> e) of - -Usually, we'd push the outer continuation (case . of ) into -both the RHS and the body of the join point j. But since we aren't doing -case-of-case we may then end up with this totally bogus result - - join x = case of in - case (case y of - A -> j 1 - B -> j 2 - C -> e) of - -This would be OK in the language of the paper, but not in GHC: j is no longer -a join point. We can only do the "push continuation into the RHS of the -join point j" if we also push the continuation right down to the /jumps/ to -j, so that it can evaporate there. If we are doing case-of-case, we'll get to - - join x = case of in - case y of - A -> j 1 - B -> j 2 - C -> case e of - -which is great. - -Bottom line: if case-of-case is off, we must stop pushing the continuation -inwards altogether at any join point. Instead simplify the (join ... in ...) -with a Stop continuation, and wrap the original continuation around the -outside. Surprisingly tricky! - - -************************************************************************ -* * - Variables -* * -************************************************************************ --} - -simplVar :: SimplEnv -> InVar -> SimplM OutExpr --- Look up an InVar in the environment -simplVar env var - | isTyVar var = return (Type (substTyVar env var)) - | isCoVar var = return (Coercion (substCoVar env var)) - | otherwise - = case substId env var of - ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e - DoneId var1 -> return (Var var1) - DoneEx e _ -> return e - -simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplIdF env var cont - = case substId env var of - ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont - -- Don't trim; haven't already simplified e, - -- so the cont is not embodied in e - - DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont) - - DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont) - -- Note [zapSubstEnv] - -- The template is already simplified, so don't re-substitute. - -- This is VITAL. Consider - -- let x = e in - -- let y = \z -> ...x... in - -- \ x -> ...y... - -- We'll clone the inner \x, adding x->x' in the id_subst - -- Then when we inline y, we must *not* replace x by x' in - -- the inlined copy!! - ---------------------------------------------------------- --- Dealing with a call site - -completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) -completeCall env var cont - | Just expr <- callSiteInline dflags var active_unf - lone_variable arg_infos interesting_cont - -- Inline the variable's RHS - = do { checkedTick (UnfoldingDone var) - ; dump_inline expr cont - ; simplExprF (zapSubstEnv env) expr cont } - - | otherwise - -- Don't inline; instead rebuild the call - = do { rule_base <- getSimplRules - ; let info = mkArgInfo env var (getRules rule_base var) - n_val_args call_cont - ; rebuildCall env info cont } - - where - dflags = seDynFlags env - (lone_variable, arg_infos, call_cont) = contArgs cont - n_val_args = length arg_infos - interesting_cont = interestingCallContext env call_cont - active_unf = activeUnfolding (getMode env) var - - log_inlining doc - = liftIO $ dumpAction dflags - (mkUserStyle dflags alwaysQualify AllTheWay) - (dumpOptionsFromFlag Opt_D_dump_inlinings) - "" FormatText doc - - dump_inline unfolding cont - | not (dopt Opt_D_dump_inlinings dflags) = return () - | not (dopt Opt_D_verbose_core2core dflags) - = when (isExternalName (idName var)) $ - log_inlining $ - sep [text "Inlining done:", nest 4 (ppr var)] - | otherwise - = liftIO $ log_inlining $ - sep [text "Inlining done: " <> ppr var, - nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), - text "Cont: " <+> ppr cont])] - -rebuildCall :: SimplEnv - -> ArgInfo - -> SimplCont - -> SimplM (SimplFloats, OutExpr) --- We decided not to inline, so --- - simplify the arguments --- - try rewrite rules --- - and rebuild - ----------- Bottoming applications -------------- -rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont - -- When we run out of strictness args, it means - -- that the call is definitely bottom; see GHC.Core.Op.Simplify.Utils.mkArgInfo - -- Then we want to discard the entire strict continuation. E.g. - -- * case (error "hello") of { ... } - -- * (error "Hello") arg - -- * f (error "Hello") where f is strict - -- etc - -- Then, especially in the first of these cases, we'd like to discard - -- the continuation, leaving just the bottoming expression. But the - -- type might not be right, so we may have to add a coerce. - | not (contIsTrivial cont) -- Only do this if there is a non-trivial - -- continuation to discard, else we do it - -- again and again! - = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] - return (emptyFloats env, castBottomExpr res cont_ty) - where - res = argInfoExpr fun rev_args - cont_ty = contResultType cont - ----------- Try rewrite RULES -------------- --- See Note [Trying rewrite rules] -rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args - , ai_rules = Just (nr_wanted, rules) }) cont - | nr_wanted == 0 || no_more_args - , let info' = info { ai_rules = Nothing } - = -- We've accumulated a simplified call in - -- so try rewrite rules; see Note [RULEs apply to simplified arguments] - -- See also Note [Rules for recursive functions] - do { mb_match <- tryRules env rules fun (reverse rev_args) cont - ; case mb_match of - Just (env', rhs, cont') -> simplExprF env' rhs cont' - Nothing -> rebuildCall env info' cont } - where - no_more_args = case cont of - ApplyToTy {} -> False - ApplyToVal {} -> False - _ -> True - - ----------- Simplify applications and casts -------------- -rebuildCall env info (CastIt co cont) - = rebuildCall env (addCastTo info co) cont - -rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) - = rebuildCall env (addTyArgTo info arg_ty) cont - -rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty - , ai_strs = str:strs, ai_discs = disc:discs }) - (ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_dup = dup_flag, sc_cont = cont }) - | isSimplified dup_flag -- See Note [Avoid redundant simplification] - = rebuildCall env (addValArgTo info' arg) cont - - | str -- Strict argument - , sm_case_case (getMode env) - = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ - simplExprF (arg_se `setInScopeFromE` env) arg - (StrictArg { sc_fun = info', sc_cci = cci_strict - , sc_dup = Simplified, sc_cont = cont }) - -- Note [Shadowing] - - | otherwise -- Lazy argument - -- DO NOT float anything outside, hence simplExprC - -- There is no benefit (unlike in a let-binding), and we'd - -- have to be very careful about bogus strictness through - -- floating a demanded let. - = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg - (mkLazyArgStop arg_ty cci_lazy) - ; rebuildCall env (addValArgTo info' arg') cont } - where - info' = info { ai_strs = strs, ai_discs = discs } - arg_ty = funArgTy fun_ty - - -- Use this for lazy arguments - cci_lazy | encl_rules = RuleArgCtxt - | disc > 0 = DiscArgCtxt -- Be keener here - | otherwise = BoringCtxt -- Nothing interesting - - -- ..and this for strict arguments - cci_strict | encl_rules = RuleArgCtxt - | disc > 0 = DiscArgCtxt - | otherwise = RhsCtxt - -- Why RhsCtxt? if we see f (g x) (h x), and f is strict, we - -- want to be a bit more eager to inline g, because it may - -- expose an eval (on x perhaps) that can be eliminated or - -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1 - -- It's worth an 18% improvement in allocation for this - -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier' - ----------- No further useful info, revert to generic rebuild ------------ -rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont - = rebuild env (argInfoExpr fun rev_args) cont - -{- Note [Trying rewrite rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet -simplified. We want to simplify enough arguments to allow the rules -to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone -is sufficient. Example: class ops - (+) dNumInt e2 e3 -If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the -latter's strictness when simplifying e2, e3. Moreover, suppose we have - RULE f Int = \x. x True - -Then given (f Int e1) we rewrite to - (\x. x True) e1 -without simplifying e1. Now we can inline x into its unique call site, -and absorb the True into it all in the same pass. If we simplified -e1 first, we couldn't do that; see Note [Avoiding exponential behaviour]. - -So we try to apply rules if either - (a) no_more_args: we've run out of argument that the rules can "see" - (b) nr_wanted: none of the rules wants any more arguments - - -Note [RULES apply to simplified arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very desirable to try RULES once the arguments have been simplified, because -doing so ensures that rule cascades work in one pass. Consider - {-# RULES g (h x) = k x - f (k x) = x #-} - ...f (g (h x))... -Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If -we match f's rules against the un-simplified RHS, it won't match. This -makes a particularly big difference when superclass selectors are involved: - op ($p1 ($p2 (df d))) -We want all this to unravel in one sweep. - -Note [Avoid redundant simplification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because RULES apply to simplified arguments, there's a danger of repeatedly -simplifying already-simplified arguments. An important example is that of - (>>=) d e1 e2 -Here e1, e2 are simplified before the rule is applied, but don't really -participate in the rule firing. So we mark them as Simplified to avoid -re-simplifying them. - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -This part of the simplifier may break the no-shadowing invariant -Consider - f (...(\a -> e)...) (case y of (a,b) -> e') -where f is strict in its second arg -If we simplify the innermost one first we get (...(\a -> e)...) -Simplifying the second arg makes us float the case out, so we end up with - case y of (a,b) -> f (...(\a -> e)...) e' -So the output does not have the no-shadowing invariant. However, there is -no danger of getting name-capture, because when the first arg was simplified -we used an in-scope set that at least mentioned all the variables free in its -static environment, and that is enough. - -We can't just do innermost first, or we'd end up with a dual problem: - case x of (a,b) -> f e (...(\a -> e')...) - -I spent hours trying to recover the no-shadowing invariant, but I just could -not think of an elegant way to do it. The simplifier is already knee-deep in -continuations. We have to keep the right in-scope set around; AND we have -to get the effect that finding (error "foo") in a strict arg position will -discard the entire application and replace it with (error "foo"). Getting -all this at once is TOO HARD! - - -************************************************************************ -* * - Rewrite rules -* * -************************************************************************ --} - -tryRules :: SimplEnv -> [CoreRule] - -> Id -> [ArgSpec] - -> SimplCont - -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) - -tryRules env rules fn args call_cont - | null rules - = return Nothing - -{- Disabled until we fix #8326 - | fn `hasKey` tagToEnumKey -- See Note [Optimising tagToEnum#] - , [_type_arg, val_arg] <- args - , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont - , isDeadBinder bndr - = do { let enum_to_tag :: CoreAlt -> CoreAlt - -- Takes K -> e into tagK# -> e - -- where tagK# is the tag of constructor K - enum_to_tag (DataAlt con, [], rhs) - = ASSERT( isEnumerationTyCon (dataConTyCon con) ) - (LitAlt tag, [], rhs) - where - tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG)) - enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt) - - new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts - new_bndr = setIdType bndr intPrimTy - -- The binder is dead, but should have the right type - ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) } --} - - | Just (rule, rule_rhs) <- lookupRule dflags (getUnfoldingInRuleMatch env) - (activeRule (getMode env)) fn - (argInfoAppArgs args) rules - -- Fire a rule for the function - = do { checkedTick (RuleFired (ruleName rule)) - ; let cont' = pushSimplifiedArgs zapped_env - (drop (ruleArity rule) args) - call_cont - -- (ruleArity rule) says how - -- many args the rule consumed - - occ_anald_rhs = occurAnalyseExpr rule_rhs - -- See Note [Occurrence-analyse after rule firing] - ; dump rule rule_rhs - ; return (Just (zapped_env, occ_anald_rhs, cont')) } - -- The occ_anald_rhs and cont' are all Out things - -- hence zapping the environment - - | otherwise -- No rule fires - = do { nodump -- This ensures that an empty file is written - ; return Nothing } - - where - dflags = seDynFlags env - zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] - - printRuleModule rule - = parens (maybe (text "BUILTIN") - (pprModuleName . moduleName) - (ruleModule rule)) - - dump rule rule_rhs - | dopt Opt_D_dump_rule_rewrites dflags - = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat - [ text "Rule:" <+> ftext (ruleName rule) - , text "Module:" <+> printRuleModule rule - , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) - , text "After: " <+> pprCoreExpr rule_rhs - , text "Cont: " <+> ppr call_cont ] - - | dopt Opt_D_dump_rule_firings dflags - = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $ - ftext (ruleName rule) - <+> printRuleModule rule - - | otherwise - = return () - - nodump - | dopt Opt_D_dump_rule_rewrites dflags - = liftIO $ do - touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites) - - | dopt Opt_D_dump_rule_firings dflags - = liftIO $ do - touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings) - - | otherwise - = return () - - log_rule dflags flag hdr details - = liftIO $ do - let sty = mkDumpStyle dflags alwaysQualify - dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $ - sep [text hdr, nest 4 details] - -trySeqRules :: SimplEnv - -> OutExpr -> InExpr -- Scrutinee and RHS - -> SimplCont - -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) --- See Note [User-defined RULES for seq] -trySeqRules in_env scrut rhs cont - = do { rule_base <- getSimplRules - ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont } - where - no_cast_scrut = drop_casts scrut - scrut_ty = exprType no_cast_scrut - seq_id_ty = idType seqId - res1_ty = piResultTy seq_id_ty rhs_rep - res2_ty = piResultTy res1_ty scrut_ty - rhs_ty = substTy in_env (exprType rhs) - rhs_rep = getRuntimeRep rhs_ty - out_args = [ TyArg { as_arg_ty = rhs_rep - , as_hole_ty = seq_id_ty } - , TyArg { as_arg_ty = scrut_ty - , as_hole_ty = res1_ty } - , TyArg { as_arg_ty = rhs_ty - , as_hole_ty = res2_ty } - , ValArg no_cast_scrut] - rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs - , sc_env = in_env, sc_cont = cont } - -- Lazily evaluated, so we don't do most of this - - drop_casts (Cast e _) = drop_casts e - drop_casts e = e - -{- Note [User-defined RULES for seq] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given - case (scrut |> co) of _ -> rhs -look for rules that match the expression - seq @t1 @t2 scrut -where scrut :: t1 - rhs :: t2 - -If you find a match, rewrite it, and apply to 'rhs'. - -Notice that we can simply drop casts on the fly here, which -makes it more likely that a rule will match. - -See Note [User-defined RULES for seq] in GHC.Types.Id.Make. - -Note [Occurrence-analyse after rule firing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -After firing a rule, we occurrence-analyse the instantiated RHS before -simplifying it. Usually this doesn't make much difference, but it can -be huge. Here's an example (simplCore/should_compile/T7785) - - map f (map f (map f xs) - -= -- Use build/fold form of map, twice - map f (build (\cn. foldr (mapFB c f) n - (build (\cn. foldr (mapFB c f) n xs)))) - -= -- Apply fold/build rule - map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n)) - -= -- Beta-reduce - -- Alas we have no occurrence-analysed, so we don't know - -- that c is used exactly once - map f (build (\cn. let c1 = mapFB c f in - foldr (mapFB c1 f) n xs)) - -= -- Use mapFB rule: mapFB (mapFB c f) g = mapFB c (f.g) - -- We can do this because (mapFB c n) is a PAP and hence expandable - map f (build (\cn. let c1 = mapFB c n in - foldr (mapFB c (f.f)) n x)) - -This is not too bad. But now do the same with the outer map, and -we get another use of mapFB, and t can interact with /both/ remaining -mapFB calls in the above expression. This is stupid because actually -that 'c1' binding is dead. The outer map introduces another c2. If -there is a deep stack of maps we get lots of dead bindings, and lots -of redundant work as we repeatedly simplify the result of firing rules. - -The easy thing to do is simply to occurrence analyse the result of -the rule firing. Note that this occ-anals not only the RHS of the -rule, but also the function arguments, which by now are OutExprs. -E.g. - RULE f (g x) = x+1 - -Call f (g BIG) --> (\x. x+1) BIG - -The rule binders are lambda-bound and applied to the OutExpr arguments -(here BIG) which lack all internal occurrence info. - -Is this inefficient? Not really: we are about to walk over the result -of the rule firing to simplify it, so occurrence analysis is at most -a constant factor. - -Possible improvement: occ-anal the rules when putting them in the -database; and in the simplifier just occ-anal the OutExpr arguments. -But that's more complicated and the rule RHS is usually tiny; so I'm -just doing the simple thing. - -Historical note: previously we did occ-anal the rules in Rule.hs, -but failed to occ-anal the OutExpr arguments, which led to the -nasty performance problem described above. - - -Note [Optimising tagToEnum#] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an enumeration data type: - - data Foo = A | B | C - -Then we want to transform - - case tagToEnum# x of ==> case x of - A -> e1 DEFAULT -> e1 - B -> e2 1# -> e2 - C -> e3 2# -> e3 - -thereby getting rid of the tagToEnum# altogether. If there was a DEFAULT -alternative we retain it (remember it comes first). If not the case must -be exhaustive, and we reflect that in the transformed version by adding -a DEFAULT. Otherwise Lint complains that the new case is not exhaustive. -See #8317. - -Note [Rules for recursive functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might think that we shouldn't apply rules for a loop breaker: -doing so might give rise to an infinite loop, because a RULE is -rather like an extra equation for the function: - RULE: f (g x) y = x+y - Eqn: f a y = a-y - -But it's too drastic to disable rules for loop breakers. -Even the foldr/build rule would be disabled, because foldr -is recursive, and hence a loop breaker: - foldr k z (build g) = g k z -So it's up to the programmer: rules can cause divergence - - -************************************************************************ -* * - Rebuilding a case expression -* * -************************************************************************ - -Note [Case elimination] -~~~~~~~~~~~~~~~~~~~~~~~ -The case-elimination transformation discards redundant case expressions. -Start with a simple situation: - - case x# of ===> let y# = x# in e - y# -> e - -(when x#, y# are of primitive type, of course). We can't (in general) -do this for algebraic cases, because we might turn bottom into -non-bottom! - -The code in GHC.Core.Op.Simplify.Utils.prepareAlts has the effect of generalise -this idea to look for a case where we're scrutinising a variable, and we know -that only the default case can match. For example: - - case x of - 0# -> ... - DEFAULT -> ...(case x of - 0# -> ... - DEFAULT -> ...) ... - -Here the inner case is first trimmed to have only one alternative, the -DEFAULT, after which it's an instance of the previous case. This -really only shows up in eliminating error-checking code. - -Note that GHC.Core.Op.Simplify.Utils.mkCase combines identical RHSs. So - - case e of ===> case e of DEFAULT -> r - True -> r - False -> r - -Now again the case may be eliminated by the CaseElim transformation. -This includes things like (==# a# b#)::Bool so that we simplify - case ==# a# b# of { True -> x; False -> x } -to just - x -This particular example shows up in default methods for -comparison operations (e.g. in (>=) for Int.Int32) - -Note [Case to let transformation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a case over a lifted type has a single alternative, and is being -used as a strict 'let' (all isDeadBinder bndrs), we may want to do -this transformation: - - case e of r ===> let r = e in ...r... - _ -> ...r... - -We treat the unlifted and lifted cases separately: - -* Unlifted case: 'e' satisfies exprOkForSpeculation - (ok-for-spec is needed to satisfy the let/app invariant). - This turns case a +# b of r -> ...r... - into let r = a +# b in ...r... - and thence .....(a +# b).... - - However, if we have - case indexArray# a i of r -> ...r... - we might like to do the same, and inline the (indexArray# a i). - But indexArray# is not okForSpeculation, so we don't build a let - in rebuildCase (lest it get floated *out*), so the inlining doesn't - happen either. Annoying. - -* Lifted case: we need to be sure that the expression is already - evaluated (exprIsHNF). If it's not already evaluated - - we risk losing exceptions, divergence or - user-specified thunk-forcing - - even if 'e' is guaranteed to converge, we don't want to - create a thunk (call by need) instead of evaluating it - right away (call by value) - - However, we can turn the case into a /strict/ let if the 'r' is - used strictly in the body. Then we won't lose divergence; and - we won't build a thunk because the let is strict. - See also Note [Case-to-let for strictly-used binders] - - NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in GHC.Core.Make. - We want to turn - case (absentError "foo") of r -> ...MkT r... - into - let r = absentError "foo" in ...MkT r... - - -Note [Case-to-let for strictly-used binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have this: - case of r { _ -> ..r.. } - -where 'r' is used strictly in (..r..), we can safely transform to - let r = in ...r... - -This is a Good Thing, because 'r' might be dead (if the body just -calls error), or might be used just once (in which case it can be -inlined); or we might be able to float the let-binding up or down. -E.g. #15631 has an example. - -Note that this can change the error behaviour. For example, we might -transform - case x of { _ -> error "bad" } - --> error "bad" -which is might be puzzling if 'x' currently lambda-bound, but later gets -let-bound to (error "good"). - -Nevertheless, the paper "A semantics for imprecise exceptions" allows -this transformation. If you want to fix the evaluation order, use -'pseq'. See #8900 for an example where the loss of this -transformation bit us in practice. - -See also Note [Empty case alternatives] in GHC.Core. - -Historical notes - -There have been various earlier versions of this patch: - -* By Sept 18 the code looked like this: - || scrut_is_demanded_var scrut - - scrut_is_demanded_var :: CoreExpr -> Bool - scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s - scrut_is_demanded_var (Var _) = isStrictDmd (idDemandInfo case_bndr) - scrut_is_demanded_var _ = False - - This only fired if the scrutinee was a /variable/, which seems - an unnecessary restriction. So in #15631 I relaxed it to allow - arbitrary scrutinees. Less code, less to explain -- but the change - had 0.00% effect on nofib. - -* Previously, in Jan 13 the code looked like this: - || case_bndr_evald_next rhs - - case_bndr_evald_next :: CoreExpr -> Bool - -- See Note [Case binder next] - case_bndr_evald_next (Var v) = v == case_bndr - case_bndr_evald_next (Cast e _) = case_bndr_evald_next e - case_bndr_evald_next (App e _) = case_bndr_evald_next e - case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e - case_bndr_evald_next _ = False - - This patch was part of fixing #7542. See also - Note [Eta reduction of an eval'd function] in GHC.Core.Utils.) - - -Further notes about case elimination -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: test :: Integer -> IO () - test = print - -Turns out that this compiles to: - Print.test - = \ eta :: Integer - eta1 :: Void# -> - case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> - case hPutStr stdout - (PrelNum.jtos eta ($w[] @ Char)) - eta1 - of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} - -Notice the strange '<' which has no effect at all. This is a funny one. -It started like this: - -f x y = if x < 0 then jtos x - else if y==0 then "" else jtos x - -At a particular call site we have (f v 1). So we inline to get - - if v < 0 then jtos x - else if 1==0 then "" else jtos x - -Now simplify the 1==0 conditional: - - if v<0 then jtos v else jtos v - -Now common-up the two branches of the case: - - case (v<0) of DEFAULT -> jtos v - -Why don't we drop the case? Because it's strict in v. It's technically -wrong to drop even unnecessary evaluations, and in practice they -may be a result of 'seq' so we *definitely* don't want to drop those. -I don't really know how to improve this situation. - - -Note [FloatBinds from constructor wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have FloatBinds coming from the constructor wrapper -(as in Note [exprIsConApp_maybe on data constructors with wrappers]), -we cannot float past them. We'd need to float the FloatBind -together with the simplify floats, unfortunately the -simplifier doesn't have case-floats. The simplest thing we can -do is to wrap all the floats here. The next iteration of the -simplifier will take care of all these cases and lets. - -Given data T = MkT !Bool, this allows us to simplify -case $WMkT b of { MkT x -> f x } -to -case b of { b' -> f b' }. - -We could try and be more clever (like maybe wfloats only contain -let binders, so we could float them). But the need for the -extra complication is not clear. --} - ---------------------------------------------------------- --- Eliminate the case if possible - -rebuildCase, reallyRebuildCase - :: SimplEnv - -> OutExpr -- Scrutinee - -> InId -- Case binder - -> [InAlt] -- Alternatives (increasing order) - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - --------------------------------------------------- --- 1. Eliminate the case if there's a known constructor --------------------------------------------------- - -rebuildCase env scrut case_bndr alts cont - | Lit lit <- scrut -- No need for same treatment as constructors - -- because literals are inlined more vigorously - , not (litIsLifted lit) - = do { tick (KnownBranch case_bndr) - ; case findAlt (LitAlt lit) alts of - Nothing -> missingAlt env case_bndr alts cont - Just (_, bs, rhs) -> simple_rhs env [] scrut bs rhs } - - | Just (in_scope', wfloats, con, ty_args, other_args) - <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut - -- Works when the scrutinee is a variable with a known unfolding - -- as well as when it's an explicit constructor application - , let env0 = setInScopeSet env in_scope' - = do { tick (KnownBranch case_bndr) - ; case findAlt (DataAlt con) alts of - Nothing -> missingAlt env0 case_bndr alts cont - Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con) - `mkTyApps` ty_args - `mkApps` other_args - in simple_rhs env0 wfloats con_app bs rhs - Just (_, bs, rhs) -> knownCon env0 scrut wfloats con ty_args other_args - case_bndr bs rhs cont - } - where - simple_rhs env wfloats scrut' bs rhs = - ASSERT( null bs ) - do { (floats1, env') <- simplNonRecX env case_bndr scrut' - -- scrut is a constructor application, - -- hence satisfies let/app invariant - ; (floats2, expr') <- simplExprF env' rhs cont - ; case wfloats of - [] -> return (floats1 `addFloats` floats2, expr') - _ -> return - -- See Note [FloatBinds from constructor wrappers] - ( emptyFloats env, - GHC.Core.Make.wrapFloats wfloats $ - wrapFloats (floats1 `addFloats` floats2) expr' )} - - --------------------------------------------------- --- 2. Eliminate the case if scrutinee is evaluated --------------------------------------------------- - -rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont - -- See if we can get rid of the case altogether - -- See Note [Case elimination] - -- mkCase made sure that if all the alternatives are equal, - -- then there is now only one (DEFAULT) rhs - - -- 2a. Dropping the case altogether, if - -- a) it binds nothing (so it's really just a 'seq') - -- b) evaluating the scrutinee has no side effects - | is_plain_seq - , exprOkForSideEffects scrut - -- The entire case is dead, so we can drop it - -- if the scrutinee converges without having imperative - -- side effects or raising a Haskell exception - -- See Note [PrimOp can_fail and has_side_effects] in PrimOp - = simplExprF env rhs cont - - -- 2b. Turn the case into a let, if - -- a) it binds only the case-binder - -- b) unlifted case: the scrutinee is ok-for-speculation - -- lifted case: the scrutinee is in HNF (or will later be demanded) - -- See Note [Case to let transformation] - | all_dead_bndrs - , doCaseToLet scrut case_bndr - = do { tick (CaseElim case_bndr) - ; (floats1, env') <- simplNonRecX env case_bndr scrut - ; (floats2, expr') <- simplExprF env' rhs cont - ; return (floats1 `addFloats` floats2, expr') } - - -- 2c. Try the seq rules if - -- a) it binds only the case binder - -- b) a rule for seq applies - -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make - | is_plain_seq - = do { mb_rule <- trySeqRules env scrut rhs cont - ; case mb_rule of - Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont' - Nothing -> reallyRebuildCase env scrut case_bndr alts cont } - where - all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] - is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect - -rebuildCase env scrut case_bndr alts cont - = reallyRebuildCase env scrut case_bndr alts cont - - -doCaseToLet :: OutExpr -- Scrutinee - -> InId -- Case binder - -> Bool --- The situation is case scrut of b { DEFAULT -> body } --- Can we transform thus? let { b = scrut } in body -doCaseToLet scrut case_bndr - | isTyCoVar case_bndr -- Respect GHC.Core - = isTyCoArg scrut -- Note [Core type and coercion invariant] - - | isUnliftedType (idType case_bndr) - = exprOkForSpeculation scrut - - | otherwise -- Scrut has a lifted type - = exprIsHNF scrut - || isStrictDmd (idDemandInfo case_bndr) - -- See Note [Case-to-let for strictly-used binders] - --------------------------------------------------- --- 3. Catch-all case --------------------------------------------------- - -reallyRebuildCase env scrut case_bndr alts cont - | not (sm_case_case (getMode env)) - = do { case_expr <- simplAlts env scrut case_bndr alts - (mkBoringStop (contHoleType cont)) - ; rebuild env case_expr cont } - - | otherwise - = do { (floats, cont') <- mkDupableCaseCont env alts cont - ; case_expr <- simplAlts (env `setInScopeFromF` floats) - scrut case_bndr alts cont' - ; return (floats, case_expr) } - -{- -simplCaseBinder checks whether the scrutinee is a variable, v. If so, -try to eliminate uses of v in the RHSs in favour of case_bndr; that -way, there's a chance that v will now only be used once, and hence -inlined. - -Historical note: we use to do the "case binder swap" in the Simplifier -so there were additional complications if the scrutinee was a variable. -Now the binder-swap stuff is done in the occurrence analyser; see -OccurAnal Note [Binder swap]. - -Note [knownCon occ info] -~~~~~~~~~~~~~~~~~~~~~~~~ -If the case binder is not dead, then neither are the pattern bound -variables: - case of x { (a,b) -> - case x of { (p,q) -> p } } -Here (a,b) both look dead, but come alive after the inner case is eliminated. -The point is that we bring into the envt a binding - let x = (a,b) -after the outer case, and that makes (a,b) alive. At least we do unless -the case binder is guaranteed dead. - -Note [Case alternative occ info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are simply reconstructing a case (the common case), we always -zap the occurrence info on the binders in the alternatives. Even -if the case binder is dead, the scrutinee is usually a variable, and *that* -can bring the case-alternative binders back to life. -See Note [Add unfolding for scrutinee] - -Note [Improving seq] -~~~~~~~~~~~~~~~~~~~ -Consider - type family F :: * -> * - type instance F Int = Int - -We'd like to transform - case e of (x :: F Int) { DEFAULT -> rhs } -===> - case e `cast` co of (x'::Int) - I# x# -> let x = x' `cast` sym co - in rhs - -so that 'rhs' can take advantage of the form of x'. Notice that Note -[Case of cast] (in OccurAnal) may then apply to the result. - -We'd also like to eliminate empty types (#13468). So if - - data Void - type instance F Bool = Void - -then we'd like to transform - case (x :: F Bool) of { _ -> error "urk" } -===> - case (x |> co) of (x' :: Void) of {} - -Nota Bene: we used to have a built-in rule for 'seq' that dropped -casts, so that - case (x |> co) of { _ -> blah } -dropped the cast; in order to improve the chances of trySeqRules -firing. But that works in the /opposite/ direction to Note [Improving -seq] so there's a danger of flip/flopping. Better to make trySeqRules -insensitive to the cast, which is now is. - -The need for [Improving seq] showed up in Roman's experiments. Example: - foo :: F Int -> Int -> Int - foo t n = t `seq` bar n - where - bar 0 = 0 - bar n = bar (n - case t of TI i -> i) -Here we'd like to avoid repeated evaluating t inside the loop, by -taking advantage of the `seq`. - -At one point I did transformation in LiberateCase, but it's more -robust here. (Otherwise, there's a danger that we'll simply drop the -'seq' altogether, before LiberateCase gets to see it.) --} - -simplAlts :: SimplEnv - -> OutExpr -- Scrutinee - -> InId -- Case binder - -> [InAlt] -- Non-empty - -> SimplCont - -> SimplM OutExpr -- Returns the complete simplified case expression - -simplAlts env0 scrut case_bndr alts cont' - = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr - , text "cont':" <+> ppr cont' - , text "in_scope" <+> ppr (seInScope env0) ]) - ; (env1, case_bndr1) <- simplBinder env0 case_bndr - ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding - env2 = modifyInScope env1 case_bndr2 - -- See Note [Case binder evaluated-ness] - - ; fam_envs <- getFamEnvs - ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut - case_bndr case_bndr2 alts - - ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts - -- NB: it's possible that the returned in_alts is empty: this is handled - -- by the caller (rebuildCase) in the missingAlt function - - ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts - ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $ - - ; let alts_ty' = contResultType cont' - -- See Note [Avoiding space leaks in OutType] - ; seqType alts_ty' `seq` - mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' } - - ------------------------------------- -improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv - -> OutExpr -> InId -> OutId -> [InAlt] - -> SimplM (SimplEnv, OutExpr, OutId) --- Note [Improving seq] -improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] - | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) - = do { case_bndr2 <- newId (fsLit "nt") ty2 - ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing - env2 = extendIdSubst env case_bndr rhs - ; return (env2, scrut `Cast` co, case_bndr2) } - -improveSeq _ env scrut _ case_bndr1 _ - = return (env, scrut, case_bndr1) - - ------------------------------------- -simplAlt :: SimplEnv - -> Maybe OutExpr -- The scrutinee - -> [AltCon] -- These constructors can't be present when - -- matching the DEFAULT alternative - -> OutId -- The case binder - -> SimplCont - -> InAlt - -> SimplM OutAlt - -simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) - = ASSERT( null bndrs ) - do { let env' = addBinderUnfolding env case_bndr' - (mkOtherCon imposs_deflt_cons) - -- Record the constructors that the case-binder *can't* be. - ; rhs' <- simplExprC env' rhs cont' - ; return (DEFAULT, [], rhs') } - -simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs) - = ASSERT( null bndrs ) - do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) - ; rhs' <- simplExprC env' rhs cont' - ; return (LitAlt lit, [], rhs') } - -simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs) - = do { -- See Note [Adding evaluatedness info to pattern-bound variables] - let vs_with_evals = addEvals scrut' con vs - ; (env', vs') <- simplLamBndrs env vs_with_evals - - -- Bind the case-binder to (con args) - ; let inst_tys' = tyConAppArgs (idType case_bndr') - con_app :: OutExpr - con_app = mkConApp2 con inst_tys' vs' - - ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app - ; rhs' <- simplExprC env'' rhs cont' - ; return (DataAlt con, vs', rhs') } - -{- Note [Adding evaluatedness info to pattern-bound variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -addEvals records the evaluated-ness of the bound variables of -a case pattern. This is *important*. Consider - - data T = T !Int !Int - - case x of { T a b -> T (a+1) b } - -We really must record that b is already evaluated so that we don't -go and re-evaluate it when constructing the result. -See Note [Data-con worker strictness] in GHC.Types.Id.Make - -NB: simplLamBndrs preserves this eval info - -In addition to handling data constructor fields with !s, addEvals -also records the fact that the result of seq# is always in WHNF. -See Note [seq# magic] in GHC.Core.Op.ConstantFold. Example (#15226): - - case seq# v s of - (# s', v' #) -> E - -we want the compiler to be aware that v' is in WHNF in E. - -Open problem: we don't record that v itself is in WHNF (and we can't -do it here). The right thing is to do some kind of binder-swap; -see #15226 for discussion. --} - -addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id] --- See Note [Adding evaluatedness info to pattern-bound variables] -addEvals scrut con vs - -- Deal with seq# applications - | Just scr <- scrut - , isUnboxedTupleCon con - , [s,x] <- vs - -- Use stripNArgs rather than collectArgsTicks to avoid building - -- a list of arguments only to throw it away immediately. - , Just (Var f) <- stripNArgs 4 scr - , Just SeqOp <- isPrimOpId_maybe f - , let x' = zapIdOccInfoAndSetEvald MarkedStrict x - = [s, x'] - - -- Deal with banged datacon fields -addEvals _scrut con vs = go vs the_strs - where - the_strs = dataConRepStrictness con - - go [] [] = [] - go (v:vs') strs | isTyVar v = v : go vs' strs - go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs - go _ _ = pprPanic "Simplify.addEvals" - (ppr con $$ - ppr vs $$ - ppr_with_length (map strdisp the_strs) $$ - ppr_with_length (dataConRepArgTys con) $$ - ppr_with_length (dataConRepStrictness con)) - where - ppr_with_length list - = ppr list <+> parens (text "length =" <+> ppr (length list)) - strdisp MarkedStrict = text "MarkedStrict" - strdisp NotMarkedStrict = text "NotMarkedStrict" - -zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id -zapIdOccInfoAndSetEvald str v = - setCaseBndrEvald str $ -- Add eval'dness info - zapIdOccInfo v -- And kill occ info; - -- see Note [Case alternative occ info] - -addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv -addAltUnfoldings env scrut case_bndr con_app - = do { let con_app_unf = mk_simple_unf con_app - env1 = addBinderUnfolding env case_bndr con_app_unf - - -- See Note [Add unfolding for scrutinee] - env2 = case scrut of - Just (Var v) -> addBinderUnfolding env1 v con_app_unf - Just (Cast (Var v) co) -> addBinderUnfolding env1 v $ - mk_simple_unf (Cast con_app (mkSymCo co)) - _ -> env1 - - ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) - ; return env2 } - where - mk_simple_unf = mkSimpleUnfolding (seDynFlags env) - -addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv -addBinderUnfolding env bndr unf - | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf - = WARN( not (eqType (idType bndr) (exprType tmpl)), - ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) ) - modifyInScope env (bndr `setIdUnfolding` unf) - - | otherwise - = modifyInScope env (bndr `setIdUnfolding` unf) - -zapBndrOccInfo :: Bool -> Id -> Id --- Consider case e of b { (a,b) -> ... } --- Then if we bind b to (a,b) in "...", and b is not dead, --- then we must zap the deadness info on a,b -zapBndrOccInfo keep_occ_info pat_id - | keep_occ_info = pat_id - | otherwise = zapIdOccInfo pat_id - -{- Note [Case binder evaluated-ness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pin on a (OtherCon []) unfolding to the case-binder of a Case, -even though it'll be over-ridden in every case alternative with a more -informative unfolding. Why? Because suppose a later, less clever, pass -simply replaces all occurrences of the case binder with the binder itself; -then Lint may complain about the let/app invariant. Example - case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in .... - ; K -> blah } - -The let/app invariant requires that y is evaluated in the call to -reallyUnsafePtrEq#, which it is. But we still want that to be true if we -propagate binders to occurrences. - -This showed up in #13027. - -Note [Add unfolding for scrutinee] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general it's unlikely that a variable scrutinee will appear -in the case alternatives case x of { ...x unlikely to appear... } -because the binder-swap in OccAnal has got rid of all such occurrences -See Note [Binder swap] in OccAnal. - -BUT it is still VERY IMPORTANT to add a suitable unfolding for a -variable scrutinee, in simplAlt. Here's why - case x of y - (a,b) -> case b of c - I# v -> ...(f y)... -There is no occurrence of 'b' in the (...(f y)...). But y gets -the unfolding (a,b), and *that* mentions b. If f has a RULE - RULE f (p, I# q) = ... -we want that rule to match, so we must extend the in-scope env with a -suitable unfolding for 'y'. It's *essential* for rule matching; but -it's also good for case-elimintation -- suppose that 'f' was inlined -and did multi-level case analysis, then we'd solve it in one -simplifier sweep instead of two. - -Exactly the same issue arises in GHC.Core.Op.SpecConstr; -see Note [Add scrutinee to ValueEnv too] in GHC.Core.Op.SpecConstr - -HOWEVER, given - case x of y { Just a -> r1; Nothing -> r2 } -we do not want to add the unfolding x -> y to 'x', which might seem cool, -since 'y' itself has different unfoldings in r1 and r2. Reason: if we -did that, we'd have to zap y's deadness info and that is a very useful -piece of information. - -So instead we add the unfolding x -> Just a, and x -> Nothing in the -respective RHSs. - - -************************************************************************ -* * -\subsection{Known constructor} -* * -************************************************************************ - -We are a bit careful with occurrence info. Here's an example - - (\x* -> case x of (a*, b) -> f a) (h v, e) - -where the * means "occurs once". This effectively becomes - case (h v, e) of (a*, b) -> f a) -and then - let a* = h v; b = e in f a -and then - f (h v) - -All this should happen in one sweep. --} - -knownCon :: SimplEnv - -> OutExpr -- The scrutinee - -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) - -> InId -> [InBndr] -> InExpr -- The alternative - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont - = do { (floats1, env1) <- bind_args env bs dc_args - ; (floats2, env2) <- bind_case_bndr env1 - ; (floats3, expr') <- simplExprF env2 rhs cont - ; case dc_floats of - [] -> - return (floats1 `addFloats` floats2 `addFloats` floats3, expr') - _ -> - return ( emptyFloats env - -- See Note [FloatBinds from constructor wrappers] - , GHC.Core.Make.wrapFloats dc_floats $ - wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') } - where - zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId - - -- Ugh! - bind_args env' [] _ = return (emptyFloats env', env') - - bind_args env' (b:bs') (Type ty : args) - = ASSERT( isTyVar b ) - bind_args (extendTvSubst env' b ty) bs' args - - bind_args env' (b:bs') (Coercion co : args) - = ASSERT( isCoVar b ) - bind_args (extendCvSubst env' b co) bs' args - - bind_args env' (b:bs') (arg : args) - = ASSERT( isId b ) - do { let b' = zap_occ b - -- Note that the binder might be "dead", because it doesn't - -- occur in the RHS; and simplNonRecX may therefore discard - -- it via postInlineUnconditionally. - -- Nevertheless we must keep it if the case-binder is alive, - -- because it may be used in the con_app. See Note [knownCon occ info] - ; (floats1, env2) <- simplNonRecX env' b' arg -- arg satisfies let/app invariant - ; (floats2, env3) <- bind_args env2 bs' args - ; return (floats1 `addFloats` floats2, env3) } - - bind_args _ _ _ = - pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ - text "scrut:" <+> ppr scrut - - -- It's useful to bind bndr to scrut, rather than to a fresh - -- binding x = Con arg1 .. argn - -- because very often the scrut is a variable, so we avoid - -- creating, and then subsequently eliminating, a let-binding - -- BUT, if scrut is a not a variable, we must be careful - -- about duplicating the arg redexes; in that case, make - -- a new con-app from the args - bind_case_bndr env - | isDeadBinder bndr = return (emptyFloats env, env) - | exprIsTrivial scrut = return (emptyFloats env - , extendIdSubst env bndr (DoneEx scrut Nothing)) - | otherwise = do { dc_args <- mapM (simplVar env) bs - -- dc_ty_args are already OutTypes, - -- but bs are InBndrs - ; let con_app = Var (dataConWorkId dc) - `mkTyApps` dc_ty_args - `mkApps` dc_args - ; simplNonRecX env bndr con_app } - -------------------- -missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -- This isn't strictly an error, although it is unusual. - -- It's possible that the simplifier might "see" that - -- an inner case has no accessible alternatives before - -- it "sees" that the entire branch of an outer case is - -- inaccessible. So we simply put an error case here instead. -missingAlt env case_bndr _ cont - = WARN( True, text "missingAlt" <+> ppr case_bndr ) - -- See Note [Avoiding space leaks in OutType] - let cont_ty = contResultType cont - in seqType cont_ty `seq` - return (emptyFloats env, mkImpossibleExpr cont_ty) - -{- -************************************************************************ -* * -\subsection{Duplicating continuations} -* * -************************************************************************ - -Consider - let x* = case e of { True -> e1; False -> e2 } - in b -where x* is a strict binding. Then mkDupableCont will be given -the continuation - case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop -and will split it into - dupable: case [] of { True -> $j1; False -> $j2 } ; stop - join floats: $j1 = e1, $j2 = e2 - non_dupable: let x* = [] in b; stop - -Putting this back together would give - let x* = let { $j1 = e1; $j2 = e2 } in - case e of { True -> $j1; False -> $j2 } - in b -(Of course we only do this if 'e' wants to duplicate that continuation.) -Note how important it is that the new join points wrap around the -inner expression, and not around the whole thing. - -In contrast, any let-bindings introduced by mkDupableCont can wrap -around the entire thing. - -Note [Bottom alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have - case (case x of { A -> error .. ; B -> e; C -> error ..) - of alts -then we can just duplicate those alts because the A and C cases -will disappear immediately. This is more direct than creating -join points and inlining them away. See #4930. --} - --------------------- -mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont - -> SimplM (SimplFloats, SimplCont) -mkDupableCaseCont env alts cont - | altsWouldDup alts = mkDupableCont env cont - | otherwise = return (emptyFloats env, cont) - -altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative -altsWouldDup [] = False -- See Note [Bottom alternatives] -altsWouldDup [_] = False -altsWouldDup (alt:alts) - | is_bot_alt alt = altsWouldDup alts - | otherwise = not (all is_bot_alt alts) - where - is_bot_alt (_,_,rhs) = exprIsBottom rhs - -------------------------- -mkDupableCont :: SimplEnv -> SimplCont - -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with - -- extra let/join-floats and in-scope variables - , SimplCont) -- dup_cont: duplicable continuation - -mkDupableCont env cont - | contIsDupable cont - = return (emptyFloats env, cont) - -mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn - -mkDupableCont env (CastIt ty cont) - = do { (floats, cont') <- mkDupableCont env cont - ; return (floats, CastIt ty cont') } - --- Duplicating ticks for now, not sure if this is good or not -mkDupableCont env (TickIt t cont) - = do { (floats, cont') <- mkDupableCont env cont - ; return (floats, TickIt t cont') } - -mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs - , sc_body = body, sc_env = se, sc_cont = cont}) - -- See Note [Duplicating StrictBind] - = do { let sb_env = se `setInScopeFromE` env - ; (sb_env1, bndr') <- simplBinder sb_env bndr - ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont - -- No need to use mkDupableCont before simplLam; we - -- use cont once here, and then share the result if necessary - - ; let join_body = wrapFloats floats1 join_inner - res_ty = contResultType cont - - ; (floats2, body2) - <- if exprIsDupable (targetPlatform (seDynFlags env)) join_body - then return (emptyFloats env, join_body) - else do { join_bndr <- newJoinId [bndr'] res_ty - ; let join_call = App (Var join_bndr) (Var bndr') - join_rhs = Lam (setOneShotLambda bndr') join_body - join_bind = NonRec join_bndr join_rhs - floats = emptyFloats env `extendFloats` join_bind - ; return (floats, join_call) } - ; return ( floats2 - , StrictBind { sc_bndr = bndr', sc_bndrs = [] - , sc_body = body2 - , sc_env = zapSubstEnv se `setInScopeFromF` floats2 - -- See Note [StaticEnv invariant] in GHC.Core.Op.Simplify.Utils - , sc_dup = OkToDup - , sc_cont = mkBoringStop res_ty } ) } - -mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci, sc_cont = cont }) - -- See Note [Duplicating StrictArg] - -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - = do { (floats1, cont') <- mkDupableCont env cont - ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env)) - (ai_args info) - ; return ( foldl' addLetFloats floats1 floats_s - , StrictArg { sc_fun = info { ai_args = args' } - , sc_cci = cci - , sc_cont = cont' - , sc_dup = OkToDup} ) } - -mkDupableCont env (ApplyToTy { sc_cont = cont - , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) - = do { (floats, cont') <- mkDupableCont env cont - ; return (floats, ApplyToTy { sc_cont = cont' - , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } - -mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup - , sc_env = se, sc_cont = cont }) - = -- e.g. [...hole...] (...arg...) - -- ==> - -- let a = ...arg... - -- in [...hole...] a - -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { (floats1, cont') <- mkDupableCont env cont - ; let env' = env `setInScopeFromF` floats1 - ; (_, se', arg') <- simplArg env' dup se arg - ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel (fsLit "karg") arg' - ; let all_floats = floats1 `addLetFloats` let_floats2 - ; return ( all_floats - , ApplyToVal { sc_arg = arg'' - , sc_env = se' `setInScopeFromF` all_floats - -- Ensure that sc_env includes the free vars of - -- arg'' in its in-scope set, even if makeTrivial - -- has turned arg'' into a fresh variable - -- See Note [StaticEnv invariant] in GHC.Core.Op.Simplify.Utils - , sc_dup = OkToDup, sc_cont = cont' }) } - -mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts - , sc_env = se, sc_cont = cont }) - = -- e.g. (case [...hole...] of { pi -> ei }) - -- ===> - -- let ji = \xij -> ei - -- in case [...hole...] of { pi -> ji xij } - -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { tick (CaseOfCase case_bndr) - ; (floats, alt_cont) <- mkDupableCaseCont env alts cont - -- NB: We call mkDupableCaseCont here to make cont duplicable - -- (if necessary, depending on the number of alts) - -- And this is important: see Note [Fusing case continuations] - - ; let alt_env = se `setInScopeFromF` floats - ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr - ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) alts - -- Safe to say that there are no handled-cons for the DEFAULT case - -- NB: simplBinder does not zap deadness occ-info, so - -- a dead case_bndr' will still advertise its deadness - -- This is really important because in - -- case e of b { (# p,q #) -> ... } - -- b is always dead, and indeed we are not allowed to bind b to (# p,q #), - -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. - -- In the new alts we build, we have the new case binder, so it must retain - -- its deadness. - -- NB: we don't use alt_env further; it has the substEnv for - -- the alternatives, and we don't want that - - ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr') - emptyJoinFloats alts' - - ; let all_floats = floats `addJoinFloats` join_floats - -- Note [Duplicated env] - ; return (all_floats - , Select { sc_dup = OkToDup - , sc_bndr = case_bndr' - , sc_alts = alts'' - , sc_env = zapSubstEnv se `setInScopeFromF` all_floats - -- See Note [StaticEnv invariant] in GHC.Core.Op.Simplify.Utils - , sc_cont = mkBoringStop (contResultType cont) } ) } - -mkDupableAlt :: Platform -> OutId - -> JoinFloats -> OutAlt - -> SimplM (JoinFloats, OutAlt) -mkDupableAlt platform case_bndr jfloats (con, bndrs', rhs') - | exprIsDupable platform rhs' -- Note [Small alternative rhs] - = return (jfloats, (con, bndrs', rhs')) - - | otherwise - = do { let rhs_ty' = exprType rhs' - scrut_ty = idType case_bndr - case_bndr_w_unf - = case con of - DEFAULT -> case_bndr - DataAlt dc -> setIdUnfolding case_bndr unf - where - -- See Note [Case binders and join points] - unf = mkInlineUnfolding rhs - rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs' - - LitAlt {} -> WARN( True, text "mkDupableAlt" - <+> ppr case_bndr <+> ppr con ) - case_bndr - -- The case binder is alive but trivial, so why has - -- it not been substituted away? - - final_bndrs' - | isDeadBinder case_bndr = filter abstract_over bndrs' - | otherwise = bndrs' ++ [case_bndr_w_unf] - - abstract_over bndr - | isTyVar bndr = True -- Abstract over all type variables just in case - | otherwise = not (isDeadBinder bndr) - -- The deadness info on the new Ids is preserved by simplBinders - final_args = varsToCoreExprs final_bndrs' - -- Note [Join point abstraction] - - -- We make the lambdas into one-shot-lambdas. The - -- join point is sure to be applied at most once, and doing so - -- prevents the body of the join point being floated out by - -- the full laziness pass - really_final_bndrs = map one_shot final_bndrs' - one_shot v | isId v = setOneShotLambda v - | otherwise = v - join_rhs = mkLams really_final_bndrs rhs' - - ; join_bndr <- newJoinId final_bndrs' rhs_ty' - - ; let join_call = mkApps (Var join_bndr) final_args - alt' = (con, bndrs', join_call) - - ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) - , alt') } - -- See Note [Duplicated env] - -{- -Note [Fusing case continuations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important to fuse two successive case continuations when the -first has one alternative. That's why we call prepareCaseCont here. -Consider this, which arises from thunk splitting (see Note [Thunk -splitting] in GHC.Core.Op.WorkWrap): - - let - x* = case (case v of {pn -> rn}) of - I# a -> I# a - in body - -The simplifier will find - (Var v) with continuation - Select (pn -> rn) ( - Select [I# a -> I# a] ( - StrictBind body Stop - -So we'll call mkDupableCont on - Select [I# a -> I# a] (StrictBind body Stop) -There is just one alternative in the first Select, so we want to -simplify the rhs (I# a) with continuation (StrictBind body Stop) -Supposing that body is big, we end up with - let $j a = - in case v of { pn -> case rn of - I# a -> $j a } -This is just what we want because the rn produces a box that -the case rn cancels with. - -See #4957 a fuller example. - -Note [Case binders and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - case (case .. ) of c { - I# c# -> ....c.... - -If we make a join point with c but not c# we get - $j = \c -> ....c.... - -But if later inlining scrutinises the c, thus - - $j = \c -> ... case c of { I# y -> ... } ... - -we won't see that 'c' has already been scrutinised. This actually -happens in the 'tabulate' function in wave4main, and makes a significant -difference to allocation. - -An alternative plan is this: - - $j = \c# -> let c = I# c# in ...c.... - -but that is bad if 'c' is *not* later scrutinised. - -So instead we do both: we pass 'c' and 'c#' , and record in c's inlining -(a stable unfolding) that it's really I# c#, thus - - $j = \c# -> \c[=I# c#] -> ...c.... - -Absence analysis may later discard 'c'. - -NB: take great care when doing strictness analysis; - see Note [Lambda-bound unfoldings] in GHC.Core.Op.DmdAnal. - -Also note that we can still end up passing stuff that isn't used. Before -strictness analysis we have - let $j x y c{=(x,y)} = (h c, ...) - in ... -After strictness analysis we see that h is strict, we end up with - let $j x y c{=(x,y)} = ($wh x y, ...) -and c is unused. - -Note [Duplicated env] -~~~~~~~~~~~~~~~~~~~~~ -Some of the alternatives are simplified, but have not been turned into a join point -So they *must* have a zapped subst-env. So we can't use completeNonRecX to -bind the join point, because it might to do PostInlineUnconditionally, and -we'd lose that when zapping the subst-env. We could have a per-alt subst-env, -but zapping it (as we do in mkDupableCont, the Select case) is safe, and -at worst delays the join-point inlining. - -Note [Small alternative rhs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is worth checking for a small RHS because otherwise we -get extra let bindings that may cause an extra iteration of the simplifier to -inline back in place. Quite often the rhs is just a variable or constructor. -The Ord instance of Maybe in PrelMaybe.hs, for example, took several extra -iterations because the version with the let bindings looked big, and so wasn't -inlined, but after the join points had been inlined it looked smaller, and so -was inlined. - -NB: we have to check the size of rhs', not rhs. -Duplicating a small InAlt might invalidate occurrence information -However, if it *is* dupable, we return the *un* simplified alternative, -because otherwise we'd need to pair it up with an empty subst-env.... -but we only have one env shared between all the alts. -(Remember we must zap the subst-env before re-simplifying something). -Rather than do this we simply agree to re-simplify the original (small) thing later. - -Note [Funky mkLamTypes] -~~~~~~~~~~~~~~~~~~~~~~ -Notice the funky mkLamTypes. If the constructor has existentials -it's possible that the join point will be abstracted over -type variables as well as term variables. - Example: Suppose we have - data T = forall t. C [t] - Then faced with - case (case e of ...) of - C t xs::[t] -> rhs - We get the join point - let j :: forall t. [t] -> ... - j = /\t \xs::[t] -> rhs - in - case (case e of ...) of - C t xs::[t] -> j t xs - -Note [Duplicating StrictArg] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We make a StrictArg duplicable simply by making all its -stored-up arguments (in sc_fun) trivial, by let-binding -them. Thus: - f E [..hole..] - ==> let a = E - in f a [..hole..] -Now if the thing in the hole is a case expression (which is when -we'll call mkDupableCont), we'll push the function call into the -branches, which is what we want. Now RULES for f may fire, and -call-pattern specialisation. Here's an example from #3116 - go (n+1) (case l of - 1 -> bs' - _ -> Chunk p fpc (o+1) (l-1) bs') -If we can push the call for 'go' inside the case, we get -call-pattern specialisation for 'go', which is *crucial* for -this program. - -Here is the (&&) example: - && E (case x of { T -> F; F -> T }) - ==> let a = E in - case x of { T -> && a F; F -> && a T } -Much better! - -Notice that - * Arguments to f *after* the strict one are handled by - the ApplyToVal case of mkDupableCont. Eg - f [..hole..] E - - * We can only do the let-binding of E because the function - part of a StrictArg continuation is an explicit syntax - tree. In earlier versions we represented it as a function - (CoreExpr -> CoreEpxr) which we couldn't take apart. - -Historical aide: previously we did this (where E is a -big argument: - f E [..hole..] - ==> let $j = \a -> f E a - in $j [..hole..] - -But this is terrible! Here's an example: - && E (case x of { T -> F; F -> T }) -Now, && is strict so we end up simplifying the case with -an ArgOf continuation. If we let-bind it, we get - let $j = \v -> && E v - in simplExpr (case x of { T -> F; F -> T }) - (ArgOf (\r -> $j r) -And after simplifying more we get - let $j = \v -> && E v - in case x of { T -> $j F; F -> $j T } -Which is a Very Bad Thing - - -Note [Duplicating StrictBind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We make a StrictBind duplicable in a very similar way to -that for case expressions. After all, - let x* = e in b is similar to case e of x -> b - -So we potentially make a join-point for the body, thus: - let x = [] in b ==> join j x = b - in let x = [] in j x - - -Note [Join point abstraction] Historical note -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: This note is now historical, describing how (in the past) we used -to add a void argument to nullary join points. But now that "join -point" is not a fuzzy concept but a formal syntactic construct (as -distinguished by the JoinId constructor of IdDetails), each of these -concerns is handled separately, with no need for a vestigial extra -argument. - -Join points always have at least one value argument, -for several reasons - -* If we try to lift a primitive-typed something out - for let-binding-purposes, we will *caseify* it (!), - with potentially-disastrous strictness results. So - instead we turn it into a function: \v -> e - where v::Void#. The value passed to this function is void, - which generates (almost) no code. - -* CPR. We used to say "&& isUnliftedType rhs_ty'" here, but now - we make the join point into a function whenever used_bndrs' - is empty. This makes the join-point more CPR friendly. - Consider: let j = if .. then I# 3 else I# 4 - in case .. of { A -> j; B -> j; C -> ... } - - Now CPR doesn't w/w j because it's a thunk, so - that means that the enclosing function can't w/w either, - which is a lose. Here's the example that happened in practice: - kgmod :: Int -> Int -> Int - kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 - then 78 - else 5 - -* Let-no-escape. We want a join point to turn into a let-no-escape - so that it is implemented as a jump, and one of the conditions - for LNE is that it's not updatable. In CoreToStg, see - Note [What is a non-escaping let] - -* Floating. Since a join point will be entered once, no sharing is - gained by floating out, but something might be lost by doing - so because it might be allocated. - -I have seen a case alternative like this: - True -> \v -> ... -It's a bit silly to add the realWorld dummy arg in this case, making - $j = \s v -> ... - True -> $j s -(the \v alone is enough to make CPR happy) but I think it's rare - -There's a slight infelicity here: we pass the overall -case_bndr to all the join points if it's used in *any* RHS, -because we don't know its usage in each RHS separately - - - -************************************************************************ -* * - Unfoldings -* * -************************************************************************ --} - -simplLetUnfolding :: SimplEnv-> TopLevelFlag - -> MaybeJoinCont - -> InId - -> OutExpr -> OutType - -> Unfolding -> SimplM Unfolding -simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty unf - | isStableUnfolding unf - = simplStableUnfolding env top_lvl cont_mb id unf rhs_ty - | isExitJoinId id - = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Op.Exitify - | otherwise - = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs - -------------------- -mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource - -> InId -> OutExpr -> SimplM Unfolding -mkLetUnfolding dflags top_lvl src id new_rhs - = is_bottoming `seq` -- See Note [Force bottoming field] - return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs) - -- We make an unfolding *even for loop-breakers*. - -- Reason: (a) It might be useful to know that they are WHNF - -- (b) In GHC.Iface.Tidy we currently assume that, if we want to - -- expose the unfolding then indeed we *have* an unfolding - -- to expose. (We could instead use the RHS, but currently - -- we don't.) The simple thing is always to have one. - where - is_top_lvl = isTopLevel top_lvl - is_bottoming = isBottomingId id - -------------------- -simplStableUnfolding :: SimplEnv -> TopLevelFlag - -> MaybeJoinCont -- Just k => a join point with continuation k - -> InId - -> Unfolding -> OutType -> SimplM Unfolding --- Note [Setting the new unfolding] -simplStableUnfolding env top_lvl mb_cont id unf rhs_ty - = case unf of - NoUnfolding -> return unf - BootUnfolding -> return unf - OtherCon {} -> return unf - - DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args } - -> do { (env', bndrs') <- simplBinders unf_env bndrs - ; args' <- mapM (simplExpr env') args - ; return (mkDFunUnfolding bndrs' con args') } - - CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide } - | isStableSource src - -> do { expr' <- case mb_cont of -- See Note [Rules and unfolding for join points] - Just cont -> simplJoinRhs unf_env id expr cont - Nothing -> simplExprC unf_env expr (mkBoringStop rhs_ty) - ; case guide of - UnfWhen { ug_arity = arity - , ug_unsat_ok = sat_ok - , ug_boring_ok = boring_ok - } - -- Happens for INLINE things - -> let guide' = - UnfWhen { ug_arity = arity - , ug_unsat_ok = sat_ok - , ug_boring_ok = - boring_ok || inlineBoringOk expr' - } - -- Refresh the boring-ok flag, in case expr' - -- has got small. This happens, notably in the inlinings - -- for dfuns for single-method classes; see - -- Note [Single-method classes] in TcInstDcls. - -- A test case is #4138 - -- But retain a previous boring_ok of True; e.g. see - -- the way it is set in calcUnfoldingGuidanceWithArity - in return (mkCoreUnfolding src is_top_lvl expr' guide') - -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold - - _other -- Happens for INLINABLE things - -> mkLetUnfolding dflags top_lvl src id expr' } - -- If the guidance is UnfIfGoodArgs, this is an INLINABLE - -- unfolding, and we need to make sure the guidance is kept up - -- to date with respect to any changes in the unfolding. - - | otherwise -> return noUnfolding -- Discard unstable unfoldings - where - dflags = seDynFlags env - is_top_lvl = isTopLevel top_lvl - act = idInlineActivation id - unf_env = updMode (updModeForStableUnfoldings act) env - -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Op.Simplify.Utils - -{- -Note [Force bottoming field] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to force bottoming, or the new unfolding holds -on to the old unfolding (which is part of the id). - -Note [Setting the new unfolding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* If there's an INLINE pragma, we simplify the RHS gently. Maybe we - should do nothing at all, but simplifying gently might get rid of - more crap. - -* If not, we make an unfolding from the new RHS. But *only* for - non-loop-breakers. Making loop breakers not have an unfolding at all - means that we can avoid tests in exprIsConApp, for example. This is - important: if exprIsConApp says 'yes' for a recursive thing, then we - can get into an infinite loop - -If there's a stable unfolding on a loop breaker (which happens for -INLINABLE), we hang on to the inlining. It's pretty dodgy, but the -user did say 'INLINE'. May need to revisit this choice. - -************************************************************************ -* * - Rules -* * -************************************************************************ - -Note [Rules in a letrec] -~~~~~~~~~~~~~~~~~~~~~~~~ -After creating fresh binders for the binders of a letrec, we -substitute the RULES and add them back onto the binders; this is done -*before* processing any of the RHSs. This is important. Manuel found -cases where he really, really wanted a RULE for a recursive function -to apply in that function's own right-hand side. - -See Note [Forming Rec groups] in OccurAnal --} - -addBndrRules :: SimplEnv -> InBndr -> OutBndr - -> MaybeJoinCont -- Just k for a join point binder - -- Nothing otherwise - -> SimplM (SimplEnv, OutBndr) --- Rules are added back into the bin -addBndrRules env in_id out_id mb_cont - | null old_rules - = return (env, out_id) - | otherwise - = do { new_rules <- simplRules env (Just out_id) old_rules mb_cont - ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules - ; return (modifyInScope env final_id, final_id) } - where - old_rules = ruleInfoRules (idSpecialisation in_id) - -simplRules :: SimplEnv -> Maybe OutId -> [CoreRule] - -> MaybeJoinCont -> SimplM [CoreRule] -simplRules env mb_new_id rules mb_cont - = mapM simpl_rule rules - where - simpl_rule rule@(BuiltinRule {}) - = return rule - - simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args - , ru_fn = fn_name, ru_rhs = rhs }) - = do { (env', bndrs') <- simplBinders env bndrs - ; let rhs_ty = substTy env' (exprType rhs) - rhs_cont = case mb_cont of -- See Note [Rules and unfolding for join points] - Nothing -> mkBoringStop rhs_ty - Just cont -> ASSERT2( join_ok, bad_join_msg ) - cont - rule_env = updMode updModeForRules env' - fn_name' = case mb_new_id of - Just id -> idName id - Nothing -> fn_name - - -- join_ok is an assertion check that the join-arity of the - -- binder matches that of the rule, so that pushing the - -- continuation into the RHS makes sense - join_ok = case mb_new_id of - Just id | Just join_arity <- isJoinId_maybe id - -> length args == join_arity - _ -> False - bad_join_msg = vcat [ ppr mb_new_id, ppr rule - , ppr (fmap isJoinId_maybe mb_new_id) ] - - ; args' <- mapM (simplExpr rule_env) args - ; rhs' <- simplExprC rule_env rhs rhs_cont - ; return (rule { ru_bndrs = bndrs' - , ru_fn = fn_name' - , ru_args = args' - , ru_rhs = rhs' }) } diff --git a/compiler/GHC/Core/Op/Simplify/Driver.hs b/compiler/GHC/Core/Op/Simplify/Driver.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/Simplify/Driver.hs +++ /dev/null @@ -1,1037 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[SimplCore]{Driver for simplifying @Core@ programs} --} - -{-# LANGUAGE CPP #-} - -module GHC.Core.Op.Simplify.Driver ( core2core, simplifyExpr ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Driver.Session -import GHC.Core -import GHC.Driver.Types -import GHC.Core.Op.CSE ( cseProgram ) -import GHC.Core.Rules ( mkRuleBase, unionRuleBase, - extendRuleBaseList, ruleCheckProgram, addRuleInfo, - getRules ) -import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) -import GHC.Core.Op.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) -import GHC.Types.Id.Info -import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) -import GHC.Core.Utils ( mkTicks, stripTicksTop ) -import GHC.Core.Lint ( endPass, lintPassResult, dumpPassResult, - lintAnnots ) -import GHC.Core.Op.Simplify ( simplTopBinds, simplExpr, simplRules ) -import GHC.Core.Op.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding ) -import GHC.Core.Op.Simplify.Env -import GHC.Core.Op.Simplify.Monad -import GHC.Core.Op.Monad -import qualified ErrUtils as Err -import GHC.Core.Op.FloatIn ( floatInwards ) -import GHC.Core.Op.FloatOut ( floatOutwards ) -import GHC.Core.FamInstEnv -import GHC.Types.Id -import ErrUtils ( withTiming, withTimingD, DumpFormat (..) ) -import GHC.Types.Basic ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma ) -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Core.Op.LiberateCase ( liberateCase ) -import GHC.Core.Op.StaticArgs ( doStaticArgs ) -import GHC.Core.Op.Specialise ( specProgram) -import GHC.Core.Op.SpecConstr ( specConstrProgram) -import GHC.Core.Op.DmdAnal ( dmdAnalProgram ) -import GHC.Core.Op.CprAnal ( cprAnalProgram ) -import GHC.Core.Op.CallArity ( callArityAnalProgram ) -import GHC.Core.Op.Exitify ( exitifyProgram ) -import GHC.Core.Op.WorkWrap ( wwTopBinds ) -import GHC.Types.SrcLoc -import Util -import GHC.Types.Module -import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) -import GHC.Runtime.Loader -- ( initializePlugins ) - -import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) -import GHC.Types.Unique.FM -import Outputable -import Control.Monad -import qualified GHC.LanguageExtensions as LangExt -{- -************************************************************************ -* * -\subsection{The driver for the simplifier} -* * -************************************************************************ --} - -core2core :: HscEnv -> ModGuts -> IO ModGuts -core2core hsc_env guts@(ModGuts { mg_module = mod - , mg_loc = loc - , mg_deps = deps - , mg_rdr_env = rdr_env }) - = do { -- make sure all plugins are loaded - - ; let builtin_passes = getCoreToDo dflags - orph_mods = mkModuleSet (mod : dep_orphs deps) - uniq_mask = 's' - ; - ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod - orph_mods print_unqual loc $ - do { hsc_env' <- getHscEnv - ; dflags' <- liftIO $ initializePlugins hsc_env' - (hsc_dflags hsc_env') - ; all_passes <- withPlugins dflags' - installCoreToDos - builtin_passes - ; runCorePasses all_passes guts } - - ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats - "Grand total simplifier statistics" - FormatText - (pprSimplCount stats) - - ; return guts2 } - where - dflags = hsc_dflags hsc_env - home_pkg_rules = hptRules hsc_env (dep_mods deps) - hpt_rule_base = mkRuleBase home_pkg_rules - print_unqual = mkPrintUnqualified dflags rdr_env - -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. - -- This is very convienent for the users of the monad (e.g. plugins do not have to - -- consume the ModGuts to find the module) but somewhat ugly because mg_module may - -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which - -- would mean our cached value would go out of date. - -{- -************************************************************************ -* * - Generating the main optimisation pipeline -* * -************************************************************************ --} - -getCoreToDo :: DynFlags -> [CoreToDo] -getCoreToDo dflags - = flatten_todos core_todo - where - opt_level = optLevel dflags - phases = simplPhases dflags - max_iter = maxSimplIterations dflags - rule_check = ruleCheck dflags - call_arity = gopt Opt_CallArity dflags - exitification = gopt Opt_Exitification dflags - strictness = gopt Opt_Strictness dflags - full_laziness = gopt Opt_FullLaziness dflags - do_specialise = gopt Opt_Specialise dflags - do_float_in = gopt Opt_FloatIn dflags - cse = gopt Opt_CSE dflags - spec_constr = gopt Opt_SpecConstr dflags - liberate_case = gopt Opt_LiberateCase dflags - late_dmd_anal = gopt Opt_LateDmdAnal dflags - late_specialise = gopt Opt_LateSpecialise dflags - static_args = gopt Opt_StaticArgumentTransformation dflags - rules_on = gopt Opt_EnableRewriteRules dflags - eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags - ww_on = gopt Opt_WorkerWrapper dflags - static_ptrs = xopt LangExt.StaticPointers dflags - - maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) - - maybe_strictness_before phase - = runWhen (phase `elem` strictnessBefore dflags) CoreDoDemand - - base_mode = SimplMode { sm_phase = panic "base_mode" - , sm_names = [] - , sm_dflags = dflags - , sm_rules = rules_on - , sm_eta_expand = eta_expand_on - , sm_inline = True - , sm_case_case = True } - - simpl_phase phase names iter - = CoreDoPasses - $ [ maybe_strictness_before phase - , CoreDoSimplify iter - (base_mode { sm_phase = Phase phase - , sm_names = names }) - - , maybe_rule_check (Phase phase) ] - - simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter - | phase <- [phases, phases-1 .. 1] ] - - - -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently = CoreDoSimplify max_iter - (base_mode { sm_phase = InitialPhase - , sm_names = ["Gentle"] - , sm_rules = rules_on -- Note [RULEs enabled in InitialPhase] - , sm_inline = True - -- See Note [Inline in InitialPhase] - , sm_case_case = False }) - -- Don't do case-of-case transformations. - -- This makes full laziness work better - - dmd_cpr_ww = if ww_on then [CoreDoDemand,CoreDoCpr,CoreDoWorkerWrapper] - else [CoreDoDemand,CoreDoCpr] - - - demand_analyser = (CoreDoPasses ( - dmd_cpr_ww ++ - [simpl_phase 0 ["post-worker-wrapper"] max_iter] - )) - - -- Static forms are moved to the top level with the FloatOut pass. - -- See Note [Grand plan for static forms] in StaticPtrTable. - static_ptrs_float_outwards = - runWhen static_ptrs $ CoreDoPasses - [ simpl_gently -- Float Out can't handle type lets (sometimes created - -- by simpleOptPgm via mkParallelBindings) - , CoreDoFloatOutwards FloatOutSwitches - { floatOutLambdas = Just 0 - , floatOutConstants = True - , floatOutOverSatApps = False - , floatToTopLevelOnly = True - } - ] - - core_todo = - if opt_level == 0 then - [ static_ptrs_float_outwards, - CoreDoSimplify max_iter - (base_mode { sm_phase = Phase 0 - , sm_names = ["Non-opt simplification"] }) - ] - - else {- opt_level >= 1 -} [ - - -- We want to do the static argument transform before full laziness as it - -- may expose extra opportunities to float things outwards. However, to fix - -- up the output of the transformation we need at do at least one simplify - -- after this before anything else - runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), - - -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently, - - -- Specialisation is best done before full laziness - -- so that overloaded functions have all their dictionary lambdas manifest - runWhen do_specialise CoreDoSpecialising, - - if full_laziness then - CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = Just 0, - floatOutConstants = True, - floatOutOverSatApps = False, - floatToTopLevelOnly = False } - -- Was: gentleFloatOutSwitches - -- - -- I have no idea why, but not floating constants to - -- top level is very bad in some cases. - -- - -- Notably: p_ident in spectral/rewrite - -- Changing from "gentle" to "constantsOnly" - -- improved rewrite's allocation by 19%, and - -- made 0.0% difference to any other nofib - -- benchmark - -- - -- Not doing floatOutOverSatApps yet, we'll do - -- that later on when we've had a chance to get more - -- accurate arity information. In fact it makes no - -- difference at all to performance if we do it here, - -- but maybe we save some unnecessary to-and-fro in - -- the simplifier. - else - -- Even with full laziness turned off, we still need to float static - -- forms to the top level. See Note [Grand plan for static forms] in - -- StaticPtrTable. - static_ptrs_float_outwards, - - simpl_phases, - - -- Phase 0: allow all Ids to be inlined now - -- This gets foldr inlined before strictness analysis - - -- At least 3 iterations because otherwise we land up with - -- huge dead expressions because of an infelicity in the - -- simplifier. - -- let k = BIG in foldr k z xs - -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs - -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs - -- Don't stop now! - simpl_phase 0 ["main"] (max max_iter 3), - - runWhen do_float_in CoreDoFloatInwards, - -- Run float-inwards immediately before the strictness analyser - -- Doing so pushes bindings nearer their use site and hence makes - -- them more likely to be strict. These bindings might only show - -- up after the inlining from simplification. Example in fulsom, - -- Csg.calc, where an arg of timesDouble thereby becomes strict. - - runWhen call_arity $ CoreDoPasses - [ CoreDoCallArity - , simpl_phase 0 ["post-call-arity"] max_iter - ], - - runWhen strictness demand_analyser, - - runWhen exitification CoreDoExitify, - -- See note [Placement of the exitification pass] - - runWhen full_laziness $ - CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = floatLamArgs dflags, - floatOutConstants = True, - floatOutOverSatApps = True, - floatToTopLevelOnly = False }, - -- nofib/spectral/hartel/wang doubles in speed if you - -- do full laziness late in the day. It only happens - -- after fusion and other stuff, so the early pass doesn't - -- catch it. For the record, the redex is - -- f_el22 (f_el21 r_midblock) - - - runWhen cse CoreCSE, - -- We want CSE to follow the final full-laziness pass, because it may - -- succeed in commoning up things floated out by full laziness. - -- CSE used to rely on the no-shadowing invariant, but it doesn't any more - - runWhen do_float_in CoreDoFloatInwards, - - maybe_rule_check (Phase 0), - - -- Case-liberation for -O2. This should be after - -- strictness analysis and the simplification which follows it. - runWhen liberate_case (CoreDoPasses [ - CoreLiberateCase, - simpl_phase 0 ["post-liberate-case"] max_iter - ]), -- Run the simplifier after LiberateCase to vastly - -- reduce the possibility of shadowing - -- Reason: see Note [Shadowing] in GHC.Core.Op.SpecConstr - - runWhen spec_constr CoreDoSpecConstr, - - maybe_rule_check (Phase 0), - - runWhen late_specialise - (CoreDoPasses [ CoreDoSpecialising - , simpl_phase 0 ["post-late-spec"] max_iter]), - - -- LiberateCase can yield new CSE opportunities because it peels - -- off one layer of a recursive function (concretely, I saw this - -- in wheel-sieve1), and I'm guessing that SpecConstr can too - -- And CSE is a very cheap pass. So it seems worth doing here. - runWhen ((liberate_case || spec_constr) && cse) CoreCSE, - - -- Final clean-up simplification: - simpl_phase 0 ["final"] max_iter, - - runWhen late_dmd_anal $ CoreDoPasses ( - dmd_cpr_ww ++ - [simpl_phase 0 ["post-late-ww"] max_iter] - ), - - -- Final run of the demand_analyser, ensures that one-shot thunks are - -- really really one-shot thunks. Only needed if the demand analyser - -- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Op.DmdAnal - -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution - -- can become /exponentially/ more expensive. See #11731, #12996. - runWhen (strictness || late_dmd_anal) CoreDoDemand, - - maybe_rule_check (Phase 0) - ] - - -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity. - flatten_todos [] = [] - flatten_todos (CoreDoNothing : rest) = flatten_todos rest - flatten_todos (CoreDoPasses passes : rest) = - flatten_todos passes ++ flatten_todos rest - flatten_todos (todo : rest) = todo : flatten_todos rest - -{- Note [Inline in InitialPhase] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is -confusing for users because when they say INLINE they expect the function to inline -right away. - -So now we do inlining immediately, even in the InitialPhase, assuming that the -Id's Activation allows it. - -This is a surprisingly big deal. Compiler performance improved a lot -when I made this change: - - perf/compiler/T5837.run T5837 [stat too good] (normal) - perf/compiler/parsing001.run parsing001 [stat too good] (normal) - perf/compiler/T12234.run T12234 [stat too good] (optasm) - perf/compiler/T9020.run T9020 [stat too good] (optasm) - perf/compiler/T3064.run T3064 [stat too good] (normal) - perf/compiler/T9961.run T9961 [stat too good] (normal) - perf/compiler/T13056.run T13056 [stat too good] (optasm) - perf/compiler/T9872d.run T9872d [stat too good] (normal) - perf/compiler/T783.run T783 [stat too good] (normal) - perf/compiler/T12227.run T12227 [stat too good] (normal) - perf/should_run/lazy-bs-alloc.run lazy-bs-alloc [stat too good] (normal) - perf/compiler/T1969.run T1969 [stat too good] (normal) - perf/compiler/T9872a.run T9872a [stat too good] (normal) - perf/compiler/T9872c.run T9872c [stat too good] (normal) - perf/compiler/T9872b.run T9872b [stat too good] (normal) - perf/compiler/T9872d.run T9872d [stat too good] (normal) - -Note [RULEs enabled in InitialPhase] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -RULES are enabled when doing "gentle" simplification in InitialPhase, -or with -O0. Two reasons: - - * We really want the class-op cancellation to happen: - op (df d1 d2) --> $cop3 d1 d2 - because this breaks the mutual recursion between 'op' and 'df' - - * I wanted the RULE - lift String ===> ... - to work in Template Haskell when simplifying - splices, so we get simpler code for literal strings - -But watch out: list fusion can prevent floating. So use phase control -to switch off those rules until after floating. - -************************************************************************ -* * - The CoreToDo interpreter -* * -************************************************************************ --} - -runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts -runCorePasses passes guts - = foldM do_pass guts passes - where - do_pass guts CoreDoNothing = return guts - do_pass guts (CoreDoPasses ps) = runCorePasses ps guts - do_pass guts pass = do - withTimingD (ppr pass <+> brackets (ppr mod)) - (const ()) $ do - { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts - ; endPass pass (mg_binds guts') (mg_rules guts') - ; return guts' } - - mod = mg_module guts - -doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts -doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} - simplifyPgm pass - -doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} - doPass cseProgram - -doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} - doPassD liberateCase - -doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} - floatInwards - -doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} - doPassDUM (floatOutwards f) - -doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} - doPassU doStaticArgs - -doCorePass CoreDoCallArity = {-# SCC "CallArity" #-} - doPassD callArityAnalProgram - -doCorePass CoreDoExitify = {-# SCC "Exitify" #-} - doPass exitifyProgram - -doCorePass CoreDoDemand = {-# SCC "DmdAnal" #-} - doPassDFM dmdAnalProgram - -doCorePass CoreDoCpr = {-# SCC "CprAnal" #-} - doPassDFM cprAnalProgram - -doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} - doPassDFU wwTopBinds - -doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} - specProgram - -doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} - specConstrProgram - -doCorePass CoreDoPrintCore = observe printCore -doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat -doCorePass CoreDoNothing = return -doCorePass (CoreDoPasses passes) = runCorePasses passes - -doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass - -doCorePass pass@CoreDesugar = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CoreDesugarOpt = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CoreTidy = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CorePrep = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CoreOccurAnal = pprPanic "doCorePass" (ppr pass) - -{- -************************************************************************ -* * -\subsection{Core pass combinators} -* * -************************************************************************ --} - -printCore :: DynFlags -> CoreProgram -> IO () -printCore dflags binds - = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds) - -ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts -ruleCheckPass current_phase pat guts = - withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) - (const ()) $ do - { rb <- getRuleBase - ; dflags <- getDynFlags - ; vis_orphs <- getVisibleOrphanMods - ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn - ++ (mg_rules guts) - ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan - (defaultDumpStyle dflags) - (ruleCheckProgram current_phase pat - rule_fn (mg_binds guts)) - ; return guts } - -doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDUM do_pass = doPassM $ \binds -> do - dflags <- getDynFlags - us <- getUniqueSupplyM - liftIO $ do_pass dflags us binds - -doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags)) - -doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags) - -doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us) - -doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassU do_pass = doPassDU (const do_pass) - -doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDFM do_pass guts = do - dflags <- getDynFlags - p_fam_env <- getPackageFamInstEnv - let fam_envs = (p_fam_env, mg_fam_inst_env guts) - doPassM (liftIO . do_pass dflags fam_envs) guts - -doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDFU do_pass guts = do - dflags <- getDynFlags - us <- getUniqueSupplyM - p_fam_env <- getPackageFamInstEnv - let fam_envs = (p_fam_env, mg_fam_inst_env guts) - doPass (do_pass dflags fam_envs us) guts - --- Most passes return no stats and don't change rules: these combinators --- let us lift them to the full blown ModGuts+CoreM world -doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts -doPassM bind_f guts = do - binds' <- bind_f (mg_binds guts) - return (guts { mg_binds = binds' }) - -doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) } - --- Observer passes just peek; don't modify the bindings at all -observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts -observe do_pass = doPassM $ \binds -> do - dflags <- getDynFlags - _ <- liftIO $ do_pass dflags binds - return binds - -{- -************************************************************************ -* * - Gentle simplification -* * -************************************************************************ --} - -simplifyExpr :: HscEnv -- includes spec of what core-to-core passes to do - -> CoreExpr - -> IO CoreExpr --- simplifyExpr is called by the driver to simplify an --- expression typed in at the interactive prompt -simplifyExpr hsc_env expr - = withTiming dflags (text "Simplify [expr]") (const ()) $ - do { eps <- hscEPS hsc_env ; - ; let rule_env = mkRuleEnv (eps_rule_base eps) [] - fi_env = ( eps_fam_inst_env eps - , extendFamInstEnvList emptyFamInstEnv $ - snd $ ic_instances $ hsc_IC hsc_env ) - simpl_env = simplEnvForGHCi dflags - - ; us <- mkSplitUniqSupply 's' - ; let sz = exprSize expr - - ; (expr', counts) <- initSmpl dflags rule_env fi_env us sz $ - simplExprGently simpl_env expr - - ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags) - "Simplifier statistics" (pprSimplCount counts) - - ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" - FormatCore - (pprCoreExpr expr') - - ; return expr' - } - where - dflags = hsc_dflags hsc_env - -simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr --- Simplifies an expression --- does occurrence analysis, then simplification --- and repeats (twice currently) because one pass --- alone leaves tons of crud. --- Used (a) for user expressions typed in at the interactive prompt --- (b) the LHS and RHS of a RULE --- (c) Template Haskell splices --- --- The name 'Gently' suggests that the SimplMode is InitialPhase, --- and in fact that is so.... but the 'Gently' in simplExprGently doesn't --- enforce that; it just simplifies the expression twice - --- It's important that simplExprGently does eta reduction; see --- Note [Simplifying the left-hand side of a RULE] above. The --- simplifier does indeed do eta reduction (it's in GHC.Core.Op.Simplify.completeLam) --- but only if -O is on. - -simplExprGently env expr = do - expr1 <- simplExpr env (occurAnalyseExpr expr) - simplExpr env (occurAnalyseExpr expr1) - -{- -************************************************************************ -* * -\subsection{The driver for the simplifier} -* * -************************************************************************ --} - -simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts -simplifyPgm pass guts - = do { hsc_env <- getHscEnv - ; us <- getUniqueSupplyM - ; rb <- getRuleBase - ; liftIOWithCount $ - simplifyPgmIO pass hsc_env us rb guts } - -simplifyPgmIO :: CoreToDo - -> HscEnv - -> UniqSupply - -> RuleBase - -> ModGuts - -> IO (SimplCount, ModGuts) -- New bindings - -simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) - hsc_env us hpt_rule_base - guts@(ModGuts { mg_module = this_mod - , mg_rdr_env = rdr_env - , mg_deps = deps - , mg_binds = binds, mg_rules = rules - , mg_fam_inst_env = fam_inst_env }) - = do { (termination_msg, it_count, counts_out, guts') - <- do_iteration us 1 [] binds rules - - ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags && - dopt Opt_D_dump_simpl_stats dflags) - "Simplifier statistics for following pass" - (vcat [text termination_msg <+> text "after" <+> ppr it_count - <+> text "iterations", - blankLine, - pprSimplCount counts_out]) - - ; return (counts_out, guts') - } - where - dflags = hsc_dflags hsc_env - print_unqual = mkPrintUnqualified dflags rdr_env - simpl_env = mkSimplEnv mode - active_rule = activeRule mode - active_unf = activeUnfolding mode - - do_iteration :: UniqSupply - -> Int -- Counts iterations - -> [SimplCount] -- Counts from earlier iterations, reversed - -> CoreProgram -- Bindings in - -> [CoreRule] -- and orphan rules - -> IO (String, Int, SimplCount, ModGuts) - - do_iteration us iteration_no counts_so_far binds rules - -- iteration_no is the number of the iteration we are - -- about to begin, with '1' for the first - | iteration_no > max_iterations -- Stop if we've run out of iterations - = WARN( debugIsOn && (max_iterations > 2) - , hang (text "Simplifier bailing out after" <+> int max_iterations - <+> text "iterations" - <+> (brackets $ hsep $ punctuate comma $ - map (int . simplCountN) (reverse counts_so_far))) - 2 (text "Size =" <+> ppr (coreBindsStats binds))) - - -- Subtract 1 from iteration_no to get the - -- number of iterations we actually completed - return ( "Simplifier baled out", iteration_no - 1 - , totalise counts_so_far - , guts { mg_binds = binds, mg_rules = rules } ) - - -- Try and force thunks off the binds; significantly reduces - -- space usage, especially with -O. JRS, 000620. - | let sz = coreBindsSize binds - , () <- sz `seq` () -- Force it - = do { - -- Occurrence analysis - let { tagged_binds = {-# SCC "OccAnal" #-} - occurAnalysePgm this_mod active_unf active_rule rules - binds - } ; - Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" - FormatCore - (pprCoreBindings tagged_binds); - - -- Get any new rules, and extend the rule base - -- See Note [Overall plumbing for rules] in GHC.Core.Rules - -- We need to do this regularly, because simplification can - -- poke on IdInfo thunks, which in turn brings in new rules - -- behind the scenes. Otherwise there's a danger we'll simply - -- miss the rules for Ids hidden inside imported inlinings - eps <- hscEPS hsc_env ; - let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps) - ; rule_base2 = extendRuleBaseList rule_base1 rules - ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) - ; vis_orphs = this_mod : dep_orphs deps } ; - - -- Simplify the program - ((binds1, rules1), counts1) <- - initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $ - do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} - simplTopBinds simpl_env tagged_binds - - -- Apply the substitution to rules defined in this module - -- for imported Ids. Eg RULE map my_f = blah - -- If we have a substitution my_f :-> other_f, we'd better - -- apply it to the rule to, or it'll never match - ; rules1 <- simplRules env1 Nothing rules Nothing - - ; return (getTopFloatBinds floats, rules1) } ; - - -- Stop if nothing happened; don't dump output - -- See Note [Which transformations are innocuous] in GHC.Core.Op.Monad - if isZeroSimplCount counts1 then - return ( "Simplifier reached fixed point", iteration_no - , totalise (counts1 : counts_so_far) -- Include "free" ticks - , guts { mg_binds = binds1, mg_rules = rules1 } ) - else do { - -- Short out indirections - -- We do this *after* at least one run of the simplifier - -- because indirection-shorting uses the export flag on *occurrences* - -- and that isn't guaranteed to be ok until after the first run propagates - -- stuff from the binding site to its occurrences - -- - -- ToDo: alas, this means that indirection-shorting does not happen at all - -- if the simplifier does nothing (not common, I know, but unsavoury) - let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; - - -- Dump the result of this iteration - dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ; - lintPassResult hsc_env pass binds2 ; - - -- Loop - do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 - } } -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = panic "do_iteration" -#endif - where - (us1, us2) = splitUniqSupply us - - -- Remember the counts_so_far are reversed - totalise :: [SimplCount] -> SimplCount - totalise = foldr (\c acc -> acc `plusSimplCount` c) - (zeroSimplCount dflags) - -simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO" - -------------------- -dump_end_iteration :: DynFlags -> PrintUnqualified -> Int - -> SimplCount -> CoreProgram -> [CoreRule] -> IO () -dump_end_iteration dflags print_unqual iteration_no counts binds rules - = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules - where - mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations - | otherwise = Nothing - -- Show details if Opt_D_dump_simpl_iterations is on - - hdr = text "Simplifier iteration=" <> int iteration_no - pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr - , pprSimplCount counts - , text "---- End of simplifier counts for" <+> hdr ] - -{- -************************************************************************ -* * - Shorting out indirections -* * -************************************************************************ - -If we have this: - - x_local = - ...bindings... - x_exported = x_local - -where x_exported is exported, and x_local is not, then we replace it with this: - - x_exported = - x_local = x_exported - ...bindings... - -Without this we never get rid of the x_exported = x_local thing. This -save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and -makes strictness information propagate better. This used to happen in -the final phase, but it's tidier to do it here. - -Note [Messing up the exported Id's RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must be careful about discarding (obviously) or even merging the -RULES on the exported Id. The example that went bad on me at one stage -was this one: - - iterate :: (a -> a) -> a -> [a] - [Exported] - iterate = iterateList - - iterateFB c f x = x `c` iterateFB c f (f x) - iterateList f x = x : iterateList f (f x) - [Not exported] - - {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterateList - #-} - -This got shorted out to: - - iterateList :: (a -> a) -> a -> [a] - iterateList = iterate - - iterateFB c f x = x `c` iterateFB c f (f x) - iterate f x = x : iterate f (f x) - - {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterate - #-} - -And now we get an infinite loop in the rule system - iterate f x -> build (\cn -> iterateFB c f x) - -> iterateFB (:) f x - -> iterate f x - -Old "solution": - use rule switching-off pragmas to get rid - of iterateList in the first place - -But in principle the user *might* want rules that only apply to the Id -he says. And inline pragmas are similar - {-# NOINLINE f #-} - f = local - local = -Then we do not want to get rid of the NOINLINE. - -Hence hasShortableIdinfo. - - -Note [Rules and indirection-zapping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Problem: what if x_exported has a RULE that mentions something in ...bindings...? -Then the things mentioned can be out of scope! Solution - a) Make sure that in this pass the usage-info from x_exported is - available for ...bindings... - b) If there are any such RULES, rec-ify the entire top-level. - It'll get sorted out next time round - -Other remarks -~~~~~~~~~~~~~ -If more than one exported thing is equal to a local thing (i.e., the -local thing really is shared), then we do one only: -\begin{verbatim} - x_local = .... - x_exported1 = x_local - x_exported2 = x_local -==> - x_exported1 = .... - - x_exported2 = x_exported1 -\end{verbatim} - -We rely on prior eta reduction to simplify things like -\begin{verbatim} - x_exported = /\ tyvars -> x_local tyvars -==> - x_exported = x_local -\end{verbatim} -Hence,there's a possibility of leaving unchanged something like this: -\begin{verbatim} - x_local = .... - x_exported1 = x_local Int -\end{verbatim} -By the time we've thrown away the types in STG land this -could be eliminated. But I don't think it's very common -and it's dangerous to do this fiddling in STG land -because we might eliminate a binding that's mentioned in the -unfolding for something. - -Note [Indirection zapping and ticks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unfortunately this is another place where we need a special case for -ticks. The following happens quite regularly: - - x_local = - x_exported = tick x_local - -Which we want to become: - - x_exported = tick - -As it makes no sense to keep the tick and the expression on separate -bindings. Note however that that this might increase the ticks scoping -over the execution of x_local, so we can only do this for floatable -ticks. More often than not, other references will be unfoldings of -x_exported, and therefore carry the tick anyway. --} - -type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks - -shortOutIndirections :: CoreProgram -> CoreProgram -shortOutIndirections binds - | isEmptyVarEnv ind_env = binds - | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping] - | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff - where - ind_env = makeIndEnv binds - -- These exported Ids are the subjects of the indirection-elimination - exp_ids = map fst $ nonDetEltsUFM ind_env - -- It's OK to use nonDetEltsUFM here because we forget the ordering - -- by immediately converting to a set or check if all the elements - -- satisfy a predicate. - exp_id_set = mkVarSet exp_ids - no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids - binds' = concatMap zap binds - - zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] - zap (Rec pairs) = [Rec (concatMap zapPair pairs)] - - zapPair (bndr, rhs) - | bndr `elemVarSet` exp_id_set - = [] -- Kill the exported-id binding - - | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr - , (exp_id', lcl_id') <- transferIdInfo exp_id bndr - = -- Turn a local-id binding into two bindings - -- exp_id = rhs; lcl_id = exp_id - [ (exp_id', mkTicks ticks rhs), - (lcl_id', Var exp_id') ] - - | otherwise - = [(bndr,rhs)] - -makeIndEnv :: [CoreBind] -> IndEnv -makeIndEnv binds - = foldl' add_bind emptyVarEnv binds - where - add_bind :: IndEnv -> CoreBind -> IndEnv - add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs) - add_bind env (Rec pairs) = foldl' add_pair env pairs - - add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv - add_pair env (exported_id, exported) - | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported - , shortMeOut env exported_id local_id - = extendVarEnv env local_id (exported_id, ticks) - add_pair env _ = env - ------------------ -shortMeOut :: IndEnv -> Id -> Id -> Bool -shortMeOut ind_env exported_id local_id --- The if-then-else stuff is just so I can get a pprTrace to see --- how often I don't get shorting out because of IdInfo stuff - = if isExportedId exported_id && -- Only if this is exported - - isLocalId local_id && -- Only if this one is defined in this - -- module, so that we *can* change its - -- binding to be the exported thing! - - not (isExportedId local_id) && -- Only if this one is not itself exported, - -- since the transformation will nuke it - - not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for - then - if hasShortableIdInfo exported_id - then True -- See Note [Messing up the exported Id's IdInfo] - else WARN( True, text "Not shorting out:" <+> ppr exported_id ) - False - else - False - ------------------ -hasShortableIdInfo :: Id -> Bool --- True if there is no user-attached IdInfo on exported_id, --- so we can safely discard it --- See Note [Messing up the exported Id's IdInfo] -hasShortableIdInfo id - = isEmptyRuleInfo (ruleInfo info) - && isDefaultInlinePragma (inlinePragInfo info) - && not (isStableUnfolding (unfoldingInfo info)) - where - info = idInfo id - ------------------ -{- Note [Transferring IdInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - lcl_id = e; exp_id = lcl_id - -and lcl_id has useful IdInfo, we don't want to discard it by going - gbl_id = e; lcl_id = gbl_id - -Instead, transfer IdInfo from lcl_id to exp_id, specifically -* (Stable) unfolding -* Strictness -* Rules -* Inline pragma - -Overwriting, rather than merging, seems to work ok. - -We also zap the InlinePragma on the lcl_id. It might originally -have had a NOINLINE, which we have now transferred; and we really -want the lcl_id to inline now that its RHS is trivial! --} - -transferIdInfo :: Id -> Id -> (Id, Id) --- See Note [Transferring IdInfo] -transferIdInfo exported_id local_id - = ( modifyIdInfo transfer exported_id - , local_id `setInlinePragma` defaultInlinePragma ) - where - local_info = idInfo local_id - transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info - `setCprInfo` cprInfo local_info - `setUnfoldingInfo` unfoldingInfo local_info - `setInlinePragInfo` inlinePragInfo local_info - `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info - new_info = setRuleInfoHead (idName exported_id) - (ruleInfo local_info) - -- Remember to set the function-name field of the - -- rules as we transfer them from one function to another diff --git a/compiler/GHC/Core/Op/Simplify/Env.hs b/compiler/GHC/Core/Op/Simplify/Env.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/Simplify/Env.hs +++ /dev/null @@ -1,938 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[GHC.Core.Op.Simplify.Monad]{The simplifier Monad} --} - -{-# LANGUAGE CPP #-} - -module GHC.Core.Op.Simplify.Env ( - -- * The simplifier mode - setMode, getMode, updMode, seDynFlags, - - -- * Environments - SimplEnv(..), pprSimplEnv, -- Temp not abstract - mkSimplEnv, extendIdSubst, - extendTvSubst, extendCvSubst, - zapSubstEnv, setSubstEnv, - getInScope, setInScopeFromE, setInScopeFromF, - setInScopeSet, modifyInScope, addNewInScopeIds, - getSimplRules, - - -- * Substitution results - SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope, - - -- * Simplifying 'Id' binders - simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, - simplBinder, simplBinders, - substTy, substTyVar, getTCvSubst, - substCo, substCoVar, - - -- * Floats - SimplFloats(..), emptyFloats, mkRecFloats, - mkFloatBind, addLetFloats, addJoinFloats, addFloats, - extendFloats, wrapFloats, - doFloatFromRhs, getTopFloatBinds, - - -- * LetFloats - LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat, - addLetFlts, mapLetFloats, - - -- * JoinFloats - JoinFloat, JoinFloats, emptyJoinFloats, - wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Core.Op.Simplify.Monad -import GHC.Core.Op.Monad ( SimplMode(..) ) -import GHC.Core -import GHC.Core.Utils -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import OrdList -import GHC.Types.Id as Id -import GHC.Core.Make ( mkWildValBinder ) -import GHC.Driver.Session ( DynFlags ) -import TysWiredIn -import qualified GHC.Core.Type as Type -import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst ) -import qualified GHC.Core.Coercion as Coercion -import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) -import GHC.Types.Basic -import MonadUtils -import Outputable -import Util -import GHC.Types.Unique.FM ( pprUniqFM ) - -import Data.List (mapAccumL) - -{- -************************************************************************ -* * -\subsubsection{The @SimplEnv@ type} -* * -************************************************************************ --} - -data SimplEnv - = SimplEnv { - ----------- Static part of the environment ----------- - -- Static in the sense of lexically scoped, - -- wrt the original expression - - seMode :: SimplMode - - -- The current substitution - , seTvSubst :: TvSubstEnv -- InTyVar |--> OutType - , seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion - , seIdSubst :: SimplIdSubst -- InId |--> OutExpr - - ----------- Dynamic part of the environment ----------- - -- Dynamic in the sense of describing the setup where - -- the expression finally ends up - - -- The current set of in-scope variables - -- They are all OutVars, and all bound in this module - , seInScope :: InScopeSet -- OutVars only - } - -data SimplFloats - = SimplFloats - { -- Ordinary let bindings - sfLetFloats :: LetFloats - -- See Note [LetFloats] - - -- Join points - , sfJoinFloats :: JoinFloats - -- Handled separately; they don't go very far - -- We consider these to be /inside/ sfLetFloats - -- because join points can refer to ordinary bindings, - -- but not vice versa - - -- Includes all variables bound by sfLetFloats and - -- sfJoinFloats, plus at least whatever is in scope where - -- these bindings land up. - , sfInScope :: InScopeSet -- All OutVars - } - -instance Outputable SimplFloats where - ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is }) - = text "SimplFloats" - <+> braces (vcat [ text "lets: " <+> ppr lf - , text "joins:" <+> ppr jf - , text "in_scope:" <+> ppr is ]) - -emptyFloats :: SimplEnv -> SimplFloats -emptyFloats env - = SimplFloats { sfLetFloats = emptyLetFloats - , sfJoinFloats = emptyJoinFloats - , sfInScope = seInScope env } - -pprSimplEnv :: SimplEnv -> SDoc --- Used for debugging; selective -pprSimplEnv env - = vcat [text "TvSubst:" <+> ppr (seTvSubst env), - text "CvSubst:" <+> ppr (seCvSubst env), - text "IdSubst:" <+> id_subst_doc, - text "InScope:" <+> in_scope_vars_doc - ] - where - id_subst_doc = pprUniqFM ppr (seIdSubst env) - in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env)) - (vcat . map ppr_one) - ppr_one v | isId v = ppr v <+> ppr (idUnfolding v) - | otherwise = ppr v - -type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr - -- See Note [Extending the Subst] in GHC.Core.Subst - --- | A substitution result. -data SimplSR - = DoneEx OutExpr (Maybe JoinArity) - -- If x :-> DoneEx e ja is in the SimplIdSubst - -- then replace occurrences of x by e - -- and ja = Just a <=> x is a join-point of arity a - -- See Note [Join arity in SimplIdSubst] - - - | DoneId OutId - -- If x :-> DoneId v is in the SimplIdSubst - -- then replace occurrences of x by v - -- and v is a join-point of arity a - -- <=> x is a join-point of arity a - - | ContEx TvSubstEnv -- A suspended substitution - CvSubstEnv - SimplIdSubst - InExpr - -- If x :-> ContEx tv cv id e is in the SimplISubst - -- then replace occurrences of x by (subst (tv,cv,id) e) - -instance Outputable SimplSR where - ppr (DoneId v) = text "DoneId" <+> ppr v - ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e - where - pp_mj = case mj of - Nothing -> empty - Just n -> parens (int n) - - ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, - ppr (filter_env tv), ppr (filter_env id) -}] - -- where - -- fvs = exprFreeVars e - -- filter_env env = filterVarEnv_Directly keep env - -- keep uniq _ = uniq `elemUFM_Directly` fvs - -{- -Note [SimplEnv invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -seInScope: - The in-scope part of Subst includes *all* in-scope TyVars and Ids - The elements of the set may have better IdInfo than the - occurrences of in-scope Ids, and (more important) they will - have a correctly-substituted type. So we use a lookup in this - set to replace occurrences - - The Ids in the InScopeSet are replete with their Rules, - and as we gather info about the unfolding of an Id, we replace - it in the in-scope set. - - The in-scope set is actually a mapping OutVar -> OutVar, and - in case expressions we sometimes bind - -seIdSubst: - The substitution is *apply-once* only, because InIds and OutIds - can overlap. - For example, we generally omit mappings - a77 -> a77 - from the substitution, when we decide not to clone a77, but it's quite - legitimate to put the mapping in the substitution anyway. - - Furthermore, consider - let x = case k of I# x77 -> ... in - let y = case k of I# x77 -> ... in ... - and suppose the body is strict in both x and y. Then the simplifier - will pull the first (case k) to the top; so the second (case k) will - cancel out, mapping x77 to, well, x77! But one is an in-Id and the - other is an out-Id. - - Of course, the substitution *must* applied! Things in its domain - simply aren't necessarily bound in the result. - -* substId adds a binding (DoneId new_id) to the substitution if - the Id's unique has changed - - Note, though that the substitution isn't necessarily extended - if the type of the Id changes. Why not? Because of the next point: - -* We *always, always* finish by looking up in the in-scope set - any variable that doesn't get a DoneEx or DoneVar hit in the substitution. - Reason: so that we never finish up with a "old" Id in the result. - An old Id might point to an old unfolding and so on... which gives a space - leak. - - [The DoneEx and DoneVar hits map to "new" stuff.] - -* It follows that substExpr must not do a no-op if the substitution is empty. - substType is free to do so, however. - -* When we come to a let-binding (say) we generate new IdInfo, including an - unfolding, attach it to the binder, and add this newly adorned binder to - the in-scope set. So all subsequent occurrences of the binder will get - mapped to the full-adorned binder, which is also the one put in the - binding site. - -* The in-scope "set" usually maps x->x; we use it simply for its domain. - But sometimes we have two in-scope Ids that are synomyms, and should - map to the same target: x->x, y->x. Notably: - case y of x { ... } - That's why the "set" is actually a VarEnv Var - -Note [Join arity in SimplIdSubst] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have to remember which incoming variables are join points: the occurrences -may not be marked correctly yet, and we're in change of propagating the change if -OccurAnal makes something a join point). - -Normally the in-scope set is where we keep the latest information, but -the in-scope set tracks only OutVars; if a binding is unconditionally -inlined (via DoneEx), it never makes it into the in-scope set, and we -need to know at the occurrence site that the variable is a join point -so that we know to drop the context. Thus we remember which join -points we're substituting. -} - -mkSimplEnv :: SimplMode -> SimplEnv -mkSimplEnv mode - = SimplEnv { seMode = mode - , seInScope = init_in_scope - , seTvSubst = emptyVarEnv - , seCvSubst = emptyVarEnv - , seIdSubst = emptyVarEnv } - -- The top level "enclosing CC" is "SUBSUMED". - -init_in_scope :: InScopeSet -init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy)) - -- See Note [WildCard binders] - -{- -Note [WildCard binders] -~~~~~~~~~~~~~~~~~~~~~~~ -The program to be simplified may have wild binders - case e of wild { p -> ... } -We want to *rename* them away, so that there are no -occurrences of 'wild-id' (with wildCardKey). The easy -way to do that is to start of with a representative -Id in the in-scope set - -There can be *occurrences* of wild-id. For example, -GHC.Core.Make.mkCoreApp transforms - e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild } -This is ok provided 'wild' isn't free in 'e', and that's the delicate -thing. Generally, you want to run the simplifier to get rid of the -wild-ids before doing much else. - -It's a very dark corner of GHC. Maybe it should be cleaned up. --} - -getMode :: SimplEnv -> SimplMode -getMode env = seMode env - -seDynFlags :: SimplEnv -> DynFlags -seDynFlags env = sm_dflags (seMode env) - -setMode :: SimplMode -> SimplEnv -> SimplEnv -setMode mode env = env { seMode = mode } - -updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv -updMode upd env = env { seMode = upd (seMode env) } - ---------------------- -extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv -extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res - = ASSERT2( isId var && not (isCoVar var), ppr var ) - env { seIdSubst = extendVarEnv subst var res } - -extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv -extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res - = ASSERT2( isTyVar var, ppr var $$ ppr res ) - env {seTvSubst = extendVarEnv tsubst var res} - -extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv -extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co - = ASSERT( isCoVar var ) - env {seCvSubst = extendVarEnv csubst var co} - ---------------------- -getInScope :: SimplEnv -> InScopeSet -getInScope env = seInScope env - -setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv -setInScopeSet env in_scope = env {seInScope = in_scope} - -setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv --- See Note [Setting the right in-scope set] -setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env } - -setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv -setInScopeFromF env floats = env { seInScope = sfInScope floats } - -addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv - -- The new Ids are guaranteed to be freshly allocated -addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs - = env { seInScope = in_scope `extendInScopeSetList` vs, - seIdSubst = id_subst `delVarEnvList` vs } - -- Why delete? Consider - -- let x = a*b in (x, \x -> x+3) - -- We add [x |-> a*b] to the substitution, but we must - -- _delete_ it from the substitution when going inside - -- the (\x -> ...)! - -modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv --- The variable should already be in scope, but --- replace the existing version with this new one --- which has more information -modifyInScope env@(SimplEnv {seInScope = in_scope}) v - = env {seInScope = extendInScopeSet in_scope v} - -{- Note [Setting the right in-scope set] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - \x. (let x = e in b) arg[x] -where the let shadows the lambda. Really this means something like - \x1. (let x2 = e in b) arg[x1] - -- When we capture the 'arg' in an ApplyToVal continuation, we capture - the environment, which says what 'x' is bound to, namely x1 - -- Then that continuation gets pushed under the let - -- Finally we simplify 'arg'. We want - - the static, lexical environment binding x :-> x1 - - the in-scopeset from "here", under the 'let' which includes - both x1 and x2 - -It's important to have the right in-scope set, else we may rename a -variable to one that is already in scope. So we must pick up the -in-scope set from "here", but otherwise use the environment we -captured along with 'arg'. This transfer of in-scope set is done by -setInScopeFromE. --} - ---------------------- -zapSubstEnv :: SimplEnv -> SimplEnv -zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} - -setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv -setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } - -mkContEx :: SimplEnv -> InExpr -> SimplSR -mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e - -{- -************************************************************************ -* * -\subsection{LetFloats} -* * -************************************************************************ - -Note [LetFloats] -~~~~~~~~~~~~~~~~ -The LetFloats is a bunch of bindings, classified by a FloatFlag. - -* All of them satisfy the let/app invariant - -Examples - - NonRec x (y:ys) FltLifted - Rec [(x,rhs)] FltLifted - - NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted? - NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n - - NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge - -Can't happen: - NonRec x# (a /# b) -- Might fail; does not satisfy let/app - NonRec x# (f y) -- Might diverge; does not satisfy let/app --} - -data LetFloats = LetFloats (OrdList OutBind) FloatFlag - -- See Note [LetFloats] - -type JoinFloat = OutBind -type JoinFloats = OrdList JoinFloat - -data FloatFlag - = FltLifted -- All bindings are lifted and lazy *or* - -- consist of a single primitive string literal - -- Hence ok to float to top level, or recursive - - | FltOkSpec -- All bindings are FltLifted *or* - -- strict (perhaps because unlifted, - -- perhaps because of a strict binder), - -- *and* ok-for-speculation - -- Hence ok to float out of the RHS - -- of a lazy non-recursive let binding - -- (but not to top level, or into a rec group) - - | FltCareful -- At least one binding is strict (or unlifted) - -- and not guaranteed cheap - -- Do not float these bindings out of a lazy let - -instance Outputable LetFloats where - ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds) - -instance Outputable FloatFlag where - ppr FltLifted = text "FltLifted" - ppr FltOkSpec = text "FltOkSpec" - ppr FltCareful = text "FltCareful" - -andFF :: FloatFlag -> FloatFlag -> FloatFlag -andFF FltCareful _ = FltCareful -andFF FltOkSpec FltCareful = FltCareful -andFF FltOkSpec _ = FltOkSpec -andFF FltLifted flt = flt - -doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool --- If you change this function look also at FloatIn.noFloatFromRhs -doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs - = not (isNilOL fs) && want_to_float && can_float - where - want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs - -- See Note [Float when cheap or expandable] - can_float = case ff of - FltLifted -> True - FltOkSpec -> isNotTopLevel lvl && isNonRec rec - FltCareful -> isNotTopLevel lvl && isNonRec rec && str - -{- -Note [Float when cheap or expandable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to float a let from a let if the residual RHS is - a) cheap, such as (\x. blah) - b) expandable, such as (f b) if f is CONLIKE -But there are - - cheap things that are not expandable (eg \x. expensive) - - expandable things that are not cheap (eg (f b) where b is CONLIKE) -so we must take the 'or' of the two. --} - -emptyLetFloats :: LetFloats -emptyLetFloats = LetFloats nilOL FltLifted - -emptyJoinFloats :: JoinFloats -emptyJoinFloats = nilOL - -unitLetFloat :: OutBind -> LetFloats --- This key function constructs a singleton float with the right form -unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind)) - LetFloats (unitOL bind) (flag bind) - where - flag (Rec {}) = FltLifted - flag (NonRec bndr rhs) - | not (isStrictId bndr) = FltLifted - | exprIsTickedString rhs = FltLifted - -- String literals can be floated freely. - -- See Note [Core top-level string literals] in GHC.Core. - | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) - | otherwise = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr ) - FltCareful - -- Unlifted binders can only be let-bound if exprOkForSpeculation holds - -unitJoinFloat :: OutBind -> JoinFloats -unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind)) - unitOL bind - -mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv) --- Make a singleton SimplFloats, and --- extend the incoming SimplEnv's in-scope set with its binders --- These binders may already be in the in-scope set, --- but may have by now been augmented with more IdInfo -mkFloatBind env bind - = (floats, env { seInScope = in_scope' }) - where - floats - | isJoinBind bind - = SimplFloats { sfLetFloats = emptyLetFloats - , sfJoinFloats = unitJoinFloat bind - , sfInScope = in_scope' } - | otherwise - = SimplFloats { sfLetFloats = unitLetFloat bind - , sfJoinFloats = emptyJoinFloats - , sfInScope = in_scope' } - - in_scope' = seInScope env `extendInScopeSetBind` bind - -extendFloats :: SimplFloats -> OutBind -> SimplFloats --- Add this binding to the floats, and extend the in-scope env too -extendFloats (SimplFloats { sfLetFloats = floats - , sfJoinFloats = jfloats - , sfInScope = in_scope }) - bind - | isJoinBind bind - = SimplFloats { sfInScope = in_scope' - , sfLetFloats = floats - , sfJoinFloats = jfloats' } - | otherwise - = SimplFloats { sfInScope = in_scope' - , sfLetFloats = floats' - , sfJoinFloats = jfloats } - where - in_scope' = in_scope `extendInScopeSetBind` bind - floats' = floats `addLetFlts` unitLetFloat bind - jfloats' = jfloats `addJoinFlts` unitJoinFloat bind - -addLetFloats :: SimplFloats -> LetFloats -> SimplFloats --- Add the let-floats for env2 to env1; --- *plus* the in-scope set for env2, which is bigger --- than that for env1 -addLetFloats floats let_floats@(LetFloats binds _) - = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats - , sfInScope = foldlOL extendInScopeSetBind - (sfInScope floats) binds } - -addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats -addJoinFloats floats join_floats - = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats - , sfInScope = foldlOL extendInScopeSetBind - (sfInScope floats) join_floats } - -extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet -extendInScopeSetBind in_scope bind - = extendInScopeSetList in_scope (bindersOf bind) - -addFloats :: SimplFloats -> SimplFloats -> SimplFloats --- Add both let-floats and join-floats for env2 to env1; --- *plus* the in-scope set for env2, which is bigger --- than that for env1 -addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 }) - (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope }) - = SimplFloats { sfLetFloats = lf1 `addLetFlts` lf2 - , sfJoinFloats = jf1 `addJoinFlts` jf2 - , sfInScope = in_scope } - -addLetFlts :: LetFloats -> LetFloats -> LetFloats -addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2) - = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2) - -letFloatBinds :: LetFloats -> [CoreBind] -letFloatBinds (LetFloats bs _) = fromOL bs - -addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats -addJoinFlts = appOL - -mkRecFloats :: SimplFloats -> SimplFloats --- Flattens the floats from env2 into a single Rec group, --- They must either all be lifted LetFloats or all JoinFloats -mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs ff - , sfJoinFloats = jbs - , sfInScope = in_scope }) - = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) ) - ASSERT2( isNilOL bs || isNilOL jbs, ppr floats ) - SimplFloats { sfLetFloats = floats' - , sfJoinFloats = jfloats' - , sfInScope = in_scope } - where - floats' | isNilOL bs = emptyLetFloats - | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs))) - jfloats' | isNilOL jbs = emptyJoinFloats - | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs))) - -wrapFloats :: SimplFloats -> OutExpr -> OutExpr --- Wrap the floats around the expression; they should all --- satisfy the let/app invariant, so mkLets should do the job just fine -wrapFloats (SimplFloats { sfLetFloats = LetFloats bs _ - , sfJoinFloats = jbs }) body - = foldrOL Let (wrapJoinFloats jbs body) bs - -- Note: Always safe to put the joins on the inside - -- since the values can't refer to them - -wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr) --- Wrap the sfJoinFloats of the env around the expression, --- and take them out of the SimplEnv -wrapJoinFloatsX floats body - = ( floats { sfJoinFloats = emptyJoinFloats } - , wrapJoinFloats (sfJoinFloats floats) body ) - -wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr --- Wrap the sfJoinFloats of the env around the expression, --- and take them out of the SimplEnv -wrapJoinFloats join_floats body - = foldrOL Let body join_floats - -getTopFloatBinds :: SimplFloats -> [CoreBind] -getTopFloatBinds (SimplFloats { sfLetFloats = lbs - , sfJoinFloats = jbs}) - = ASSERT( isNilOL jbs ) -- Can't be any top-level join bindings - letFloatBinds lbs - -mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats -mapLetFloats (LetFloats fs ff) fun - = LetFloats (mapOL app fs) ff - where - app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' - app (Rec bs) = Rec (map fun bs) - -{- -************************************************************************ -* * - Substitution of Vars -* * -************************************************************************ - -Note [Global Ids in the substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We look up even a global (eg imported) Id in the substitution. Consider - case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... } -The binder-swap in the occurrence analyser will add a binding -for a LocalId version of g (with the same unique though): - case X.g_34 of b { (a,b) -> let g_34 = b in - ... case X.g_34 of { (p,q) -> ...} ... } -So we want to look up the inner X.g_34 in the substitution, where we'll -find that it has been substituted by b. (Or conceivably cloned.) --} - -substId :: SimplEnv -> InId -> SimplSR --- Returns DoneEx only on a non-Var expression -substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v - = case lookupVarEnv ids v of -- Note [Global Ids in the substitution] - Nothing -> DoneId (refineFromInScope in_scope v) - Just (DoneId v) -> DoneId (refineFromInScope in_scope v) - Just res -> res -- DoneEx non-var, or ContEx - - -- Get the most up-to-date thing from the in-scope set - -- Even though it isn't in the substitution, it may be in - -- the in-scope set with better IdInfo. - -- - -- See also Note [In-scope set as a substitution] in GHC.Core.Op.Simplify. - -refineFromInScope :: InScopeSet -> Var -> Var -refineFromInScope in_scope v - | isLocalId v = case lookupInScope in_scope v of - Just v' -> v' - Nothing -> WARN( True, ppr v ) v -- This is an error! - | otherwise = v - -lookupRecBndr :: SimplEnv -> InId -> OutId --- Look up an Id which has been put into the envt by simplRecBndrs, --- but where we have not yet done its RHS -lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v - = case lookupVarEnv ids v of - Just (DoneId v) -> v - Just _ -> pprPanic "lookupRecBndr" (ppr v) - Nothing -> refineFromInScope in_scope v - -{- -************************************************************************ -* * -\section{Substituting an Id binder} -* * -************************************************************************ - - -These functions are in the monad only so that they can be made strict via seq. - -Note [Return type for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - (join j :: Char -> Int -> Int) 77 - ( j x = \y. y + ord x ) - (in case v of ) - ( A -> j 'x' ) - ( B -> j 'y' ) - ( C -> ) - -The simplifier pushes the "apply to 77" continuation inwards to give - - join j :: Char -> Int - j x = (\y. y + ord x) 77 - in case v of - A -> j 'x' - B -> j 'y' - C -> 77 - -Notice that the "apply to 77" continuation went into the RHS of the -join point. And that meant that the return type of the join point -changed!! - -That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr -takes a (Just res_ty) argument so that it knows to do the type-changing -thing. --} - -simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) -simplBinders env bndrs = mapAccumLM simplBinder env bndrs - -------------- -simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) --- Used for lambda and case-bound variables --- Clone Id if necessary, substitute type --- Return with IdInfo already substituted, but (fragile) occurrence info zapped --- The substitution is extended only if the variable is cloned, because --- we *don't* need to use it to track occurrence info. -simplBinder env bndr - | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr - ; seqTyVar tv `seq` return (env', tv) } - | otherwise = do { let (env', id) = substIdBndr Nothing env bndr - ; seqId id `seq` return (env', id) } - ---------------- -simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) --- A non-recursive let binder -simplNonRecBndr env id - = do { let (env1, id1) = substIdBndr Nothing env id - ; seqId id1 `seq` return (env1, id1) } - ---------------- -simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr - -> SimplM (SimplEnv, OutBndr) --- A non-recursive let binder for a join point; --- context being pushed inward may change the type --- See Note [Return type for join points] -simplNonRecJoinBndr env res_ty id - = do { let (env1, id1) = substIdBndr (Just res_ty) env id - ; seqId id1 `seq` return (env1, id1) } - ---------------- -simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv --- Recursive let binders -simplRecBndrs env@(SimplEnv {}) ids - = ASSERT(all (not . isJoinId) ids) - do { let (env1, ids1) = mapAccumL (substIdBndr Nothing) env ids - ; seqIds ids1 `seq` return env1 } - ---------------- -simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv --- Recursive let binders for join points; --- context being pushed inward may change types --- See Note [Return type for join points] -simplRecJoinBndrs env@(SimplEnv {}) res_ty ids - = ASSERT(all isJoinId ids) - do { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids - ; seqIds ids1 `seq` return env1 } - ---------------- -substIdBndr :: Maybe OutType -> SimplEnv -> InBndr -> (SimplEnv, OutBndr) --- Might be a coercion variable -substIdBndr new_res_ty env bndr - | isCoVar bndr = substCoVarBndr env bndr - | otherwise = substNonCoVarIdBndr new_res_ty env bndr - ---------------- -substNonCoVarIdBndr - :: Maybe OutType -- New result type, if a join binder - -- See Note [Return type for join points] - -> SimplEnv - -> InBndr -- Env and binder to transform - -> (SimplEnv, OutBndr) --- Clone Id if necessary, substitute its type --- Return an Id with its --- * Type substituted --- * UnfoldingInfo, Rules, WorkerInfo zapped --- * Fragile OccInfo (only) zapped: Note [Robust OccInfo] --- * Robust info, retained especially arity and demand info, --- so that they are available to occurrences that occur in an --- earlier binding of a letrec --- --- For the robust info, see Note [Arity robustness] --- --- Augment the substitution if the unique changed --- Extend the in-scope set with the new Id --- --- Similar to GHC.Core.Subst.substIdBndr, except that --- the type of id_subst differs --- all fragile info is zapped -substNonCoVarIdBndr new_res_ty - env@(SimplEnv { seInScope = in_scope - , seIdSubst = id_subst }) - old_id - = ASSERT2( not (isCoVar old_id), ppr old_id ) - (env { seInScope = in_scope `extendInScopeSet` new_id, - seIdSubst = new_subst }, new_id) - where - id1 = uniqAway in_scope old_id - id2 = substIdType env id1 - - id3 | Just res_ty <- new_res_ty - = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2) - -- See Note [Return type for join points] - | otherwise - = id2 - - new_id = zapFragileIdInfo id3 -- Zaps rules, worker-info, unfolding - -- and fragile OccInfo - - -- Extend the substitution if the unique has changed, - -- or there's some useful occurrence information - -- See the notes with substTyVarBndr for the delSubstEnv - new_subst | new_id /= old_id - = extendVarEnv id_subst old_id (DoneId new_id) - | otherwise - = delVarEnv id_subst old_id - ------------------------------------- -seqTyVar :: TyVar -> () -seqTyVar b = b `seq` () - -seqId :: Id -> () -seqId id = seqType (idType id) `seq` - idInfo id `seq` - () - -seqIds :: [Id] -> () -seqIds [] = () -seqIds (id:ids) = seqId id `seq` seqIds ids - -{- -Note [Arity robustness] -~~~~~~~~~~~~~~~~~~~~~~~ -We *do* transfer the arity from from the in_id of a let binding to the -out_id. This is important, so that the arity of an Id is visible in -its own RHS. For example: - f = \x. ....g (\y. f y).... -We can eta-reduce the arg to g, because f is a value. But that -needs to be visible. - -This interacts with the 'state hack' too: - f :: Bool -> IO Int - f = \x. case x of - True -> f y - False -> \s -> ... -Can we eta-expand f? Only if we see that f has arity 1, and then we -take advantage of the 'state hack' on the result of -(f y) :: State# -> (State#, Int) to expand the arity one more. - -There is a disadvantage though. Making the arity visible in the RHS -allows us to eta-reduce - f = \x -> f x -to - f = f -which technically is not sound. This is very much a corner case, so -I'm not worried about it. Another idea is to ensure that f's arity -never decreases; its arity started as 1, and we should never eta-reduce -below that. - - -Note [Robust OccInfo] -~~~~~~~~~~~~~~~~~~~~~ -It's important that we *do* retain the loop-breaker OccInfo, because -that's what stops the Id getting inlined infinitely, in the body of -the letrec. --} - - -{- -************************************************************************ -* * - Impedance matching to type substitution -* * -************************************************************************ --} - -getTCvSubst :: SimplEnv -> TCvSubst -getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env - , seCvSubst = cv_env }) - = mkTCvSubst in_scope (tv_env, cv_env) - -substTy :: SimplEnv -> Type -> Type -substTy env ty = Type.substTy (getTCvSubst env) ty - -substTyVar :: SimplEnv -> TyVar -> Type -substTyVar env tv = Type.substTyVar (getTCvSubst env) tv - -substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) -substTyVarBndr env tv - = case Type.substTyVarBndr (getTCvSubst env) tv of - (TCvSubst in_scope' tv_env' cv_env', tv') - -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv') - -substCoVar :: SimplEnv -> CoVar -> Coercion -substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv - -substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) -substCoVarBndr env cv - = case Coercion.substCoVarBndr (getTCvSubst env) cv of - (TCvSubst in_scope' tv_env' cv_env', cv') - -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') - -substCo :: SimplEnv -> Coercion -> Coercion -substCo env co = Coercion.substCo (getTCvSubst env) co - ------------------- -substIdType :: SimplEnv -> Id -> Id -substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id - | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) - || noFreeVarsOfType old_ty - = id - | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty) - -- The tyCoVarsOfType is cheaper than it looks - -- because we cache the free tyvars of the type - -- in a Note in the id's type itself - where - old_ty = idType id diff --git a/compiler/GHC/Core/Op/Simplify/Monad.hs b/compiler/GHC/Core/Op/Simplify/Monad.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/Simplify/Monad.hs +++ /dev/null @@ -1,252 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[GHC.Core.Op.Simplify.Monad]{The simplifier Monad} --} - -{-# LANGUAGE DeriveFunctor #-} -module GHC.Core.Op.Simplify.Monad ( - -- The monad - SimplM, - initSmpl, traceSmpl, - getSimplRules, getFamEnvs, - - -- Unique supply - MonadUnique(..), newId, newJoinId, - - -- Counting - SimplCount, tick, freeTick, checkedTick, - getSimplCount, zeroSimplCount, pprSimplCount, - plusSimplCount, isZeroSimplCount - ) where - -import GhcPrelude - -import GHC.Types.Var ( Var, isId, mkLocalVar ) -import GHC.Types.Name ( mkSystemVarName ) -import GHC.Types.Id ( Id, mkSysLocalOrCoVar ) -import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) -import GHC.Core.Type ( Type, mkLamTypes ) -import GHC.Core.FamInstEnv ( FamInstEnv ) -import GHC.Core ( RuleEnv(..) ) -import GHC.Types.Unique.Supply -import GHC.Driver.Session -import GHC.Core.Op.Monad -import Outputable -import FastString -import MonadUtils -import ErrUtils as Err -import Util ( count ) -import Panic (throwGhcExceptionIO, GhcException (..)) -import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf ) -import Control.Monad ( ap ) - -{- -************************************************************************ -* * -\subsection{Monad plumbing} -* * -************************************************************************ - -For the simplifier monad, we want to {\em thread} a unique supply and a counter. -(Command-line switches move around through the explicitly-passed SimplEnv.) --} - -newtype SimplM result - = SM { unSM :: SimplTopEnv -- Envt that does not change much - -> UniqSupply -- We thread the unique supply because - -- constantly splitting it is rather expensive - -> SimplCount - -> IO (result, UniqSupply, SimplCount)} - -- we only need IO here for dump output - deriving (Functor) - -data SimplTopEnv - = STE { st_flags :: DynFlags - , st_max_ticks :: IntWithInf -- Max #ticks in this simplifier run - , st_rules :: RuleEnv - , st_fams :: (FamInstEnv, FamInstEnv) } - -initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv) - -> UniqSupply -- No init count; set to 0 - -> Int -- Size of the bindings, used to limit - -- the number of ticks we allow - -> SimplM a - -> IO (a, SimplCount) - -initSmpl dflags rules fam_envs us size m - = do (result, _, count) <- unSM m env us (zeroSimplCount dflags) - return (result, count) - where - env = STE { st_flags = dflags, st_rules = rules - , st_max_ticks = computeMaxTicks dflags size - , st_fams = fam_envs } - -computeMaxTicks :: DynFlags -> Int -> IntWithInf --- Compute the max simplifier ticks as --- (base-size + pgm-size) * magic-multiplier * tick-factor/100 --- where --- magic-multiplier is a constant that gives reasonable results --- base-size is a constant to deal with size-zero programs -computeMaxTicks dflags size - = treatZeroAsInf $ - fromInteger ((toInteger (size + base_size) - * toInteger (tick_factor * magic_multiplier)) - `div` 100) - where - tick_factor = simplTickFactor dflags - base_size = 100 - magic_multiplier = 40 - -- MAGIC NUMBER, multiplies the simplTickFactor - -- We can afford to be generous; this is really - -- just checking for loops, and shouldn't usually fire - -- A figure of 20 was too small: see #5539. - -{-# INLINE thenSmpl #-} -{-# INLINE thenSmpl_ #-} -{-# INLINE returnSmpl #-} - - -instance Applicative SimplM where - pure = returnSmpl - (<*>) = ap - (*>) = thenSmpl_ - -instance Monad SimplM where - (>>) = (*>) - (>>=) = thenSmpl - -returnSmpl :: a -> SimplM a -returnSmpl e = SM (\_st_env us sc -> return (e, us, sc)) - -thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b -thenSmpl_ :: SimplM a -> SimplM b -> SimplM b - -thenSmpl m k - = SM $ \st_env us0 sc0 -> do - (m_result, us1, sc1) <- unSM m st_env us0 sc0 - unSM (k m_result) st_env us1 sc1 - -thenSmpl_ m k - = SM $ \st_env us0 sc0 -> do - (_, us1, sc1) <- unSM m st_env us0 sc0 - unSM k st_env us1 sc1 - --- TODO: this specializing is not allowed --- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-} --- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-} --- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-} - -traceSmpl :: String -> SDoc -> SimplM () -traceSmpl herald doc - = do { dflags <- getDynFlags - ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace" - FormatText - (hang (text herald) 2 doc) } - -{- -************************************************************************ -* * -\subsection{The unique supply} -* * -************************************************************************ --} - -instance MonadUnique SimplM where - getUniqueSupplyM - = SM (\_st_env us sc -> case splitUniqSupply us of - (us1, us2) -> return (us1, us2, sc)) - - getUniqueM - = SM (\_st_env us sc -> case takeUniqFromSupply us of - (u, us') -> return (u, us', sc)) - - getUniquesM - = SM (\_st_env us sc -> case splitUniqSupply us of - (us1, us2) -> return (uniqsFromSupply us1, us2, sc)) - -instance HasDynFlags SimplM where - getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc)) - -instance MonadIO SimplM where - liftIO m = SM $ \_ us sc -> do - x <- m - return (x, us, sc) - -getSimplRules :: SimplM RuleEnv -getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc)) - -getFamEnvs :: SimplM (FamInstEnv, FamInstEnv) -getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc)) - -newId :: FastString -> Type -> SimplM Id -newId fs ty = do uniq <- getUniqueM - return (mkSysLocalOrCoVar fs uniq ty) - -newJoinId :: [Var] -> Type -> SimplM Id -newJoinId bndrs body_ty - = do { uniq <- getUniqueM - ; let name = mkSystemVarName uniq (fsLit "$j") - join_id_ty = mkLamTypes bndrs body_ty -- Note [Funky mkLamTypes] - arity = count isId bndrs - -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core - join_arity = length bndrs - details = JoinId join_arity - id_info = vanillaIdInfo `setArityInfo` arity --- `setOccInfo` strongLoopBreaker - - ; return (mkLocalVar details name join_id_ty id_info) } - -{- -************************************************************************ -* * -\subsection{Counting up what we've done} -* * -************************************************************************ --} - -getSimplCount :: SimplM SimplCount -getSimplCount = SM (\_st_env us sc -> return (sc, us, sc)) - -tick :: Tick -> SimplM () -tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc - in sc' `seq` return ((), us, sc')) - -checkedTick :: Tick -> SimplM () --- Try to take a tick, but fail if too many -checkedTick t - = SM (\st_env us sc -> - if st_max_ticks st_env <= mkIntWithInf (simplCountN sc) - then throwGhcExceptionIO $ - PprProgramError "Simplifier ticks exhausted" (msg sc) - else let sc' = doSimplTick (st_flags st_env) t sc - in sc' `seq` return ((), us, sc')) - where - msg sc = vcat - [ text "When trying" <+> ppr t - , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)." - , space - , text "If you need to increase the limit substantially, please file a" - , text "bug report and indicate the factor you needed." - , space - , text "If GHC was unable to complete compilation even" - <+> text "with a very large factor" - , text "(a thousand or more), please consult the" - <+> doubleQuotes (text "Known bugs or infelicities") - , text "section in the Users Guide before filing a report. There are a" - , text "few situations unlikely to occur in practical programs for which" - , text "simplifier non-termination has been judged acceptable." - , space - , pp_details sc - , pprSimplCount sc ] - pp_details sc - | hasDetailedCounts sc = empty - | otherwise = text "To see detailed counts use -ddump-simpl-stats" - - -freeTick :: Tick -> SimplM () --- Record a tick, but don't add to the total tick count, which is --- used to decide when nothing further has happened -freeTick t - = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc - in sc' `seq` return ((), us, sc')) diff --git a/compiler/GHC/Core/Op/Simplify/Utils.hs b/compiler/GHC/Core/Op/Simplify/Utils.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/Simplify/Utils.hs +++ /dev/null @@ -1,2329 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -The simplifier utilities --} - -{-# LANGUAGE CPP #-} - -module GHC.Core.Op.Simplify.Utils ( - -- Rebuilding - mkLam, mkCase, prepareAlts, tryEtaExpandRhs, - - -- Inlining, - preInlineUnconditionally, postInlineUnconditionally, - activeUnfolding, activeRule, - getUnfoldingInRuleMatch, - simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules, - - -- The continuation type - SimplCont(..), DupFlag(..), StaticEnv, - isSimplified, contIsStop, - contIsDupable, contResultType, contHoleType, - contIsTrivial, contArgs, - countArgs, - mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, - interestingCallContext, - - -- ArgInfo - ArgInfo(..), ArgSpec(..), mkArgInfo, - addValArgTo, addCastTo, addTyArgTo, - argInfoExpr, argInfoAppArgs, pushSimplifiedArgs, - - abstractFloats, - - -- Utilities - isExitJoinId - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Core.Op.Simplify.Env -import GHC.Core.Op.Monad ( SimplMode(..), Tick(..) ) -import GHC.Driver.Session -import GHC.Core -import qualified GHC.Core.Subst -import GHC.Core.Ppr -import GHC.Core.TyCo.Ppr ( pprParendType ) -import GHC.Core.FVs -import GHC.Core.Utils -import GHC.Core.Arity -import GHC.Core.Unfold -import GHC.Types.Name -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Var -import GHC.Types.Demand -import GHC.Core.Op.Simplify.Monad -import GHC.Core.Type hiding( substTy ) -import GHC.Core.Coercion hiding( substCo ) -import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon ) -import GHC.Types.Var.Set -import GHC.Types.Basic -import Util -import OrdList ( isNilOL ) -import MonadUtils -import Outputable -import GHC.Core.Op.ConstantFold -import FastString ( fsLit ) - -import Control.Monad ( when ) -import Data.List ( sortBy ) - -{- -************************************************************************ -* * - The SimplCont and DupFlag types -* * -************************************************************************ - -A SimplCont allows the simplifier to traverse the expression in a -zipper-like fashion. The SimplCont represents the rest of the expression, -"above" the point of interest. - -You can also think of a SimplCont as an "evaluation context", using -that term in the way it is used for operational semantics. This is the -way I usually think of it, For example you'll often see a syntax for -evaluation context looking like - C ::= [] | C e | case C of alts | C `cast` co -That's the kind of thing we are doing here, and I use that syntax in -the comments. - - -Key points: - * A SimplCont describes a *strict* context (just like - evaluation contexts do). E.g. Just [] is not a SimplCont - - * A SimplCont describes a context that *does not* bind - any variables. E.g. \x. [] is not a SimplCont --} - -data SimplCont - = Stop -- Stop[e] = e - OutType -- Type of the - CallCtxt -- Tells if there is something interesting about - -- the context, and hence the inliner - -- should be a bit keener (see interestingCallContext) - -- Specifically: - -- This is an argument of a function that has RULES - -- Inlining the call might allow the rule to fire - -- Never ValAppCxt (use ApplyToVal instead) - -- or CaseCtxt (use Select instead) - - | CastIt -- (CastIt co K)[e] = K[ e `cast` co ] - OutCoercion -- The coercion simplified - -- Invariant: never an identity coercion - SimplCont - - | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ] - { sc_dup :: DupFlag -- See Note [DupFlag invariants] - , sc_arg :: InExpr -- The argument, - , sc_env :: StaticEnv -- see Note [StaticEnv invariant] - , sc_cont :: SimplCont } - - | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] - { sc_arg_ty :: OutType -- Argument type - , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) - -- See Note [The hole type in ApplyToTy] - , sc_cont :: SimplCont } - - | Select -- (Select alts K)[e] = K[ case e of alts ] - { sc_dup :: DupFlag -- See Note [DupFlag invariants] - , sc_bndr :: InId -- case binder - , sc_alts :: [InAlt] -- Alternatives - , sc_env :: StaticEnv -- See Note [StaticEnv invariant] - , sc_cont :: SimplCont } - - -- The two strict forms have no DupFlag, because we never duplicate them - | StrictBind -- (StrictBind x xs b K)[e] = let x = e in K[\xs.b] - -- or, equivalently, = K[ (\x xs.b) e ] - { sc_dup :: DupFlag -- See Note [DupFlag invariants] - , sc_bndr :: InId - , sc_bndrs :: [InBndr] - , sc_body :: InExpr - , sc_env :: StaticEnv -- See Note [StaticEnv invariant] - , sc_cont :: SimplCont } - - | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] - { sc_dup :: DupFlag -- Always Simplified or OkToDup - , sc_fun :: ArgInfo -- Specifies f, e1..en, Whether f has rules, etc - -- plus strictness flags for *further* args - , sc_cci :: CallCtxt -- Whether *this* argument position is interesting - , sc_cont :: SimplCont } - - | TickIt -- (TickIt t K)[e] = K[ tick t e ] - (Tickish Id) -- Tick tickish - SimplCont - -type StaticEnv = SimplEnv -- Just the static part is relevant - -data DupFlag = NoDup -- Unsimplified, might be big - | Simplified -- Simplified - | OkToDup -- Simplified and small - -isSimplified :: DupFlag -> Bool -isSimplified NoDup = False -isSimplified _ = True -- Invariant: the subst-env is empty - -perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type -perhapsSubstTy dup env ty - | isSimplified dup = ty - | otherwise = substTy env ty - -{- Note [StaticEnv invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pair up an InExpr or InAlts with a StaticEnv, which establishes the -lexical scope for that InExpr. When we simplify that InExpr/InAlts, we -use - - Its captured StaticEnv - - Overriding its InScopeSet with the larger one at the - simplification point. - -Why override the InScopeSet? Example: - (let y = ey in f) ex -By the time we simplify ex, 'y' will be in scope. - -However the InScopeSet in the StaticEnv is not irrelevant: it should -include all the free vars of applying the substitution to the InExpr. -Reason: contHoleType uses perhapsSubstTy to apply the substitution to -the expression, and that (rightly) gives ASSERT failures if the InScopeSet -isn't big enough. - -Note [DupFlag invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~ -In both (ApplyToVal dup _ env k) - and (Select dup _ _ env k) -the following invariants hold - - (a) if dup = OkToDup, then continuation k is also ok-to-dup - (b) if dup = OkToDup or Simplified, the subst-env is empty - (and and hence no need to re-simplify) --} - -instance Outputable DupFlag where - ppr OkToDup = text "ok" - ppr NoDup = text "nodup" - ppr Simplified = text "simpl" - -instance Outputable SimplCont where - ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty - ppr (CastIt co cont ) = (text "CastIt" <+> pprOptCo co) $$ ppr cont - ppr (TickIt t cont) = (text "TickIt" <+> ppr t) $$ ppr cont - ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) - = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont - ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont }) - = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg) - $$ ppr cont - ppr (StrictBind { sc_bndr = b, sc_cont = cont }) - = (text "StrictBind" <+> ppr b) $$ ppr cont - ppr (StrictArg { sc_fun = ai, sc_cont = cont }) - = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont - ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) - = (text "Select" <+> ppr dup <+> ppr bndr) $$ - whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont - - -{- Note [The hole type in ApplyToTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The sc_hole_ty field of ApplyToTy records the type of the "hole" in the -continuation. It is absolutely necessary to compute contHoleType, but it is -not used for anything else (and hence may not be evaluated). - -Why is it necessary for contHoleType? Consider the continuation - ApplyToType Int (Stop Int) -corresponding to - ( @Int) :: Int -What is the type of ? It could be (forall a. Int) or (forall a. a), -and there is no way to know which, so we must record it. - -In a chain of applications (f @t1 @t2 @t3) we'll lazily compute exprType -for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably -doesn't matter because we'll never compute them all. - -************************************************************************ -* * - ArgInfo and ArgSpec -* * -************************************************************************ --} - -data ArgInfo - = ArgInfo { - ai_fun :: OutId, -- The function - ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) - - ai_type :: OutType, -- Type of (f a1 ... an) - - ai_rules :: FunRules, -- Rules for this function - - ai_encl :: Bool, -- Flag saying whether this function - -- or an enclosing one has rules (recursively) - -- True => be keener to inline in all args - - ai_strs :: [Bool], -- Strictness of remaining arguments - -- Usually infinite, but if it is finite it guarantees - -- that the function diverges after being given - -- that number of args - ai_discs :: [Int] -- Discounts for remaining arguments; non-zero => be keener to inline - -- Always infinite - } - -data ArgSpec - = ValArg OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal - | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy - , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah) - | CastBy OutCoercion -- Cast by this; c.f. CastIt - -instance Outputable ArgSpec where - ppr (ValArg e) = text "ValArg" <+> ppr e - ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty - ppr (CastBy c) = text "CastBy" <+> ppr c - -addValArgTo :: ArgInfo -> OutExpr -> ArgInfo -addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai - , ai_type = applyTypeToArg (ai_type ai) arg - , ai_rules = decRules (ai_rules ai) } - -addTyArgTo :: ArgInfo -> OutType -> ArgInfo -addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai - , ai_type = piResultTy poly_fun_ty arg_ty - , ai_rules = decRules (ai_rules ai) } - where - poly_fun_ty = ai_type ai - arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = poly_fun_ty } - -addCastTo :: ArgInfo -> OutCoercion -> ArgInfo -addCastTo ai co = ai { ai_args = CastBy co : ai_args ai - , ai_type = coercionRKind co } - -argInfoAppArgs :: [ArgSpec] -> [OutExpr] -argInfoAppArgs [] = [] -argInfoAppArgs (CastBy {} : _) = [] -- Stop at a cast -argInfoAppArgs (ValArg e : as) = e : argInfoAppArgs as -argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as - -pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont -pushSimplifiedArgs _env [] k = k -pushSimplifiedArgs env (arg : args) k - = case arg of - TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } - -> ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest } - ValArg e -> ApplyToVal { sc_arg = e, sc_env = env, sc_dup = Simplified, sc_cont = rest } - CastBy c -> CastIt c rest - where - rest = pushSimplifiedArgs env args k - -- The env has an empty SubstEnv - -argInfoExpr :: OutId -> [ArgSpec] -> OutExpr --- NB: the [ArgSpec] is reversed so that the first arg --- in the list is the last one in the application -argInfoExpr fun rev_args - = go rev_args - where - go [] = Var fun - go (ValArg a : as) = go as `App` a - go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty - go (CastBy co : as) = mkCast (go as) co - - -type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function - -- Nothing => No rules - -- Just (n, rules) => some rules, requiring at least n more type/value args - -decRules :: FunRules -> FunRules -decRules (Just (n, rules)) = Just (n-1, rules) -decRules Nothing = Nothing - -mkFunRules :: [CoreRule] -> FunRules -mkFunRules [] = Nothing -mkFunRules rs = Just (n_required, rs) - where - n_required = maximum (map ruleArity rs) - -{- -************************************************************************ -* * - Functions on SimplCont -* * -************************************************************************ --} - -mkBoringStop :: OutType -> SimplCont -mkBoringStop ty = Stop ty BoringCtxt - -mkRhsStop :: OutType -> SimplCont -- See Note [RHS of lets] in GHC.Core.Unfold -mkRhsStop ty = Stop ty RhsCtxt - -mkLazyArgStop :: OutType -> CallCtxt -> SimplCont -mkLazyArgStop ty cci = Stop ty cci - -------------------- -contIsRhsOrArg :: SimplCont -> Bool -contIsRhsOrArg (Stop {}) = True -contIsRhsOrArg (StrictBind {}) = True -contIsRhsOrArg (StrictArg {}) = True -contIsRhsOrArg _ = False - -contIsRhs :: SimplCont -> Bool -contIsRhs (Stop _ RhsCtxt) = True -contIsRhs _ = False - -------------------- -contIsStop :: SimplCont -> Bool -contIsStop (Stop {}) = True -contIsStop _ = False - -contIsDupable :: SimplCont -> Bool -contIsDupable (Stop {}) = True -contIsDupable (ApplyToTy { sc_cont = k }) = contIsDupable k -contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants] -contIsDupable (Select { sc_dup = OkToDup }) = True -- ...ditto... -contIsDupable (StrictArg { sc_dup = OkToDup }) = True -- ...ditto... -contIsDupable (CastIt _ k) = contIsDupable k -contIsDupable _ = False - -------------------- -contIsTrivial :: SimplCont -> Bool -contIsTrivial (Stop {}) = True -contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial k -contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k -contIsTrivial (CastIt _ k) = contIsTrivial k -contIsTrivial _ = False - -------------------- -contResultType :: SimplCont -> OutType -contResultType (Stop ty _) = ty -contResultType (CastIt _ k) = contResultType k -contResultType (StrictBind { sc_cont = k }) = contResultType k -contResultType (StrictArg { sc_cont = k }) = contResultType k -contResultType (Select { sc_cont = k }) = contResultType k -contResultType (ApplyToTy { sc_cont = k }) = contResultType k -contResultType (ApplyToVal { sc_cont = k }) = contResultType k -contResultType (TickIt _ k) = contResultType k - -contHoleType :: SimplCont -> OutType -contHoleType (Stop ty _) = ty -contHoleType (TickIt _ k) = contHoleType k -contHoleType (CastIt co _) = coercionLKind co -contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se }) - = perhapsSubstTy dup se (idType b) -contHoleType (StrictArg { sc_fun = ai }) = funArgTy (ai_type ai) -contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] -contHoleType (ApplyToVal { sc_arg = e, sc_env = se, sc_dup = dup, sc_cont = k }) - = mkVisFunTy (perhapsSubstTy dup se (exprType e)) - (contHoleType k) -contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) - = perhapsSubstTy d se (idType b) - -------------------- -countArgs :: SimplCont -> Int --- Count all arguments, including types, coercions, and other values -countArgs (ApplyToTy { sc_cont = cont }) = 1 + countArgs cont -countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont -countArgs _ = 0 - -contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont) --- Summarises value args, discards type args and coercions --- The returned continuation of the call is only used to --- answer questions like "are you interesting?" -contArgs cont - | lone cont = (True, [], cont) - | otherwise = go [] cont - where - lone (ApplyToTy {}) = False -- See Note [Lone variables] in GHC.Core.Unfold - lone (ApplyToVal {}) = False - lone (CastIt {}) = False - lone _ = True - - go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) - = go (is_interesting arg se : args) k - go args (ApplyToTy { sc_cont = k }) = go args k - go args (CastIt _ k) = go args k - go args k = (False, reverse args, k) - - is_interesting arg se = interestingArg se arg - -- Do *not* use short-cutting substitution here - -- because we want to get as much IdInfo as possible - - -------------------- -mkArgInfo :: SimplEnv - -> Id - -> [CoreRule] -- Rules for function - -> Int -- Number of value args - -> SimplCont -- Context of the call - -> ArgInfo - -mkArgInfo env fun rules n_val_args call_cont - | n_val_args < idArity fun -- Note [Unsaturated functions] - = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty - , ai_rules = fun_rules - , ai_encl = False - , ai_strs = vanilla_stricts - , ai_discs = vanilla_discounts } - | otherwise - = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty - , ai_rules = fun_rules - , ai_encl = interestingArgContext rules call_cont - , ai_strs = arg_stricts - , ai_discs = arg_discounts } - where - fun_ty = idType fun - - fun_rules = mkFunRules rules - - vanilla_discounts, arg_discounts :: [Int] - vanilla_discounts = repeat 0 - arg_discounts = case idUnfolding fun of - CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} - -> discounts ++ vanilla_discounts - _ -> vanilla_discounts - - vanilla_stricts, arg_stricts :: [Bool] - vanilla_stricts = repeat False - - arg_stricts - | not (sm_inline (seMode env)) - = vanilla_stricts -- See Note [Do not expose strictness if sm_inline=False] - | otherwise - = add_type_str fun_ty $ - case splitStrictSig (idStrictness fun) of - (demands, result_info) - | not (demands `lengthExceeds` n_val_args) - -> -- Enough args, use the strictness given. - -- For bottoming functions we used to pretend that the arg - -- is lazy, so that we don't treat the arg as an - -- interesting context. This avoids substituting - -- top-level bindings for (say) strings into - -- calls to error. But now we are more careful about - -- inlining lone variables, so it's ok - -- (see GHC.Core.Op.Simplify.Utils.analyseCont) - if isBotDiv result_info then - map isStrictDmd demands -- Finite => result is bottom - else - map isStrictDmd demands ++ vanilla_stricts - | otherwise - -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun) - <+> ppr n_val_args <+> ppr demands ) - vanilla_stricts -- Not enough args, or no strictness - - add_type_str :: Type -> [Bool] -> [Bool] - -- If the function arg types are strict, record that in the 'strictness bits' - -- No need to instantiate because unboxed types (which dominate the strict - -- types) can't instantiate type variables. - -- add_type_str is done repeatedly (for each call); - -- might be better once-for-all in the function - -- But beware primops/datacons with no strictness - - add_type_str _ [] = [] - add_type_str fun_ty all_strs@(str:strs) - | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info - = (str || Just False == isLiftedType_maybe arg_ty) - : add_type_str fun_ty' strs - -- If the type is levity-polymorphic, we can't know whether it's - -- strict. isLiftedType_maybe will return Just False only when - -- we're sure the type is unlifted. - - | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty - = add_type_str fun_ty' all_strs -- Look through foralls - - | otherwise - = all_strs - -{- Note [Unsaturated functions] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (test eyeball/inline4) - x = a:as - y = f x -where f has arity 2. Then we do not want to inline 'x', because -it'll just be floated out again. Even if f has lots of discounts -on its first argument -- it must be saturated for these to kick in - -Note [Do not expose strictness if sm_inline=False] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#15163 showed a case in which we had - - {-# INLINE [1] zip #-} - zip = undefined - - {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-} - -If we expose zip's bottoming nature when simplifying the LHS of the -RULE we get - {-# RULES "foo" forall as bs. - stream (case zip of {}) = ..blah... #-} -discarding the arguments to zip. Usually this is fine, but on the -LHS of a rule it's not, because 'as' and 'bs' are now not bound on -the LHS. - -This is a pretty pathological example, so I'm not losing sleep over -it, but the simplest solution was to check sm_inline; if it is False, -which it is on the LHS of a rule (see updModeForRules), then don't -make use of the strictness info for the function. --} - - -{- -************************************************************************ -* * - Interesting arguments -* * -************************************************************************ - -Note [Interesting call context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to avoid inlining an expression where there can't possibly be -any gain, such as in an argument position. Hence, if the continuation -is interesting (eg. a case scrutinee, application etc.) then we -inline, otherwise we don't. - -Previously some_benefit used to return True only if the variable was -applied to some value arguments. This didn't work: - - let x = _coerce_ (T Int) Int (I# 3) in - case _coerce_ Int (T Int) x of - I# y -> .... - -we want to inline x, but can't see that it's a constructor in a case -scrutinee position, and some_benefit is False. - -Another example: - -dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) - -.... case dMonadST _@_ x0 of (a,b,c) -> .... - -we'd really like to inline dMonadST here, but we *don't* want to -inline if the case expression is just - - case x of y { DEFAULT -> ... } - -since we can just eliminate this case instead (x is in WHNF). Similar -applies when x is bound to a lambda expression. Hence -contIsInteresting looks for case expressions with just a single -default case. - -Note [No case of case is boring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see - case f x of - -we'd usually treat the context as interesting, to encourage 'f' to -inline. But if case-of-case is off, it's really not so interesting -after all, because we are unlikely to be able to push the case -expression into the branches of any case in f's unfolding. So, to -reduce unnecessary code expansion, we just make the context look boring. -This made a small compile-time perf improvement in perf/compiler/T6048, -and it looks plausible to me. --} - -interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt --- See Note [Interesting call context] -interestingCallContext env cont - = interesting cont - where - interesting (Select {}) - | sm_case_case (getMode env) = CaseCtxt - | otherwise = BoringCtxt - -- See Note [No case of case is boring] - - interesting (ApplyToVal {}) = ValAppCtxt - -- Can happen if we have (f Int |> co) y - -- If f has an INLINE prag we need to give it some - -- motivation to inline. See Note [Cast then apply] - -- in GHC.Core.Unfold - - interesting (StrictArg { sc_cci = cci }) = cci - interesting (StrictBind {}) = BoringCtxt - interesting (Stop _ cci) = cci - interesting (TickIt _ k) = interesting k - interesting (ApplyToTy { sc_cont = k }) = interesting k - interesting (CastIt _ k) = interesting k - -- If this call is the arg of a strict function, the context - -- is a bit interesting. If we inline here, we may get useful - -- evaluation information to avoid repeated evals: e.g. - -- x + (y * z) - -- Here the contIsInteresting makes the '*' keener to inline, - -- which in turn exposes a constructor which makes the '+' inline. - -- Assuming that +,* aren't small enough to inline regardless. - -- - -- It's also very important to inline in a strict context for things - -- like - -- foldr k z (f x) - -- Here, the context of (f x) is strict, and if f's unfolding is - -- a build it's *great* to inline it here. So we must ensure that - -- the context for (f x) is not totally uninteresting. - -interestingArgContext :: [CoreRule] -> SimplCont -> Bool --- If the argument has form (f x y), where x,y are boring, --- and f is marked INLINE, then we don't want to inline f. --- But if the context of the argument is --- g (f x y) --- where g has rules, then we *do* want to inline f, in case it --- exposes a rule that might fire. Similarly, if the context is --- h (g (f x x)) --- where h has rules, then we do want to inline f; hence the --- call_cont argument to interestingArgContext --- --- The ai-rules flag makes this happen; if it's --- set, the inliner gets just enough keener to inline f --- regardless of how boring f's arguments are, if it's marked INLINE --- --- The alternative would be to *always* inline an INLINE function, --- regardless of how boring its context is; but that seems overkill --- For example, it'd mean that wrapper functions were always inlined --- --- The call_cont passed to interestingArgContext is the context of --- the call itself, e.g. g in the example above -interestingArgContext rules call_cont - = notNull rules || enclosing_fn_has_rules - where - enclosing_fn_has_rules = go call_cont - - go (Select {}) = False - go (ApplyToVal {}) = False -- Shouldn't really happen - go (ApplyToTy {}) = False -- Ditto - go (StrictArg { sc_cci = cci }) = interesting cci - go (StrictBind {}) = False -- ?? - go (CastIt _ c) = go c - go (Stop _ cci) = interesting cci - go (TickIt _ c) = go c - - interesting RuleArgCtxt = True - interesting _ = False - - -{- Note [Interesting arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An argument is interesting if it deserves a discount for unfoldings -with a discount in that argument position. The idea is to avoid -unfolding a function that is applied only to variables that have no -unfolding (i.e. they are probably lambda bound): f x y z There is -little point in inlining f here. - -Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But -we must look through lets, eg (let x = e in C a b), because the let will -float, exposing the value, if we inline. That makes it different to -exprIsHNF. - -Before 2009 we said it was interesting if the argument had *any* structure -at all; i.e. (hasSomeUnfolding v). But does too much inlining; see #3016. - -But we don't regard (f x y) as interesting, unless f is unsaturated. -If it's saturated and f hasn't inlined, then it's probably not going -to now! - -Note [Conlike is interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f d = ...((*) d x y)... - ... f (df d')... -where df is con-like. Then we'd really like to inline 'f' so that the -rule for (*) (df d) can fire. To do this - a) we give a discount for being an argument of a class-op (eg (*) d) - b) we say that a con-like argument (eg (df d)) is interesting --} - -interestingArg :: SimplEnv -> CoreExpr -> ArgSummary --- See Note [Interesting arguments] -interestingArg env e = go env 0 e - where - -- n is # value args to which the expression is applied - go env n (Var v) - = case substId env v of - DoneId v' -> go_var n v' - DoneEx e _ -> go (zapSubstEnv env) n e - ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e - - go _ _ (Lit {}) = ValueArg - go _ _ (Type _) = TrivArg - go _ _ (Coercion _) = TrivArg - go env n (App fn (Type _)) = go env n fn - go env n (App fn _) = go env (n+1) fn - go env n (Tick _ a) = go env n a - go env n (Cast e _) = go env n e - go env n (Lam v e) - | isTyVar v = go env n e - | n>0 = NonTrivArg -- (\x.b) e is NonTriv - | otherwise = ValueArg - go _ _ (Case {}) = NonTrivArg - go env n (Let b e) = case go env' n e of - ValueArg -> ValueArg - _ -> NonTrivArg - where - env' = env `addNewInScopeIds` bindersOf b - - go_var n v - | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that - -- data constructors here - | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding - | n > 0 = NonTrivArg -- Saturated or unknown call - | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding - -- See Note [Conlike is interesting] - | otherwise = TrivArg -- n==0, no useful unfolding - where - conlike_unfolding = isConLikeUnfolding (idUnfolding v) - -{- -************************************************************************ -* * - SimplMode -* * -************************************************************************ - -The SimplMode controls several switches; see its definition in -GHC.Core.Op.Monad - sm_rules :: Bool -- Whether RULES are enabled - sm_inline :: Bool -- Whether inlining is enabled - sm_case_case :: Bool -- Whether case-of-case is enabled - sm_eta_expand :: Bool -- Whether eta-expansion is enabled --} - -simplEnvForGHCi :: DynFlags -> SimplEnv -simplEnvForGHCi dflags - = mkSimplEnv $ SimplMode { sm_names = ["GHCi"] - , sm_phase = InitialPhase - , sm_dflags = dflags - , sm_rules = rules_on - , sm_inline = False - , sm_eta_expand = eta_expand_on - , sm_case_case = True } - where - rules_on = gopt Opt_EnableRewriteRules dflags - eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags - -- Do not do any inlining, in case we expose some unboxed - -- tuple stuff that confuses the bytecode interpreter - -updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode --- See Note [Simplifying inside stable unfoldings] -updModeForStableUnfoldings inline_rule_act current_mode - = current_mode { sm_phase = phaseFromActivation inline_rule_act - , sm_inline = True - , sm_eta_expand = False } - -- sm_eta_expand: see Note [No eta expansion in stable unfoldings] - -- For sm_rules, just inherit; sm_rules might be "off" - -- because of -fno-enable-rewrite-rules - where - phaseFromActivation (ActiveAfter _ n) = Phase n - phaseFromActivation _ = InitialPhase - -updModeForRules :: SimplMode -> SimplMode --- See Note [Simplifying rules] -updModeForRules current_mode - = current_mode { sm_phase = InitialPhase - , sm_inline = False -- See Note [Do not expose strictness if sm_inline=False] - , sm_rules = False - , sm_eta_expand = False } - -{- Note [Simplifying rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When simplifying a rule LHS, refrain from /any/ inlining or applying -of other RULES. - -Doing anything to the LHS is plain confusing, because it means that what the -rule matches is not what the user wrote. c.f. #10595, and #10528. -Moreover, inlining (or applying rules) on rule LHSs risks introducing -Ticks into the LHS, which makes matching trickier. #10665, #10745. - -Doing this to either side confounds tools like HERMIT, which seek to reason -about and apply the RULES as originally written. See #10829. - -Note [No eta expansion in stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have a stable unfolding - - f :: Ord a => a -> IO () - -- Unfolding template - -- = /\a \(d:Ord a) (x:a). bla - -we do not want to eta-expand to - - f :: Ord a => a -> IO () - -- Unfolding template - -- = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co - -because not specialisation of the overloading doesn't work properly -(see Note [Specialisation shape] in GHC.Core.Op.Specialise), #9509. - -So we disable eta-expansion in stable unfoldings. - -Note [Inlining in gentle mode] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Something is inlined if - (i) the sm_inline flag is on, AND - (ii) the thing has an INLINE pragma, AND - (iii) the thing is inlinable in the earliest phase. - -Example of why (iii) is important: - {-# INLINE [~1] g #-} - g = ... - - {-# INLINE f #-} - f x = g (g x) - -If we were to inline g into f's inlining, then an importing module would -never be able to do - f e --> g (g e) ---> RULE fires -because the stable unfolding for f has had g inlined into it. - -On the other hand, it is bad not to do ANY inlining into an -stable unfolding, because then recursive knots in instance declarations -don't get unravelled. - -However, *sometimes* SimplGently must do no call-site inlining at all -(hence sm_inline = False). Before full laziness we must be careful -not to inline wrappers, because doing so inhibits floating - e.g. ...(case f x of ...)... - ==> ...(case (case x of I# x# -> fw x#) of ...)... - ==> ...(case x of I# x# -> case fw x# of ...)... -and now the redex (f x) isn't floatable any more. - -The no-inlining thing is also important for Template Haskell. You might be -compiling in one-shot mode with -O2; but when TH compiles a splice before -running it, we don't want to use -O2. Indeed, we don't want to inline -anything, because the byte-code interpreter might get confused about -unboxed tuples and suchlike. - -Note [Simplifying inside stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must take care with simplification inside stable unfoldings (which come from -INLINE pragmas). - -First, consider the following example - let f = \pq -> BIG - in - let g = \y -> f y y - {-# INLINE g #-} - in ...g...g...g...g...g... -Now, if that's the ONLY occurrence of f, it might be inlined inside g, -and thence copied multiple times when g is inlined. HENCE we treat -any occurrence in a stable unfolding as a multiple occurrence, not a single -one; see OccurAnal.addRuleUsage. - -Second, we do want *do* to some modest rules/inlining stuff in stable -unfoldings, partly to eliminate senseless crap, and partly to break -the recursive knots generated by instance declarations. - -However, suppose we have - {-# INLINE f #-} - f = -meaning "inline f in phases p where activation (p) holds". -Then what inlinings/rules can we apply to the copy of captured in -f's stable unfolding? Our model is that literally is substituted for -f when it is inlined. So our conservative plan (implemented by -updModeForStableUnfoldings) is this: - - ------------------------------------------------------------- - When simplifying the RHS of a stable unfolding, set the phase - to the phase in which the stable unfolding first becomes active - ------------------------------------------------------------- - -That ensures that - - a) Rules/inlinings that *cease* being active before p will - not apply to the stable unfolding, consistent with it being - inlined in its *original* form in phase p. - - b) Rules/inlinings that only become active *after* p will - not apply to the stable unfolding, again to be consistent with - inlining the *original* rhs in phase p. - -For example, - {-# INLINE f #-} - f x = ...g... - - {-# NOINLINE [1] g #-} - g y = ... - - {-# RULE h g = ... #-} -Here we must not inline g into f's RHS, even when we get to phase 0, -because when f is later inlined into some other module we want the -rule for h to fire. - -Similarly, consider - {-# INLINE f #-} - f x = ...g... - - g y = ... -and suppose that there are auto-generated specialisations and a strictness -wrapper for g. The specialisations get activation AlwaysActive, and the -strictness wrapper get activation (ActiveAfter 0). So the strictness -wrepper fails the test and won't be inlined into f's stable unfolding. That -means f can inline, expose the specialised call to g, so the specialisation -rules can fire. - -A note about wrappers -~~~~~~~~~~~~~~~~~~~~~ -It's also important not to inline a worker back into a wrapper. -A wrapper looks like - wraper = inline_me (\x -> ...worker... ) -Normally, the inline_me prevents the worker getting inlined into -the wrapper (initially, the worker's only call site!). But, -if the wrapper is sure to be called, the strictness analyser will -mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf -continuation. --} - -activeUnfolding :: SimplMode -> Id -> Bool -activeUnfolding mode id - | isCompulsoryUnfolding (realIdUnfolding id) - = True -- Even sm_inline can't override compulsory unfoldings - | otherwise - = isActive (sm_phase mode) (idInlineActivation id) - && sm_inline mode - -- `or` isStableUnfolding (realIdUnfolding id) - -- Inline things when - -- (a) they are active - -- (b) sm_inline says so, except that for stable unfoldings - -- (ie pragmas) we inline anyway - -getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv --- When matching in RULE, we want to "look through" an unfolding --- (to see a constructor) if *rules* are on, even if *inlinings* --- are not. A notable example is DFuns, which really we want to --- match in rules like (op dfun) in gentle mode. Another example --- is 'otherwise' which we want exprIsConApp_maybe to be able to --- see very early on -getUnfoldingInRuleMatch env - = (in_scope, id_unf) - where - in_scope = seInScope env - mode = getMode env - id_unf id | unf_is_active id = idUnfolding id - | otherwise = NoUnfolding - unf_is_active id - | not (sm_rules mode) = -- active_unfolding_minimal id - isStableUnfolding (realIdUnfolding id) - -- Do we even need to test this? I think this InScopeEnv - -- is only consulted if activeRule returns True, which - -- never happens if sm_rules is False - | otherwise = isActive (sm_phase mode) (idInlineActivation id) - ----------------------- -activeRule :: SimplMode -> Activation -> Bool --- Nothing => No rules at all -activeRule mode - | not (sm_rules mode) = \_ -> False -- Rewriting is off - | otherwise = isActive (sm_phase mode) - -{- -************************************************************************ -* * - preInlineUnconditionally -* * -************************************************************************ - -preInlineUnconditionally -~~~~~~~~~~~~~~~~~~~~~~~~ -@preInlineUnconditionally@ examines a bndr to see if it is used just -once in a completely safe way, so that it is safe to discard the -binding inline its RHS at the (unique) usage site, REGARDLESS of how -big the RHS might be. If this is the case we don't simplify the RHS -first, but just inline it un-simplified. - -This is much better than first simplifying a perhaps-huge RHS and then -inlining and re-simplifying it. Indeed, it can be at least quadratically -better. Consider - - x1 = e1 - x2 = e2[x1] - x3 = e3[x2] - ...etc... - xN = eN[xN-1] - -We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc. -This can happen with cascades of functions too: - - f1 = \x1.e1 - f2 = \xs.e2[f1] - f3 = \xs.e3[f3] - ...etc... - -THE MAIN INVARIANT is this: - - ---- preInlineUnconditionally invariant ----- - IF preInlineUnconditionally chooses to inline x = - THEN doing the inlining should not change the occurrence - info for the free vars of - ---------------------------------------------- - -For example, it's tempting to look at trivial binding like - x = y -and inline it unconditionally. But suppose x is used many times, -but this is the unique occurrence of y. Then inlining x would change -y's occurrence info, which breaks the invariant. It matters: y -might have a BIG rhs, which will now be dup'd at every occurrence of x. - - -Even RHSs labelled InlineMe aren't caught here, because there might be -no benefit from inlining at the call site. - -[Sept 01] Don't unconditionally inline a top-level thing, because that -can simply make a static thing into something built dynamically. E.g. - x = (a,b) - main = \s -> h x - -[Remember that we treat \s as a one-shot lambda.] No point in -inlining x unless there is something interesting about the call site. - -But watch out: if you aren't careful, some useful foldr/build fusion -can be lost (most notably in spectral/hartel/parstof) because the -foldr didn't see the build. Doing the dynamic allocation isn't a big -deal, in fact, but losing the fusion can be. But the right thing here -seems to be to do a callSiteInline based on the fact that there is -something interesting about the call site (it's strict). Hmm. That -seems a bit fragile. - -Conclusion: inline top level things gaily until Phase 0 (the last -phase), at which point don't. - -Note [pre/postInlineUnconditionally in gentle mode] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even in gentle mode we want to do preInlineUnconditionally. The -reason is that too little clean-up happens if you don't inline -use-once things. Also a bit of inlining is *good* for full laziness; -it can expose constant sub-expressions. Example in -spectral/mandel/Mandel.hs, where the mandelset function gets a useful -let-float if you inline windowToViewport - -However, as usual for Gentle mode, do not inline things that are -inactive in the initial stages. See Note [Gentle mode]. - -Note [Stable unfoldings and preInlineUnconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas! -Example - - {-# INLINE f #-} - f :: Eq a => a -> a - f x = ... - - fInt :: Int -> Int - fInt = f Int dEqInt - - ...fInt...fInt...fInt... - -Here f occurs just once, in the RHS of fInt. But if we inline it there -it might make fInt look big, and we'll lose the opportunity to inline f -at each of fInt's call sites. The INLINE pragma will only inline when -the application is saturated for exactly this reason; and we don't -want PreInlineUnconditionally to second-guess it. A live example is -#3736. - c.f. Note [Stable unfoldings and postInlineUnconditionally] - -NB: if the pragma is INLINEABLE, then we don't want to behave in -this special way -- an INLINEABLE pragma just says to GHC "inline this -if you like". But if there is a unique occurrence, we want to inline -the stable unfolding, not the RHS. - -Note [Top-level bottoming Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Don't inline top-level Ids that are bottoming, even if they are used just -once, because FloatOut has gone to some trouble to extract them out. -Inlining them won't make the program run faster! - -Note [Do not inline CoVars unconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Coercion variables appear inside coercions, and the RHS of a let-binding -is a term (not a coercion) so we can't necessarily inline the latter in -the former. --} - -preInlineUnconditionally - :: SimplEnv -> TopLevelFlag -> InId - -> InExpr -> StaticEnv -- These two go together - -> Maybe SimplEnv -- Returned env has extended substitution --- Precondition: rhs satisfies the let/app invariant --- See Note [Core let/app invariant] in GHC.Core --- Reason: we don't want to inline single uses, or discard dead bindings, --- for unlifted, side-effect-ful bindings -preInlineUnconditionally env top_lvl bndr rhs rhs_env - | not pre_inline_unconditionally = Nothing - | not active = Nothing - | isTopLevel top_lvl && isBottomingId bndr = Nothing -- Note [Top-level bottoming Ids] - | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally] - | isExitJoinId bndr = Nothing -- Note [Do not inline exit join points] - -- in module Exitify - | not (one_occ (idOccInfo bndr)) = Nothing - | not (isStableUnfolding unf) = Just (extend_subst_with rhs) - - -- Note [Stable unfoldings and preInlineUnconditionally] - | isInlinablePragma inline_prag - , Just inl <- maybeUnfoldingTemplate unf = Just (extend_subst_with inl) - | otherwise = Nothing - where - unf = idUnfolding bndr - extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs) - - one_occ IAmDead = True -- Happens in ((\x.1) v) - one_occ OneOcc{ occ_one_br = InOneBranch - , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase - one_occ OneOcc{ occ_one_br = InOneBranch - , occ_in_lam = IsInsideLam - , occ_int_cxt = IsInteresting } = canInlineInLam rhs - one_occ _ = False - - pre_inline_unconditionally = gopt Opt_SimplPreInlining (seDynFlags env) - mode = getMode env - active = isActive (sm_phase mode) (inlinePragmaActivation inline_prag) - -- See Note [pre/postInlineUnconditionally in gentle mode] - inline_prag = idInlinePragma bndr - --- Be very careful before inlining inside a lambda, because (a) we must not --- invalidate occurrence information, and (b) we want to avoid pushing a --- single allocation (here) into multiple allocations (inside lambda). --- Inlining a *function* with a single *saturated* call would be ok, mind you. --- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok) --- where --- is_cheap = exprIsCheap rhs --- ok = is_cheap && int_cxt - - -- int_cxt The context isn't totally boring - -- E.g. let f = \ab.BIG in \y. map f xs - -- Don't want to substitute for f, because then we allocate - -- its closure every time the \y is called - -- But: let f = \ab.BIG in \y. map (f y) xs - -- Now we do want to substitute for f, even though it's not - -- saturated, because we're going to allocate a closure for - -- (f y) every time round the loop anyhow. - - -- canInlineInLam => free vars of rhs are (Once in_lam) or Many, - -- so substituting rhs inside a lambda doesn't change the occ info. - -- Sadly, not quite the same as exprIsHNF. - canInlineInLam (Lit _) = True - canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e - canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e - canInlineInLam _ = False - -- not ticks. Counting ticks cannot be duplicated, and non-counting - -- ticks around a Lam will disappear anyway. - - early_phase = case sm_phase mode of - Phase 0 -> False - _ -> True --- If we don't have this early_phase test, consider --- x = length [1,2,3] --- The full laziness pass carefully floats all the cons cells to --- top level, and preInlineUnconditionally floats them all back in. --- Result is (a) static allocation replaced by dynamic allocation --- (b) many simplifier iterations because this tickles --- a related problem; only one inlining per pass --- --- On the other hand, I have seen cases where top-level fusion is --- lost if we don't inline top level thing (e.g. string constants) --- Hence the test for phase zero (which is the phase for all the final --- simplifications). Until phase zero we take no special notice of --- top level things, but then we become more leery about inlining --- them. - -{- -************************************************************************ -* * - postInlineUnconditionally -* * -************************************************************************ - -postInlineUnconditionally -~~~~~~~~~~~~~~~~~~~~~~~~~ -@postInlineUnconditionally@ decides whether to unconditionally inline -a thing based on the form of its RHS; in particular if it has a -trivial RHS. If so, we can inline and discard the binding altogether. - -NB: a loop breaker has must_keep_binding = True and non-loop-breakers -only have *forward* references. Hence, it's safe to discard the binding - -NOTE: This isn't our last opportunity to inline. We're at the binding -site right now, and we'll get another opportunity when we get to the -occurrence(s) - -Note that we do this unconditional inlining only for trivial RHSs. -Don't inline even WHNFs inside lambdas; doing so may simply increase -allocation when the function is called. This isn't the last chance; see -NOTE above. - -NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why? -Because we don't even want to inline them into the RHS of constructor -arguments. See NOTE above - -NB: At one time even NOINLINE was ignored here: if the rhs is trivial -it's best to inline it anyway. We often get a=E; b=a from desugaring, -with both a and b marked NOINLINE. But that seems incompatible with -our new view that inlining is like a RULE, so I'm sticking to the 'active' -story for now. --} - -postInlineUnconditionally - :: SimplEnv -> TopLevelFlag - -> OutId -- The binder (*not* a CoVar), including its unfolding - -> OccInfo -- From the InId - -> OutExpr - -> Bool --- Precondition: rhs satisfies the let/app invariant --- See Note [Core let/app invariant] in GHC.Core --- Reason: we don't want to inline single uses, or discard dead bindings, --- for unlifted, side-effect-ful bindings -postInlineUnconditionally env top_lvl bndr occ_info rhs - | not active = False - | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline - -- because it might be referred to "earlier" - | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally] - | isTopLevel top_lvl = False -- Note [Top level and postInlineUnconditionally] - | exprIsTrivial rhs = True - | otherwise - = case occ_info of - -- The point of examining occ_info here is that for *non-values* - -- that occur outside a lambda, the call-site inliner won't have - -- a chance (because it doesn't know that the thing - -- only occurs once). The pre-inliner won't have gotten - -- it either, if the thing occurs in more than one branch - -- So the main target is things like - -- let x = f y in - -- case v of - -- True -> case x of ... - -- False -> case x of ... - -- This is very important in practice; e.g. wheel-seive1 doubles - -- in allocation if you miss this out - OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt } - -- OneOcc => no code-duplication issue - -> smallEnoughToInline dflags unfolding -- Small enough to dup - -- ToDo: consider discount on smallEnoughToInline if int_cxt is true - -- - -- NB: Do NOT inline arbitrarily big things, even if one_br is True - -- Reason: doing so risks exponential behaviour. We simplify a big - -- expression, inline it, and simplify it again. But if the - -- very same thing happens in the big expression, we get - -- exponential cost! - -- PRINCIPLE: when we've already simplified an expression once, - -- make sure that we only inline it if it's reasonably small. - - && (in_lam == NotInsideLam || - -- Outside a lambda, we want to be reasonably aggressive - -- about inlining into multiple branches of case - -- e.g. let x = - -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... } - -- Inlining can be a big win if C3 is the hot-spot, even if - -- the uses in C1, C2 are not 'interesting' - -- An example that gets worse if you add int_cxt here is 'clausify' - - (isCheapUnfolding unfolding && int_cxt == IsInteresting)) - -- isCheap => acceptable work duplication; in_lam may be true - -- int_cxt to prevent us inlining inside a lambda without some - -- good reason. See the notes on int_cxt in preInlineUnconditionally - - IAmDead -> True -- This happens; for example, the case_bndr during case of - -- known constructor: case (a,b) of x { (p,q) -> ... } - -- Here x isn't mentioned in the RHS, so we don't want to - -- create the (dead) let-binding let x = (a,b) in ... - - _ -> False - --- Here's an example that we don't handle well: --- let f = if b then Left (\x.BIG) else Right (\y.BIG) --- in \y. ....case f of {...} .... --- Here f is used just once, and duplicating the case work is fine (exprIsCheap). --- But --- - We can't preInlineUnconditionally because that would invalidate --- the occ info for b. --- - We can't postInlineUnconditionally because the RHS is big, and --- that risks exponential behaviour --- - We can't call-site inline, because the rhs is big --- Alas! - - where - unfolding = idUnfolding bndr - dflags = seDynFlags env - active = isActive (sm_phase (getMode env)) (idInlineActivation bndr) - -- See Note [pre/postInlineUnconditionally in gentle mode] - -{- -Note [Top level and postInlineUnconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't do postInlineUnconditionally for top-level things (even for -ones that are trivial): - - * Doing so will inline top-level error expressions that have been - carefully floated out by FloatOut. More generally, it might - replace static allocation with dynamic. - - * Even for trivial expressions there's a problem. Consider - {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-} - blah xs = reverse xs - ruggle = sort - In one simplifier pass we might fire the rule, getting - blah xs = ruggle xs - but in *that* simplifier pass we must not do postInlineUnconditionally - on 'ruggle' because then we'll have an unbound occurrence of 'ruggle' - - If the rhs is trivial it'll be inlined by callSiteInline, and then - the binding will be dead and discarded by the next use of OccurAnal - - * There is less point, because the main goal is to get rid of local - bindings used in multiple case branches. - - * The inliner should inline trivial things at call sites anyway. - - * The Id might be exported. We could check for that separately, - but since we aren't going to postInlineUnconditionally /any/ - top-level bindings, we don't need to test. - -Note [Stable unfoldings and postInlineUnconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do not do postInlineUnconditionally if the Id has a stable unfolding, -otherwise we lose the unfolding. Example - - -- f has stable unfolding with rhs (e |> co) - -- where 'e' is big - f = e |> co - -Then there's a danger we'll optimise to - - f' = e - f = f' |> co - -and now postInlineUnconditionally, losing the stable unfolding on f. Now f' -won't inline because 'e' is too big. - - c.f. Note [Stable unfoldings and preInlineUnconditionally] - - -************************************************************************ -* * - Rebuilding a lambda -* * -************************************************************************ --} - -mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr --- mkLam tries three things --- a) eta reduction, if that gives a trivial expression --- b) eta expansion [only if there are some value lambdas] - -mkLam _env [] body _cont - = return body -mkLam env bndrs body cont - = do { dflags <- getDynFlags - ; mkLam' dflags bndrs body } - where - mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr - mkLam' dflags bndrs (Cast body co) - | not (any bad bndrs) - -- Note [Casts and lambdas] - = do { lam <- mkLam' dflags bndrs body - ; return (mkCast lam (mkPiCos Representational bndrs co)) } - where - co_vars = tyCoVarsOfCo co - bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars - - mkLam' dflags bndrs body@(Lam {}) - = mkLam' dflags (bndrs ++ bndrs1) body1 - where - (bndrs1, body1) = collectBinders body - - mkLam' dflags bndrs (Tick t expr) - | tickishFloatable t - = mkTick t <$> mkLam' dflags bndrs expr - - mkLam' dflags bndrs body - | gopt Opt_DoEtaReduction dflags - , Just etad_lam <- tryEtaReduce bndrs body - = do { tick (EtaReduction (head bndrs)) - ; return etad_lam } - - | not (contIsRhs cont) -- See Note [Eta-expanding lambdas] - , sm_eta_expand (getMode env) - , any isRuntimeVar bndrs - , let body_arity = exprEtaExpandArity dflags body - , body_arity > 0 - = do { tick (EtaExpansion (head bndrs)) - ; let res = mkLams bndrs (etaExpand body_arity body) - ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body) - , text "after" <+> ppr res]) - ; return res } - - | otherwise - = return (mkLams bndrs body) - -{- -Note [Eta expanding lambdas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we *do* want to eta-expand lambdas. Consider - f (\x -> case x of (a,b) -> \s -> blah) -where 's' is a state token, and hence can be eta expanded. This -showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather -important function! - -The eta-expansion will never happen unless we do it now. (Well, it's -possible that CorePrep will do it, but CorePrep only has a half-baked -eta-expander that can't deal with casts. So it's much better to do it -here.) - -However, when the lambda is let-bound, as the RHS of a let, we have a -better eta-expander (in the form of tryEtaExpandRhs), so we don't -bother to try expansion in mkLam in that case; hence the contIsRhs -guard. - -NB: We check the SimplEnv (sm_eta_expand), not DynFlags. - See Note [No eta expansion in stable unfoldings] - -Note [Casts and lambdas] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - (\x. (\y. e) `cast` g1) `cast` g2 -There is a danger here that the two lambdas look separated, and the -full laziness pass might float an expression to between the two. - -So this equation in mkLam' floats the g1 out, thus: - (\x. e `cast` g1) --> (\x.e) `cast` (tx -> g1) -where x:tx. - -In general, this floats casts outside lambdas, where (I hope) they -might meet and cancel with some other cast: - \x. e `cast` co ===> (\x. e) `cast` (tx -> co) - /\a. e `cast` co ===> (/\a. e) `cast` (/\a. co) - /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co) - (if not (g `in` co)) - -Notice that it works regardless of 'e'. Originally it worked only -if 'e' was itself a lambda, but in some cases that resulted in -fruitless iteration in the simplifier. A good example was when -compiling Text.ParserCombinators.ReadPrec, where we had a definition -like (\x. Get `cast` g) -where Get is a constructor with nonzero arity. Then mkLam eta-expanded -the Get, and the next iteration eta-reduced it, and then eta-expanded -it again. - -Note also the side condition for the case of coercion binders. -It does not make sense to transform - /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g) -because the latter is not well-kinded. - -************************************************************************ -* * - Eta expansion -* * -************************************************************************ --} - -tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr - -> SimplM (Arity, Bool, OutExpr) --- See Note [Eta-expanding at let bindings] --- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then --- (a) rhs' has manifest arity n --- (b) if is_bot is True then rhs' applied to n args is guaranteed bottom -tryEtaExpandRhs mode bndr rhs - | Just join_arity <- isJoinId_maybe bndr - = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs - ; return (count isId join_bndrs, exprIsBottom join_body, rhs) } - -- Note [Do not eta-expand join points] - -- But do return the correct arity and bottom-ness, because - -- these are used to set the bndr's IdInfo (#15517) - -- Note [Invariants on join points] invariant 2b, in GHC.Core - - | otherwise - = do { (new_arity, is_bot, new_rhs) <- try_expand - - ; WARN( new_arity < old_id_arity, - (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity - <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) ) - -- Note [Arity decrease] in GHC.Core.Op.Simplify - return (new_arity, is_bot, new_rhs) } - where - try_expand - | exprIsTrivial rhs - = return (exprArity rhs, False, rhs) - - | sm_eta_expand mode -- Provided eta-expansion is on - , new_arity > old_arity -- And the current manifest arity isn't enough - = do { tick (EtaExpansion bndr) - ; return (new_arity, is_bot, etaExpand new_arity rhs) } - - | otherwise - = return (old_arity, is_bot && new_arity == old_arity, rhs) - - dflags = sm_dflags mode - old_arity = exprArity rhs -- See Note [Do not expand eta-expand PAPs] - old_id_arity = idArity bndr - - (new_arity1, is_bot) = findRhsArity dflags bndr rhs old_arity - new_arity2 = idCallArity bndr - new_arity = max new_arity1 new_arity2 - -{- -Note [Eta-expanding at let bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We now eta expand at let-bindings, which is where the payoff comes. -The most significant thing is that we can do a simple arity analysis -(in GHC.Core.Arity.findRhsArity), which we can't do for free-floating lambdas - -One useful consequence of not eta-expanding lambdas is this example: - genMap :: C a => ... - {-# INLINE genMap #-} - genMap f xs = ... - - myMap :: D a => ... - {-# INLINE myMap #-} - myMap = genMap - -Notice that 'genMap' should only inline if applied to two arguments. -In the stable unfolding for myMap we'll have the unfolding - (\d -> genMap Int (..d..)) -We do not want to eta-expand to - (\d f xs -> genMap Int (..d..) f xs) -because then 'genMap' will inline, and it really shouldn't: at least -as far as the programmer is concerned, it's not applied to two -arguments! - -Note [Do not eta-expand join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Similarly to CPR (see Note [Don't w/w join points for CPR] in -GHC.Core.Op.WorkWrap), a join point stands well to gain from its outer binding's -eta-expansion, and eta-expanding a join point is fraught with issues like how to -deal with a cast: - - let join $j1 :: IO () - $j1 = ... - $j2 :: Int -> IO () - $j2 n = if n > 0 then $j1 - else ... - - => - - let join $j1 :: IO () - $j1 = (\eta -> ...) - `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) - ~ IO () - $j2 :: Int -> IO () - $j2 n = (\eta -> if n > 0 then $j1 - else ...) - `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) - ~ IO () - -The cast here can't be pushed inside the lambda (since it's not casting to a -function type), so the lambda has to stay, but it can't because it contains a -reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather -than try and detect this situation (and whatever other situations crop up!), we -don't bother; again, any surrounding eta-expansion will improve these join -points anyway, since an outer cast can *always* be pushed inside. By the time -CorePrep comes around, the code is very likely to look more like this: - - let join $j1 :: State# RealWorld -> (# State# RealWorld, ()) - $j1 = (...) eta - $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ()) - $j2 = if n > 0 then $j1 - else (...) eta - -Note [Do not eta-expand PAPs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to have old_arity = manifestArity rhs, which meant that we -would eta-expand even PAPs. But this gives no particular advantage, -and can lead to a massive blow-up in code size, exhibited by #9020. -Suppose we have a PAP - foo :: IO () - foo = returnIO () -Then we can eta-expand do - foo = (\eta. (returnIO () |> sym g) eta) |> g -where - g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #) - -But there is really no point in doing this, and it generates masses of -coercions and whatnot that eventually disappear again. For T9020, GHC -allocated 6.6G before, and 0.8G afterwards; and residency dropped from -1.8G to 45M. - -But note that this won't eta-expand, say - f = \g -> map g -Does it matter not eta-expanding such functions? I'm not sure. Perhaps -strictness analysis will have less to bite on? - - -************************************************************************ -* * -\subsection{Floating lets out of big lambdas} -* * -************************************************************************ - -Note [Floating and type abstraction] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - x = /\a. C e1 e2 -We'd like to float this to - y1 = /\a. e1 - y2 = /\a. e2 - x = /\a. C (y1 a) (y2 a) -for the usual reasons: we want to inline x rather vigorously. - -You may think that this kind of thing is rare. But in some programs it is -common. For example, if you do closure conversion you might get: - - data a :-> b = forall e. (e -> a -> b) :$ e - - f_cc :: forall a. a :-> a - f_cc = /\a. (\e. id a) :$ () - -Now we really want to inline that f_cc thing so that the -construction of the closure goes away. - -So I have elaborated simplLazyBind to understand right-hand sides that look -like - /\ a1..an. body - -and treat them specially. The real work is done in -GHC.Core.Op.Simplify.Utils.abstractFloats, but there is quite a bit of plumbing -in simplLazyBind as well. - -The same transformation is good when there are lets in the body: - - /\abc -> let(rec) x = e in b - ==> - let(rec) x' = /\abc -> let x = x' a b c in e - in - /\abc -> let x = x' a b c in b - -This is good because it can turn things like: - - let f = /\a -> letrec g = ... g ... in g -into - letrec g' = /\a -> ... g' a ... - in - let f = /\ a -> g' a - -which is better. In effect, it means that big lambdas don't impede -let-floating. - -This optimisation is CRUCIAL in eliminating the junk introduced by -desugaring mutually recursive definitions. Don't eliminate it lightly! - -[May 1999] If we do this transformation *regardless* then we can -end up with some pretty silly stuff. For example, - - let - st = /\ s -> let { x1=r1 ; x2=r2 } in ... - in .. -becomes - let y1 = /\s -> r1 - y2 = /\s -> r2 - st = /\s -> ...[y1 s/x1, y2 s/x2] - in .. - -Unless the "..." is a WHNF there is really no point in doing this. -Indeed it can make things worse. Suppose x1 is used strictly, -and is of the form - - x1* = case f y of { (a,b) -> e } - -If we abstract this wrt the tyvar we then can't do the case inline -as we would normally do. - -That's why the whole transformation is part of the same process that -floats let-bindings and constructor arguments out of RHSs. In particular, -it is guarded by the doFloatFromRhs call in simplLazyBind. - -Note [Which type variables to abstract over] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Abstract only over the type variables free in the rhs wrt which the -new binding is abstracted. Note that - - * The naive approach of abstracting wrt the - tyvars free in the Id's /type/ fails. Consider: - /\ a b -> let t :: (a,b) = (e1, e2) - x :: a = fst t - in ... - Here, b isn't free in x's type, but we must nevertheless - abstract wrt b as well, because t's type mentions b. - Since t is floated too, we'd end up with the bogus: - poly_t = /\ a b -> (e1, e2) - poly_x = /\ a -> fst (poly_t a *b*) - - * We must do closeOverKinds. Example (#10934): - f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ... - Here we want to float 't', but we must remember to abstract over - 'k' as well, even though it is not explicitly mentioned in the RHS, - otherwise we get - t = /\ (f:k->*) (a:k). AccFailure @ (f a) - which is obviously bogus. --} - -abstractFloats :: DynFlags -> TopLevelFlag -> [OutTyVar] -> SimplFloats - -> OutExpr -> SimplM ([OutBind], OutExpr) -abstractFloats dflags top_lvl main_tvs floats body - = ASSERT( notNull body_floats ) - ASSERT( isNilOL (sfJoinFloats floats) ) - do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats - ; return (float_binds, GHC.Core.Subst.substExpr (text "abstract_floats1") subst body) } - where - is_top_lvl = isTopLevel top_lvl - main_tv_set = mkVarSet main_tvs - body_floats = letFloatBinds (sfLetFloats floats) - empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats) - - abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind) - abstract subst (NonRec id rhs) - = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id - ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs' - subst' = GHC.Core.Subst.extendIdSubst subst id poly_app - ; return (subst', NonRec poly_id2 poly_rhs) } - where - rhs' = GHC.Core.Subst.substExpr (text "abstract_floats2") subst rhs - - -- tvs_here: see Note [Which type variables to abstract over] - tvs_here = scopedSort $ - filter (`elemVarSet` main_tv_set) $ - closeOverKindsList $ - exprSomeFreeVarsList isTyVar rhs' - - abstract subst (Rec prs) - = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids - ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps) - poly_pairs = [ mk_poly2 poly_id tvs_here rhs' - | (poly_id, rhs) <- poly_ids `zip` rhss - , let rhs' = GHC.Core.Subst.substExpr (text "abstract_floats") - subst' rhs ] - ; return (subst', Rec poly_pairs) } - where - (ids,rhss) = unzip prs - -- For a recursive group, it's a bit of a pain to work out the minimal - -- set of tyvars over which to abstract: - -- /\ a b c. let x = ...a... in - -- letrec { p = ...x...q... - -- q = .....p...b... } in - -- ... - -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted - -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'. - -- Since it's a pain, we just use the whole set, which is always safe - -- - -- If you ever want to be more selective, remember this bizarre case too: - -- x::a = x - -- Here, we must abstract 'x' over 'a'. - tvs_here = scopedSort main_tvs - - mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr) - mk_poly1 tvs_here var - = do { uniq <- getUniqueM - ; let poly_name = setNameUnique (idName var) uniq -- Keep same name - poly_ty = mkInvForAllTys tvs_here (idType var) -- But new type of course - poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id - mkLocalId poly_name poly_ty - ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } - -- In the olden days, it was crucial to copy the occInfo of the original var, - -- because we were looking at occurrence-analysed but as yet unsimplified code! - -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking - -- at already simplified code, so it doesn't matter - -- - -- It's even right to retain single-occurrence or dead-var info: - -- Suppose we started with /\a -> let x = E in B - -- where x occurs once in B. Then we transform to: - -- let x' = /\a -> E in /\a -> let x* = x' a in B - -- where x* has an INLINE prag on it. Now, once x* is inlined, - -- the occurrences of x' will be just the occurrences originally - -- pinned on x. - - mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr) - mk_poly2 poly_id tvs_here rhs - = (poly_id `setIdUnfolding` unf, poly_rhs) - where - poly_rhs = mkLams tvs_here rhs - unf = mkUnfolding dflags InlineRhs is_top_lvl False poly_rhs - - -- We want the unfolding. Consider - -- let - -- x = /\a. let y = ... in Just y - -- in body - -- Then we float the y-binding out (via abstractFloats and addPolyBind) - -- but 'x' may well then be inlined in 'body' in which case we'd like the - -- opportunity to inline 'y' too. - -{- -Note [Abstract over coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the -type variable a. Rather than sort this mess out, we simply bale out and abstract -wrt all the type variables if any of them are coercion variables. - - -Historical note: if you use let-bindings instead of a substitution, beware of this: - - -- Suppose we start with: - -- - -- x = /\ a -> let g = G in E - -- - -- Then we'll float to get - -- - -- x = let poly_g = /\ a -> G - -- in /\ a -> let g = poly_g a in E - -- - -- But now the occurrence analyser will see just one occurrence - -- of poly_g, not inside a lambda, so the simplifier will - -- PreInlineUnconditionally poly_g back into g! Badk to square 1! - -- (I used to think that the "don't inline lone occurrences" stuff - -- would stop this happening, but since it's the *only* occurrence, - -- PreInlineUnconditionally kicks in first!) - -- - -- Solution: put an INLINE note on g's RHS, so that poly_g seems - -- to appear many times. (NB: mkInlineMe eliminates - -- such notes on trivial RHSs, so do it manually.) - -************************************************************************ -* * - prepareAlts -* * -************************************************************************ - -prepareAlts tries these things: - -1. Eliminate alternatives that cannot match, including the - DEFAULT alternative. - -2. If the DEFAULT alternative can match only one possible constructor, - then make that constructor explicit. - e.g. - case e of x { DEFAULT -> rhs } - ===> - case e of x { (a,b) -> rhs } - where the type is a single constructor type. This gives better code - when rhs also scrutinises x or e. - -3. Returns a list of the constructors that cannot holds in the - DEFAULT alternative (if there is one) - -Here "cannot match" includes knowledge from GADTs - -It's a good idea to do this stuff before simplifying the alternatives, to -avoid simplifying alternatives we know can't happen, and to come up with -the list of constructors that are handled, to put into the IdInfo of the -case binder, for use when simplifying the alternatives. - -Eliminating the default alternative in (1) isn't so obvious, but it can -happen: - -data Colour = Red | Green | Blue - -f x = case x of - Red -> .. - Green -> .. - DEFAULT -> h x - -h y = case y of - Blue -> .. - DEFAULT -> [ case y of ... ] - -If we inline h into f, the default case of the inlined h can't happen. -If we don't notice this, we may end up filtering out *all* the cases -of the inner case y, which give us nowhere to go! --} - -prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) --- The returned alternatives can be empty, none are possible -prepareAlts scrut case_bndr' alts - | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr') - -- Case binder is needed just for its type. Note that as an - -- OutId, it has maximum information; this is important. - -- Test simpl013 is an example - = do { us <- getUniquesM - ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts - (yes2, alts2) = refineDefaultAlt us tc tys idcs1 alts1 - (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2 - -- "idcs" stands for "impossible default data constructors" - -- i.e. the constructors that can't match the default case - ; when yes2 $ tick (FillInCaseDefault case_bndr') - ; when yes3 $ tick (AltMerge case_bndr') - ; return (idcs3, alts3) } - - | otherwise -- Not a data type, so nothing interesting happens - = return ([], alts) - where - imposs_cons = case scrut of - Var v -> otherCons (idUnfolding v) - _ -> [] - - -{- -************************************************************************ -* * - mkCase -* * -************************************************************************ - -mkCase tries these things - -* Note [Nerge nested cases] -* Note [Eliminate identity case] -* Note [Scrutinee constant folding] - -Note [Merge Nested Cases] -~~~~~~~~~~~~~~~~~~~~~~~~~ - case e of b { ==> case e of b { - p1 -> rhs1 p1 -> rhs1 - ... ... - pm -> rhsm pm -> rhsm - _ -> case b of b' { pn -> let b'=b in rhsn - pn -> rhsn ... - ... po -> let b'=b in rhso - po -> rhso _ -> let b'=b in rhsd - _ -> rhsd - } - -which merges two cases in one case when -- the default alternative of -the outer case scrutises the same variable as the outer case. This -transformation is called Case Merging. It avoids that the same -variable is scrutinised multiple times. - -Note [Eliminate Identity Case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - case e of ===> e - True -> True; - False -> False - -and similar friends. - -Note [Scrutinee Constant Folding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - case x op# k# of _ { ===> case x of _ { - a1# -> e1 (a1# inv_op# k#) -> e1 - a2# -> e2 (a2# inv_op# k#) -> e2 - ... ... - DEFAULT -> ed DEFAULT -> ed - - where (x op# k#) inv_op# k# == x - -And similarly for commuted arguments and for some unary operations. - -The purpose of this transformation is not only to avoid an arithmetic -operation at runtime but to allow other transformations to apply in cascade. - -Example with the "Merge Nested Cases" optimization (from #12877): - - main = case t of t0 - 0## -> ... - DEFAULT -> case t0 `minusWord#` 1## of t1 - 0## -> ... - DEFAULT -> case t1 `minusWord#` 1## of t2 - 0## -> ... - DEFAULT -> case t2 `minusWord#` 1## of _ - 0## -> ... - DEFAULT -> ... - - becomes: - - main = case t of _ - 0## -> ... - 1## -> ... - 2## -> ... - 3## -> ... - DEFAULT -> ... - -There are some wrinkles - -* Do not apply caseRules if there is just a single DEFAULT alternative - case e +# 3# of b { DEFAULT -> rhs } - If we applied the transformation here we would (stupidly) get - case a of b' { DEFAULT -> let b = e +# 3# in rhs } - and now the process may repeat, because that let will really - be a case. - -* The type of the scrutinee might change. E.g. - case tagToEnum (x :: Int#) of (b::Bool) - False -> e1 - True -> e2 - ==> - case x of (b'::Int#) - DEFAULT -> e1 - 1# -> e2 - -* The case binder may be used in the right hand sides, so we need - to make a local binding for it, if it is alive. e.g. - case e +# 10# of b - DEFAULT -> blah...b... - 44# -> blah2...b... - ===> - case e of b' - DEFAULT -> let b = b' +# 10# in blah...b... - 34# -> let b = 44# in blah2...b... - - Note that in the non-DEFAULT cases we know what to bind 'b' to, - whereas in the DEFAULT case we must reconstruct the original value. - But NB: we use b'; we do not duplicate 'e'. - -* In dataToTag we might need to make up some fake binders; - see Note [caseRules for dataToTag] in GHC.Core.Op.ConstantFold --} - -mkCase, mkCase1, mkCase2, mkCase3 - :: DynFlags - -> OutExpr -> OutId - -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order - -> SimplM OutExpr - --------------------------------------------------- --- 1. Merge Nested Cases --------------------------------------------------- - -mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts) - | gopt Opt_CaseMerge dflags - , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) - <- stripTicksTop tickishFloatable deflt_rhs - , inner_scrut_var == outer_bndr - = do { tick (CaseMerge outer_bndr) - - ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args ) - (con, args, wrap_rhs rhs) - -- Simplifier's no-shadowing invariant should ensure - -- that outer_bndr is not shadowed by the inner patterns - wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs - -- The let is OK even for unboxed binders, - - wrapped_alts | isDeadBinder inner_bndr = inner_alts - | otherwise = map wrap_alt inner_alts - - merged_alts = mergeAlts outer_alts wrapped_alts - -- NB: mergeAlts gives priority to the left - -- case x of - -- A -> e1 - -- DEFAULT -> case x of - -- A -> e2 - -- B -> e3 - -- When we merge, we must ensure that e1 takes - -- precedence over e2 as the value for A! - - ; fmap (mkTicks ticks) $ - mkCase1 dflags scrut outer_bndr alts_ty merged_alts - } - -- Warning: don't call mkCase recursively! - -- Firstly, there's no point, because inner alts have already had - -- mkCase applied to them, so they won't have a case in their default - -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr - -- in munge_rhs may put a case into the DEFAULT branch! - -mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts - --------------------------------------------------- --- 2. Eliminate Identity Case --------------------------------------------------- - -mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case - | all identity_alt alts - = do { tick (CaseIdentity case_bndr) - ; return (mkTicks ticks $ re_cast scrut rhs1) } - where - ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts) - identity_alt (con, args, rhs) = check_eq rhs con args - - check_eq (Cast rhs co) con args -- See Note [RHS casts] - = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args - check_eq (Tick t e) alt args - = tickishFloatable t && check_eq e alt args - - check_eq (Lit lit) (LitAlt lit') _ = lit == lit' - check_eq (Var v) _ _ | v == case_bndr = True - check_eq (Var v) (DataAlt con) args - | null arg_tys, null args = v == dataConWorkId con - -- Optimisation only - check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $ - mkConApp2 con arg_tys args - check_eq _ _ _ = False - - arg_tys = tyConAppArgs (idType case_bndr) - - -- Note [RHS casts] - -- ~~~~~~~~~~~~~~~~ - -- We've seen this: - -- case e of x { _ -> x `cast` c } - -- And we definitely want to eliminate this case, to give - -- e `cast` c - -- So we throw away the cast from the RHS, and reconstruct - -- it at the other end. All the RHS casts must be the same - -- if (all identity_alt alts) holds. - -- - -- Don't worry about nested casts, because the simplifier combines them - - re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co - re_cast scrut _ = scrut - -mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts - --------------------------------------------------- --- 2. Scrutinee Constant Folding --------------------------------------------------- - -mkCase2 dflags scrut bndr alts_ty alts - | -- See Note [Scrutinee Constant Folding] - case alts of -- Not if there is just a DEFAULT alternative - [(DEFAULT,_,_)] -> False - _ -> True - , gopt Opt_CaseFolding dflags - , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut - = do { bndr' <- newId (fsLit "lwild") (exprType scrut') - - ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts - -- mapMaybeM: discard unreachable alternatives - -- See Note [Unreachable caseRules alternatives] - -- in GHC.Core.Op.ConstantFold - - ; mkCase3 dflags scrut' bndr' alts_ty $ - add_default (re_sort alts') - } - - | otherwise - = mkCase3 dflags scrut bndr alts_ty alts - where - -- We need to keep the correct association between the scrutinee and its - -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with - -- "let bndr = ... in": - -- - -- case v + 10 of y =====> case v of y - -- 20 -> e1 10 -> let y = 20 in e1 - -- DEFAULT -> e2 DEFAULT -> let y = v + 10 in e2 - -- - -- Other transformations give: =====> case v of y' - -- 10 -> let y = 20 in e1 - -- DEFAULT -> let y = y' + 10 in e2 - -- - -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules, - -- to construct an expression equivalent to the original one, for use - -- in the DEFAULT case - - tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id - -> CoreAlt -> SimplM (Maybe CoreAlt) - tx_alt tx_con mk_orig new_bndr (con, bs, rhs) - = case tx_con con of - Nothing -> return Nothing - Just con' -> do { bs' <- mk_new_bndrs new_bndr con' - ; return (Just (con', bs', rhs')) } - where - rhs' | isDeadBinder bndr = rhs - | otherwise = bindNonRec bndr orig_val rhs - - orig_val = case con of - DEFAULT -> mk_orig new_bndr - LitAlt l -> Lit l - DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs - - mk_new_bndrs new_bndr (DataAlt dc) - | not (isNullaryRepDataCon dc) - = -- For non-nullary data cons we must invent some fake binders - -- See Note [caseRules for dataToTag] in GHC.Core.Op.ConstantFold - do { us <- getUniquesM - ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc - (tyConAppArgs (idType new_bndr)) - ; return (ex_tvs ++ arg_ids) } - mk_new_bndrs _ _ = return [] - - re_sort :: [CoreAlt] -> [CoreAlt] - -- Sort the alternatives to re-establish - -- GHC.Core Note [Case expression invariants] - re_sort alts = sortBy cmpAlt alts - - add_default :: [CoreAlt] -> [CoreAlt] - -- See Note [Literal cases] - add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts - add_default alts = alts - -{- Note [Literal cases] -~~~~~~~~~~~~~~~~~~~~~~~ -If we have - case tagToEnum (a ># b) of - False -> e1 - True -> e2 - -then caseRules for TagToEnum will turn it into - case tagToEnum (a ># b) of - 0# -> e1 - 1# -> e2 - -Since the case is exhaustive (all cases are) we can convert it to - case tagToEnum (a ># b) of - DEFAULT -> e1 - 1# -> e2 - -This may generate sligthtly better code (although it should not, since -all cases are exhaustive) and/or optimise better. I'm not certain that -it's necessary, but currently we do make this change. We do it here, -NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum] -in GHC.Core.Op.ConstantFold) --} - --------------------------------------------------- --- Catch-all --------------------------------------------------- -mkCase3 _dflags scrut bndr alts_ty alts - = return (Case scrut bndr alts_ty alts) - --- See Note [Exitification] and Note [Do not inline exit join points] in --- GHC.Core.Op.Exitify --- This lives here (and not in Id) because occurrence info is only valid on --- InIds, so it's crucial that isExitJoinId is only called on freshly --- occ-analysed code. It's not a generic function you can call anywhere. -isExitJoinId :: Var -> Bool -isExitJoinId id - = isJoinId id - && isOneOcc (idOccInfo id) - && occ_in_lam (idOccInfo id) == IsInsideLam - -{- -Note [Dead binders] -~~~~~~~~~~~~~~~~~~~~ -Note that dead-ness is maintained by the simplifier, so that it is -accurate after simplification as well as before. - - -Note [Cascading case merge] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Case merging should cascade in one sweep, because it -happens bottom-up - - case e of a { - DEFAULT -> case a of b - DEFAULT -> case b of c { - DEFAULT -> e - A -> ea - B -> eb - C -> ec -==> - case e of a { - DEFAULT -> case a of b - DEFAULT -> let c = b in e - A -> let c = b in ea - B -> eb - C -> ec -==> - case e of a { - DEFAULT -> let b = a in let c = b in e - A -> let b = a in let c = b in ea - B -> let b = a in eb - C -> ec - - -However here's a tricky case that we still don't catch, and I don't -see how to catch it in one pass: - - case x of c1 { I# a1 -> - case a1 of c2 -> - 0 -> ... - DEFAULT -> case x of c3 { I# a2 -> - case a2 of ... - -After occurrence analysis (and its binder-swap) we get this - - case x of c1 { I# a1 -> - let x = c1 in -- Binder-swap addition - case a1 of c2 -> - 0 -> ... - DEFAULT -> case x of c3 { I# a2 -> - case a2 of ... - -When we simplify the inner case x, we'll see that -x=c1=I# a1. So we'll bind a2 to a1, and get - - case x of c1 { I# a1 -> - case a1 of c2 -> - 0 -> ... - DEFAULT -> case a1 of ... - -This is correct, but we can't do a case merge in this sweep -because c2 /= a1. Reason: the binding c1=I# a1 went inwards -without getting changed to c1=I# c2. - -I don't think this is worth fixing, even if I knew how. It'll -all come out in the next pass anyway. --} diff --git a/compiler/GHC/Core/Op/SpecConstr.hs b/compiler/GHC/Core/Op/SpecConstr.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/SpecConstr.hs +++ /dev/null @@ -1,2360 +0,0 @@ -{- -ToDo [Oct 2013] -~~~~~~~~~~~~~~~ -1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim) -2. Nuke NoSpecConstr - - -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[SpecConstr]{Specialise over constructors} --} - -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module GHC.Core.Op.SpecConstr( - specConstrProgram, - SpecConstrAnnotation(..) - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Core -import GHC.Core.Subst -import GHC.Core.Utils -import GHC.Core.Unfold ( couldBeSmallEnoughToInline ) -import GHC.Core.FVs ( exprsFreeVarsList ) -import GHC.Core.Op.Monad -import GHC.Types.Literal ( litIsLifted ) -import GHC.Driver.Types ( ModGuts(..) ) -import GHC.Core.Op.WorkWrap.Lib ( isWorkerSmallEnough, mkWorkerArgs ) -import GHC.Core.DataCon -import GHC.Core.Coercion hiding( substCo ) -import GHC.Core.Rules -import GHC.Core.Type hiding ( substTy ) -import GHC.Core.TyCon ( tyConName ) -import GHC.Types.Id -import GHC.Core.Ppr ( pprParendExpr ) -import GHC.Core.Make ( mkImpossibleExpr ) -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Name -import GHC.Types.Basic -import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) - , gopt, hasPprDebug ) -import Maybes ( orElse, catMaybes, isJust, isNothing ) -import GHC.Types.Demand -import GHC.Types.Cpr -import GHC.Serialized ( deserializeWithData ) -import Util -import Pair -import GHC.Types.Unique.Supply -import Outputable -import FastString -import GHC.Types.Unique.FM -import MonadUtils -import Control.Monad ( zipWithM ) -import Data.List -import PrelNames ( specTyConName ) -import GHC.Types.Module -import GHC.Core.TyCon ( TyCon ) -import GHC.Exts( SpecConstrAnnotation(..) ) -import Data.Ord( comparing ) - -{- ------------------------------------------------------ - Game plan ------------------------------------------------------ - -Consider - drop n [] = [] - drop 0 xs = [] - drop n (x:xs) = drop (n-1) xs - -After the first time round, we could pass n unboxed. This happens in -numerical code too. Here's what it looks like in Core: - - drop n xs = case xs of - [] -> [] - (y:ys) -> case n of - I# n# -> case n# of - 0 -> [] - _ -> drop (I# (n# -# 1#)) xs - -Notice that the recursive call has an explicit constructor as argument. -Noticing this, we can make a specialised version of drop - - RULE: drop (I# n#) xs ==> drop' n# xs - - drop' n# xs = let n = I# n# in ...orig RHS... - -Now the simplifier will apply the specialisation in the rhs of drop', giving - - drop' n# xs = case xs of - [] -> [] - (y:ys) -> case n# of - 0 -> [] - _ -> drop' (n# -# 1#) xs - -Much better! - -We'd also like to catch cases where a parameter is carried along unchanged, -but evaluated each time round the loop: - - f i n = if i>0 || i>n then i else f (i*2) n - -Here f isn't strict in n, but we'd like to avoid evaluating it each iteration. -In Core, by the time we've w/wd (f is strict in i) we get - - f i# n = case i# ># 0 of - False -> I# i# - True -> case n of { I# n# -> - case i# ># n# of - False -> I# i# - True -> f (i# *# 2#) n - -At the call to f, we see that the argument, n is known to be (I# n#), -and n is evaluated elsewhere in the body of f, so we can play the same -trick as above. - - -Note [Reboxing] -~~~~~~~~~~~~~~~ -We must be careful not to allocate the same constructor twice. Consider - f p = (...(case p of (a,b) -> e)...p..., - ...let t = (r,s) in ...t...(f t)...) -At the recursive call to f, we can see that t is a pair. But we do NOT want -to make a specialised copy: - f' a b = let p = (a,b) in (..., ...) -because now t is allocated by the caller, then r and s are passed to the -recursive call, which allocates the (r,s) pair again. - -This happens if - (a) the argument p is used in other than a case-scrutinisation way. - (b) the argument to the call is not a 'fresh' tuple; you have to - look into its unfolding to see that it's a tuple - -Hence the "OR" part of Note [Good arguments] below. - -ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves -allocation, but does perhaps save evals. In the RULE we'd have -something like - - f (I# x#) = f' (I# x#) x# - -If at the call site the (I# x) was an unfolding, then we'd have to -rely on CSE to eliminate the duplicate allocation.... This alternative -doesn't look attractive enough to pursue. - -ALTERNATIVE 3: ignore the reboxing problem. The trouble is that -the conservative reboxing story prevents many useful functions from being -specialised. Example: - foo :: Maybe Int -> Int -> Int - foo (Just m) 0 = 0 - foo x@(Just m) n = foo x (n-m) -Here the use of 'x' will clearly not require boxing in the specialised function. - -The strictness analyser has the same problem, in fact. Example: - f p@(a,b) = ... -If we pass just 'a' and 'b' to the worker, it might need to rebox the -pair to create (a,b). A more sophisticated analysis might figure out -precisely the cases in which this could happen, but the strictness -analyser does no such analysis; it just passes 'a' and 'b', and hopes -for the best. - -So my current choice is to make SpecConstr similarly aggressive, and -ignore the bad potential of reboxing. - - -Note [Good arguments] -~~~~~~~~~~~~~~~~~~~~~ -So we look for - -* A self-recursive function. Ignore mutual recursion for now, - because it's less common, and the code is simpler for self-recursion. - -* EITHER - - a) At a recursive call, one or more parameters is an explicit - constructor application - AND - That same parameter is scrutinised by a case somewhere in - the RHS of the function - - OR - - b) At a recursive call, one or more parameters has an unfolding - that is an explicit constructor application - AND - That same parameter is scrutinised by a case somewhere in - the RHS of the function - AND - Those are the only uses of the parameter (see Note [Reboxing]) - - -What to abstract over -~~~~~~~~~~~~~~~~~~~~~ -There's a bit of a complication with type arguments. If the call -site looks like - - f p = ...f ((:) [a] x xs)... - -then our specialised function look like - - f_spec x xs = let p = (:) [a] x xs in ....as before.... - -This only makes sense if either - a) the type variable 'a' is in scope at the top of f, or - b) the type variable 'a' is an argument to f (and hence fs) - -Actually, (a) may hold for value arguments too, in which case -we may not want to pass them. Suppose 'x' is in scope at f's -defn, but xs is not. Then we'd like - - f_spec xs = let p = (:) [a] x xs in ....as before.... - -Similarly (b) may hold too. If x is already an argument at the -call, no need to pass it again. - -Finally, if 'a' is not in scope at the call site, we could abstract -it as we do the term variables: - - f_spec a x xs = let p = (:) [a] x xs in ...as before... - -So the grand plan is: - - * abstract the call site to a constructor-only pattern - e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3) - - * Find the free variables of the abstracted pattern - - * Pass these variables, less any that are in scope at - the fn defn. But see Note [Shadowing] below. - - -NOTICE that we only abstract over variables that are not in scope, -so we're in no danger of shadowing variables used in "higher up" -in f_spec's RHS. - - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -In this pass we gather up usage information that may mention variables -that are bound between the usage site and the definition site; or (more -seriously) may be bound to something different at the definition site. -For example: - - f x = letrec g y v = let x = ... - in ...(g (a,b) x)... - -Since 'x' is in scope at the call site, we may make a rewrite rule that -looks like - RULE forall a,b. g (a,b) x = ... -But this rule will never match, because it's really a different 'x' at -the call site -- and that difference will be manifest by the time the -simplifier gets to it. [A worry: the simplifier doesn't *guarantee* -no-shadowing, so perhaps it may not be distinct?] - -Anyway, the rule isn't actually wrong, it's just not useful. One possibility -is to run deShadowBinds before running SpecConstr, but instead we run the -simplifier. That gives the simplest possible program for SpecConstr to -chew on; and it virtually guarantees no shadowing. - -Note [Specialising for constant parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This one is about specialising on a *constant* (but not necessarily -constructor) argument - - foo :: Int -> (Int -> Int) -> Int - foo 0 f = 0 - foo m f = foo (f m) (+1) - -It produces - - lvl_rmV :: GHC.Base.Int -> GHC.Base.Int - lvl_rmV = - \ (ds_dlk :: GHC.Base.Int) -> - case ds_dlk of wild_alH { GHC.Base.I# x_alG -> - GHC.Base.I# (GHC.Prim.+# x_alG 1) - - T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) -> - GHC.Prim.Int# - T.$wfoo = - \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) -> - case ww_sme of ds_Xlw { - __DEFAULT -> - case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz -> - T.$wfoo ww1_Xmz lvl_rmV - }; - 0 -> 0 - } - -The recursive call has lvl_rmV as its argument, so we could create a specialised copy -with that argument baked in; that is, not passed at all. Now it can perhaps be inlined. - -When is this worth it? Call the constant 'lvl' -- If 'lvl' has an unfolding that is a constructor, see if the corresponding - parameter is scrutinised anywhere in the body. - -- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding - parameter is applied (...to enough arguments...?) - - Also do this is if the function has RULES? - -Also - -Note [Specialising for lambda parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - foo :: Int -> (Int -> Int) -> Int - foo 0 f = 0 - foo m f = foo (f m) (\n -> n-m) - -This is subtly different from the previous one in that we get an -explicit lambda as the argument: - - T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) -> - GHC.Prim.Int# - T.$wfoo = - \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) -> - case ww_sm8 of ds_Xlr { - __DEFAULT -> - case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq -> - T.$wfoo - ww1_Xmq - (\ (n_ad3 :: GHC.Base.Int) -> - case n_ad3 of wild_alB { GHC.Base.I# x_alA -> - GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr) - }) - }; - 0 -> 0 - } - -I wonder if SpecConstr couldn't be extended to handle this? After all, -lambda is a sort of constructor for functions and perhaps it already -has most of the necessary machinery? - -Furthermore, there's an immediate win, because you don't need to allocate the lambda -at the call site; and if perchance it's called in the recursive call, then you -may avoid allocating it altogether. Just like for constructors. - -Looks cool, but probably rare...but it might be easy to implement. - - -Note [SpecConstr for casts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family T a :: * - data instance T Int = T Int - - foo n = ... - where - go (T 0) = 0 - go (T n) = go (T (n-1)) - -The recursive call ends up looking like - go (T (I# ...) `cast` g) -So we want to spot the constructor application inside the cast. -That's why we have the Cast case in argToPat - -Note [Local recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a *local* recursive group, we can see all the calls to the -function, so we seed the specialisation loop from the calls in the -body, not from the calls in the RHS. Consider: - - bar m n = foo n (n,n) (n,n) (n,n) (n,n) - where - foo n p q r s - | n == 0 = m - | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s } - | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s } - | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s } - | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) } - -If we start with the RHSs of 'foo', we get lots and lots of specialisations, -most of which are not needed. But if we start with the (single) call -in the rhs of 'bar' we get exactly one fully-specialised copy, and all -the recursive calls go to this fully-specialised copy. Indeed, the original -function is later collected as dead code. This is very important in -specialising the loops arising from stream fusion, for example in NDP where -we were getting literally hundreds of (mostly unused) specialisations of -a local function. - -In a case like the above we end up never calling the original un-specialised -function. (Although we still leave its code around just in case.) - -However, if we find any boring calls in the body, including *unsaturated* -ones, such as - letrec foo x y = ....foo... - in map foo xs -then we will end up calling the un-specialised function, so then we *should* -use the calls in the un-specialised RHS as seeds. We call these -"boring call patterns", and callsToPats reports if it finds any of these. - -Note [Seeding top-level recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This seeding is done in the binding for seed_calls in specRec. - -1. If all the bindings in a top-level recursive group are local (not - exported), then all the calls are in the rest of the top-level - bindings. This means we can specialise with those call patterns - ONLY, and NOT with the RHSs of the recursive group (exactly like - Note [Local recursive groups]) - -2. But if any of the bindings are exported, the function may be called - with any old arguments, so (for lack of anything better) we specialise - based on - (a) the call patterns in the RHS - (b) the call patterns in the rest of the top-level bindings - NB: before Apr 15 we used (a) only, but Dimitrios had an example - where (b) was crucial, so I added that. - Adding (b) also improved nofib allocation results: - multiplier: 4% better - minimax: 2.8% better - -Actually in case (2), instead of using the calls from the RHS, it -would be better to specialise in the importing module. We'd need to -add an INLINABLE pragma to the function, and then it can be -specialised in the importing scope, just as is done for type classes -in GHC.Core.Op.Specialise.specImports. This remains to be done (#10346). - -Note [Top-level recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To get the call usage information from "the rest of the top level -bindings" (c.f. Note [Seeding top-level recursive groups]), we work -backwards through the top-level bindings so we see the usage before we -get to the binding of the function. Before we can collect the usage -though, we go through all the bindings and add them to the -environment. This is necessary because usage is only tracked for -functions in the environment. These two passes are called - 'go' and 'goEnv' -in specConstrProgram. (Looks a bit revolting to me.) - -Note [Do not specialise diverging functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Specialising a function that just diverges is a waste of code. -Furthermore, it broke GHC (simpl014) thus: - {-# STR Sb #-} - f = \x. case x of (a,b) -> f x -If we specialise f we get - f = \x. case x of (a,b) -> fspec a b -But fspec doesn't have decent strictness info. As it happened, -(f x) :: IO t, so the state hack applied and we eta expanded fspec, -and hence f. But now f's strictness is less than its arity, which -breaks an invariant. - - -Note [Forcing specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With stream fusion and in other similar cases, we want to fully -specialise some (but not necessarily all!) loops regardless of their -size and the number of specialisations. - -We allow a library to do this, in one of two ways (one which is -deprecated): - - 1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body. - - 2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts, - and then add *that* type as a parameter to the loop body - -The reason #2 is deprecated is because it requires GHCi, which isn't -available for things like a cross compiler using stage1. - -Here's a (simplified) example from the `vector` package. You may bring -the special 'force specialization' type into scope by saying: - - import GHC.Types (SPEC(..)) - -or by defining your own type (again, deprecated): - - data SPEC = SPEC | SPEC2 - {-# ANN type SPEC ForceSpecConstr #-} - -(Note this is the exact same definition of GHC.Types.SPEC, just -without the annotation.) - -After that, you say: - - foldl :: (a -> b -> a) -> a -> Stream b -> a - {-# INLINE foldl #-} - foldl f z (Stream step s _) = foldl_loop SPEC z s - where - foldl_loop !sPEC z s = case step s of - Yield x s' -> foldl_loop sPEC (f z x) s' - Skip -> foldl_loop sPEC z s' - Done -> z - -SpecConstr will spot the SPEC parameter and always fully specialise -foldl_loop. Note that - - * We have to prevent the SPEC argument from being removed by - w/w which is why (a) SPEC is a sum type, and (b) we have to seq on - the SPEC argument. - - * And lastly, the SPEC argument is ultimately eliminated by - SpecConstr itself so there is no runtime overhead. - -This is all quite ugly; we ought to come up with a better design. - -ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set -sc_force to True when calling specLoop. This flag does four things: - - * Ignore specConstrThreshold, to specialise functions of arbitrary size - (see scTopBind) - * Ignore specConstrCount, to make arbitrary numbers of specialisations - (see specialise) - * Specialise even for arguments that are not scrutinised in the loop - (see argToPat; #4448) - * Only specialise on recursive types a finite number of times - (see is_too_recursive; #5550; Note [Limit recursive specialisation]) - -The flag holds only for specialising a single binding group, and NOT -for nested bindings. (So really it should be passed around explicitly -and not stored in ScEnv.) #14379 turned out to be caused by - f SPEC x = let g1 x = ... - in ... -We force-specialise f (because of the SPEC), but that generates a specialised -copy of g1 (as well as the original). Alas g1 has a nested binding g2; and -in each copy of g1 we get an unspecialised and specialised copy of g2; and so -on. Result, exponential. So the force-spec flag now only applies to one -level of bindings at a time. - -Mechanism for this one-level-only thing: - - - Switch it on at the call to specRec, in scExpr and scTopBinds - - Switch it off when doing the RHSs; - this can be done very conveniently in decreaseSpecCount - -What alternatives did I consider? - -* Annotating the loop itself doesn't work because (a) it is local and - (b) it will be w/w'ed and having w/w propagating annotations somehow - doesn't seem like a good idea. The types of the loop arguments - really seem to be the most persistent thing. - -* Annotating the types that make up the loop state doesn't work, - either, because (a) it would prevent us from using types like Either - or tuples here, (b) we don't want to restrict the set of types that - can be used in Stream states and (c) some types are fixed by the - user (e.g., the accumulator here) but we still want to specialise as - much as possible. - -Alternatives to ForceSpecConstr -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Instead of giving the loop an extra argument of type SPEC, we -also considered *wrapping* arguments in SPEC, thus - data SPEC a = SPEC a | SPEC2 - - loop = \arg -> case arg of - SPEC state -> - case state of (x,y) -> ... loop (SPEC (x',y')) ... - S2 -> error ... -The idea is that a SPEC argument says "specialise this argument -regardless of whether the function case-analyses it". But this -doesn't work well: - * SPEC must still be a sum type, else the strictness analyser - eliminates it - * But that means that 'loop' won't be strict in its real payload -This loss of strictness in turn screws up specialisation, because -we may end up with calls like - loop (SPEC (case z of (p,q) -> (q,p))) -Without the SPEC, if 'loop' were strict, the case would move out -and we'd see loop applied to a pair. But if 'loop' isn't strict -this doesn't look like a specialisable call. - -Note [Limit recursive specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is possible for ForceSpecConstr to cause an infinite loop of specialisation. -Because there is no limit on the number of specialisations, a recursive call with -a recursive constructor as an argument (for example, list cons) will generate -a specialisation for that constructor. If the resulting specialisation also -contains a recursive call with the constructor, this could proceed indefinitely. - -For example, if ForceSpecConstr is on: - loop :: [Int] -> [Int] -> [Int] - loop z [] = z - loop z (x:xs) = loop (x:z) xs -this example will create a specialisation for the pattern - loop (a:b) c = loop' a b c - - loop' a b [] = (a:b) - loop' a b (x:xs) = loop (x:(a:b)) xs -and a new pattern is found: - loop (a:(b:c)) d = loop'' a b c d -which can continue indefinitely. - -Roman's suggestion to fix this was to stop after a couple of times on recursive types, -but still specialising on non-recursive types as much as possible. - -To implement this, we count the number of times we have gone round the -"specialise recursively" loop ('go' in 'specRec'). Once have gone round -more than N times (controlled by -fspec-constr-recursive=N) we check - - - If sc_force is off, and sc_count is (Just max) then we don't - need to do anything: trim_pats will limit the number of specs - - - Otherwise check if any function has now got more than (sc_count env) - specialisations. If sc_count is "no limit" then we arbitrarily - choose 10 as the limit (ugh). - -See #5550. Also #13623, where this test had become over-aggressive, -and we lost a wonderful specialisation that we really wanted! - -Note [NoSpecConstr] -~~~~~~~~~~~~~~~~~~~ -The ignoreDataCon stuff allows you to say - {-# ANN type T NoSpecConstr #-} -to mean "don't specialise on arguments of this type". It was added -before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised -regardless of size; and then we needed a way to turn that *off*. Now -that we have ForceSpecConstr, this NoSpecConstr is probably redundant. -(Used only for PArray, TODO: remove?) - ------------------------------------------------------ - Stuff not yet handled ------------------------------------------------------ - -Here are notes arising from Roman's work that I don't want to lose. - -Example 1 -~~~~~~~~~ - data T a = T !a - - foo :: Int -> T Int -> Int - foo 0 t = 0 - foo x t | even x = case t of { T n -> foo (x-n) t } - | otherwise = foo (x-1) t - -SpecConstr does no specialisation, because the second recursive call -looks like a boxed use of the argument. A pity. - - $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# - $wfoo_sFw = - \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) -> - case ww_sFo of ds_Xw6 [Just L] { - __DEFAULT -> - case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] { - __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq; - 0 -> - case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] -> - case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] -> - $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy - } } }; - 0 -> 0 - -Example 2 -~~~~~~~~~ - data a :*: b = !a :*: !b - data T a = T !a - - foo :: (Int :*: T Int) -> Int - foo (0 :*: t) = 0 - foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) } - | otherwise = foo ((x-1) :*: t) - -Very similar to the previous one, except that the parameters are now in -a strict tuple. Before SpecConstr, we have - - $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# - $wfoo_sG3 = - \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T - GHC.Base.Int) -> - case ww_sFU of ds_Xws [Just L] { - __DEFAULT -> - case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] { - __DEFAULT -> - case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] -> - $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1 - }; - 0 -> - case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] -> - case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] -> - $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2 - } } }; - 0 -> 0 } - -We get two specialisations: -"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#} - Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB) - = Foo.$s$wfoo1 a_sFB sc_sGC ; -"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#} - Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp)) - = Foo.$s$wfoo y_aFp sc_sGC ; - -But perhaps the first one isn't good. After all, we know that tpl_B2 is -a T (I# x) really, because T is strict and Int has one constructor. (We can't -unbox the strict fields, because T is polymorphic!) - -************************************************************************ -* * -\subsection{Top level wrapper stuff} -* * -************************************************************************ --} - -specConstrProgram :: ModGuts -> CoreM ModGuts -specConstrProgram guts - = do - dflags <- getDynFlags - us <- getUniqueSupplyM - (_, annos) <- getFirstAnnotations deserializeWithData guts - this_mod <- getModule - let binds' = reverse $ fst $ initUs us $ do - -- Note [Top-level recursive groups] - (env, binds) <- goEnv (initScEnv dflags this_mod annos) - (mg_binds guts) - -- binds is identical to (mg_binds guts), except that the - -- binders on the LHS have been replaced by extendBndr - -- (SPJ this seems like overkill; I don't think the binders - -- will change at all; and we don't substitute in the RHSs anyway!!) - go env nullUsage (reverse binds) - - return (guts { mg_binds = binds' }) - where - -- See Note [Top-level recursive groups] - goEnv env [] = return (env, []) - goEnv env (bind:binds) = do (env', bind') <- scTopBindEnv env bind - (env'', binds') <- goEnv env' binds - return (env'', bind' : binds') - - -- Arg list of bindings is in reverse order - go _ _ [] = return [] - go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind - binds' <- go env usg' binds - return (bind' : binds') - -{- -************************************************************************ -* * -\subsection{Environment: goes downwards} -* * -************************************************************************ - -Note [Work-free values only in environment] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The sc_vals field keeps track of in-scope value bindings, so -that if we come across (case x of Just y ->...) we can reduce the -case from knowing that x is bound to a pair. - -But only *work-free* values are ok here. For example if the envt had - x -> Just (expensive v) -then we do NOT want to expand to - let y = expensive v in ... -because the x-binding still exists and we've now duplicated (expensive v). - -This seldom happens because let-bound constructor applications are -ANF-ised, but it can happen as a result of on-the-fly transformations in -SpecConstr itself. Here is #7865: - - let { - a'_shr = - case xs_af8 of _ { - [] -> acc_af6; - : ds_dgt [Dmd=] ds_dgu [Dmd=] -> - (expensive x_af7, x_af7 - } } in - let { - ds_sht = - case a'_shr of _ { (p'_afd, q'_afe) -> - TSpecConstr_DoubleInline.recursive - (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd) - } } in - -When processed knowing that xs_af8 was bound to a cons, we simplify to - a'_shr = (expensive x_af7, x_af7) -and we do NOT want to inline that at the occurrence of a'_shr in ds_sht. -(There are other occurrences of a'_shr.) No no no. - -It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned -into a work-free value again, thus - a1 = expensive x_af7 - a'_shr = (a1, x_af7) -but that's more work, so until its shown to be important I'm going to -leave it for now. - -Note [Making SpecConstr keener] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this, in (perf/should_run/T9339) - last (filter odd [1..1000]) - -After optimisation, including SpecConstr, we get: - f :: Int# -> Int -> Int - f x y = case case remInt# x 2# of - __DEFAULT -> case x of - __DEFAULT -> f (+# wild_Xp 1#) (I# x) - 1000000# -> ... - 0# -> case x of - __DEFAULT -> f (+# wild_Xp 1#) y - 1000000# -> y - -Not good! We build an (I# x) box every time around the loop. -SpecConstr (as described in the paper) does not specialise f, despite -the call (f ... (I# x)) because 'y' is not scrutinised in the body. -But it is much better to specialise f for the case where the argument -is of form (I# x); then we build the box only when returning y, which -is on the cold path. - -Another example: - - f x = ...(g x).... - -Here 'x' is not scrutinised in f's body; but if we did specialise 'f' -then the call (g x) might allow 'g' to be specialised in turn. - -So sc_keen controls whether or not we take account of whether argument is -scrutinised in the body. True <=> ignore that, and specialise whenever -the function is applied to a data constructor. --} - -data ScEnv = SCE { sc_dflags :: DynFlags, - sc_module :: !Module, - sc_size :: Maybe Int, -- Size threshold - -- Nothing => no limit - - sc_count :: Maybe Int, -- Max # of specialisations for any one fn - -- Nothing => no limit - -- See Note [Avoiding exponential blowup] - - sc_recursive :: Int, -- Max # of specialisations over recursive type. - -- Stops ForceSpecConstr from diverging. - - sc_keen :: Bool, -- Specialise on arguments that are known - -- constructors, even if they are not - -- scrutinised in the body. See - -- Note [Making SpecConstr keener] - - sc_force :: Bool, -- Force specialisation? - -- See Note [Forcing specialisation] - - sc_subst :: Subst, -- Current substitution - -- Maps InIds to OutExprs - - sc_how_bound :: HowBoundEnv, - -- Binds interesting non-top-level variables - -- Domain is OutVars (*after* applying the substitution) - - sc_vals :: ValueEnv, - -- Domain is OutIds (*after* applying the substitution) - -- Used even for top-level bindings (but not imported ones) - -- The range of the ValueEnv is *work-free* values - -- such as (\x. blah), or (Just v) - -- but NOT (Just (expensive v)) - -- See Note [Work-free values only in environment] - - sc_annotations :: UniqFM SpecConstrAnnotation - } - ---------------------- -type HowBoundEnv = VarEnv HowBound -- Domain is OutVars - ---------------------- -type ValueEnv = IdEnv Value -- Domain is OutIds -data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors - -- The AltCon is never DEFAULT - | LambdaVal -- Inlinable lambdas or PAPs - -instance Outputable Value where - ppr (ConVal con args) = ppr con <+> interpp'SP args - ppr LambdaVal = text "" - ---------------------- -initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv -initScEnv dflags this_mod anns - = SCE { sc_dflags = dflags, - sc_module = this_mod, - sc_size = specConstrThreshold dflags, - sc_count = specConstrCount dflags, - sc_recursive = specConstrRecursive dflags, - sc_keen = gopt Opt_SpecConstrKeen dflags, - sc_force = False, - sc_subst = emptySubst, - sc_how_bound = emptyVarEnv, - sc_vals = emptyVarEnv, - sc_annotations = anns } - -data HowBound = RecFun -- These are the recursive functions for which - -- we seek interesting call patterns - - | RecArg -- These are those functions' arguments, or their sub-components; - -- we gather occurrence information for these - -instance Outputable HowBound where - ppr RecFun = text "RecFun" - ppr RecArg = text "RecArg" - -scForce :: ScEnv -> Bool -> ScEnv -scForce env b = env { sc_force = b } - -lookupHowBound :: ScEnv -> Id -> Maybe HowBound -lookupHowBound env id = lookupVarEnv (sc_how_bound env) id - -scSubstId :: ScEnv -> Id -> CoreExpr -scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v - -scSubstTy :: ScEnv -> Type -> Type -scSubstTy env ty = substTy (sc_subst env) ty - -scSubstCo :: ScEnv -> Coercion -> Coercion -scSubstCo env co = substCo (sc_subst env) co - -zapScSubst :: ScEnv -> ScEnv -zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) } - -extendScInScope :: ScEnv -> [Var] -> ScEnv - -- Bring the quantified variables into scope -extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars } - - -- Extend the substitution -extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv -extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr } - -extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv -extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs } - -extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv -extendHowBound env bndrs how_bound - = env { sc_how_bound = extendVarEnvList (sc_how_bound env) - [(bndr,how_bound) | bndr <- bndrs] } - -extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var]) -extendBndrsWith how_bound env bndrs - = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs') - where - (subst', bndrs') = substBndrs (sc_subst env) bndrs - hb_env' = sc_how_bound env `extendVarEnvList` - [(bndr,how_bound) | bndr <- bndrs'] - -extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var) -extendBndrWith how_bound env bndr - = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr') - where - (subst', bndr') = substBndr (sc_subst env) bndr - hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound - -extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var]) -extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs') - where - (subst', bndrs') = substRecBndrs (sc_subst env) bndrs - -extendBndr :: ScEnv -> Var -> (ScEnv, Var) -extendBndr env bndr = (env { sc_subst = subst' }, bndr') - where - (subst', bndr') = substBndr (sc_subst env) bndr - -extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv -extendValEnv env _ Nothing = env -extendValEnv env id (Just cv) - | valueIsWorkFree cv -- Don't duplicate work!! #7865 - = env { sc_vals = extendVarEnv (sc_vals env) id cv } -extendValEnv env _ _ = env - -extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var]) --- When we encounter --- case scrut of b --- C x y -> ... --- we want to bind b, to (C x y) --- NB1: Extends only the sc_vals part of the envt --- NB2: Kill the dead-ness info on the pattern binders x,y, since --- they are potentially made alive by the [b -> C x y] binding -extendCaseBndrs env scrut case_bndr con alt_bndrs - = (env2, alt_bndrs') - where - live_case_bndr = not (isDeadBinder case_bndr) - env1 | Var v <- stripTicksTopE (const True) scrut - = extendValEnv env v cval - | otherwise = env -- See Note [Add scrutinee to ValueEnv too] - env2 | live_case_bndr = extendValEnv env1 case_bndr cval - | otherwise = env1 - - alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr } - = map zap alt_bndrs - | otherwise - = alt_bndrs - - cval = case con of - DEFAULT -> Nothing - LitAlt {} -> Just (ConVal con []) - DataAlt {} -> Just (ConVal con vanilla_args) - where - vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ - varsToCoreExprs alt_bndrs - - zap v | isTyVar v = v -- See NB2 above - | otherwise = zapIdOccInfo v - - -decreaseSpecCount :: ScEnv -> Int -> ScEnv --- See Note [Avoiding exponential blowup] -decreaseSpecCount env n_specs - = env { sc_force = False -- See Note [Forcing specialisation] - , sc_count = case sc_count env of - Nothing -> Nothing - Just n -> Just (n `div` (n_specs + 1)) } - -- The "+1" takes account of the original function; - -- See Note [Avoiding exponential blowup] - ---------------------------------------------------- --- See Note [Forcing specialisation] -ignoreType :: ScEnv -> Type -> Bool -ignoreDataCon :: ScEnv -> DataCon -> Bool -forceSpecBndr :: ScEnv -> Var -> Bool - -ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc) - -ignoreType env ty - = case tyConAppTyCon_maybe ty of - Just tycon -> ignoreTyCon env tycon - _ -> False - -ignoreTyCon :: ScEnv -> TyCon -> Bool -ignoreTyCon env tycon - = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr - -forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var - -forceSpecFunTy :: ScEnv -> Type -> Bool -forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys - -forceSpecArgTy :: ScEnv -> Type -> Bool -forceSpecArgTy env ty - | Just ty' <- coreView ty = forceSpecArgTy env ty' - -forceSpecArgTy env ty - | Just (tycon, tys) <- splitTyConApp_maybe ty - , tycon /= funTyCon - = tyConName tycon == specTyConName - || lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr - || any (forceSpecArgTy env) tys - -forceSpecArgTy _ _ = False - -{- -Note [Add scrutinee to ValueEnv too] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - case x of y - (a,b) -> case b of c - I# v -> ...(f y)... -By the time we get to the call (f y), the ValueEnv -will have a binding for y, and for c - y -> (a,b) - c -> I# v -BUT that's not enough! Looking at the call (f y) we -see that y is pair (a,b), but we also need to know what 'b' is. -So in extendCaseBndrs we must *also* add the binding - b -> I# v -else we lose a useful specialisation for f. This is necessary even -though the simplifier has systematically replaced uses of 'x' with 'y' -and 'b' with 'c' in the code. The use of 'b' in the ValueEnv came -from outside the case. See #4908 for the live example. - -Note [Avoiding exponential blowup] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The sc_count field of the ScEnv says how many times we are prepared to -duplicate a single function. But we must take care with recursive -specialisations. Consider - - let $j1 = let $j2 = let $j3 = ... - in - ...$j3... - in - ...$j2... - in - ...$j1... - -If we specialise $j1 then in each specialisation (as well as the original) -we can specialise $j2, and similarly $j3. Even if we make just *one* -specialisation of each, because we also have the original we'll get 2^n -copies of $j3, which is not good. - -So when recursively specialising we divide the sc_count by the number of -copies we are making at this level, including the original. - - -************************************************************************ -* * -\subsection{Usage information: flows upwards} -* * -************************************************************************ --} - -data ScUsage - = SCU { - scu_calls :: CallEnv, -- Calls - -- The functions are a subset of the - -- RecFuns in the ScEnv - - scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences - } -- The domain is OutIds - -type CallEnv = IdEnv [Call] -data Call = Call Id [CoreArg] ValueEnv - -- The arguments of the call, together with the - -- env giving the constructor bindings at the call site - -- We keep the function mainly for debug output - -instance Outputable ScUsage where - ppr (SCU { scu_calls = calls, scu_occs = occs }) - = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls - , text "occs =" <+> ppr occs ]) - -instance Outputable Call where - ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args) - -nullUsage :: ScUsage -nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv } - -combineCalls :: CallEnv -> CallEnv -> CallEnv -combineCalls = plusVarEnv_C (++) - where --- plus cs ds | length res > 1 --- = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs --- , text "ds:" <+> ppr ds]) --- res --- | otherwise = res --- where --- res = cs ++ ds - -combineUsage :: ScUsage -> ScUsage -> ScUsage -combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2), - scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) } - -combineUsages :: [ScUsage] -> ScUsage -combineUsages [] = nullUsage -combineUsages us = foldr1 combineUsage us - -lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc]) -lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs - = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs}, - [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs]) - -data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument - | UnkOcc -- Used in some unknown way - - | ScrutOcc -- See Note [ScrutOcc] - (DataConEnv [ArgOcc]) -- How the sub-components are used - -type DataConEnv a = UniqFM a -- Keyed by DataCon - -{- Note [ScrutOcc] -~~~~~~~~~~~~~~~~~~~ -An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, -is *only* taken apart or applied. - - Functions, literal: ScrutOcc emptyUFM - Data constructors: ScrutOcc subs, - -where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components, -The domain of the UniqFM is the Unique of the data constructor - -The [ArgOcc] is the occurrences of the *pattern-bound* components -of the data structure. E.g. - data T a = forall b. MkT a b (b->a) -A pattern binds b, x::a, y::b, z::b->a, but not 'a'! - --} - -instance Outputable ArgOcc where - ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs - ppr UnkOcc = text "unk-occ" - ppr NoOcc = text "no-occ" - -evalScrutOcc :: ArgOcc -evalScrutOcc = ScrutOcc emptyUFM - --- Experimentally, this version of combineOcc makes ScrutOcc "win", so --- that if the thing is scrutinised anywhere then we get to see that --- in the overall result, even if it's also used in a boxed way --- This might be too aggressive; see Note [Reboxing] Alternative 3 -combineOcc :: ArgOcc -> ArgOcc -> ArgOcc -combineOcc NoOcc occ = occ -combineOcc occ NoOcc = occ -combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys) -combineOcc UnkOcc (ScrutOcc ys) = ScrutOcc ys -combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs -combineOcc UnkOcc UnkOcc = UnkOcc - -combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc] -combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys - -setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage --- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee --- is a variable, and an interesting variable -setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ -setScrutOcc env usg (Tick _ e) occ = setScrutOcc env usg e occ -setScrutOcc env usg (Var v) occ - | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ } - | otherwise = usg -setScrutOcc _env usg _other _occ -- Catch-all - = usg - -{- -************************************************************************ -* * -\subsection{The main recursive function} -* * -************************************************************************ - -The main recursive function gathers up usage information, and -creates specialised versions of functions. --} - -scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr) - -- The unique supply is needed when we invent - -- a new name for the specialised function and its args - -scExpr env e = scExpr' env e - -scExpr' env (Var v) = case scSubstId env v of - Var v' -> return (mkVarUsage env v' [], Var v') - e' -> scExpr (zapScSubst env) e' - -scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t)) -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') -scExpr' env (Cast e co) = do (usg, e') <- scExpr env e - return (usg, mkCast e' (scSubstCo env co)) - -- Important to use mkCast here - -- See Note [SpecConstr call patterns] -scExpr' env e@(App _ _) = scApp env (collectArgs e) -scExpr' env (Lam b e) = do let (env', b') = extendBndr env b - (usg, e') <- scExpr env' e - return (usg, Lam b' e') - -scExpr' env (Case scrut b ty alts) - = do { (scrut_usg, scrut') <- scExpr env scrut - ; case isValue (sc_vals env) scrut' of - Just (ConVal con args) -> sc_con_app con args scrut' - _other -> sc_vanilla scrut_usg scrut' - } - where - sc_con_app con args scrut' -- Known constructor; simplify - = do { let (_, bs, rhs) = findAlt con alts - `orElse` (DEFAULT, [], mkImpossibleExpr ty) - alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) - ; scExpr alt_env' rhs } - - sc_vanilla scrut_usg scrut' -- Normal case - = do { let (alt_env,b') = extendBndrWith RecArg env b - -- Record RecArg for the components - - ; (alt_usgs, alt_occs, alts') - <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts - - ; let scrut_occ = foldr combineOcc NoOcc alt_occs - scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ - -- The combined usage of the scrutinee is given - -- by scrut_occ, which is passed to scScrut, which - -- in turn treats a bare-variable scrutinee specially - - ; return (foldr combineUsage scrut_usg' alt_usgs, - Case scrut' b' (scSubstTy env ty) alts') } - - sc_alt env scrut' b' (con,bs,rhs) - = do { let (env1, bs1) = extendBndrsWith RecArg env bs - (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 - ; (usg, rhs') <- scExpr env2 rhs - ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2) - scrut_occ = case con of - DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) - _ -> ScrutOcc emptyUFM - ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) } - -scExpr' env (Let (NonRec bndr rhs) body) - | isTyVar bndr -- Type-lets may be created by doBeta - = scExpr' (extendScSubst env bndr rhs) body - - | otherwise - = do { let (body_env, bndr') = extendBndr env bndr - ; rhs_info <- scRecRhs env (bndr',rhs) - - ; let body_env2 = extendHowBound body_env [bndr'] RecFun - -- Note [Local let bindings] - rhs' = ri_new_rhs rhs_info - body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') - - ; (body_usg, body') <- scExpr body_env3 body - - -- NB: For non-recursive bindings we inherit sc_force flag from - -- the parent function (see Note [Forcing specialisation]) - ; (spec_usg, specs) <- specNonRec env body_usg rhs_info - - ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } - `combineUsage` spec_usg, -- Note [spec_usg includes rhs_usg] - mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body') - } - - --- A *local* recursive group: see Note [Local recursive groups] -scExpr' env (Let (Rec prs) body) - = do { let (bndrs,rhss) = unzip prs - (rhs_env1,bndrs') = extendRecBndrs env bndrs - rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun - force_spec = any (forceSpecBndr env) bndrs' - -- Note [Forcing specialisation] - - ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss) - ; (body_usg, body') <- scExpr rhs_env2 body - - -- NB: start specLoop from body_usg - ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec) - body_usg rhs_infos - -- Do not unconditionally generate specialisations from rhs_usgs - -- Instead use them only if we find an unspecialised call - -- See Note [Local recursive groups] - - ; let all_usg = spec_usg `combineUsage` body_usg -- Note [spec_usg includes rhs_usg] - bind' = Rec (concat (zipWith ruleInfoBinds rhs_infos specs)) - - ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' }, - Let bind' body') } - -{- -Note [Local let bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~ -It is not uncommon to find this - - let $j = \x. in ...$j True...$j True... - -Here $j is an arbitrary let-bound function, but it often comes up for -join points. We might like to specialise $j for its call patterns. -Notice the difference from a letrec, where we look for call patterns -in the *RHS* of the function. Here we look for call patterns in the -*body* of the let. - -At one point I predicated this on the RHS mentioning the outer -recursive function, but that's not essential and might even be -harmful. I'm not sure. --} - -scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr) - -scApp env (Var fn, args) -- Function is a variable - = ASSERT( not (null args) ) - do { args_w_usgs <- mapM (scExpr env) args - ; let (arg_usgs, args') = unzip args_w_usgs - arg_usg = combineUsages arg_usgs - ; case scSubstId env fn of - fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args') - -- Do beta-reduction and try again - - Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args', - mkApps (Var fn') args') - - other_fn' -> return (arg_usg, mkApps other_fn' args') } - -- NB: doing this ignores any usage info from the substituted - -- function, but I don't think that matters. If it does - -- we can fix it. - where - doBeta :: OutExpr -> [OutExpr] -> OutExpr - -- ToDo: adjust for System IF - doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args) - doBeta fn args = mkApps fn args - --- The function is almost always a variable, but not always. --- In particular, if this pass follows float-in, --- which it may, we can get --- (let f = ...f... in f) arg1 arg2 -scApp env (other_fn, args) - = do { (fn_usg, fn') <- scExpr env other_fn - ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args - ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') } - ----------------------- -mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage -mkVarUsage env fn args - = case lookupHowBound env fn of - Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)] - , scu_occs = emptyVarEnv } - Just RecArg -> SCU { scu_calls = emptyVarEnv - , scu_occs = unitVarEnv fn arg_occ } - Nothing -> nullUsage - where - -- I rather think we could use UnkOcc all the time - arg_occ | null args = UnkOcc - | otherwise = evalScrutOcc - ----------------------- -scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) -scTopBindEnv env (Rec prs) - = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs - rhs_env2 = extendHowBound rhs_env1 bndrs RecFun - - prs' = zip bndrs' rhss - ; return (rhs_env2, Rec prs') } - where - (bndrs,rhss) = unzip prs - -scTopBindEnv env (NonRec bndr rhs) - = do { let (env1, bndr') = extendBndr env bndr - env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs) - ; return (env2, NonRec bndr' rhs) } - ----------------------- -scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind) - -{- -scTopBind _ usage _ - | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False - = error "false" --} - -scTopBind env body_usage (Rec prs) - | Just threshold <- sc_size env - , not force_spec - , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss) - -- No specialisation - = -- pprTrace "scTopBind: nospec" (ppr bndrs) $ - do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss - ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) } - - | otherwise -- Do specialisation - = do { rhs_infos <- mapM (scRecRhs env) prs - - ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec) - body_usage rhs_infos - - ; return (body_usage `combineUsage` spec_usage, - Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) } - where - (bndrs,rhss) = unzip prs - force_spec = any (forceSpecBndr env) bndrs - -- Note [Forcing specialisation] - -scTopBind env usage (NonRec bndr rhs) -- Oddly, we don't seem to specialise top-level non-rec functions - = do { (rhs_usg', rhs') <- scExpr env rhs - ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') } - ----------------------- -scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo -scRecRhs env (bndr,rhs) - = do { let (arg_bndrs,body) = collectBinders rhs - (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs - ; (body_usg, body') <- scExpr body_env body - ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs' - ; return (RI { ri_rhs_usg = rhs_usg - , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body' - , ri_lam_bndrs = arg_bndrs, ri_lam_body = body - , ri_arg_occs = arg_occs }) } - -- The arg_occs says how the visible, - -- lambda-bound binders of the RHS are used - -- (including the TyVar binders) - -- Two pats are the same if they match both ways - ----------------------- -ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)] -ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs }) - (SI { si_specs = specs }) - = [(id,rhs) | OS { os_id = id, os_rhs = rhs } <- specs] ++ - -- First the specialised bindings - - [(fn `addIdSpecialisations` rules, new_rhs)] - -- And now the original binding - where - rules = [r | OS { os_rule = r } <- specs] - -{- -************************************************************************ -* * - The specialiser itself -* * -************************************************************************ --} - -data RhsInfo - = RI { ri_fn :: OutId -- The binder - , ri_new_rhs :: OutExpr -- The specialised RHS (in current envt) - , ri_rhs_usg :: ScUsage -- Usage info from specialising RHS - - , ri_lam_bndrs :: [InVar] -- The *original* RHS (\xs.body) - , ri_lam_body :: InExpr -- Note [Specialise original body] - , ri_arg_occs :: [ArgOcc] -- Info on how the xs occur in body - } - -data SpecInfo -- Info about specialisations for a particular Id - = SI { si_specs :: [OneSpec] -- The specialisations we have generated - - , si_n_specs :: Int -- Length of si_specs; used for numbering them - - , si_mb_unspec :: Maybe ScUsage -- Just cs => we have not yet used calls in the - } -- from calls in the *original* RHS as - -- seeds for new specialisations; - -- if you decide to do so, here is the - -- RHS usage (which has not yet been - -- unleashed) - -- Nothing => we have - -- See Note [Local recursive groups] - -- See Note [spec_usg includes rhs_usg] - - -- One specialisation: Rule plus definition -data OneSpec = - OS { os_pat :: CallPat -- Call pattern that generated this specialisation - , os_rule :: CoreRule -- Rule connecting original id with the specialisation - , os_id :: OutId -- Spec id - , os_rhs :: OutExpr } -- Spec rhs - -noSpecInfo :: SpecInfo -noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing } - ----------------------- -specNonRec :: ScEnv - -> ScUsage -- Body usage - -> RhsInfo -- Structure info usage info for un-specialised RHS - -> UniqSM (ScUsage, SpecInfo) -- Usage from RHSs (specialised and not) - -- plus details of specialisations - -specNonRec env body_usg rhs_info - = specialise env (scu_calls body_usg) rhs_info - (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) }) - ----------------------- -specRec :: TopLevelFlag -> ScEnv - -> ScUsage -- Body usage - -> [RhsInfo] -- Structure info and usage info for un-specialised RHSs - -> UniqSM (ScUsage, [SpecInfo]) -- Usage from all RHSs (specialised and not) - -- plus details of specialisations - -specRec top_lvl env body_usg rhs_infos - = go 1 seed_calls nullUsage init_spec_infos - where - (seed_calls, init_spec_infos) -- Note [Seeding top-level recursive groups] - | isTopLevel top_lvl - , any (isExportedId . ri_fn) rhs_infos -- Seed from body and RHSs - = (all_calls, [noSpecInfo | _ <- rhs_infos]) - | otherwise -- Seed from body only - = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) } - | ri <- rhs_infos]) - - calls_in_body = scu_calls body_usg - calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos - all_calls = calls_in_rhss `combineCalls` calls_in_body - - -- Loop, specialising, until you get no new specialisations - go :: Int -- Which iteration of the "until no new specialisations" - -- loop we are on; first iteration is 1 - -> CallEnv -- Seed calls - -- Two accumulating parameters: - -> ScUsage -- Usage from earlier specialisations - -> [SpecInfo] -- Details of specialisations so far - -> UniqSM (ScUsage, [SpecInfo]) - go n_iter seed_calls usg_so_far spec_infos - | isEmptyVarEnv seed_calls - = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos) - -- , ppr seed_calls - -- , ppr body_usg ]) $ - return (usg_so_far, spec_infos) - - -- Limit recursive specialisation - -- See Note [Limit recursive specialisation] - | n_iter > sc_recursive env -- Too many iterations of the 'go' loop - , sc_force env || isNothing (sc_count env) - -- If both of these are false, the sc_count - -- threshold will prevent non-termination - , any ((> the_limit) . si_n_specs) spec_infos - = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $ - return (usg_so_far, spec_infos) - - | otherwise - = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos) - -- , text "iteration" <+> int n_iter - -- , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos) - -- ]) $ - do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos - ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg - extra_usg = combineUsages extra_usg_s - all_usg = usg_so_far `combineUsage` extra_usg - ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos } - - -- See Note [Limit recursive specialisation] - the_limit = case sc_count env of - Nothing -> 10 -- Ugh! - Just max -> max - - ----------------------- -specialise - :: ScEnv - -> CallEnv -- Info on newly-discovered calls to this function - -> RhsInfo - -> SpecInfo -- Original RHS plus patterns dealt with - -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage - --- See Note [spec_usg includes rhs_usg] - --- Note: this only generates *specialised* bindings --- The original binding is added by ruleInfoBinds --- --- Note: the rhs here is the optimised version of the original rhs --- So when we make a specialised copy of the RHS, we're starting --- from an RHS whose nested functions have been optimised already. - -specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs - , ri_lam_body = body, ri_arg_occs = arg_occs }) - spec_info@(SI { si_specs = specs, si_n_specs = spec_count - , si_mb_unspec = mb_unspec }) - | isBottomingId fn -- Note [Do not specialise diverging functions] - -- and do not generate specialisation seeds from its RHS - = -- pprTrace "specialise bot" (ppr fn) $ - return (nullUsage, spec_info) - - | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation] - || null arg_bndrs -- Only specialise functions - = -- pprTrace "specialise inactive" (ppr fn) $ - case mb_unspec of -- Behave as if there was a single, boring call - Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing }) - -- See Note [spec_usg includes rhs_usg] - Nothing -> return (nullUsage, spec_info) - - | Just all_calls <- lookupVarEnv bind_calls fn - = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $ - do { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls - - ; let n_pats = length new_pats --- ; if (not (null new_pats) || isJust mb_unspec) then --- pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns" --- , text "mb_unspec" <+> ppr (isJust mb_unspec) --- , text "arg_occs" <+> ppr arg_occs --- , text "good pats" <+> ppr new_pats]) $ --- return () --- else return () - - ; let spec_env = decreaseSpecCount env n_pats - ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body) - (new_pats `zip` [spec_count..]) - -- See Note [Specialise original body] - - ; let spec_usg = combineUsages spec_usgs - - -- If there were any boring calls among the seeds (= all_calls), then those - -- calls will call the un-specialised function. So we should use the seeds - -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning - -- then in new_usg. - (new_usg, mb_unspec') - = case mb_unspec of - Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing) - _ -> (spec_usg, mb_unspec) - --- ; pprTrace "specialise return }" --- (vcat [ ppr fn --- , text "boring_call:" <+> ppr boring_call --- , text "new calls:" <+> ppr (scu_calls new_usg)]) $ --- return () - - ; return (new_usg, SI { si_specs = new_specs ++ specs - , si_n_specs = spec_count + n_pats - , si_mb_unspec = mb_unspec' }) } - - | otherwise -- No new seeds, so return nullUsage - = return (nullUsage, spec_info) - - - - ---------------------- -spec_one :: ScEnv - -> OutId -- Function - -> [InVar] -- Lambda-binders of RHS; should match patterns - -> InExpr -- Body of the original function - -> (CallPat, Int) - -> UniqSM (ScUsage, OneSpec) -- Rule and binding - --- spec_one creates a specialised copy of the function, together --- with a rule for using it. I'm very proud of how short this --- function is, considering what it does :-). - -{- - Example - - In-scope: a, x::a - f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))... - [c::*, v::(b,c) are presumably bound by the (...) part] - ==> - f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] -> - (...entire body of f...) [b -> (b,c), - y -> ((:) (a,(b,c)) (x,v) hw)] - - RULE: forall b::* c::*, -- Note, *not* forall a, x - v::(b,c), - hw::[(a,(b,c))] . - - f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw --} - -spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) - = do { spec_uniq <- getUniqueM - ; let spec_env = extendScSubstList (extendScInScope env qvars) - (arg_bndrs `zip` pats) - fn_name = idName fn - fn_loc = nameSrcSpan fn_name - fn_occ = nameOccName fn_name - spec_occ = mkSpecOcc fn_occ - -- We use fn_occ rather than fn in the rule_name string - -- as we don't want the uniq to end up in the rule, and - -- hence in the ABI, as that can cause spurious ABI - -- changes (#4012). - rule_name = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number) - spec_name = mkInternalName spec_uniq spec_occ fn_loc --- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn --- <+> ppr pats <+> text "-->" <+> ppr spec_name) $ --- return () - - -- Specialise the body - ; (spec_usg, spec_body) <- scExpr spec_env body - --- ; pprTrace "done spec_one}" (ppr fn) $ --- return () - - -- And build the results - ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env) - qvars body_ty - -- Usual w/w hack to avoid generating - -- a spec_rhs of unlifted type and no args - - spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args - -- Annotate the variables with the strictness information from - -- the function (see Note [Strictness information in worker binders]) - - spec_join_arity | isJoinId fn = Just (length spec_lam_args) - | otherwise = Nothing - spec_id = mkLocalId spec_name - (mkLamTypes spec_lam_args body_ty) - -- See Note [Transfer strictness] - `setIdStrictness` spec_str - `setIdCprInfo` topCprSig - `setIdArity` count isId spec_lam_args - `asJoinId_maybe` spec_join_arity - spec_str = calcSpecStrictness fn spec_lam_args pats - - - -- Conditionally use result of new worker-wrapper transform - spec_rhs = mkLams spec_lam_args_str spec_body - body_ty = exprType spec_body - rule_rhs = mkVarApps (Var spec_id) spec_call_args - inline_act = idInlineActivation fn - this_mod = sc_module spec_env - rule = mkRule this_mod True {- Auto -} True {- Local -} - rule_name inline_act fn_name qvars pats rule_rhs - -- See Note [Transfer activation] - ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule - , os_id = spec_id - , os_rhs = spec_rhs }) } - - --- See Note [Strictness information in worker binders] -handOutStrictnessInformation :: [Demand] -> [Var] -> [Var] -handOutStrictnessInformation = go - where - go _ [] = [] - go [] vs = vs - go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs - go dmds (v:vs) = v : go dmds vs - -calcSpecStrictness :: Id -- The original function - -> [Var] -> [CoreExpr] -- Call pattern - -> StrictSig -- Strictness of specialised thing --- See Note [Transfer strictness] -calcSpecStrictness fn qvars pats - = mkClosedStrictSig spec_dmds topDiv - where - spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] - StrictSig (DmdType _ dmds _) = idStrictness fn - - dmd_env = go emptyVarEnv dmds pats - - go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv - go env ds (Type {} : pats) = go env ds pats - go env ds (Coercion {} : pats) = go env ds pats - go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats - go env _ _ = env - - go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv - go_one env d (Var v) = extendVarEnv_C bothDmd env v d - go_one env d e - | Just ds <- splitProdDmd_maybe d -- NB: d does not have to be strict - , (Var _, args) <- collectArgs e = go env ds args - go_one env _ _ = env - -{- -Note [spec_usg includes rhs_usg] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In calls to 'specialise', the returned ScUsage must include the rhs_usg in -the passed-in SpecInfo, unless there are no calls at all to the function. - -The caller can, indeed must, assume this. He should not combine in rhs_usg -himself, or he'll get rhs_usg twice -- and that can lead to an exponential -blowup of duplicates in the CallEnv. This is what gave rise to the massive -performance loss in #8852. - -Note [Specialise original body] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The RhsInfo for a binding keeps the *original* body of the binding. We -must specialise that, *not* the result of applying specExpr to the RHS -(which is also kept in RhsInfo). Otherwise we end up specialising a -specialised RHS, and that can lead directly to exponential behaviour. - -Note [Transfer activation] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - This note is for SpecConstr, but exactly the same thing - happens in the overloading specialiser; see - Note [Auto-specialisation and RULES] in GHC.Core.Op.Specialise. - -In which phase should the specialise-constructor rules be active? -Originally I made them always-active, but Manuel found that this -defeated some clever user-written rules. Then I made them active only -in Phase 0; after all, currently, the specConstr transformation is -only run after the simplifier has reached Phase 0, but that meant -that specialisations didn't fire inside wrappers; see test -simplCore/should_compile/spec-inline. - -So now I just use the inline-activation of the parent Id, as the -activation for the specialisation RULE, just like the main specialiser; - -This in turn means there is no point in specialising NOINLINE things, -so we test for that. - -Note [Transfer strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must transfer strictness information from the original function to -the specialised one. Suppose, for example - - f has strictness SS - and a RULE f (a:as) b = f_spec a as b - -Now we want f_spec to have strictness LLS, otherwise we'll use call-by-need -when calling f_spec instead of call-by-value. And that can result in -unbounded worsening in space (cf the classic foldl vs foldl') - -See #3437 for a good example. - -The function calcSpecStrictness performs the calculation. - -Note [Strictness information in worker binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -After having calculated the strictness annotation for the worker (see Note -[Transfer strictness] above), we also want to have this information attached to -the worker’s arguments, for the benefit of later passes. The function -handOutStrictnessInformation decomposes the strictness annotation calculated by -calcSpecStrictness and attaches them to the variables. - -************************************************************************ -* * -\subsection{Argument analysis} -* * -************************************************************************ - -This code deals with analysing call-site arguments to see whether -they are constructor applications. - -Note [Free type variables of the qvar types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a call (f @a x True), that we want to specialise, what variables should -we quantify over. Clearly over 'a' and 'x', but what about any type variables -free in x's type? In fact we don't need to worry about them because (f @a) -can only be a well-typed application if its type is compatible with x, so any -variables free in x's type must be free in (f @a), and hence either be gathered -via 'a' itself, or be in scope at f's defn. Hence we just take - (exprsFreeVars pats). - -BUT phantom type synonyms can mess this reasoning up, - eg x::T b with type T b = Int -So we apply expandTypeSynonyms to the bound Ids. -See # 5458. Yuk. - -Note [SpecConstr call patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "call patterns" that we collect is going to become the LHS of a RULE. -It's important that it doesn't have - e |> Refl -or - e |> g1 |> g2 -because both of these will be optimised by Simplify.simplRule. In the -former case such optimisation benign, because the rule will match more -terms; but in the latter we may lose a binding of 'g1' or 'g2', and -end up with a rule LHS that doesn't bind the template variables -(#10602). - -The simplifier eliminates such things, but SpecConstr itself constructs -new terms by substituting. So the 'mkCast' in the Cast case of scExpr -is very important! - -Note [Choosing patterns] -~~~~~~~~~~~~~~~~~~~~~~~~ -If we get lots of patterns we may not want to make a specialisation -for each of them (code bloat), so we choose as follows, implemented -by trim_pats. - -* The flag -fspec-constr-count-N sets the sc_count field - of the ScEnv to (Just n). This limits the total number - of specialisations for a given function to N. - -* -fno-spec-constr-count sets the sc_count field to Nothing, - which switches of the limit. - -* The ghastly ForceSpecConstr trick also switches of the limit - for a particular function - -* Otherwise we sort the patterns to choose the most general - ones first; more general => more widely applicable. - -Note [SpecConstr and casts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14270) a call like - - let f = e - in ... f (K @(a |> co)) ... - -where 'co' is a coercion variable not in scope at f's definition site. -If we aren't caereful we'll get - - let $sf a co = e (K @(a |> co)) - RULE "SC:f" forall a co. f (K @(a |> co)) = $sf a co - f = e - in ... - -But alas, when we match the call we won't bind 'co', because type-matching -(for good reasons) discards casts). - -I don't know how to solve this, so for now I'm just discarding any -call patterns that - * Mentions a coercion variable in a type argument - * That is not in scope at the binding of the function - -I think this is very rare. - -It is important (e.g. #14936) that this /only/ applies to -coercions mentioned in casts. We don't want to be discombobulated -by casts in terms! For example, consider - f ((e1,e2) |> sym co) -where, say, - f :: Foo -> blah - co :: Foo ~R (Int,Int) - -Here we definitely do want to specialise for that pair! We do not -match on the structure of the coercion; instead we just match on a -coercion variable, so the RULE looks like - - forall (x::Int, y::Int, co :: (Int,Int) ~R Foo) - f ((x,y) |> co) = $sf x y co - -Often the body of f looks like - f arg = ...(case arg |> co' of - (x,y) -> blah)... - -so that the specialised f will turn into - $sf x y co = let arg = (x,y) |> co - in ...(case arg>| co' of - (x,y) -> blah).... - -which will simplify to not use 'co' at all. But we can't guarantee -that co will end up unused, so we still pass it. Absence analysis -may remove it later. - -Note that this /also/ discards the call pattern if we have a cast in a -/term/, although in fact Rules.match does make a very flaky and -fragile attempt to match coercions. e.g. a call like - f (Maybe Age) (Nothing |> co) blah - where co :: Maybe Int ~ Maybe Age -will be discarded. It's extremely fragile to match on the form of a -coercion, so I think it's better just not to try. A more complicated -alternative would be to discard calls that mention coercion variables -only in kind-casts, but I'm doing the simple thing for now. --} - -type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments - -- See Note [SpecConstr call patterns] - -callsToNewPats :: ScEnv -> Id - -> SpecInfo - -> [ArgOcc] -> [Call] - -> UniqSM (Bool, [CallPat]) - -- Result has no duplicate patterns, - -- nor ones mentioned in done_pats - -- Bool indicates that there was at least one boring pattern -callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls - = do { mb_pats <- mapM (callToPats env bndr_occs) calls - - ; let have_boring_call = any isNothing mb_pats - - good_pats :: [CallPat] - good_pats = catMaybes mb_pats - - -- Remove patterns we have already done - new_pats = filterOut is_done good_pats - is_done p = any (samePat p . os_pat) done_specs - - -- Remove duplicates - non_dups = nubBy samePat new_pats - - -- Remove ones that have too many worker variables - small_pats = filterOut too_big non_dups - too_big (vars,_) = not (isWorkerSmallEnough (sc_dflags env) vars) - -- We are about to construct w/w pair in 'spec_one'. - -- Omit specialisation leading to high arity workers. - -- See Note [Limit w/w arity] in GHC.Core.Op.WorkWrap.Lib - - -- Discard specialisations if there are too many of them - trimmed_pats = trim_pats env fn spec_info small_pats - --- ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls --- , text "done_specs:" <+> ppr (map os_pat done_specs) --- , text "good_pats:" <+> ppr good_pats ]) $ --- return () - - ; return (have_boring_call, trimmed_pats) } - - -trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat] --- See Note [Choosing patterns] -trim_pats env fn (SI { si_n_specs = done_spec_count }) pats - | sc_force env - || isNothing mb_scc - || n_remaining >= n_pats - = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats) - pats -- No need to trim - - | otherwise - = emit_trace $ -- Need to trim, so keep the best ones - take n_remaining sorted_pats - - where - n_pats = length pats - spec_count' = n_pats + done_spec_count - n_remaining = max_specs - done_spec_count - mb_scc = sc_count env - Just max_specs = mb_scc - - sorted_pats = map fst $ - sortBy (comparing snd) $ - [(pat, pat_cons pat) | pat <- pats] - -- Sort in order of increasing number of constructors - -- (i.e. decreasing generality) and pick the initial - -- segment of this list - - pat_cons :: CallPat -> Int - -- How many data constructors of literals are in - -- the pattern. More data-cons => less general - pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps - where - q_set = mkVarSet qs - n_cons (Var v) | v `elemVarSet` q_set = 0 - | otherwise = 1 - n_cons (Cast e _) = n_cons e - n_cons (App e1 e2) = n_cons e1 + n_cons e2 - n_cons (Lit {}) = 1 - n_cons _ = 0 - - emit_trace result - | debugIsOn || hasPprDebug (sc_dflags env) - -- Suppress this scary message for ordinary users! #5125 - = pprTrace "SpecConstr" msg result - | otherwise - = result - msg = vcat [ sep [ text "Function" <+> quotes (ppr fn) - , nest 2 (text "has" <+> - speakNOf spec_count' (text "call pattern") <> comma <+> - text "but the limit is" <+> int max_specs) ] - , text "Use -fspec-constr-count=n to set the bound" - , text "done_spec_count =" <+> int done_spec_count - , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats - , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ] - - -callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) - -- The [Var] is the variables to quantify over in the rule - -- Type variables come first, since they may scope - -- over the following term variables - -- The [CoreExpr] are the argument patterns for the rule -callToPats env bndr_occs call@(Call _ args con_env) - | args `ltLength` bndr_occs -- Check saturated - = return Nothing - | otherwise - = do { let in_scope = substInScope (sc_subst env) - ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs - ; let pat_fvs = exprsFreeVarsList pats - -- To get determinism we need the list of free variables in - -- deterministic order. Otherwise we end up creating - -- lambdas with different argument orders. See - -- determinism/simplCore/should_compile/spec-inline-determ.hs - -- for an example. For explanation of determinism - -- considerations See Note [Unique Determinism] in GHC.Types.Unique. - - in_scope_vars = getInScopeVars in_scope - is_in_scope v = v `elemVarSet` in_scope_vars - qvars = filterOut is_in_scope pat_fvs - -- Quantify over variables that are not in scope - -- at the call site - -- See Note [Free type variables of the qvar types] - -- See Note [Shadowing] at the top - - (ktvs, ids) = partition isTyVar qvars - qvars' = scopedSort ktvs ++ map sanitise ids - -- Order into kind variables, type variables, term variables - -- The kind of a type variable may mention a kind variable - -- and the type of a term variable may mention a type variable - - sanitise id = id `setIdType` expandTypeSynonyms (idType id) - -- See Note [Free type variables of the qvar types] - - -- Bad coercion variables: see Note [SpecConstr and casts] - bad_covars :: CoVarSet - bad_covars = mapUnionVarSet get_bad_covars pats - get_bad_covars :: CoreArg -> CoVarSet - get_bad_covars (Type ty) - = filterVarSet (\v -> isId v && not (is_in_scope v)) $ - tyCoVarsOfType ty - get_bad_covars _ - = emptyVarSet - - ; -- pprTrace "callToPats" (ppr args $$ ppr bndr_occs) $ - WARN( not (isEmptyVarSet bad_covars) - , text "SpecConstr: bad covars:" <+> ppr bad_covars - $$ ppr call ) - if interesting && isEmptyVarSet bad_covars - then return (Just (qvars', pats)) - else return Nothing } - - -- argToPat takes an actual argument, and returns an abstracted - -- version, consisting of just the "constructor skeleton" of the - -- argument, with non-constructor sub-expression replaced by new - -- placeholder variables. For example: - -- C a (D (f x) (g y)) ==> C p1 (D p2 p3) - -argToPat :: ScEnv - -> InScopeSet -- What's in scope at the fn defn site - -> ValueEnv -- ValueEnv at the call site - -> CoreArg -- A call arg (or component thereof) - -> ArgOcc - -> UniqSM (Bool, CoreArg) - --- Returns (interesting, pat), --- where pat is the pattern derived from the argument --- interesting=True if the pattern is non-trivial (not a variable or type) --- E.g. x:xs --> (True, x:xs) --- f xs --> (False, w) where w is a fresh wildcard --- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard --- \x. x+y --> (True, \x. x+y) --- lvl7 --> (True, lvl7) if lvl7 is bound --- somewhere further out - -argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ - = return (False, arg) - -argToPat env in_scope val_env (Tick _ arg) arg_occ - = argToPat env in_scope val_env arg arg_occ - -- Note [Notes in call patterns] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Ignore Notes. In particular, we want to ignore any InlineMe notes - -- Perhaps we should not ignore profiling notes, but I'm going to - -- ride roughshod over them all for now. - --- See Note [Notes in RULE matching] in GHC.Core.Rules - -argToPat env in_scope val_env (Let _ arg) arg_occ - = argToPat env in_scope val_env arg arg_occ - -- See Note [Matching lets] in Rule.hs - -- Look through let expressions - -- e.g. f (let v = rhs in (v,w)) - -- Here we can specialise for f (v,w) - -- because the rule-matcher will look through the let. - -{- Disabled; see Note [Matching cases] in Rule.hs -argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ - | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs - = argToPat env in_scope val_env rhs arg_occ --} - -argToPat env in_scope val_env (Cast arg co) arg_occ - | not (ignoreType env ty2) - = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ - ; if not interesting then - wildCardPat ty2 - else do - { -- Make a wild-card pattern for the coercion - uniq <- getUniqueM - ; let co_name = mkSysTvName uniq (fsLit "sg") - co_var = mkCoVar co_name (mkCoercionType Representational ty1 ty2) - ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } - where - Pair ty1 ty2 = coercionKind co - - - -{- Disabling lambda specialisation for now - It's fragile, and the spec_loop can be infinite -argToPat in_scope val_env arg arg_occ - | is_value_lam arg - = return (True, arg) - where - is_value_lam (Lam v e) -- Spot a value lambda, even if - | isId v = True -- it is inside a type lambda - | otherwise = is_value_lam e - is_value_lam other = False --} - - -- Check for a constructor application - -- NB: this *precedes* the Var case, so that we catch nullary constrs -argToPat env in_scope val_env arg arg_occ - | Just (ConVal (DataAlt dc) args) <- isValue val_env arg - , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] - , Just arg_occs <- mb_scrut dc - = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args - ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs - ; return (True, - mkConApp dc (ty_args ++ args')) } - where - mb_scrut dc = case arg_occ of - ScrutOcc bs | Just occs <- lookupUFM bs dc - -> Just (occs) -- See Note [Reboxing] - _other | sc_force env || sc_keen env - -> Just (repeat UnkOcc) - | otherwise - -> Nothing - - -- Check if the argument is a variable that - -- (a) is used in an interesting way in the function body - -- (b) we know what its value is - -- In that case it counts as "interesting" -argToPat env in_scope val_env (Var v) arg_occ - | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) - is_value, -- (b) - -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing] - -- So sc_keen focused just on f (I# x), where we have freshly-allocated - -- box that we can eliminate in the caller - not (ignoreType env (varType v)) - = return (True, Var v) - where - is_value - | isLocalId v = v `elemInScopeSet` in_scope - && isJust (lookupVarEnv val_env v) - -- Local variables have values in val_env - | otherwise = isValueUnfolding (idUnfolding v) - -- Imports have unfoldings - --- I'm really not sure what this comment means --- And by not wild-carding we tend to get forall'd --- variables that are in scope, which in turn can --- expose the weakness in let-matching --- See Note [Matching lets] in GHC.Core.Rules - - -- Check for a variable bound inside the function. - -- Don't make a wild-card, because we may usefully share - -- e.g. f a = let x = ... in f (x,x) - -- NB: this case follows the lambda and con-app cases!! --- argToPat _in_scope _val_env (Var v) _arg_occ --- = return (False, Var v) - -- SLPJ : disabling this to avoid proliferation of versions - -- also works badly when thinking about seeding the loop - -- from the body of the let - -- f x y = letrec g z = ... in g (x,y) - -- We don't want to specialise for that *particular* x,y - - -- The default case: make a wild-card - -- We use this for coercions too -argToPat _env _in_scope _val_env arg _arg_occ - = wildCardPat (exprType arg) - -wildCardPat :: Type -> UniqSM (Bool, CoreArg) -wildCardPat ty - = do { uniq <- getUniqueM - ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq ty - ; return (False, varToCoreExpr id) } - -argsToPats :: ScEnv -> InScopeSet -> ValueEnv - -> [CoreArg] -> [ArgOcc] -- Should be same length - -> UniqSM (Bool, [CoreArg]) -argsToPats env in_scope val_env args occs - = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs - ; let (interesting_s, args') = unzip stuff - ; return (or interesting_s, args') } - -isValue :: ValueEnv -> CoreExpr -> Maybe Value -isValue _env (Lit lit) - | litIsLifted lit = Nothing - | otherwise = Just (ConVal (LitAlt lit) []) - -isValue env (Var v) - | Just cval <- lookupVarEnv env v - = Just cval -- You might think we could look in the idUnfolding here - -- but that doesn't take account of which branch of a - -- case we are in, which is the whole point - - | not (isLocalId v) && isCheapUnfolding unf - = isValue env (unfoldingTemplate unf) - where - unf = idUnfolding v - -- However we do want to consult the unfolding - -- as well, for let-bound constructors! - -isValue env (Lam b e) - | isTyVar b = case isValue env e of - Just _ -> Just LambdaVal - Nothing -> Nothing - | otherwise = Just LambdaVal - -isValue env (Tick t e) - | not (tickishIsCode t) - = isValue env e - -isValue _env expr -- Maybe it's a constructor application - | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr - = case isDataConWorkId_maybe fun of - - Just con | args `lengthAtLeast` dataConRepArity con - -- Check saturated; might be > because the - -- arity excludes type args - -> Just (ConVal (DataAlt con) args) - - _other | valArgCount args < idArity fun - -- Under-applied function - -> Just LambdaVal -- Partial application - - _other -> Nothing - -isValue _env _expr = Nothing - -valueIsWorkFree :: Value -> Bool -valueIsWorkFree LambdaVal = True -valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args - -samePat :: CallPat -> CallPat -> Bool -samePat (vs1, as1) (vs2, as2) - = all2 same as1 as2 - where - same (Var v1) (Var v2) - | v1 `elem` vs1 = v2 `elem` vs2 - | v2 `elem` vs2 = False - | otherwise = v1 == v2 - - same (Lit l1) (Lit l2) = l1==l2 - same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2 - - same (Type {}) (Type {}) = True -- Note [Ignore type differences] - same (Coercion {}) (Coercion {}) = True - same (Tick _ e1) e2 = same e1 e2 -- Ignore casts and notes - same (Cast e1 _) e2 = same e1 e2 - same e1 (Tick _ e2) = same e1 e2 - same e1 (Cast e2 _) = same e1 e2 - - same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2) - False -- Let, lambda, case should not occur - bad (Case {}) = True - bad (Let {}) = True - bad (Lam {}) = True - bad _other = False - -{- -Note [Ignore type differences] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not want to generate specialisations where the call patterns -differ only in their type arguments! Not only is it utterly useless, -but it also means that (with polymorphic recursion) we can generate -an infinite number of specialisations. Example is Data.Sequence.adjustTree, -I think. --} diff --git a/compiler/GHC/Core/Op/Specialise.hs b/compiler/GHC/Core/Op/Specialise.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/Specialise.hs +++ /dev/null @@ -1,2716 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[Specialise]{Stamping out overloading, and (optionally) polymorphism} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module GHC.Core.Op.Specialise ( specProgram, specUnfolding ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Types.Id -import TcType hiding( substTy ) -import GHC.Core.Type hiding( substTy, extendTvSubstList ) -import GHC.Core.Predicate -import GHC.Types.Module( Module, HasModule(..) ) -import GHC.Core.Coercion( Coercion ) -import GHC.Core.Op.Monad -import qualified GHC.Core.Subst -import GHC.Core.Unfold -import GHC.Types.Var ( isLocalVar ) -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Core -import GHC.Core.Rules -import GHC.Core.SimpleOpt ( collectBindersPushingCo ) -import GHC.Core.Utils ( exprIsTrivial, mkCast, exprType ) -import GHC.Core.FVs -import GHC.Core.Arity ( etaExpandToJoinPointRule ) -import GHC.Types.Unique.Supply -import GHC.Types.Name -import GHC.Types.Id.Make ( voidArgId, voidPrimId ) -import Maybes ( mapMaybe, isJust ) -import MonadUtils ( foldlM ) -import GHC.Types.Basic -import GHC.Driver.Types -import Bag -import GHC.Driver.Session -import Util -import Outputable -import FastString -import State -import GHC.Types.Unique.DFM -import GHC.Core.TyCo.Rep (TyCoBinder (..)) - -import Control.Monad - -{- -************************************************************************ -* * -\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]} -* * -************************************************************************ - -These notes describe how we implement specialisation to eliminate -overloading. - -The specialisation pass works on Core -syntax, complete with all the explicit dictionary application, -abstraction and construction as added by the type checker. The -existing type checker remains largely as it is. - -One important thought: the {\em types} passed to an overloaded -function, and the {\em dictionaries} passed are mutually redundant. -If the same function is applied to the same type(s) then it is sure to -be applied to the same dictionary(s)---or rather to the same {\em -values}. (The arguments might look different but they will evaluate -to the same value.) - -Second important thought: we know that we can make progress by -treating dictionary arguments as static and worth specialising on. So -we can do without binding-time analysis, and instead specialise on -dictionary arguments and no others. - -The basic idea -~~~~~~~~~~~~~~ -Suppose we have - - let f = - in - -and suppose f is overloaded. - -STEP 1: CALL-INSTANCE COLLECTION - -We traverse , accumulating all applications of f to types and -dictionaries. - -(Might there be partial applications, to just some of its types and -dictionaries? In principle yes, but in practice the type checker only -builds applications of f to all its types and dictionaries, so partial -applications could only arise as a result of transformation, and even -then I think it's unlikely. In any case, we simply don't accumulate such -partial applications.) - - -STEP 2: EQUIVALENCES - -So now we have a collection of calls to f: - f t1 t2 d1 d2 - f t3 t4 d3 d4 - ... -Notice that f may take several type arguments. To avoid ambiguity, we -say that f is called at type t1/t2 and t3/t4. - -We take equivalence classes using equality of the *types* (ignoring -the dictionary args, which as mentioned previously are redundant). - -STEP 3: SPECIALISATION - -For each equivalence class, choose a representative (f t1 t2 d1 d2), -and create a local instance of f, defined thus: - - f@t1/t2 = t1 t2 d1 d2 - -f_rhs presumably has some big lambdas and dictionary lambdas, so lots -of simplification will now result. However we don't actually *do* that -simplification. Rather, we leave it for the simplifier to do. If we -*did* do it, though, we'd get more call instances from the specialised -RHS. We can work out what they are by instantiating the call-instance -set from f's RHS with the types t1, t2. - -Add this new id to f's IdInfo, to record that f has a specialised version. - -Before doing any of this, check that f's IdInfo doesn't already -tell us about an existing instance of f at the required type/s. -(This might happen if specialisation was applied more than once, or -it might arise from user SPECIALIZE pragmas.) - -Recursion -~~~~~~~~~ -Wait a minute! What if f is recursive? Then we can't just plug in -its right-hand side, can we? - -But it's ok. The type checker *always* creates non-recursive definitions -for overloaded recursive functions. For example: - - f x = f (x+x) -- Yes I know its silly - -becomes - - f a (d::Num a) = let p = +.sel a d - in - letrec fl (y::a) = fl (p y y) - in - fl - -We still have recursion for non-overloaded functions which we -specialise, but the recursive call should get specialised to the -same recursive version. - - -Polymorphism 1 -~~~~~~~~~~~~~~ - -All this is crystal clear when the function is applied to *constant -types*; that is, types which have no type variables inside. But what if -it is applied to non-constant types? Suppose we find a call of f at type -t1/t2. There are two possibilities: - -(a) The free type variables of t1, t2 are in scope at the definition point -of f. In this case there's no problem, we proceed just as before. A common -example is as follows. Here's the Haskell: - - g y = let f x = x+x - in f y + f y - -After typechecking we have - - g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x - in +.sel a d (f a d y) (f a d y) - -Notice that the call to f is at type type "a"; a non-constant type. -Both calls to f are at the same type, so we can specialise to give: - - g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x - in +.sel a d (f@a y) (f@a y) - - -(b) The other case is when the type variables in the instance types -are *not* in scope at the definition point of f. The example we are -working with above is a good case. There are two instances of (+.sel a d), -but "a" is not in scope at the definition of +.sel. Can we do anything? -Yes, we can "common them up", a sort of limited common sub-expression deal. -This would give: - - g a (d::Num a) (y::a) = let +.sel@a = +.sel a d - f@a (x::a) = +.sel@a x x - in +.sel@a (f@a y) (f@a y) - -This can save work, and can't be spotted by the type checker, because -the two instances of +.sel weren't originally at the same type. - -Further notes on (b) - -* There are quite a few variations here. For example, the defn of - +.sel could be floated outside the \y, to attempt to gain laziness. - It certainly mustn't be floated outside the \d because the d has to - be in scope too. - -* We don't want to inline f_rhs in this case, because -that will duplicate code. Just commoning up the call is the point. - -* Nothing gets added to +.sel's IdInfo. - -* Don't bother unless the equivalence class has more than one item! - -Not clear whether this is all worth it. It is of course OK to -simply discard call-instances when passing a big lambda. - -Polymorphism 2 -- Overloading -~~~~~~~~~~~~~~ -Consider a function whose most general type is - - f :: forall a b. Ord a => [a] -> b -> b - -There is really no point in making a version of g at Int/Int and another -at Int/Bool, because it's only instantiating the type variable "a" which -buys us any efficiency. Since g is completely polymorphic in b there -ain't much point in making separate versions of g for the different -b types. - -That suggests that we should identify which of g's type variables -are constrained (like "a") and which are unconstrained (like "b"). -Then when taking equivalence classes in STEP 2, we ignore the type args -corresponding to unconstrained type variable. In STEP 3 we make -polymorphic versions. Thus: - - f@t1/ = /\b -> t1 b d1 d2 - -We do this. - - -Dictionary floating -~~~~~~~~~~~~~~~~~~~ -Consider this - - f a (d::Num a) = let g = ... - in - ...(let d1::Ord a = Num.Ord.sel a d in g a d1)... - -Here, g is only called at one type, but the dictionary isn't in scope at the -definition point for g. Usually the type checker would build a -definition for d1 which enclosed g, but the transformation system -might have moved d1's defn inward. Solution: float dictionary bindings -outwards along with call instances. - -Consider - - f x = let g p q = p==q - h r s = (r+s, g r s) - in - h x x - - -Before specialisation, leaving out type abstractions we have - - f df x = let g :: Eq a => a -> a -> Bool - g dg p q = == dg p q - h :: Num a => a -> a -> (a, Bool) - h dh r s = let deq = eqFromNum dh - in (+ dh r s, g deq r s) - in - h df x x - -After specialising h we get a specialised version of h, like this: - - h' r s = let deq = eqFromNum df - in (+ df r s, g deq r s) - -But we can't naively make an instance for g from this, because deq is not in scope -at the defn of g. Instead, we have to float out the (new) defn of deq -to widen its scope. Notice that this floating can't be done in advance -- it only -shows up when specialisation is done. - -User SPECIALIZE pragmas -~~~~~~~~~~~~~~~~~~~~~~~ -Specialisation pragmas can be digested by the type checker, and implemented -by adding extra definitions along with that of f, in the same way as before - - f@t1/t2 = t1 t2 d1 d2 - -Indeed the pragmas *have* to be dealt with by the type checker, because -only it knows how to build the dictionaries d1 and d2! For example - - g :: Ord a => [a] -> [a] - {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-} - -Here, the specialised version of g is an application of g's rhs to the -Ord dictionary for (Tree Int), which only the type checker can conjure -up. There might not even *be* one, if (Tree Int) is not an instance of -Ord! (All the other specialision has suitable dictionaries to hand -from actual calls.) - -Problem. The type checker doesn't have to hand a convenient , because -it is buried in a complex (as-yet-un-desugared) binding group. -Maybe we should say - - f@t1/t2 = f* t1 t2 d1 d2 - -where f* is the Id f with an IdInfo which says "inline me regardless!". -Indeed all the specialisation could be done in this way. -That in turn means that the simplifier has to be prepared to inline absolutely -any in-scope let-bound thing. - - -Again, the pragma should permit polymorphism in unconstrained variables: - - h :: Ord a => [a] -> b -> b - {-# SPECIALIZE h :: [Int] -> b -> b #-} - -We *insist* that all overloaded type variables are specialised to ground types, -(and hence there can be no context inside a SPECIALIZE pragma). -We *permit* unconstrained type variables to be specialised to - - a ground type - - or left as a polymorphic type variable -but nothing in between. So - - {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-} - -is *illegal*. (It can be handled, but it adds complication, and gains the -programmer nothing.) - - -SPECIALISING INSTANCE DECLARATIONS -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - instance Foo a => Foo [a] where - ... - {-# SPECIALIZE instance Foo [Int] #-} - -The original instance decl creates a dictionary-function -definition: - - dfun.Foo.List :: forall a. Foo a -> Foo [a] - -The SPECIALIZE pragma just makes a specialised copy, just as for -ordinary function definitions: - - dfun.Foo.List@Int :: Foo [Int] - dfun.Foo.List@Int = dfun.Foo.List Int dFooInt - -The information about what instance of the dfun exist gets added to -the dfun's IdInfo in the same way as a user-defined function too. - - -Automatic instance decl specialisation? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Can instance decls be specialised automatically? It's tricky. -We could collect call-instance information for each dfun, but -then when we specialised their bodies we'd get new call-instances -for ordinary functions; and when we specialised their bodies, we might get -new call-instances of the dfuns, and so on. This all arises because of -the unrestricted mutual recursion between instance decls and value decls. - -Still, there's no actual problem; it just means that we may not do all -the specialisation we could theoretically do. - -Furthermore, instance decls are usually exported and used non-locally, -so we'll want to compile enough to get those specialisations done. - -Lastly, there's no such thing as a local instance decl, so we can -survive solely by spitting out *usage* information, and then reading that -back in as a pragma when next compiling the file. So for now, -we only specialise instance decls in response to pragmas. - - -SPITTING OUT USAGE INFORMATION -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -To spit out usage information we need to traverse the code collecting -call-instance information for all imported (non-prelude?) functions -and data types. Then we equivalence-class it and spit it out. - -This is done at the top-level when all the call instances which escape -must be for imported functions and data types. - -*** Not currently done *** - - -Partial specialisation by pragmas -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What about partial specialisation: - - k :: (Ord a, Eq b) => [a] -> b -> b -> [a] - {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-} - -or even - - {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-} - -Seems quite reasonable. Similar things could be done with instance decls: - - instance (Foo a, Foo b) => Foo (a,b) where - ... - {-# SPECIALIZE instance Foo a => Foo (a,Int) #-} - {-# SPECIALIZE instance Foo b => Foo (Int,b) #-} - -Ho hum. Things are complex enough without this. I pass. - - -Requirements for the simplifier -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The simplifier has to be able to take advantage of the specialisation. - -* When the simplifier finds an application of a polymorphic f, it looks in -f's IdInfo in case there is a suitable instance to call instead. This converts - - f t1 t2 d1 d2 ===> f_t1_t2 - -Note that the dictionaries get eaten up too! - -* Dictionary selection operations on constant dictionaries must be - short-circuited: - - +.sel Int d ===> +Int - -The obvious way to do this is in the same way as other specialised -calls: +.sel has inside it some IdInfo which tells that if it's applied -to the type Int then it should eat a dictionary and transform to +Int. - -In short, dictionary selectors need IdInfo inside them for constant -methods. - -* Exactly the same applies if a superclass dictionary is being - extracted: - - Eq.sel Int d ===> dEqInt - -* Something similar applies to dictionary construction too. Suppose -dfun.Eq.List is the function taking a dictionary for (Eq a) to -one for (Eq [a]). Then we want - - dfun.Eq.List Int d ===> dEq.List_Int - -Where does the Eq [Int] dictionary come from? It is built in -response to a SPECIALIZE pragma on the Eq [a] instance decl. - -In short, dfun Ids need IdInfo with a specialisation for each -constant instance of their instance declaration. - -All this uses a single mechanism: the SpecEnv inside an Id - - -What does the specialisation IdInfo look like? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The SpecEnv of an Id maps a list of types (the template) to an expression - - [Type] |-> Expr - -For example, if f has this RuleInfo: - - [Int, a] -> \d:Ord Int. f' a - -it means that we can replace the call - - f Int t ===> (\d. f' t) - -This chucks one dictionary away and proceeds with the -specialised version of f, namely f'. - - -What can't be done this way? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is no way, post-typechecker, to get a dictionary for (say) -Eq a from a dictionary for Eq [a]. So if we find - - ==.sel [t] d - -we can't transform to - - eqList (==.sel t d') - -where - eqList :: (a->a->Bool) -> [a] -> [a] -> Bool - -Of course, we currently have no way to automatically derive -eqList, nor to connect it to the Eq [a] instance decl, but you -can imagine that it might somehow be possible. Taking advantage -of this is permanently ruled out. - -Still, this is no great hardship, because we intend to eliminate -overloading altogether anyway! - -A note about non-tyvar dictionaries -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some Ids have types like - - forall a,b,c. Eq a -> Ord [a] -> tau - -This seems curious at first, because we usually only have dictionary -args whose types are of the form (C a) where a is a type variable. -But this doesn't hold for the functions arising from instance decls, -which sometimes get arguments with types of form (C (T a)) for some -type constructor T. - -Should we specialise wrt this compound-type dictionary? We used to say -"no", saying: - "This is a heuristic judgement, as indeed is the fact that we - specialise wrt only dictionaries. We choose *not* to specialise - wrt compound dictionaries because at the moment the only place - they show up is in instance decls, where they are simply plugged - into a returned dictionary. So nothing is gained by specialising - wrt them." - -But it is simpler and more uniform to specialise wrt these dicts too; -and in future GHC is likely to support full fledged type signatures -like - f :: Eq [(a,b)] => ... - - -************************************************************************ -* * -\subsubsection{The new specialiser} -* * -************************************************************************ - -Our basic game plan is this. For let(rec) bound function - f :: (C a, D c) => (a,b,c,d) -> Bool - -* Find any specialised calls of f, (f ts ds), where - ts are the type arguments t1 .. t4, and - ds are the dictionary arguments d1 .. d2. - -* Add a new definition for f1 (say): - - f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2 - - Note that we abstract over the unconstrained type arguments. - -* Add the mapping - - [t1,b,t3,d] |-> \d1 d2 -> f1 b d - - to the specialisations of f. This will be used by the - simplifier to replace calls - (f t1 t2 t3 t4) da db - by - (\d1 d1 -> f1 t2 t4) da db - - All the stuff about how many dictionaries to discard, and what types - to apply the specialised function to, are handled by the fact that the - SpecEnv contains a template for the result of the specialisation. - -We don't build *partial* specialisations for f. For example: - - f :: Eq a => a -> a -> Bool - {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-} - -Here, little is gained by making a specialised copy of f. -There's a distinct danger that the specialised version would -first build a dictionary for (Eq b, Eq c), and then select the (==) -method from it! Even if it didn't, not a great deal is saved. - -We do, however, generate polymorphic, but not overloaded, specialisations: - - f :: Eq a => [a] -> b -> b -> b - ... SPECIALISE f :: [Int] -> b -> b -> b ... - -Hence, the invariant is this: - - *** no specialised version is overloaded *** - - -************************************************************************ -* * -\subsubsection{The exported function} -* * -************************************************************************ --} - --- | Specialise calls to type-class overloaded functions occurring in a program. -specProgram :: ModGuts -> CoreM ModGuts -specProgram guts@(ModGuts { mg_module = this_mod - , mg_rules = local_rules - , mg_binds = binds }) - = do { dflags <- getDynFlags - - -- Specialise the bindings of this module - ; (binds', uds) <- runSpecM dflags this_mod (go binds) - - -- Specialise imported functions - ; hpt_rules <- getRuleBase - ; let rule_base = extendRuleBaseList hpt_rules local_rules - ; (new_rules, spec_binds) <- specImports dflags this_mod top_env emptyVarSet - [] rule_base uds - - ; let final_binds - | null spec_binds = binds' - | otherwise = Rec (flattenBinds spec_binds) : binds' - -- Note [Glom the bindings if imported functions are specialised] - - ; return (guts { mg_binds = final_binds - , mg_rules = new_rules ++ local_rules }) } - where - -- We need to start with a Subst that knows all the things - -- that are in scope, so that the substitution engine doesn't - -- accidentally re-use a unique that's already in use - -- Easiest thing is to do it all at once, as if all the top-level - -- decls were mutually recursive - top_env = SE { se_subst = GHC.Core.Subst.mkEmptySubst $ mkInScopeSet $ mkVarSet $ - bindersOfBinds binds - , se_interesting = emptyVarSet } - - go [] = return ([], emptyUDs) - go (bind:binds) = do (binds', uds) <- go binds - (bind', uds') <- specBind top_env bind uds - return (bind' ++ binds', uds') - -{- -Note [Wrap bindings returned by specImports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'specImports' returns a set of specialized bindings. However, these are lacking -necessary floated dictionary bindings, which are returned by -UsageDetails(ud_binds). These dictionaries need to be brought into scope with -'wrapDictBinds' before the bindings returned by 'specImports' can be used. See, -for instance, the 'specImports' call in 'specProgram'. - - -Note [Disabling cross-module specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since GHC 7.10 we have performed specialisation of INLINABLE bindings living -in modules outside of the current module. This can sometimes uncover user code -which explodes in size when aggressively optimized. The --fno-cross-module-specialise option was introduced to allow users to being -bitten by such instances to revert to the pre-7.10 behavior. - -See #10491 --} - --- | An argument that we might want to specialise. --- See Note [Specialising Calls] for the nitty gritty details. -data SpecArg - = - -- | Type arguments that should be specialised, due to appearing - -- free in the type of a 'SpecDict'. - SpecType Type - -- | Type arguments that should remain polymorphic. - | UnspecType - -- | Dictionaries that should be specialised. - | SpecDict DictExpr - -- | Value arguments that should not be specialised. - | UnspecArg - -instance Outputable SpecArg where - ppr (SpecType t) = text "SpecType" <+> ppr t - ppr UnspecType = text "UnspecType" - ppr (SpecDict d) = text "SpecDict" <+> ppr d - ppr UnspecArg = text "UnspecArg" - -getSpecDicts :: [SpecArg] -> [DictExpr] -getSpecDicts = mapMaybe go - where - go (SpecDict d) = Just d - go _ = Nothing - -getSpecTypes :: [SpecArg] -> [Type] -getSpecTypes = mapMaybe go - where - go (SpecType t) = Just t - go _ = Nothing - -isUnspecArg :: SpecArg -> Bool -isUnspecArg UnspecArg = True -isUnspecArg UnspecType = True -isUnspecArg _ = False - -isValueArg :: SpecArg -> Bool -isValueArg UnspecArg = True -isValueArg (SpecDict _) = True -isValueArg _ = False - --- | Given binders from an original function 'f', and the 'SpecArg's --- corresponding to its usage, compute everything necessary to build --- a specialisation. --- --- We will use a running example. Consider the function --- --- foo :: forall a b. Eq a => Int -> blah --- foo @a @b dEqA i = blah --- --- which is called with the 'CallInfo' --- --- [SpecType T1, UnspecType, SpecDict dEqT1, UnspecArg] --- --- We'd eventually like to build the RULE --- --- RULE "SPEC foo @T1 _" --- forall @a @b (dEqA' :: Eq a). --- foo @T1 @b dEqA' = $sfoo @b --- --- and the specialisation '$sfoo' --- --- $sfoo :: forall b. Int -> blah --- $sfoo @b = \i -> SUBST[a->T1, dEqA->dEqA'] blah --- --- The cases for 'specHeader' below are presented in the same order as this --- running example. The result of 'specHeader' for this example is as follows: --- --- ( -- Returned arguments --- env + [a -> T1, deqA -> dEqA'] --- , [] --- --- -- RULE helpers --- , [b, dx', i] --- , [T1, b, dx', i] --- --- -- Specialised function helpers --- , [b, i] --- , [dx] --- , [T1, b, dx_spec, i] --- ) -specHeader - :: SpecEnv - -> [CoreBndr] -- The binders from the original function 'f' - -> [SpecArg] -- From the CallInfo - -> SpecM ( -- Returned arguments - SpecEnv -- Substitution to apply to the body of 'f' - , [CoreBndr] -- All the remaining unspecialised args from the original function 'f' - - -- RULE helpers - , [CoreBndr] -- Binders for the RULE - , [CoreArg] -- Args for the LHS of the rule - - -- Specialised function helpers - , [CoreBndr] -- Binders for $sf - , [DictBind] -- Auxiliary dictionary bindings - , [CoreExpr] -- Specialised arguments for unfolding - ) - --- We want to specialise on type 'T1', and so we must construct a substitution --- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding --- details. -specHeader env (bndr : bndrs) (SpecType t : args) - = do { let env' = extendTvSubstList env [(bndr, t)] - ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env' bndrs args - ; pure ( env'' - , unused_bndrs - , rule_bs - , Type t : rule_es - , bs' - , dx - , Type t : spec_args - ) - } - --- Next we have a type that we don't want to specialise. We need to perform --- a substitution on it (in case the type refers to 'a'). Additionally, we need --- to produce a binder, LHS argument and RHS argument for the resulting rule, --- /and/ a binder for the specialised body. -specHeader env (bndr : bndrs) (UnspecType : args) - = do { let (env', bndr') = substBndr env bndr - ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env' bndrs args - ; pure ( env'' - , unused_bndrs - , bndr' : rule_bs - , varToCoreExpr bndr' : rule_es - , bndr' : bs' - , dx - , varToCoreExpr bndr' : spec_args - ) - } - --- Next we want to specialise the 'Eq a' dict away. We need to construct --- a wildcard binder to match the dictionary (See Note [Specialising Calls] for --- the nitty-gritty), as a LHS rule and unfolding details. -specHeader env (bndr : bndrs) (SpecDict d : args) - = do { inst_dict_id <- newDictBndr env bndr - ; let (rhs_env2, dx_binds, spec_dict_args') - = bindAuxiliaryDicts env [bndr] [d] [inst_dict_id] - ; (env', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader rhs_env2 bndrs args - ; pure ( env' - , unused_bndrs - -- See Note [Evidence foralls] - , exprFreeIdsList (varToCoreExpr inst_dict_id) ++ rule_bs - , varToCoreExpr inst_dict_id : rule_es - , bs' - , dx_binds ++ dx - , spec_dict_args' ++ spec_args - ) - } - --- Finally, we have the unspecialised argument 'i'. We need to produce --- a binder, LHS and RHS argument for the RULE, and a binder for the --- specialised body. --- --- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is --- why 'i' doesn't appear in our RULE above. But we have no guarantee that --- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so --- this case must be here. -specHeader env (bndr : bndrs) (UnspecArg : args) - = do { let (env', bndr') = substBndr env bndr - ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env' bndrs args - ; pure ( env'' - , unused_bndrs - , bndr' : rule_bs - , varToCoreExpr bndr' : rule_es - , bndr' : bs' - , dx - , varToCoreExpr bndr' : spec_args - ) - } - --- Return all remaining binders from the original function. These have the --- invariant that they should all correspond to unspecialised arguments, so --- it's safe to stop processing at this point. -specHeader env bndrs [] = pure (env, bndrs, [], [], [], [], []) -specHeader env [] _ = pure (env, [], [], [], [], [], []) - - --- | Specialise a set of calls to imported bindings -specImports :: DynFlags - -> Module - -> SpecEnv -- Passed in so that all top-level Ids are in scope - -> VarSet -- Don't specialise these ones - -- See Note [Avoiding recursive specialisation] - -> [Id] -- Stack of imported functions being specialised - -> RuleBase -- Rules from this module and the home package - -- (but not external packages, which can change) - -> UsageDetails -- Calls for imported things, and floating bindings - -> CoreM ( [CoreRule] -- New rules - , [CoreBind] ) -- Specialised bindings - -- See Note [Wrapping bindings returned by specImports] -specImports dflags this_mod top_env done callers rule_base - (MkUD { ud_binds = dict_binds, ud_calls = calls }) - -- See Note [Disabling cross-module specialisation] - | not $ gopt Opt_CrossModuleSpecialise dflags - = return ([], []) - - | otherwise - = do { let import_calls = dVarEnvElts calls - ; (rules, spec_binds) <- go rule_base import_calls - - -- Don't forget to wrap the specialized bindings with - -- bindings for the needed dictionaries. - -- See Note [Wrap bindings returned by specImports] - ; let spec_binds' = wrapDictBinds dict_binds spec_binds - - ; return (rules, spec_binds') } - where - go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind]) - go _ [] = return ([], []) - go rb (cis@(CIS fn _) : other_calls) - = do { let ok_calls = filterCalls cis dict_binds - -- Drop calls that (directly or indirectly) refer to fn - -- See Note [Avoiding loops] --- ; debugTraceMsg (text "specImport" <+> vcat [ ppr fn --- , text "calls" <+> ppr cis --- , text "ud_binds =" <+> ppr dict_binds --- , text "dump set =" <+> ppr dump_set --- , text "filtered calls =" <+> ppr ok_calls ]) - ; (rules1, spec_binds1) <- specImport dflags this_mod top_env - done callers rb fn ok_calls - - ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls - ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) } - -specImport :: DynFlags - -> Module - -> SpecEnv -- Passed in so that all top-level Ids are in scope - -> VarSet -- Don't specialise these - -- See Note [Avoiding recursive specialisation] - -> [Id] -- Stack of imported functions being specialised - -> RuleBase -- Rules from this module - -> Id -> [CallInfo] -- Imported function and calls for it - -> CoreM ( [CoreRule] -- New rules - , [CoreBind] ) -- Specialised bindings -specImport dflags this_mod top_env done callers rb fn calls_for_fn - | fn `elemVarSet` done - = return ([], []) -- No warning. This actually happens all the time - -- when specialising a recursive function, because - -- the RHS of the specialised function contains a recursive - -- call to the original function - - | null calls_for_fn -- We filtered out all the calls in deleteCallsMentioning - = return ([], []) - - | wantSpecImport dflags unfolding - , Just rhs <- maybeUnfoldingTemplate unfolding - = do { -- Get rules from the external package state - -- We keep doing this in case we "page-fault in" - -- more rules as we go along - ; hsc_env <- getHscEnv - ; eps <- liftIO $ hscEPS hsc_env - ; vis_orphs <- getVisibleOrphanMods - ; let full_rb = unionRuleBase rb (eps_rule_base eps) - rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn - - ; (rules1, spec_pairs, uds) - <- -- pprTrace "specImport1" (vcat [ppr fn, ppr calls_for_fn, ppr rhs]) $ - runSpecM dflags this_mod $ - specCalls (Just this_mod) top_env rules_for_fn calls_for_fn fn rhs - ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] - -- After the rules kick in we may get recursion, but - -- we rely on a global GlomBinds to sort that out later - -- See Note [Glom the bindings if imported functions are specialised] - - -- Now specialise any cascaded calls - ; (rules2, spec_binds2) <- -- pprTrace "specImport 2" (ppr fn $$ ppr rules1 $$ ppr spec_binds1) $ - specImports dflags this_mod top_env - (extendVarSet done fn) - (fn:callers) - (extendRuleBaseList rb rules1) - uds - - ; let final_binds = spec_binds2 ++ spec_binds1 - - ; return (rules2 ++ rules1, final_binds) } - - | otherwise = do { tryWarnMissingSpecs dflags callers fn calls_for_fn - ; return ([], [])} - - where - unfolding = realIdUnfolding fn -- We want to see the unfolding even for loop breakers - --- | Returns whether or not to show a missed-spec warning. --- If -Wall-missed-specializations is on, show the warning. --- Otherwise, if -Wmissed-specializations is on, only show a warning --- if there is at least one imported function being specialized, --- and if all imported functions are marked with an inline pragma --- Use the most specific warning as the reason. -tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () --- See Note [Warning about missed specialisations] -tryWarnMissingSpecs dflags callers fn calls_for_fn - | wopt Opt_WarnMissedSpecs dflags - && not (null callers) - && allCallersInlined = doWarn $ Reason Opt_WarnMissedSpecs - | wopt Opt_WarnAllMissedSpecs dflags = doWarn $ Reason Opt_WarnAllMissedSpecs - | otherwise = return () - where - allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers - doWarn reason = - warnMsg reason - (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) - 2 (vcat [ text "when specialising" <+> quotes (ppr caller) - | caller <- callers]) - , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) - , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) - -wantSpecImport :: DynFlags -> Unfolding -> Bool --- See Note [Specialise imported INLINABLE things] -wantSpecImport dflags unf - = case unf of - NoUnfolding -> False - BootUnfolding -> False - OtherCon {} -> False - DFunUnfolding {} -> True - CoreUnfolding { uf_src = src, uf_guidance = _guidance } - | gopt Opt_SpecialiseAggressively dflags -> True - | isStableSource src -> True - -- Specialise even INLINE things; it hasn't inlined yet, - -- so perhaps it never will. Moreover it may have calls - -- inside it that we want to specialise - | otherwise -> False -- Stable, not INLINE, hence INLINABLE - -{- Note [Warning about missed specialisations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose - * In module Lib, you carefully mark a function 'foo' INLINABLE - * Import Lib(foo) into another module M - * Call 'foo' at some specialised type in M -Then you jolly well expect it to be specialised in M. But what if -'foo' calls another function 'Lib.bar'. Then you'd like 'bar' to be -specialised too. But if 'bar' is not marked INLINABLE it may well -not be specialised. The warning Opt_WarnMissedSpecs warns about this. - -It's more noisy to warning about a missed specialisation opportunity -for /every/ overloaded imported function, but sometimes useful. That -is what Opt_WarnAllMissedSpecs does. - -ToDo: warn about missed opportunities for local functions. - -Note [Specialise imported INLINABLE things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What imported functions do we specialise? The basic set is - * DFuns and things with INLINABLE pragmas. -but with -fspecialise-aggressively we add - * Anything with an unfolding template - -#8874 has a good example of why we want to auto-specialise DFuns. - -We have the -fspecialise-aggressively flag (usually off), because we -risk lots of orphan modules from over-vigorous specialisation. -However it's not a big deal: anything non-recursive with an -unfolding-template will probably have been inlined already. - -Note [Glom the bindings if imported functions are specialised] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an imported, *recursive*, INLINABLE function - f :: Eq a => a -> a - f = /\a \d x. ...(f a d)... -In the module being compiled we have - g x = f (x::Int) -Now we'll make a specialised function - f_spec :: Int -> Int - f_spec = \x -> ...(f Int dInt)... - {-# RULE f Int _ = f_spec #-} - g = \x. f Int dInt x -Note that f_spec doesn't look recursive -After rewriting with the RULE, we get - f_spec = \x -> ...(f_spec)... -BUT since f_spec was non-recursive before it'll *stay* non-recursive. -The occurrence analyser never turns a NonRec into a Rec. So we must -make sure that f_spec is recursive. Easiest thing is to make all -the specialisations for imported bindings recursive. - - -Note [Avoiding recursive specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we specialise 'f' we may find new overloaded calls to 'g', 'h' in -'f's RHS. So we want to specialise g,h. But we don't want to -specialise f any more! It's possible that f's RHS might have a -recursive yet-more-specialised call, so we'd diverge in that case. -And if the call is to the same type, one specialisation is enough. -Avoiding this recursive specialisation loop is the reason for the -'done' VarSet passed to specImports and specImport. - -************************************************************************ -* * -\subsubsection{@specExpr@: the main function} -* * -************************************************************************ --} - -data SpecEnv - = SE { se_subst :: GHC.Core.Subst.Subst - -- We carry a substitution down: - -- a) we must clone any binding that might float outwards, - -- to avoid name clashes - -- b) we carry a type substitution to use when analysing - -- the RHS of specialised bindings (no type-let!) - - - , se_interesting :: VarSet - -- Dict Ids that we know something about - -- and hence may be worth specialising against - -- See Note [Interesting dictionary arguments] - } - -specVar :: SpecEnv -> Id -> CoreExpr -specVar env v = GHC.Core.Subst.lookupIdSubst (text "specVar") (se_subst env) v - -specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails) - ----------------- First the easy cases -------------------- -specExpr env (Type ty) = return (Type (substTy env ty), emptyUDs) -specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs) -specExpr env (Var v) = return (specVar env v, emptyUDs) -specExpr _ (Lit lit) = return (Lit lit, emptyUDs) -specExpr env (Cast e co) - = do { (e', uds) <- specExpr env e - ; return ((mkCast e' (substCo env co)), uds) } -specExpr env (Tick tickish body) - = do { (body', uds) <- specExpr env body - ; return (Tick (specTickish env tickish) body', uds) } - ----------------- Applications might generate a call instance -------------------- -specExpr env expr@(App {}) - = go expr [] - where - go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg - (fun', uds_app) <- go fun (arg':args) - return (App fun' arg', uds_arg `plusUDs` uds_app) - - go (Var f) args = case specVar env f of - Var f' -> return (Var f', mkCallUDs env f' args) - e' -> return (e', emptyUDs) -- I don't expect this! - go other _ = specExpr env other - ----------------- Lambda/case require dumping of usage details -------------------- -specExpr env e@(Lam _ _) = do - (body', uds) <- specExpr env' body - let (free_uds, dumped_dbs) = dumpUDs bndrs' uds - return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds) - where - (bndrs, body) = collectBinders e - (env', bndrs') = substBndrs env bndrs - -- More efficient to collect a group of binders together all at once - -- and we don't want to split a lambda group with dumped bindings - -specExpr env (Case scrut case_bndr ty alts) - = do { (scrut', scrut_uds) <- specExpr env scrut - ; (scrut'', case_bndr', alts', alts_uds) - <- specCase env scrut' case_bndr alts - ; return (Case scrut'' case_bndr' (substTy env ty) alts' - , scrut_uds `plusUDs` alts_uds) } - ----------------- Finally, let is the interesting case -------------------- -specExpr env (Let bind body) - = do { -- Clone binders - (rhs_env, body_env, bind') <- cloneBindSM env bind - - -- Deal with the body - ; (body', body_uds) <- specExpr body_env body - - -- Deal with the bindings - ; (binds', uds) <- specBind rhs_env bind' body_uds - - -- All done - ; return (foldr Let body' binds', uds) } - -specTickish :: SpecEnv -> Tickish Id -> Tickish Id -specTickish env (Breakpoint ix ids) - = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]] - -- drop vars from the list if they have a non-variable substitution. - -- should never happen, but it's harmless to drop them anyway. -specTickish _ other_tickish = other_tickish - -specCase :: SpecEnv - -> CoreExpr -- Scrutinee, already done - -> Id -> [CoreAlt] - -> SpecM ( CoreExpr -- New scrutinee - , Id - , [CoreAlt] - , UsageDetails) -specCase env scrut' case_bndr [(con, args, rhs)] - | isDictId case_bndr -- See Note [Floating dictionaries out of cases] - , interestingDict env scrut' - , not (isDeadBinder case_bndr && null sc_args') - = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') - - ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg') - [(con, args', Var sc_arg')] - | sc_arg' <- sc_args' ] - - -- Extend the substitution for RHS to map the *original* binders - -- to their floated versions. - mb_sc_flts :: [Maybe DictId] - mb_sc_flts = map (lookupVarEnv clone_env) args' - clone_env = zipVarEnv sc_args' sc_args_flt - subst_prs = (case_bndr, Var case_bndr_flt) - : [ (arg, Var sc_flt) - | (arg, Just sc_flt) <- args `zip` mb_sc_flts ] - env_rhs' = env_rhs { se_subst = GHC.Core.Subst.extendIdSubstList (se_subst env_rhs) subst_prs - , se_interesting = se_interesting env_rhs `extendVarSetList` - (case_bndr_flt : sc_args_flt) } - - ; (rhs', rhs_uds) <- specExpr env_rhs' rhs - ; let scrut_bind = mkDB (NonRec case_bndr_flt scrut') - case_bndr_set = unitVarSet case_bndr_flt - sc_binds = [(NonRec sc_arg_flt sc_rhs, case_bndr_set) - | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ] - flt_binds = scrut_bind : sc_binds - (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds - all_uds = flt_binds `addDictBinds` free_uds - alt' = (con, args', wrapDictBindsE dumped_dbs rhs') - ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } - where - (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args) - sc_args' = filter is_flt_sc_arg args' - - clone_me bndr = do { uniq <- getUniqueM - ; return (mkUserLocalOrCoVar occ uniq ty loc) } - where - name = idName bndr - ty = idType bndr - occ = nameOccName name - loc = getSrcSpan name - - arg_set = mkVarSet args' - is_flt_sc_arg var = isId var - && not (isDeadBinder var) - && isDictTy var_ty - && not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set) - where - var_ty = idType var - - -specCase env scrut case_bndr alts - = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts - ; return (scrut, case_bndr', alts', uds_alts) } - where - (env_alt, case_bndr') = substBndr env case_bndr - spec_alt (con, args, rhs) = do - (rhs', uds) <- specExpr env_rhs rhs - let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds - return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds) - where - (env_rhs, args') = substBndrs env_alt args - -{- -Note [Floating dictionaries out of cases] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - g = \d. case d of { MkD sc ... -> ...(f sc)... } -Naively we can't float d2's binding out of the case expression, -because 'sc' is bound by the case, and that in turn means we can't -specialise f, which seems a pity. - -So we invert the case, by floating out a binding -for 'sc_flt' thus: - sc_flt = case d of { MkD sc ... -> sc } -Now we can float the call instance for 'f'. Indeed this is just -what'll happen if 'sc' was originally bound with a let binding, -but case is more efficient, and necessary with equalities. So it's -good to work with both. - -You might think that this won't make any difference, because the -call instance will only get nuked by the \d. BUT if 'g' itself is -specialised, then transitively we should be able to specialise f. - -In general, given - case e of cb { MkD sc ... -> ...(f sc)... } -we transform to - let cb_flt = e - sc_flt = case cb_flt of { MkD sc ... -> sc } - in - case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... } - -The "_flt" things are the floated binds; we use the current substitution -to substitute sc -> sc_flt in the RHS - -************************************************************************ -* * - Dealing with a binding -* * -************************************************************************ --} - -specBind :: SpecEnv -- Use this for RHSs - -> CoreBind -- Binders are already cloned by cloneBindSM, - -- but RHSs are un-processed - -> UsageDetails -- Info on how the scope of the binding - -> SpecM ([CoreBind], -- New bindings - UsageDetails) -- And info to pass upstream - --- Returned UsageDetails: --- No calls for binders of this bind -specBind rhs_env (NonRec fn rhs) body_uds - = do { (rhs', rhs_uds) <- specExpr rhs_env rhs - ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds fn rhs - - ; let pairs = spec_defns ++ [(fn', rhs')] - -- fn' mentions the spec_defns in its rules, - -- so put the latter first - - combined_uds = body_uds1 `plusUDs` rhs_uds - - (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds - - final_binds :: [DictBind] - -- See Note [From non-recursive to recursive] - final_binds - | not (isEmptyBag dump_dbs) - , not (null spec_defns) - = [recWithDumpedDicts pairs dump_dbs] - | otherwise - = [mkDB $ NonRec b r | (b,r) <- pairs] - ++ bagToList dump_dbs - - ; if float_all then - -- Rather than discard the calls mentioning the bound variables - -- we float this (dictionary) binding along with the others - return ([], free_uds `snocDictBinds` final_binds) - else - -- No call in final_uds mentions bound variables, - -- so we can just leave the binding here - return (map fst final_binds, free_uds) } - - -specBind rhs_env (Rec pairs) body_uds - -- Note [Specialising a recursive group] - = do { let (bndrs,rhss) = unzip pairs - ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss - ; let scope_uds = body_uds `plusUDs` rhs_uds - -- Includes binds and calls arising from rhss - - ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs - - ; (bndrs3, spec_defns3, uds3) - <- if null spec_defns1 -- Common case: no specialisation - then return (bndrs1, [], uds1) - else do { -- Specialisation occurred; do it again - (bndrs2, spec_defns2, uds2) - <- specDefns rhs_env uds1 (bndrs1 `zip` rhss) - ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) } - - ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3 - final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss') - dumped_dbs - - ; if float_all then - return ([], final_uds `snocDictBind` final_bind) - else - return ([fst final_bind], final_uds) } - - ---------------------------- -specDefns :: SpecEnv - -> UsageDetails -- Info on how it is used in its scope - -> [(OutId,InExpr)] -- The things being bound and their un-processed RHS - -> SpecM ([OutId], -- Original Ids with RULES added - [(OutId,OutExpr)], -- Extra, specialised bindings - UsageDetails) -- Stuff to fling upwards from the specialised versions - --- Specialise a list of bindings (the contents of a Rec), but flowing usages --- upwards binding by binding. Example: { f = ...g ...; g = ...f .... } --- Then if the input CallDetails has a specialised call for 'g', whose specialisation --- in turn generates a specialised call for 'f', we catch that in this one sweep. --- But not vice versa (it's a fixpoint problem). - -specDefns _env uds [] - = return ([], [], uds) -specDefns env uds ((bndr,rhs):pairs) - = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs - ; (bndr1, spec_defns2, uds2) <- specDefn env uds1 bndr rhs - ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) } - ---------------------------- -specDefn :: SpecEnv - -> UsageDetails -- Info on how it is used in its scope - -> OutId -> InExpr -- The thing being bound and its un-processed RHS - -> SpecM (Id, -- Original Id with added RULES - [(Id,CoreExpr)], -- Extra, specialised bindings - UsageDetails) -- Stuff to fling upwards from the specialised versions - -specDefn env body_uds fn rhs - = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds - rules_for_me = idCoreRules fn - ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me - calls_for_me fn rhs - ; return ( fn `addIdSpecialisations` rules - , spec_defns - , body_uds_without_me `plusUDs` spec_uds) } - -- It's important that the `plusUDs` is this way - -- round, because body_uds_without_me may bind - -- dictionaries that are used in calls_for_me passed - -- to specDefn. So the dictionary bindings in - -- spec_uds may mention dictionaries bound in - -- body_uds_without_me - ---------------------------- -specCalls :: Maybe Module -- Just this_mod => specialising imported fn - -- Nothing => specialising local fn - -> SpecEnv - -> [CoreRule] -- Existing RULES for the fn - -> [CallInfo] - -> OutId -> InExpr - -> SpecM SpecInfo -- New rules, specialised bindings, and usage details - --- This function checks existing rules, and does not create --- duplicate ones. So the caller does not need to do this filtering. --- See 'already_covered' - -type SpecInfo = ( [CoreRule] -- Specialisation rules - , [(Id,CoreExpr)] -- Specialised definition - , UsageDetails ) -- Usage details from specialised RHSs - -specCalls mb_mod env existing_rules calls_for_me fn rhs - -- The first case is the interesting one - | callSpecArity pis <= fn_arity -- See Note [Specialisation Must Preserve Sharing] - && notNull calls_for_me -- And there are some calls to specialise - && not (isNeverActive (idInlineActivation fn)) - -- Don't specialise NOINLINE things - -- See Note [Auto-specialisation and RULES] - --- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small --- See Note [Inline specialisation] for why we do not --- switch off specialisation for inline functions - - = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $ - foldlM spec_call ([], [], emptyUDs) calls_for_me - - | otherwise -- No calls or RHS doesn't fit our preconceptions - = WARN( not (exprIsTrivial rhs) && notNull calls_for_me, - text "Missed specialisation opportunity for" - <+> ppr fn $$ _trace_doc ) - -- Note [Specialisation shape] - -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ - return ([], [], emptyUDs) - where - _trace_doc = sep [ ppr rhs_tyvars, ppr rhs_bndrs - , ppr (idInlineActivation fn) ] - - fn_type = idType fn - fn_arity = idArity fn - fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here - pis = fst $ splitPiTys fn_type - theta = getTheta pis - n_dicts = length theta - inl_prag = idInlinePragma fn - inl_act = inlinePragmaActivation inl_prag - is_local = isLocalId fn - - -- Figure out whether the function has an INLINE pragma - -- See Note [Inline specialisations] - - (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs - -- See Note [Account for casts in binding] - rhs_tyvars = filter isTyVar rhs_bndrs - - in_scope = GHC.Core.Subst.substInScope (se_subst env) - - already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool - already_covered dflags new_rules args -- Note [Specialisations already covered] - = isJust (lookupRule dflags (in_scope, realIdUnfolding) - (const True) fn args - (new_rules ++ existing_rules)) - -- NB: we look both in the new_rules (generated by this invocation - -- of specCalls), and in existing_rules (passed in to specCalls) - - ---------------------------------------------------------- - -- Specialise to one particular call pattern - spec_call :: SpecInfo -- Accumulating parameter - -> CallInfo -- Call instance - -> SpecM SpecInfo - spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) - (CI { ci_key = call_args, ci_arity = call_arity }) - = ASSERT(call_arity <= fn_arity) - - -- See Note [Specialising Calls] - do { (rhs_env2, unused_bndrs, rule_bndrs, rule_args, unspec_bndrs, dx_binds, spec_args) - <- specHeader env rhs_bndrs $ dropWhileEndLE isUnspecArg call_args - ; let rhs_body' = mkLams unused_bndrs rhs_body - ; dflags <- getDynFlags - ; if already_covered dflags rules_acc rule_args - then return spec_acc - else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids - -- , text "rhs_env2" <+> ppr (se_subst rhs_env2) - -- , ppr dx_binds ]) $ - do - { -- Figure out the type of the specialised function - let body = mkLams unspec_bndrs rhs_body' - body_ty = substTy rhs_env2 $ exprType body - (lam_extra_args, app_args) -- See Note [Specialisations Must Be Lifted] - | isUnliftedType body_ty -- C.f. GHC.Core.Op.WorkWrap.Lib.mkWorkerArgs - , not (isJoinId fn) - = ([voidArgId], voidPrimId : unspec_bndrs) - | otherwise = ([], unspec_bndrs) - join_arity_change = length app_args - length rule_args - spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn - = Just (orig_join_arity + join_arity_change) - | otherwise - = Nothing - - ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_extra_args body) - ; let spec_id_ty = exprType spec_rhs - ; spec_f <- newSpecIdSM fn spec_id_ty spec_join_arity - ; this_mod <- getModule - ; let - -- The rule to put in the function's specialisation is: - -- forall x @b d1' d2'. - -- f x @T1 @b @T2 d1' d2' = f1 x @b - -- See Note [Specialising Calls] - herald = case mb_mod of - Nothing -- Specialising local fn - -> text "SPEC" - Just this_mod -- Specialising imported fn - -> text "SPEC/" <> ppr this_mod - - rule_name = mkFastString $ showSDoc dflags $ - herald <+> ftext (occNameFS (getOccName fn)) - <+> hsep (mapMaybe ppr_call_key_ty call_args) - -- This name ends up in interface files, so use occNameString. - -- Otherwise uniques end up there, making builds - -- less deterministic (See #4012 comment:61 ff) - - rule_wout_eta = mkRule - this_mod - True {- Auto generated -} - is_local - rule_name - inl_act -- Note [Auto-specialisation and RULES] - (idName fn) - rule_bndrs - rule_args - (mkVarApps (Var spec_f) app_args) - - spec_rule - = case isJoinId_maybe fn of - Just join_arity -> etaExpandToJoinPointRule join_arity - rule_wout_eta - Nothing -> rule_wout_eta - - -- Add the { d1' = dx1; d2' = dx2 } usage stuff - -- See Note [Specialising Calls] - spec_uds = foldr consDictBind rhs_uds dx_binds - - -------------------------------------- - -- Add a suitable unfolding if the spec_inl_prag says so - -- See Note [Inline specialisations] - (spec_inl_prag, spec_unf) - | not is_local && isStrongLoopBreaker (idOccInfo fn) - = (neverInlinePragma, noUnfolding) - -- See Note [Specialising imported functions] in OccurAnal - - | InlinePragma { inl_inline = Inlinable } <- inl_prag - = (inl_prag { inl_inline = NoUserInline }, noUnfolding) - - | otherwise - = (inl_prag, specUnfolding dflags unspec_bndrs spec_app n_dicts fn_unf) - - spec_app e = e `mkApps` spec_args - - -------------------------------------- - -- Adding arity information just propagates it a bit faster - -- See Note [Arity decrease] in GHC.Core.Op.Simplify - -- Copy InlinePragma information from the parent Id. - -- So if f has INLINE[1] so does spec_f - spec_f_w_arity = spec_f `setIdArity` max 0 (fn_arity - n_dicts) - `setInlinePragma` spec_inl_prag - `setIdUnfolding` spec_unf - `asJoinId_maybe` spec_join_arity - - _rule_trace_doc = vcat [ ppr spec_f, ppr fn_type, ppr spec_id_ty - , ppr rhs_bndrs, ppr call_args - , ppr spec_rule - ] - - ; -- pprTrace "spec_call: rule" _rule_trace_doc - return ( spec_rule : rules_acc - , (spec_f_w_arity, spec_rhs) : pairs_acc - , spec_uds `plusUDs` uds_acc - ) } } - -{- Note [Specialisation Must Preserve Sharing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a function: - - f :: forall a. Eq a => a -> blah - f = - if expensive - then f1 - else f2 - -As written, all calls to 'f' will share 'expensive'. But if we specialise 'f' -at 'Int', eg: - - $sfInt = SUBST[a->Int,dict->dEqInt] (if expensive then f1 else f2) - - RULE "SPEC f" - forall (d :: Eq Int). - f Int _ = $sfIntf - -We've now lost sharing between 'f' and '$sfInt' for 'expensive'. Yikes! - -To avoid this, we only generate specialisations for functions whose arity is -enough to bind all of the arguments we need to specialise. This ensures our -specialised functions don't do any work before receiving all of their dicts, -and thus avoids the 'f' case above. - -Note [Specialisations Must Be Lifted] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a function 'f': - - f = forall a. Eq a => Array# a - -used like - - case x of - True -> ...f @Int dEqInt... - False -> 0 - -Naively, we might generate an (expensive) specialisation - - $sfInt :: Array# Int - -even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to -the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to -preserve laziness. - -Note [Specialising Calls] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a function: - - f :: Int -> forall a b c. (Foo a, Foo c) => Bar -> Qux - f = \x -> /\ a b c -> \d1 d2 bar -> rhs - -and suppose it is called at: - - f 7 @T1 @T2 @T3 dFooT1 dFooT3 bar - -This call is described as a 'CallInfo' whose 'ci_key' is - - [ UnspecArg, SpecType T1, UnspecType, SpecType T3, SpecDict dFooT1 - , SpecDict dFooT3, UnspecArg ] - -Why are 'a' and 'c' identified as 'SpecType', while 'b' is 'UnspecType'? -Because we must specialise the function on type variables that appear -free in its *dictionary* arguments; but not on type variables that do not -appear in any dictionaries, i.e. are fully polymorphic. - -Because this call has dictionaries applied, we'd like to specialise -the call on any type argument that appears free in those dictionaries. -In this case, those are (a ~ T1, c ~ T3). - -As a result, we'd like to generate a function: - - $sf :: Int -> forall b. Bar -> Qux - $sf = SUBST[a->T1, c->T3, d1->d1', d2->d2'] (\x -> /\ b -> \bar -> rhs) - -Note that the substitution is applied to the whole thing. This is -convenient, but just slightly fragile. Notably: - * There had better be no name clashes in a/b/c - -We must construct a rewrite rule: - - RULE "SPEC f @T1 _ @T3" - forall (x :: Int) (@b :: Type) (d1' :: Foo T1) (d2' :: Foo T3). - f x @T1 @b @T3 d1' d2' = $sf x @b - -In the rule, d1' and d2' are just wildcards, not used in the RHS. Note -additionally that 'bar' isn't captured by this rule --- we bind only -enough etas in order to capture all of the *specialised* arguments. - -Finally, we must also construct the usage-details - - { d1' = dx1; d2' = dx2 } - -where d1', d2' are cloned versions of d1,d2, with the type substitution -applied. These auxiliary bindings just avoid duplication of dx1, dx2. - -Note [Account for casts in binding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: Eq a => a -> IO () - {-# INLINABLE f - StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g - #-} - f = ... - -In f's stable unfolding we have done some modest simplification which -has pushed the cast to the outside. (I wonder if this is the Right -Thing, but it's what happens now; see GHC.Core.Op.Simplify.Utils Note [Casts and -lambdas].) Now that stable unfolding must be specialised, so we want -to push the cast back inside. It would be terrible if the cast -defeated specialisation! Hence the use of collectBindersPushingCo. - -Note [Evidence foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose (#12212) that we are specialising - f :: forall a b. (Num a, F a ~ F b) => blah -with a=b=Int. Then the RULE will be something like - RULE forall (d:Num Int) (g :: F Int ~ F Int). - f Int Int d g = f_spec -But both varToCoreExpr (when constructing the LHS args), and the -simplifier (when simplifying the LHS args), will transform to - RULE forall (d:Num Int) (g :: F Int ~ F Int). - f Int Int d = f_spec -by replacing g with Refl. So now 'g' is unbound, which results in a later -crash. So we use Refl right off the bat, and do not forall-quantify 'g': - * varToCoreExpr generates a Refl - * exprsFreeIdsList returns the Ids bound by the args, - which won't include g - -You might wonder if this will match as often, but the simplifier replaces -complicated Refl coercions with Refl pretty aggressively. - -Note [Orphans and auto-generated rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we specialise an INLINABLE function, or when we have --fspecialise-aggressively, we auto-generate RULES that are orphans. -We don't want to warn about these, or we'd generate a lot of warnings. -Thus, we only warn about user-specified orphan rules. - -Indeed, we don't even treat the module as an orphan module if it has -auto-generated *rule* orphans. Orphan modules are read every time we -compile, so they are pretty obtrusive and slow down every compilation, -even non-optimised ones. (Reason: for type class instances it's a -type correctness issue.) But specialisation rules are strictly for -*optimisation* only so it's fine not to read the interface. - -What this means is that a SPEC rules from auto-specialisation in -module M will be used in other modules only if M.hi has been read for -some other reason, which is actually pretty likely. --} - -bindAuxiliaryDicts - :: SpecEnv - -> [DictId] -> [CoreExpr] -- Original dict bndrs, and the witnessing expressions - -> [DictId] -- A cloned dict-id for each dict arg - -> (SpecEnv, -- Substitute for all orig_dicts - [DictBind], -- Auxiliary dict bindings - [CoreExpr]) -- Witnessing expressions (all trivial) --- Bind any dictionary arguments to fresh names, to preserve sharing -bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting }) - orig_dict_ids call_ds inst_dict_ids - = (env', dx_binds, spec_dict_args) - where - (dx_binds, spec_dict_args) = go call_ds inst_dict_ids - env' = env { se_subst = subst `GHC.Core.Subst.extendSubstList` - (orig_dict_ids `zip` spec_dict_args) - `GHC.Core.Subst.extendInScopeList` dx_ids - , se_interesting = interesting `unionVarSet` interesting_dicts } - - dx_ids = [dx_id | (NonRec dx_id _, _) <- dx_binds] - interesting_dicts = mkVarSet [ dx_id | (NonRec dx_id dx, _) <- dx_binds - , interestingDict env dx ] - -- See Note [Make the new dictionaries interesting] - - go :: [CoreExpr] -> [CoreBndr] -> ([DictBind], [CoreExpr]) - go [] _ = ([], []) - go (dx:dxs) (dx_id:dx_ids) - | exprIsTrivial dx = (dx_binds, dx : args) - | otherwise = (mkDB (NonRec dx_id dx) : dx_binds, Var dx_id : args) - where - (dx_binds, args) = go dxs dx_ids - -- In the first case extend the substitution but not bindings; - -- in the latter extend the bindings but not the substitution. - -- For the former, note that we bind the *original* dict in the substitution, - -- overriding any d->dx_id binding put there by substBndrs - go _ _ = pprPanic "bindAuxiliaryDicts" (ppr orig_dict_ids $$ ppr call_ds $$ ppr inst_dict_ids) - -{- -Note [Make the new dictionaries interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Important! We're going to substitute dx_id1 for d -and we want it to look "interesting", else we won't gather *any* -consequential calls. E.g. - f d = ...g d.... -If we specialise f for a call (f (dfun dNumInt)), we'll get -a consequent call (g d') with an auxiliary definition - d' = df dNumInt -We want that consequent call to look interesting - - -Note [From non-recursive to recursive] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even in the non-recursive case, if any dict-binds depend on 'fn' we might -have built a recursive knot - - f a d x = - MkUD { ud_binds = NonRec d7 (MkD ..f..) - , ud_calls = ...(f T d7)... } - -The we generate - - Rec { fs x = [T/a, d7/d] - f a d x = - RULE f T _ = fs - d7 = ...f... } - -Here the recursion is only through the RULE. - -However we definitely should /not/ make the Rec in this wildly common -case: - d = ... - MkUD { ud_binds = NonRec d7 (...d...) - , ud_calls = ...(f T d7)... } - -Here we want simply to add d to the floats, giving - MkUD { ud_binds = NonRec d (...) - NonRec d7 (...d...) - , ud_calls = ...(f T d7)... } - -In general, we need only make this Rec if - - there are some specialisations (spec_binds non-empty) - - there are some dict_binds that depend on f (dump_dbs non-empty) - -Note [Avoiding loops] -~~~~~~~~~~~~~~~~~~~~~ -When specialising /dictionary functions/ we must be very careful to -avoid building loops. Here is an example that bit us badly: #3591 - - class Eq a => C a - instance Eq [a] => C [a] - -This translates to - dfun :: Eq [a] -> C [a] - dfun a d = MkD a d (meth d) - - d4 :: Eq [T] = - d2 :: C [T] = dfun T d4 - d1 :: Eq [T] = $p1 d2 - d3 :: C [T] = dfun T d1 - -None of these definitions is recursive. What happened was that we -generated a specialisation: - - RULE forall d. dfun T d = dT :: C [T] - dT = (MkD a d (meth d)) [T/a, d1/d] - = MkD T d1 (meth d1) - -But now we use the RULE on the RHS of d2, to get - - d2 = dT = MkD d1 (meth d1) - d1 = $p1 d2 - -and now d1 is bottom! The problem is that when specialising 'dfun' we -should first dump "below" the binding all floated dictionary bindings -that mention 'dfun' itself. So d2 and d3 (and hence d1) must be -placed below 'dfun', and thus unavailable to it when specialising -'dfun'. That in turn means that the call (dfun T d1) must be -discarded. On the other hand, the call (dfun T d4) is fine, assuming -d4 doesn't mention dfun. - -Solution: - Discard all calls that mention dictionaries that depend - (directly or indirectly) on the dfun we are specialising. - This is done by 'filterCalls' - --------------- -Here's another example, this time for an imported dfun, so the call -to filterCalls is in specImports (#13429). Suppose we have - class Monoid v => C v a where ... - -We start with a call - f @ [Integer] @ Integer $fC[]Integer - -Specialising call to 'f' gives dict bindings - $dMonoid_1 :: Monoid [Integer] - $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer - - $dC_1 :: C [Integer] (Node [Integer] Integer) - $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 - -...plus a recursive call to - f @ [Integer] @ (Node [Integer] Integer) $dC_1 - -Specialising that call gives - $dMonoid_2 :: Monoid [Integer] - $dMonoid_2 = M.$p1C @ [Integer] $dC_1 - - $dC_2 :: C [Integer] (Node [Integer] Integer) - $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2 - -Now we have two calls to the imported function - M.$fCvNode :: Monoid v => C v a - M.$fCvNode @v @a m = C m some_fun - -But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2) -for specialisation, else we get: - - $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 - $dMonoid_2 = M.$p1C @ [Integer] $dC_1 - $s$fCvNode = C $dMonoid_2 ... - RULE M.$fCvNode [Integer] _ _ = $s$fCvNode - -Now use the rule to rewrite the call in the RHS of $dC_1 -and we get a loop! - --------------- -Here's yet another example - - class C a where { foo,bar :: [a] -> [a] } - - instance C Int where - foo x = r_bar x - bar xs = reverse xs - - r_bar :: C a => [a] -> [a] - r_bar xs = bar (xs ++ xs) - -That translates to: - - r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) - - Rec { $fCInt :: C Int = MkC foo_help reverse - foo_help (xs::[Int]) = r_bar Int $fCInt xs } - -The call (r_bar $fCInt) mentions $fCInt, - which mentions foo_help, - which mentions r_bar -But we DO want to specialise r_bar at Int: - - Rec { $fCInt :: C Int = MkC foo_help reverse - foo_help (xs::[Int]) = r_bar Int $fCInt xs - - r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) - RULE r_bar Int _ = r_bar_Int - - r_bar_Int xs = bar Int $fCInt (xs ++ xs) - } - -Note that, because of its RULE, r_bar joins the recursive -group. (In this case it'll unravel a short moment later.) - - -Note [Specialising a recursive group] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let rec { f x = ...g x'... - ; g y = ...f y'.... } - in f 'a' -Here we specialise 'f' at Char; but that is very likely to lead to -a specialisation of 'g' at Char. We must do the latter, else the -whole point of specialisation is lost. - -But we do not want to keep iterating to a fixpoint, because in the -presence of polymorphic recursion we might generate an infinite number -of specialisations. - -So we use the following heuristic: - * Arrange the rec block in dependency order, so far as possible - (the occurrence analyser already does this) - - * Specialise it much like a sequence of lets - - * Then go through the block a second time, feeding call-info from - the RHSs back in the bottom, as it were - -In effect, the ordering maxmimises the effectiveness of each sweep, -and we do just two sweeps. This should catch almost every case of -monomorphic recursion -- the exception could be a very knotted-up -recursion with multiple cycles tied up together. - -This plan is implemented in the Rec case of specBindItself. - -Note [Specialisations already covered] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We obviously don't want to generate two specialisations for the same -argument pattern. There are two wrinkles - -1. We do the already-covered test in specDefn, not when we generate -the CallInfo in mkCallUDs. We used to test in the latter place, but -we now iterate the specialiser somewhat, and the Id at the call site -might therefore not have all the RULES that we can see in specDefn - -2. What about two specialisations where the second is an *instance* -of the first? If the more specific one shows up first, we'll generate -specialisations for both. If the *less* specific one shows up first, -we *don't* currently generate a specialisation for the more specific -one. (See the call to lookupRule in already_covered.) Reasons: - (a) lookupRule doesn't say which matches are exact (bad reason) - (b) if the earlier specialisation is user-provided, it's - far from clear that we should auto-specialise further - -Note [Auto-specialisation and RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - g :: Num a => a -> a - g = ... - - f :: (Int -> Int) -> Int - f w = ... - {-# RULE f g = 0 #-} - -Suppose that auto-specialisation makes a specialised version of -g::Int->Int That version won't appear in the LHS of the RULE for f. -So if the specialisation rule fires too early, the rule for f may -never fire. - -It might be possible to add new rules, to "complete" the rewrite system. -Thus when adding - RULE forall d. g Int d = g_spec -also add - RULE f g_spec = 0 - -But that's a bit complicated. For now we ask the programmer's help, -by *copying the INLINE activation pragma* to the auto-specialised -rule. So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule -will also not be active until phase 2. And that's what programmers -should jolly well do anyway, even aside from specialisation, to ensure -that g doesn't inline too early. - -This in turn means that the RULE would never fire for a NOINLINE -thing so not much point in generating a specialisation at all. - -Note [Specialisation shape] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only specialise a function if it has visible top-level lambdas -corresponding to its overloading. E.g. if - f :: forall a. Eq a => .... -then its body must look like - f = /\a. \d. ... - -Reason: when specialising the body for a call (f ty dexp), we want to -substitute dexp for d, and pick up specialised calls in the body of f. - -This doesn't always work. One example I came across was this: - newtype Gen a = MkGen{ unGen :: Int -> a } - - choose :: Eq a => a -> Gen a - choose n = MkGen (\r -> n) - - oneof = choose (1::Int) - -It's a silly example, but we get - choose = /\a. g `cast` co -where choose doesn't have any dict arguments. Thus far I have not -tried to fix this (wait till there's a real example). - -Mind you, then 'choose' will be inlined (since RHS is trivial) so -it doesn't matter. This comes up with single-method classes - - class C a where { op :: a -> a } - instance C a => C [a] where .... -==> - $fCList :: C a => C [a] - $fCList = $copList |> (...coercion>...) - ....(uses of $fCList at particular types)... - -So we suppress the WARN if the rhs is trivial. - -Note [Inline specialisations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is what we do with the InlinePragma of the original function - * Activation/RuleMatchInfo: both transferred to the - specialised function - * InlineSpec: - (a) An INLINE pragma is transferred - (b) An INLINABLE pragma is *not* transferred - -Why (a): transfer INLINE pragmas? The point of INLINE was precisely to -specialise the function at its call site, and arguably that's not so -important for the specialised copies. BUT *pragma-directed* -specialisation now takes place in the typechecker/desugarer, with -manually specified INLINEs. The specialisation here is automatic. -It'd be very odd if a function marked INLINE was specialised (because -of some local use), and then forever after (including importing -modules) the specialised version wasn't INLINEd. After all, the -programmer said INLINE! - -You might wonder why we specialise INLINE functions at all. After -all they should be inlined, right? Two reasons: - - * Even INLINE functions are sometimes not inlined, when they aren't - applied to interesting arguments. But perhaps the type arguments - alone are enough to specialise (even though the args are too boring - to trigger inlining), and it's certainly better to call the - specialised version. - - * The RHS of an INLINE function might call another overloaded function, - and we'd like to generate a specialised version of that function too. - This actually happens a lot. Consider - replicateM_ :: (Monad m) => Int -> m a -> m () - {-# INLINABLE replicateM_ #-} - replicateM_ d x ma = ... - The strictness analyser may transform to - replicateM_ :: (Monad m) => Int -> m a -> m () - {-# INLINE replicateM_ #-} - replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma - - $wreplicateM_ :: (Monad m) => Int# -> m a -> m () - {-# INLINABLE $wreplicateM_ #-} - $wreplicateM_ = ... - Now an importing module has a specialised call to replicateM_, say - (replicateM_ dMonadIO). We certainly want to specialise $wreplicateM_! - This particular example had a huge effect on the call to replicateM_ - in nofib/shootout/n-body. - -Why (b): discard INLINABLE pragmas? See #4874 for persuasive examples. -Suppose we have - {-# INLINABLE f #-} - f :: Ord a => [a] -> Int - f xs = letrec f' = ...f'... in f' -Then, when f is specialised and optimised we might get - wgo :: [Int] -> Int# - wgo = ...wgo... - f_spec :: [Int] -> Int - f_spec xs = case wgo xs of { r -> I# r } -and we clearly want to inline f_spec at call sites. But if we still -have the big, un-optimised of f (albeit specialised) captured in an -INLINABLE pragma for f_spec, we won't get that optimisation. - -So we simply drop INLINABLE pragmas when specialising. It's not really -a complete solution; ignoring specialisation for now, INLINABLE functions -don't get properly strictness analysed, for example. But it works well -for examples involving specialisation, which is the dominant use of -INLINABLE. See #4874. - - -************************************************************************ -* * -\subsubsection{UsageDetails and suchlike} -* * -************************************************************************ --} - -data UsageDetails - = MkUD { - ud_binds :: !(Bag DictBind), - -- See Note [Floated dictionary bindings] - -- The order is important; - -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1 - -- (Remember, Bags preserve order in GHC.) - - ud_calls :: !CallDetails - - -- INVARIANT: suppose bs = bindersOf ud_binds - -- Then 'calls' may *mention* 'bs', - -- but there should be no calls *for* bs - } - --- | A 'DictBind' is a binding along with a cached set containing its free --- variables (both type variables and dictionaries) -type DictBind = (CoreBind, VarSet) - -{- Note [Floated dictionary bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We float out dictionary bindings for the reasons described under -"Dictionary floating" above. But not /just/ dictionary bindings. -Consider - - f :: Eq a => blah - f a d = rhs - - $c== :: T -> T -> Bool - $c== x y = ... - - $df :: Eq T - $df = Eq $c== ... - - gurgle = ...(f @T $df)... - -We gather the call info for (f @T $df), and we don't want to drop it -when we come across the binding for $df. So we add $df to the floats -and continue. But then we have to add $c== to the floats, and so on. -These all float above the binding for 'f', and now we can -successfully specialise 'f'. - -So the DictBinds in (ud_binds :: Bag DictBind) may contain -non-dictionary bindings too. --} - -instance Outputable UsageDetails where - ppr (MkUD { ud_binds = dbs, ud_calls = calls }) - = text "MkUD" <+> braces (sep (punctuate comma - [text "binds" <+> equals <+> ppr dbs, - text "calls" <+> equals <+> ppr calls])) - -emptyUDs :: UsageDetails -emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv } - ------------------------------------------------------------- -type CallDetails = DIdEnv CallInfoSet - -- The order of specialized binds and rules depends on how we linearize - -- CallDetails, so to get determinism we must use a deterministic set here. - -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM - -data CallInfoSet = CIS Id (Bag CallInfo) - -- The list of types and dictionaries is guaranteed to - -- match the type of f - -- The Bag may contain duplicate calls (i.e. f @T and another f @T) - -- These dups are eliminated by already_covered in specCalls - -data CallInfo - = CI { ci_key :: [SpecArg] -- All arguments - , ci_arity :: Int -- The number of variables necessary to bind - -- all of the specialised arguments - , ci_fvs :: VarSet -- Free vars of the ci_key - -- call (including tyvars) - -- [*not* include the main id itself, of course] - } - -type DictExpr = CoreExpr - -ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet -ciSetFilter p (CIS id a) = CIS id (filterBag p a) - -instance Outputable CallInfoSet where - ppr (CIS fn map) = hang (text "CIS" <+> ppr fn) - 2 (ppr map) - -pprCallInfo :: Id -> CallInfo -> SDoc -pprCallInfo fn (CI { ci_key = key }) - = ppr fn <+> ppr key - -ppr_call_key_ty :: SpecArg -> Maybe SDoc -ppr_call_key_ty (SpecType ty) = Just $ char '@' <> pprParendType ty -ppr_call_key_ty UnspecType = Just $ char '_' -ppr_call_key_ty (SpecDict _) = Nothing -ppr_call_key_ty UnspecArg = Nothing - -instance Outputable CallInfo where - ppr (CI { ci_key = key, ci_fvs = fvs }) - = text "CI" <> braces (hsep [ fsep (mapMaybe ppr_call_key_ty key), ppr fvs ]) - -unionCalls :: CallDetails -> CallDetails -> CallDetails -unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2 - -unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet -unionCallInfoSet (CIS f calls1) (CIS _ calls2) = - CIS f (calls1 `unionBags` calls2) - -callDetailsFVs :: CallDetails -> VarSet -callDetailsFVs calls = - nonDetFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls - -- It's OK to use nonDetFoldUDFM here because we forget the ordering - -- immediately by converting to a nondeterministic set. - -callInfoFVs :: CallInfoSet -> VarSet -callInfoFVs (CIS _ call_info) = - foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info - -computeArity :: [SpecArg] -> Int -computeArity = length . filter isValueArg . dropWhileEndLE isUnspecArg - -callSpecArity :: [TyCoBinder] -> Int -callSpecArity = length . filter (not . isNamedBinder) . dropWhileEndLE isVisibleBinder - -getTheta :: [TyCoBinder] -> [PredType] -getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedBinder) - - ------------------------------------------------------------- -singleCall :: Id -> [SpecArg] -> UsageDetails -singleCall id args - = MkUD {ud_binds = emptyBag, - ud_calls = unitDVarEnv id $ CIS id $ - unitBag (CI { ci_key = args -- used to be tys - , ci_arity = computeArity args - , ci_fvs = call_fvs }) } - where - tys = getSpecTypes args - dicts = getSpecDicts args - call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs - tys_fvs = tyCoVarsOfTypes tys - -- The type args (tys) are guaranteed to be part of the dictionary - -- types, because they are just the constrained types, - -- and the dictionary is therefore sure to be bound - -- inside the binding for any type variables free in the type; - -- hence it's safe to neglect tyvars free in tys when making - -- the free-var set for this call - -- BUT I don't trust this reasoning; play safe and include tys_fvs - -- - -- We don't include the 'id' itself. - -mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails -mkCallUDs env f args - = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ]) - res - where - res = mkCallUDs' env f args - -mkCallUDs' env f args - | not (want_calls_for f) -- Imported from elsewhere - || null theta -- Not overloaded - = emptyUDs - - | not (all type_determines_value theta) - || not (computeArity ci_key <= idArity f) - || not (length dicts == length theta) - || not (any (interestingDict env) dicts) -- Note [Interesting dictionary arguments] - -- See also Note [Specialisations already covered] - = -- pprTrace "mkCallUDs: discarding" _trace_doc - emptyUDs -- Not overloaded, or no specialisation wanted - - | otherwise - = -- pprTrace "mkCallUDs: keeping" _trace_doc - singleCall f ci_key - where - _trace_doc = vcat [ppr f, ppr args, ppr (map (interestingDict env) dicts)] - pis = fst $ splitPiTys $ idType f - theta = getTheta pis - constrained_tyvars = tyCoVarsOfTypes theta - - ci_key :: [SpecArg] - ci_key = fmap (\(t, a) -> - case t of - Named (binderVar -> tyVar) - | tyVar `elemVarSet` constrained_tyvars - -> case a of - Type ty -> SpecType ty - _ -> pprPanic "ci_key" $ ppr a - | otherwise - -> UnspecType - Anon InvisArg _ -> SpecDict a - Anon VisArg _ -> UnspecArg - ) $ zip pis args - - dicts = getSpecDicts ci_key - - want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f)) - -- For imported things, we gather call instances if - -- there is an unfolding that we could in principle specialise - -- We might still decide not to use it (consulting dflags) - -- in specImports - -- Use 'realIdUnfolding' to ignore the loop-breaker flag! - - type_determines_value pred -- See Note [Type determines value] - = case classifyPredType pred of - ClassPred cls _ -> not (isIPClass cls) -- Superclasses can't be IPs - EqPred {} -> True - IrredPred {} -> True -- Things like (D []) where D is a - -- Constraint-ranged family; #7785 - ForAllPred {} -> True - -{- -Note [Type determines value] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Only specialise if all overloading is on non-IP *class* params, -because these are the ones whose *type* determines their *value*. In -parrticular, with implicit params, the type args *don't* say what the -value of the implicit param is! See #7101 - -However, consider - type family D (v::*->*) :: Constraint - type instance D [] = () - f :: D v => v Char -> Int -If we see a call (f "foo"), we'll pass a "dictionary" - () |> (g :: () ~ D []) -and it's good to specialise f at this dictionary. - -So the question is: can an implicit parameter "hide inside" a -type-family constraint like (D a). Well, no. We don't allow - type instance D Maybe = ?x:Int -Hence the IrredPred case in type_determines_value. -See #7785. - -Note [Interesting dictionary arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - \a.\d:Eq a. let f = ... in ...(f d)... -There really is not much point in specialising f wrt the dictionary d, -because the code for the specialised f is not improved at all, because -d is lambda-bound. We simply get junk specialisations. - -What is "interesting"? Just that it has *some* structure. But what about -variables? - - * A variable might be imported, in which case its unfolding - will tell us whether it has useful structure - - * Local variables are cloned on the way down (to avoid clashes when - we float dictionaries), and cloning drops the unfolding - (cloneIdBndr). Moreover, we make up some new bindings, and it's a - nuisance to give them unfoldings. So we keep track of the - "interesting" dictionaries as a VarSet in SpecEnv. - We have to take care to put any new interesting dictionary - bindings in the set. - -We accidentally lost accurate tracking of local variables for a long -time, because cloned variables don't have unfoldings. But makes a -massive difference in a few cases, eg #5113. For nofib as a -whole it's only a small win: 2.2% improvement in allocation for ansi, -1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. --} - -interestingDict :: SpecEnv -> CoreExpr -> Bool --- A dictionary argument is interesting if it has *some* structure --- NB: "dictionary" arguments include constraints of all sorts, --- including equality constraints; hence the Coercion case -interestingDict env (Var v) = hasSomeUnfolding (idUnfolding v) - || isDataConWorkId v - || v `elemVarSet` se_interesting env -interestingDict _ (Type _) = False -interestingDict _ (Coercion _) = False -interestingDict env (App fn (Type _)) = interestingDict env fn -interestingDict env (App fn (Coercion _)) = interestingDict env fn -interestingDict env (Tick _ a) = interestingDict env a -interestingDict env (Cast e _) = interestingDict env e -interestingDict _ _ = True - -plusUDs :: UsageDetails -> UsageDetails -> UsageDetails -plusUDs (MkUD {ud_binds = db1, ud_calls = calls1}) - (MkUD {ud_binds = db2, ud_calls = calls2}) - = MkUD { ud_binds = db1 `unionBags` db2 - , ud_calls = calls1 `unionCalls` calls2 } - ------------------------------ -_dictBindBndrs :: Bag DictBind -> [Id] -_dictBindBndrs dbs = foldr ((++) . bindersOf . fst) [] dbs - --- | Construct a 'DictBind' from a 'CoreBind' -mkDB :: CoreBind -> DictBind -mkDB bind = (bind, bind_fvs bind) - --- | Identify the free variables of a 'CoreBind' -bind_fvs :: CoreBind -> VarSet -bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs) -bind_fvs (Rec prs) = foldl' delVarSet rhs_fvs bndrs - where - bndrs = map fst prs - rhs_fvs = unionVarSets (map pair_fvs prs) - -pair_fvs :: (Id, CoreExpr) -> VarSet -pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs - `unionVarSet` idFreeVars bndr - -- idFreeVars: don't forget variables mentioned in - -- the rules of the bndr. C.f. OccAnal.addRuleUsage - -- Also tyvars mentioned in its type; they may not appear - -- in the RHS - -- type T a = Int - -- x :: T a = 3 - where - interesting :: InterestingVarFun - interesting v = isLocalVar v || (isId v && isDFunId v) - -- Very important: include DFunIds /even/ if it is imported - -- Reason: See Note [Avoiding loops], the second example - -- involving an imported dfun. We must know whether - -- a dictionary binding depends on an imported dfun, - -- in case we try to specialise that imported dfun - -- #13429 illustrates - --- | Flatten a set of "dumped" 'DictBind's, and some other binding --- pairs, into a single recursive binding. -recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind -recWithDumpedDicts pairs dbs - = (Rec bindings, fvs) - where - (bindings, fvs) = foldr add - ([], emptyVarSet) - (dbs `snocBag` mkDB (Rec pairs)) - add (NonRec b r, fvs') (pairs, fvs) = - ((b,r) : pairs, fvs `unionVarSet` fvs') - add (Rec prs1, fvs') (pairs, fvs) = - (prs1 ++ pairs, fvs `unionVarSet` fvs') - -snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails --- Add ud_binds to the tail end of the bindings in uds -snocDictBinds uds dbs - = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs } - -consDictBind :: DictBind -> UsageDetails -> UsageDetails -consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds } - -addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails -addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds } - -snocDictBind :: UsageDetails -> DictBind -> UsageDetails -snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind } - -wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind] -wrapDictBinds dbs binds - = foldr add binds dbs - where - add (bind,_) binds = bind : binds - -wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr -wrapDictBindsE dbs expr - = foldr add expr dbs - where - add (bind,_) expr = Let bind expr - ----------------------- -dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind) --- Used at a lambda or case binder; just dump anything mentioning the binder -dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) - | null bndrs = (uds, emptyBag) -- Common in case alternatives - | otherwise = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ - (free_uds, dump_dbs) - where - free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } - bndr_set = mkVarSet bndrs - (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set - free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor - deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be - -- no calls for any of the dicts in dump_dbs - -dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool) --- Used at a let(rec) binding. --- We return a boolean indicating whether the binding itself is mentioned, --- directly or indirectly, by any of the ud_calls; in that case we want to --- float the binding itself; --- See Note [Floated dictionary bindings] -dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) - = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ - (free_uds, dump_dbs, float_all) - where - free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } - bndr_set = mkVarSet bndrs - (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set - free_calls = deleteCallsFor bndrs orig_calls - float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls - -callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo]) -callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) - = -- pprTrace ("callsForMe") - -- (vcat [ppr fn, - -- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs), - -- text "Orig calls =" <+> ppr orig_calls, - -- text "Dep set =" <+> ppr dep_set, - -- text "Calls for me =" <+> ppr calls_for_me]) $ - (uds_without_me, calls_for_me) - where - uds_without_me = MkUD { ud_binds = orig_dbs - , ud_calls = delDVarEnv orig_calls fn } - calls_for_me = case lookupDVarEnv orig_calls fn of - Nothing -> [] - Just cis -> filterCalls cis orig_dbs - -- filterCalls: drop calls that (directly or indirectly) - -- refer to fn. See Note [Avoiding loops] - ----------------------- -filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo] --- See Note [Avoiding loops] -filterCalls (CIS fn call_bag) dbs - = filter ok_call (bagToList call_bag) - where - dump_set = foldl' go (unitVarSet fn) dbs - -- This dump-set could also be computed by splitDictBinds - -- (_,_,dump_set) = splitDictBinds dbs {fn} - -- But this variant is shorter - - go so_far (db,fvs) | fvs `intersectsVarSet` so_far - = extendVarSetList so_far (bindersOf db) - | otherwise = so_far - - ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set) - ----------------------- -splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet) --- splitDictBinds dbs bndrs returns --- (free_dbs, dump_dbs, dump_set) --- where --- * dump_dbs depends, transitively on bndrs --- * free_dbs does not depend on bndrs --- * dump_set = bndrs `union` bndrs(dump_dbs) -splitDictBinds dbs bndr_set - = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs - -- Important that it's foldl' not foldr; - -- we're accumulating the set of dumped ids in dump_set - where - split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs) - | dump_idset `intersectsVarSet` fvs -- Dump it - = (free_dbs, dump_dbs `snocBag` db, - extendVarSetList dump_idset (bindersOf bind)) - - | otherwise -- Don't dump it - = (free_dbs `snocBag` db, dump_dbs, dump_idset) - - ----------------------- -deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails --- Remove calls *mentioning* bs in any way -deleteCallsMentioning bs calls - = mapDVarEnv (ciSetFilter keep_call) calls - where - keep_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` bs) - -deleteCallsFor :: [Id] -> CallDetails -> CallDetails --- Remove calls *for* bs -deleteCallsFor bs calls = delDVarEnvList calls bs - -{- -************************************************************************ -* * -\subsubsection{Boring helper functions} -* * -************************************************************************ --} - -newtype SpecM a = SpecM (State SpecState a) deriving (Functor) - -data SpecState = SpecState { - spec_uniq_supply :: UniqSupply, - spec_module :: Module, - spec_dflags :: DynFlags - } - -instance Applicative SpecM where - pure x = SpecM $ return x - (<*>) = ap - -instance Monad SpecM where - SpecM x >>= f = SpecM $ do y <- x - case f y of - SpecM z -> - z - -instance MonadFail SpecM where - fail str = SpecM $ error str - -instance MonadUnique SpecM where - getUniqueSupplyM - = SpecM $ do st <- get - let (us1, us2) = splitUniqSupply $ spec_uniq_supply st - put $ st { spec_uniq_supply = us2 } - return us1 - - getUniqueM - = SpecM $ do st <- get - let (u,us') = takeUniqFromSupply $ spec_uniq_supply st - put $ st { spec_uniq_supply = us' } - return u - -instance HasDynFlags SpecM where - getDynFlags = SpecM $ liftM spec_dflags get - -instance HasModule SpecM where - getModule = SpecM $ liftM spec_module get - -runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a -runSpecM dflags this_mod (SpecM spec) - = do us <- getUniqueSupplyM - let initialState = SpecState { - spec_uniq_supply = us, - spec_module = this_mod, - spec_dflags = dflags - } - return $ evalState spec initialState - -mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails) -mapAndCombineSM _ [] = return ([], emptyUDs) -mapAndCombineSM f (x:xs) = do (y, uds1) <- f x - (ys, uds2) <- mapAndCombineSM f xs - return (y:ys, uds1 `plusUDs` uds2) - -extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv -extendTvSubstList env tv_binds - = env { se_subst = GHC.Core.Subst.extendTvSubstList (se_subst env) tv_binds } - -substTy :: SpecEnv -> Type -> Type -substTy env ty = GHC.Core.Subst.substTy (se_subst env) ty - -substCo :: SpecEnv -> Coercion -> Coercion -substCo env co = GHC.Core.Subst.substCo (se_subst env) co - -substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr) -substBndr env bs = case GHC.Core.Subst.substBndr (se_subst env) bs of - (subst', bs') -> (env { se_subst = subst' }, bs') - -substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr]) -substBndrs env bs = case GHC.Core.Subst.substBndrs (se_subst env) bs of - (subst', bs') -> (env { se_subst = subst' }, bs') - -cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind) --- Clone the binders of the bind; return new bind with the cloned binders --- Return the substitution to use for RHSs, and the one to use for the body -cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs) - = do { us <- getUniqueSupplyM - ; let (subst', bndr') = GHC.Core.Subst.cloneIdBndr subst us bndr - interesting' | interestingDict env rhs - = interesting `extendVarSet` bndr' - | otherwise = interesting - ; return (env, env { se_subst = subst', se_interesting = interesting' } - , NonRec bndr' rhs) } - -cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs) - = do { us <- getUniqueSupplyM - ; let (subst', bndrs') = GHC.Core.Subst.cloneRecIdBndrs subst us (map fst pairs) - env' = env { se_subst = subst' - , se_interesting = interesting `extendVarSetList` - [ v | (v,r) <- pairs, interestingDict env r ] } - ; return (env', env', Rec (bndrs' `zip` map snd pairs)) } - -newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr --- Make up completely fresh binders for the dictionaries --- Their bindings are going to float outwards -newDictBndr env b = do { uniq <- getUniqueM - ; let n = idName b - ty' = substTy env (idType b) - ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) } - -newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id - -- Give the new Id a similar occurrence name to the old one -newSpecIdSM old_id new_ty join_arity_maybe - = do { uniq <- getUniqueM - ; let name = idName old_id - new_occ = mkSpecOcc (nameOccName name) - new_id = mkUserLocal new_occ uniq new_ty (getSrcSpan name) - `asJoinId_maybe` join_arity_maybe - ; return new_id } - -{- - Old (but interesting) stuff about unboxed bindings - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -What should we do when a value is specialised to a *strict* unboxed value? - - map_*_* f (x:xs) = let h = f x - t = map f xs - in h:t - -Could convert let to case: - - map_*_Int# f (x:xs) = case f x of h# -> - let t = map f xs - in h#:t - -This may be undesirable since it forces evaluation here, but the value -may not be used in all branches of the body. In the general case this -transformation is impossible since the mutual recursion in a letrec -cannot be expressed as a case. - -There is also a problem with top-level unboxed values, since our -implementation cannot handle unboxed values at the top level. - -Solution: Lift the binding of the unboxed value and extract it when it -is used: - - map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h# - t = map f xs - in case h of - _Lift h# -> h#:t - -Now give it to the simplifier and the _Lifting will be optimised away. - -The benefit is that we have given the specialised "unboxed" values a -very simple lifted semantics and then leave it up to the simplifier to -optimise it --- knowing that the overheads will be removed in nearly -all cases. - -In particular, the value will only be evaluated in the branches of the -program which use it, rather than being forced at the point where the -value is bound. For example: - - filtermap_*_* p f (x:xs) - = let h = f x - t = ... - in case p x of - True -> h:t - False -> t - ==> - filtermap_*_Int# p f (x:xs) - = let h = case (f x) of h# -> _Lift h# - t = ... - in case p x of - True -> case h of _Lift h# - -> h#:t - False -> t - -The binding for h can still be inlined in the one branch and the -_Lifting eliminated. - - -Question: When won't the _Lifting be eliminated? - -Answer: When they at the top-level (where it is necessary) or when -inlining would duplicate work (or possibly code depending on -options). However, the _Lifting will still be eliminated if the -strictness analyser deems the lifted binding strict. --} diff --git a/compiler/GHC/Core/Op/StaticArgs.hs b/compiler/GHC/Core/Op/StaticArgs.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/StaticArgs.hs +++ /dev/null @@ -1,433 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -************************************************************************ - - Static Argument Transformation pass - -************************************************************************ - -May be seen as removing invariants from loops: -Arguments of recursive functions that do not change in recursive -calls are removed from the recursion, which is done locally -and only passes the arguments which effectively change. - -Example: -map = /\ ab -> \f -> \xs -> case xs of - [] -> [] - (a:b) -> f a : map f b - -as map is recursively called with the same argument f (unmodified) -we transform it to - -map = /\ ab -> \f -> \xs -> let map' ys = case ys of - [] -> [] - (a:b) -> f a : map' b - in map' xs - -Notice that for a compiler that uses lambda lifting this is -useless as map' will be transformed back to what map was. - -We could possibly do the same for big lambdas, but we don't as -they will eventually be removed in later stages of the compiler, -therefore there is no penalty in keeping them. - -We only apply the SAT when the number of static args is > 2. This -produces few bad cases. See - should_transform -in saTransform. - -Here are the headline nofib results: - Size Allocs Runtime -Min +0.0% -13.7% -21.4% -Max +0.1% +0.0% +5.4% -Geometric Mean +0.0% -0.2% -6.9% - -The previous patch, to fix polymorphic floatout demand signatures, is -essential to make this work well! --} - -{-# LANGUAGE CPP #-} -module GHC.Core.Op.StaticArgs ( doStaticArgs ) where - -import GhcPrelude - -import GHC.Types.Var -import GHC.Core -import GHC.Core.Utils -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Types.Id -import GHC.Types.Name -import GHC.Types.Var.Env -import GHC.Types.Unique.Supply -import Util -import GHC.Types.Unique.FM -import GHC.Types.Var.Set -import GHC.Types.Unique -import GHC.Types.Unique.Set -import Outputable - -import Data.List (mapAccumL) -import FastString - -#include "HsVersions.h" - -doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram -doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds - where - sat_bind_threaded_us us bind = - let (us1, us2) = splitUniqSupply us - in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet)) - --- We don't bother to SAT recursive groups since it can lead --- to massive code expansion: see Andre Santos' thesis for details. --- This means we only apply the actual SAT to Rec groups of one element, --- but we want to recurse into the others anyway to discover other binds -satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo) -satBind (NonRec binder expr) interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - return (NonRec binder expr', finalizeApp expr_app sat_info_expr) -satBind (Rec [(binder, rhs)]) interesting_ids = do - let interesting_ids' = interesting_ids `addOneToUniqSet` binder - (rhs_binders, rhs_body) = collectBinders rhs - (rhs_body', sat_info_rhs_body) <- satTopLevelExpr rhs_body interesting_ids' - let sat_info_rhs_from_args = unitVarEnv binder (bindersToSATInfo rhs_binders) - sat_info_rhs' = mergeIdSATInfo sat_info_rhs_from_args sat_info_rhs_body - - shadowing = binder `elementOfUniqSet` interesting_ids - sat_info_rhs'' = if shadowing - then sat_info_rhs' `delFromUFM` binder -- For safety - else sat_info_rhs' - - bind' <- saTransformMaybe binder (lookupUFM sat_info_rhs' binder) - rhs_binders rhs_body' - return (bind', sat_info_rhs'') -satBind (Rec pairs) interesting_ids = do - let (binders, rhss) = unzip pairs - rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss - let (rhss', sat_info_rhss') = unzip rhss_SATed - return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss') - -data App = VarApp Id | TypeApp Type | CoApp Coercion -data Staticness a = Static a | NotStatic - -type IdAppInfo = (Id, SATInfo) - -type SATInfo = [Staticness App] -type IdSATInfo = IdEnv SATInfo -emptyIdSATInfo :: IdSATInfo -emptyIdSATInfo = emptyUFM - -{- -pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info)) - where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info) --} - -pprSATInfo :: SATInfo -> SDoc -pprSATInfo staticness = hcat $ map pprStaticness staticness - -pprStaticness :: Staticness App -> SDoc -pprStaticness (Static (VarApp _)) = text "SV" -pprStaticness (Static (TypeApp _)) = text "ST" -pprStaticness (Static (CoApp _)) = text "SC" -pprStaticness NotStatic = text "NS" - - -mergeSATInfo :: SATInfo -> SATInfo -> SATInfo -mergeSATInfo l r = zipWith mergeSA l r - where - mergeSA NotStatic _ = NotStatic - mergeSA _ NotStatic = NotStatic - mergeSA (Static (VarApp v)) (Static (VarApp v')) - | v == v' = Static (VarApp v) - | otherwise = NotStatic - mergeSA (Static (TypeApp t)) (Static (TypeApp t')) - | t `eqType` t' = Static (TypeApp t) - | otherwise = NotStatic - mergeSA (Static (CoApp c)) (Static (CoApp c')) - | c `eqCoercion` c' = Static (CoApp c) - | otherwise = NotStatic - mergeSA _ _ = pprPanic "mergeSATInfo" $ - text "Left:" - <> pprSATInfo l <> text ", " - <> text "Right:" - <> pprSATInfo r - -mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo -mergeIdSATInfo = plusUFM_C mergeSATInfo - -mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo -mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo - -bindersToSATInfo :: [Id] -> SATInfo -bindersToSATInfo vs = map (Static . binderToApp) vs - where binderToApp v | isId v = VarApp v - | isTyVar v = TypeApp $ mkTyVarTy v - | otherwise = CoApp $ mkCoVarCo v - -finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo -finalizeApp Nothing id_sat_info = id_sat_info -finalizeApp (Just (v, sat_info')) id_sat_info = - let sat_info'' = case lookupUFM id_sat_info v of - Nothing -> sat_info' - Just sat_info -> mergeSATInfo sat_info sat_info' - in extendVarEnv id_sat_info v sat_info'' - -satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo) -satTopLevelExpr expr interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - return (expr', finalizeApp expr_app sat_info_expr) - -satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) -satExpr var@(Var v) interesting_ids = do - let app_info = if v `elementOfUniqSet` interesting_ids - then Just (v, []) - else Nothing - return (var, emptyIdSATInfo, app_info) - -satExpr lit@(Lit _) _ = do - return (lit, emptyIdSATInfo, Nothing) - -satExpr (Lam binders body) interesting_ids = do - (body', sat_info, this_app) <- satExpr body interesting_ids - return (Lam binders body', finalizeApp this_app sat_info, Nothing) - -satExpr (App fn arg) interesting_ids = do - (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids - let satRemainder = boring fn' sat_info_fn - case fn_app of - Nothing -> satRemainder Nothing - Just (fn_id, fn_app_info) -> - -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface) - let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness]) - in case arg of - Type t -> satRemainderWithStaticness $ Static (TypeApp t) - Coercion c -> satRemainderWithStaticness $ Static (CoApp c) - Var v -> satRemainderWithStaticness $ Static (VarApp v) - _ -> satRemainderWithStaticness $ NotStatic - where - boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) - boring fn' sat_info_fn app_info = - do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids - let sat_info_arg' = finalizeApp arg_app sat_info_arg - sat_info = mergeIdSATInfo sat_info_fn sat_info_arg' - return (App fn' arg', sat_info, app_info) - -satExpr (Case expr bndr ty alts) interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - let sat_info_expr' = finalizeApp expr_app sat_info_expr - - zipped_alts' <- mapM satAlt alts - let (alts', sat_infos_alts) = unzip zipped_alts' - return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing) - where - satAlt (con, bndrs, expr) = do - (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids - return ((con, bndrs, expr'), sat_info_expr) - -satExpr (Let bind body) interesting_ids = do - (body', sat_info_body, body_app) <- satExpr body interesting_ids - (bind', sat_info_bind) <- satBind bind interesting_ids - return (Let bind' body', mergeIdSATInfo sat_info_body sat_info_bind, body_app) - -satExpr (Tick tickish expr) interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - return (Tick tickish expr', sat_info_expr, expr_app) - -satExpr ty@(Type _) _ = do - return (ty, emptyIdSATInfo, Nothing) - -satExpr co@(Coercion _) _ = do - return (co, emptyIdSATInfo, Nothing) - -satExpr (Cast expr coercion) interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - return (Cast expr' coercion, sat_info_expr, expr_app) - -{- -************************************************************************ - - Static Argument Transformation Monad - -************************************************************************ --} - -type SatM result = UniqSM result - -runSAT :: UniqSupply -> SatM a -> a -runSAT = initUs_ - -newUnique :: SatM Unique -newUnique = getUniqueM - -{- -************************************************************************ - - Static Argument Transformation Monad - -************************************************************************ - -To do the transformation, the game plan is to: - -1. Create a small nonrecursive RHS that takes the - original arguments to the function but discards - the ones that are static and makes a call to the - SATed version with the remainder. We intend that - this will be inlined later, removing the overhead - -2. Bind this nonrecursive RHS over the original body - WITH THE SAME UNIQUE as the original body so that - any recursive calls to the original now go via - the small wrapper - -3. Rebind the original function to a new one which contains - our SATed function and just makes a call to it: - we call the thing making this call the local body - -Example: transform this - - map :: forall a b. (a->b) -> [a] -> [b] - map = /\ab. \(f:a->b) (as:[a]) -> body[map] -to - map :: forall a b. (a->b) -> [a] -> [b] - map = /\ab. \(f:a->b) (as:[a]) -> - letrec map' :: [a] -> [b] - -- The "worker function - map' = \(as:[a]) -> - let map :: forall a' b'. (a -> b) -> [a] -> [b] - -- The "shadow function - map = /\a'b'. \(f':(a->b) (as:[a]). - map' as - in body[map] - in map' as - -Note [Shadow binding] -~~~~~~~~~~~~~~~~~~~~~ -The calls to the inner map inside body[map] should get inlined -by the local re-binding of 'map'. We call this the "shadow binding". - -But we can't use the original binder 'map' unchanged, because -it might be exported, in which case the shadow binding won't be -discarded as dead code after it is inlined. - -So we use a hack: we make a new SysLocal binder with the *same* unique -as binder. (Another alternative would be to reset the export flag.) - -Note [Binder type capture] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Notice that in the inner map (the "shadow function"), the static arguments -are discarded -- it's as if they were underscores. Instead, mentions -of these arguments (notably in the types of dynamic arguments) are bound -by the *outer* lambdas of the main function. So we must make up fresh -names for the static arguments so that they do not capture variables -mentioned in the types of dynamic args. - -In the map example, the shadow function must clone the static type -argument a,b, giving a',b', to ensure that in the \(as:[a]), the 'a' -is bound by the outer forall. We clone f' too for consistency, but -that doesn't matter either way because static Id arguments aren't -mentioned in the shadow binding at all. - -If we don't we get something like this: - -[Exported] -[Arity 3] -GHC.Base.until = - \ (@ a_aiK) - (p_a6T :: a_aiK -> GHC.Types.Bool) - (f_a6V :: a_aiK -> a_aiK) - (x_a6X :: a_aiK) -> - letrec { - sat_worker_s1aU :: a_aiK -> a_aiK - [] - sat_worker_s1aU = - \ (x_a6X :: a_aiK) -> - let { - sat_shadow_r17 :: forall a_a3O. - (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O - [] - sat_shadow_r17 = - \ (@ a_aiK) - (p_a6T :: a_aiK -> GHC.Types.Bool) - (f_a6V :: a_aiK -> a_aiK) - (x_a6X :: a_aiK) -> - sat_worker_s1aU x_a6X } in - case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] { - GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X); - GHC.Types.True -> x_a6X - }; } in - sat_worker_s1aU x_a6X - -Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK -type argument. This is bad because it means the application sat_worker_s1aU x_a6X -is not well typed. --} - -saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind -saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body - | Just arg_staticness <- maybe_arg_staticness - , should_transform arg_staticness - = saTransform binder arg_staticness rhs_binders rhs_body - | otherwise - = return (Rec [(binder, mkLams rhs_binders rhs_body)]) - where - should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT - where - n_static_args = count isStaticValue staticness - -saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind -saTransform binder arg_staticness rhs_binders rhs_body - = do { shadow_lam_bndrs <- mapM clone binders_w_staticness - ; uniq <- newUnique - ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) } - where - -- Running example: foldr - -- foldr \alpha \beta c n xs = e, for some e - -- arg_staticness = [Static TypeApp, Static TypeApp, Static VarApp, Static VarApp, NonStatic] - -- rhs_binders = [\alpha, \beta, c, n, xs] - -- rhs_body = e - - binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic) - -- Any extra args are assumed NotStatic - - non_static_args :: [Var] - -- non_static_args = [xs] - -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs] - non_static_args = [v | (v, NotStatic) <- binders_w_staticness] - - clone (bndr, NotStatic) = return bndr - clone (bndr, _ ) = do { uniq <- newUnique - ; return (setVarUnique bndr uniq) } - - -- new_rhs = \alpha beta c n xs -> - -- let sat_worker = \xs -> let sat_shadow = \alpha' beta' c n xs -> - -- sat_worker xs - -- in e - -- in sat_worker xs - mk_new_rhs uniq shadow_lam_bndrs - = mkLams rhs_binders $ - Let (Rec [(rec_body_bndr, rec_body)]) - local_body - where - local_body = mkVarApps (Var rec_body_bndr) non_static_args - - rec_body = mkLams non_static_args $ - Let (NonRec shadow_bndr shadow_rhs) rhs_body - - -- See Note [Binder type capture] - shadow_rhs = mkLams shadow_lam_bndrs local_body - -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs - - rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq (exprType rec_body) - -- rec_body_bndr = sat_worker - - -- See Note [Shadow binding]; make a SysLocal - shadow_bndr = mkSysLocal (occNameFS (getOccName binder)) - (idUnique binder) - (exprType shadow_rhs) - -isStaticValue :: Staticness App -> Bool -isStaticValue (Static (VarApp _)) = True -isStaticValue _ = False diff --git a/compiler/GHC/Core/Op/WorkWrap.hs b/compiler/GHC/Core/Op/WorkWrap.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/WorkWrap.hs +++ /dev/null @@ -1,776 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} --} - -{-# LANGUAGE CPP #-} -module GHC.Core.Op.WorkWrap ( wwTopBinds ) where - -import GhcPrelude - -import GHC.Core.Arity ( manifestArity ) -import GHC.Core -import GHC.Core.Unfold ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding ) -import GHC.Core.Utils ( exprType, exprIsHNF ) -import GHC.Core.FVs ( exprFreeVars ) -import GHC.Types.Var -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Core.Type -import GHC.Types.Unique.Supply -import GHC.Types.Basic -import GHC.Driver.Session -import GHC.Types.Demand -import GHC.Types.Cpr -import GHC.Core.Op.WorkWrap.Lib -import Util -import Outputable -import GHC.Core.FamInstEnv -import MonadUtils - -#include "HsVersions.h" - -{- -We take Core bindings whose binders have: - -\begin{enumerate} - -\item Strictness attached (by the front-end of the strictness -analyser), and / or - -\item Constructed Product Result information attached by the CPR -analysis pass. - -\end{enumerate} - -and we return some ``plain'' bindings which have been -worker/wrapper-ified, meaning: - -\begin{enumerate} - -\item Functions have been split into workers and wrappers where -appropriate. If a function has both strictness and CPR properties -then only one worker/wrapper doing both transformations is produced; - -\item Binders' @IdInfos@ have been updated to reflect the existence of -these workers/wrappers (this is where we get STRICTNESS and CPR pragma -info for exported values). -\end{enumerate} --} - -wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram - -wwTopBinds dflags fam_envs us top_binds - = initUs_ us $ do - top_binds' <- mapM (wwBind dflags fam_envs) top_binds - return (concat top_binds') - -{- -************************************************************************ -* * -\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@} -* * -************************************************************************ - -@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in -turn. Non-recursive case first, then recursive... --} - -wwBind :: DynFlags - -> FamInstEnvs - -> CoreBind - -> UniqSM [CoreBind] -- returns a WwBinding intermediate form; - -- the caller will convert to Expr/Binding, - -- as appropriate. - -wwBind dflags fam_envs (NonRec binder rhs) = do - new_rhs <- wwExpr dflags fam_envs rhs - new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs - return [NonRec b e | (b,e) <- new_pairs] - -- Generated bindings must be non-recursive - -- because the original binding was. - -wwBind dflags fam_envs (Rec pairs) - = return . Rec <$> concatMapM do_one pairs - where - do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs - tryWW dflags fam_envs Recursive binder new_rhs - -{- -@wwExpr@ basically just walks the tree, looking for appropriate -annotations that can be used. Remember it is @wwBind@ that does the -matching by looking for strict arguments of the correct type. -@wwExpr@ is a version that just returns the ``Plain'' Tree. --} - -wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr - -wwExpr _ _ e@(Type {}) = return e -wwExpr _ _ e@(Coercion {}) = return e -wwExpr _ _ e@(Lit {}) = return e -wwExpr _ _ e@(Var {}) = return e - -wwExpr dflags fam_envs (Lam binder expr) - = Lam new_binder <$> wwExpr dflags fam_envs expr - where new_binder | isId binder = zapIdUsedOnceInfo binder - | otherwise = binder - -- See Note [Zapping Used Once info in WorkWrap] - -wwExpr dflags fam_envs (App f a) - = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a - -wwExpr dflags fam_envs (Tick note expr) - = Tick note <$> wwExpr dflags fam_envs expr - -wwExpr dflags fam_envs (Cast expr co) = do - new_expr <- wwExpr dflags fam_envs expr - return (Cast new_expr co) - -wwExpr dflags fam_envs (Let bind expr) - = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr - -wwExpr dflags fam_envs (Case expr binder ty alts) = do - new_expr <- wwExpr dflags fam_envs expr - new_alts <- mapM ww_alt alts - let new_binder = zapIdUsedOnceInfo binder - -- See Note [Zapping Used Once info in WorkWrap] - return (Case new_expr new_binder ty new_alts) - where - ww_alt (con, binders, rhs) = do - new_rhs <- wwExpr dflags fam_envs rhs - let new_binders = [ if isId b then zapIdUsedOnceInfo b else b - | b <- binders ] - -- See Note [Zapping Used Once info in WorkWrap] - return (con, new_binders, new_rhs) - -{- -************************************************************************ -* * -\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair} -* * -************************************************************************ - -@tryWW@ just accumulates arguments, converts strictness info from the -front-end into the proper form, then calls @mkWwBodies@ to do -the business. - -The only reason this is monadised is for the unique supply. - -Note [Don't w/w INLINE things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very important to refrain from w/w-ing an INLINE function (ie one -with a stable unfolding) because the wrapper will then overwrite the -old stable unfolding with the wrapper code. - -Furthermore, if the programmer has marked something as INLINE, -we may lose by w/w'ing it. - -If the strictness analyser is run twice, this test also prevents -wrappers (which are INLINEd) from being re-done. (You can end up with -several liked-named Ids bouncing around at the same time---absolute -mischief.) - -Notice that we refrain from w/w'ing an INLINE function even if it is -in a recursive group. It might not be the loop breaker. (We could -test for loop-breaker-hood, but I'm not sure that ever matters.) - -Note [Worker-wrapper for INLINABLE functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - {-# INLINABLE f #-} - f :: Ord a => [a] -> Int -> a - f x y = ....f.... - -where f is strict in y, we might get a more efficient loop by w/w'ing -f. But that would make a new unfolding which would overwrite the old -one! So the function would no longer be INLNABLE, and in particular -will not be specialised at call sites in other modules. - -This comes in practice (#6056). - -Solution: do the w/w for strictness analysis, but transfer the Stable -unfolding to the *worker*. So we will get something like this: - - {-# INLINE[0] f #-} - f :: Ord a => [a] -> Int -> a - f d x y = case y of I# y' -> fw d x y' - - {-# INLINABLE[0] fw #-} - fw :: Ord a => [a] -> Int# -> a - fw d x y' = let y = I# y' in ...f... - -How do we "transfer the unfolding"? Easy: by using the old one, wrapped -in work_fn! See GHC.Core.Unfold.mkWorkerUnfolding. - -Note [Worker-wrapper for NOINLINE functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to disable worker/wrapper for NOINLINE things, but it turns out -this can cause unnecessary reboxing of values. Consider - - {-# NOINLINE f #-} - f :: Int -> a - f x = error (show x) - - g :: Bool -> Bool -> Int -> Int - g True True p = f p - g False True p = p + 1 - g b False p = g b True p - -the strictness analysis will discover f and g are strict, but because f -has no wrapper, the worker for g will rebox p. So we get - - $wg x y p# = - let p = I# p# in -- Yikes! Reboxing! - case x of - False -> - case y of - False -> $wg False True p# - True -> +# p# 1# - True -> - case y of - False -> $wg True True p# - True -> case f p of { } - - g x y p = case p of (I# p#) -> $wg x y p# - -Now, in this case the reboxing will float into the True branch, and so -the allocation will only happen on the error path. But it won't float -inwards if there are multiple branches that call (f p), so the reboxing -will happen on every call of g. Disaster. - -Solution: do worker/wrapper even on NOINLINE things; but move the -NOINLINE pragma to the worker. - -(See #13143 for a real-world example.) - -It is crucial that we do this for *all* NOINLINE functions. #10069 -demonstrates what happens when we promise to w/w a (NOINLINE) leaf function, but -fail to deliver: - - data C = C Int# Int# - - {-# NOINLINE c1 #-} - c1 :: C -> Int# - c1 (C _ n) = n - - {-# NOINLINE fc #-} - fc :: C -> Int# - fc c = 2 *# c1 c - -Failing to w/w `c1`, but still w/wing `fc` leads to the following code: - - c1 :: C -> Int# - c1 (C _ n) = n - - $wfc :: Int# -> Int# - $wfc n = let c = C 0# n in 2 #* c1 c - - fc :: C -> Int# - fc (C _ n) = $wfc n - -Yikes! The reboxed `C` in `$wfc` can't cancel out, so we are in a bad place. -This generalises to any function that derives its strictness signature from -its callees, so we have to make sure that when a function announces particular -strictness properties, we have to w/w them accordingly, even if it means -splitting a NOINLINE function. - -Note [Worker activation] -~~~~~~~~~~~~~~~~~~~~~~~~ -Follows on from Note [Worker-wrapper for INLINABLE functions] - -It is *vital* that if the worker gets an INLINABLE pragma (from the -original function), then the worker has the same phase activation as -the wrapper (or later). That is necessary to allow the wrapper to -inline into the worker's unfolding: see GHC.Core.Op.Simplify.Utils -Note [Simplifying inside stable unfoldings]. - -If the original is NOINLINE, it's important that the work inherit the -original activation. Consider - - {-# NOINLINE expensive #-} - expensive x = x + 1 - - f y = let z = expensive y in ... - -If expensive's worker inherits the wrapper's activation, -we'll get this (because of the compromise in point (2) of -Note [Wrapper activation]) - - {-# NOINLINE[0] $wexpensive #-} - $wexpensive x = x + 1 - {-# INLINE[0] expensive #-} - expensive x = $wexpensive x - - f y = let z = expensive y in ... - -and $wexpensive will be immediately inlined into expensive, followed by -expensive into f. This effectively removes the original NOINLINE! - -Otherwise, nothing is lost by giving the worker the same activation as the -wrapper, because the worker won't have any chance of inlining until the -wrapper does; there's no point in giving it an earlier activation. - -Note [Don't w/w inline small non-loop-breaker things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, we refrain from w/w-ing *small* functions, which are not -loop breakers, because they'll inline anyway. But we must take care: -it may look small now, but get to be big later after other inlining -has happened. So we take the precaution of adding an INLINE pragma to -any such functions. - -I made this change when I observed a big function at the end of -compilation with a useful strictness signature but no w-w. (It was -small during demand analysis, we refrained from w/w, and then got big -when something was inlined in its rhs.) When I measured it on nofib, -it didn't make much difference; just a few percent improved allocation -on one benchmark (bspt/Euclid.space). But nothing got worse. - -There is an infelicity though. We may get something like - f = g val -==> - g x = case gw x of r -> I# r - - f {- InlineStable, Template = g val -} - f = case gw x of r -> I# r - -The code for f duplicates that for g, without any real benefit. It -won't really be executed, because calls to f will go via the inlining. - -Note [Don't w/w join points for CPR] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's no point in exploiting CPR info on a join point. If the whole function -is getting CPR'd, then the case expression around the worker function will get -pushed into the join point by the simplifier, which will have the same effect -that w/w'ing for CPR would have - the result will be returned in an unboxed -tuple. - - f z = let join j x y = (x+1, y+1) - in case z of A -> j 1 2 - B -> j 2 3 - - => - - f z = case $wf z of (# a, b #) -> (a, b) - $wf z = case (let join j x y = (x+1, y+1) - in case z of A -> j 1 2 - B -> j 2 3) of (a, b) -> (# a, b #) - - => - - f z = case $wf z of (# a, b #) -> (a, b) - $wf z = let join j x y = (# x+1, y+1 #) - in case z of A -> j 1 2 - B -> j 2 3 - -Note that we still want to give @j@ the CPR property, so that @f@ has it. So -CPR *analyse* join points as regular functions, but don't *transform* them. - -Doing W/W for returned products on a join point would be tricky anyway, as the -worker could not be a join point because it would not be tail-called. However, -doing the *argument* part of W/W still works for join points, since the wrapper -body will make a tail call: - - f z = let join j x y = x + y - in ... - - => - - f z = let join $wj x# y# = x# +# y# - j x y = case x of I# x# -> - case y of I# y# -> - $wj x# y# - in ... - -Note [Wrapper activation] -~~~~~~~~~~~~~~~~~~~~~~~~~ -When should the wrapper inlining be active? - -1. It must not be active earlier than the current Activation of the - Id - -2. It should be active at some point, despite (1) because of - Note [Worker-wrapper for NOINLINE functions] - -3. For ordinary functions with no pragmas we want to inline the - wrapper as early as possible (#15056). Suppose another module - defines f x = g x x - and suppose there is some RULE for (g True True). Then if we have - a call (f True), we'd expect to inline 'f' and the RULE will fire. - But if f is w/w'd (which it might be), we want the inlining to - occur just as if it hadn't been. - - (This only matters if f's RHS is big enough to w/w, but small - enough to inline given the call site, but that can happen.) - -4. We do not want to inline the wrapper before specialisation. - module Foo where - f :: Num a => a -> Int -> a - f n 0 = n -- Strict in the Int, hence wrapper - f n x = f (n+n) (x-1) - - g :: Int -> Int - g x = f x x -- Provokes a specialisation for f - - module Bar where - import Foo - - h :: Int -> Int - h x = f 3 x - - In module Bar we want to give specialisations a chance to fire - before inlining f's wrapper. - -Reminder: Note [Don't w/w INLINE things], so we don't need to worry - about INLINE things here. - -Conclusion: - - If the user said NOINLINE[n], respect that - - If the user said NOINLINE, inline the wrapper as late as - poss (phase 0). This is a compromise driven by (2) above - - Otherwise inline wrapper in phase 2. That allows the - 'gentle' simplification pass to apply specialisation rules - -Historical note: At one stage I tried making the wrapper inlining -always-active, and that had a very bad effect on nofib/imaginary/x2n1; -a wrapper was inlined before the specialisation fired. - -Note [Wrapper NoUserInline] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The use an inl_inline of NoUserInline on the wrapper distinguishes -this pragma from one that was given by the user. In particular, CSE -will not happen if there is a user-specified pragma, but should happen -for w/w’ed things (#14186). --} - -tryWW :: DynFlags - -> FamInstEnvs - -> RecFlag - -> Id -- The fn binder - -> CoreExpr -- The bound rhs; its innards - -- are already ww'd - -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs; - -- if one, then no worker (only - -- the orig "wrapper" lives on); - -- if two, then a worker and a - -- wrapper. -tryWW dflags fam_envs is_rec fn_id rhs - -- See Note [Worker-wrapper for NOINLINE functions] - - | Just stable_unf <- certainlyWillInline dflags fn_info - = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ] - -- See Note [Don't w/w INLINE things] - -- See Note [Don't w/w inline small non-loop-breaker things] - - | is_fun && is_eta_exp - = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs - - | is_thunk -- See Note [Thunk splitting] - = splitThunk dflags fam_envs is_rec new_fn_id rhs - - | otherwise - = return [ (new_fn_id, rhs) ] - - where - fn_info = idInfo fn_id - (wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info) - - cpr_ty = getCprSig (cprInfo fn_info) - -- Arity of the CPR sig should match idArity when it's not a join point. - -- See Note [Arity trimming for CPR signatures] in GHC.Core.Op.CprAnal - cpr = ASSERT2( isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info - , ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) - ct_cpr cpr_ty - - new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id) - -- See Note [Zapping DmdEnv after Demand Analyzer] and - -- See Note [Zapping Used Once info WorkWrap] - - is_fun = notNull wrap_dmds || isJoinId fn_id - -- See Note [Don't eta expand in w/w] - is_eta_exp = length wrap_dmds == manifestArity rhs - is_thunk = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id) - && not (isUnliftedType (idType fn_id)) - -{- -Note [Zapping DmdEnv after Demand Analyzer] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the worker-wrapper pass we zap the DmdEnv. Why? - (a) it is never used again - (b) it wastes space - (c) it becomes incorrect as things are cloned, because - we don't push the substitution into it - -Why here? - * Because we don’t want to do it in the Demand Analyzer, as we never know - there when we are doing the last pass. - * We want them to be still there at the end of DmdAnal, so that - -ddump-str-anal contains them. - * We don’t want a second pass just for that. - * WorkWrap looks at all bindings anyway. - -We also need to do it in TidyCore.tidyLetBndr to clean up after the -final, worker/wrapper-less run of the demand analyser (see -Note [Final Demand Analyser run] in GHC.Core.Op.DmdAnal). - -Note [Zapping Used Once info in WorkWrap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the worker-wrapper pass we zap the used once info in demands and in -strictness signatures. - -Why? - * The simplifier may happen to transform code in a way that invalidates the - data (see #11731 for an example). - * It is not used in later passes, up to code generation. - -So as the data is useless and possibly wrong, we want to remove it. The most -convenient place to do that is the worker wrapper phase, as it runs after every -run of the demand analyser besides the very last one (which is the one where we -want to _keep_ the info for the code generator). - -We do not do it in the demand analyser for the same reasons outlined in -Note [Zapping DmdEnv after Demand Analyzer] above. - -Note [Don't eta expand in w/w] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A binding where the manifestArity of the RHS is less than idArity of the binder -means GHC.Core.Arity didn't eta expand that binding. When this happens, it does so -for a reason (see Note [exprArity invariant] in GHC.Core.Arity) and we probably have -a PAP, cast or trivial expression as RHS. - -Performing the worker/wrapper split will implicitly eta-expand the binding to -idArity, overriding GHC.Core.Arity's decision. Other than playing fast and loose with -divergence, it's also broken for newtypes: - - f = (\xy.blah) |> co - where - co :: (Int -> Int -> Char) ~ T - -Then idArity is 2 (despite the type T), and it can have a StrictSig based on a -threshold of 2. But we can't w/w it without a type error. - -The situation is less grave for PAPs, but the implicit eta expansion caused a -compiler allocation regression in T15164, where huge recursive instance method -groups, mostly consisting of PAPs, got w/w'd. This caused great churn in the -simplifier, when simply waiting for the PAPs to inline arrived at the same -output program. - -Note there is the worry here that such PAPs and trivial RHSs might not *always* -be inlined. That would lead to reboxing, because the analysis tacitly assumes -that we W/W'd for idArity and will propagate analysis information under that -assumption. So far, this doesn't seem to matter in practice. -See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064. --} - - ---------------------- -splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> CprResult -> CoreExpr - -> UniqSM [(Id, CoreExpr)] -splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs - = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) ) do - -- The arity should match the signature - stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info - case stuff of - Just (work_demands, join_arity, wrap_fn, work_fn) -> do - work_uniq <- getUniqueM - let work_rhs = work_fn rhs - work_act = case fn_inline_spec of -- See Note [Worker activation] - NoInline -> fn_act - _ -> wrap_act - - work_prag = InlinePragma { inl_src = SourceText "{-# INLINE" - , inl_inline = fn_inline_spec - , inl_sat = Nothing - , inl_act = work_act - , inl_rule = FunLike } - -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions] - -- inl_act: see Note [Worker activation] - -- inl_rule: it does not make sense for workers to be constructorlike. - - work_join_arity | isJoinId fn_id = Just join_arity - | otherwise = Nothing - -- worker is join point iff wrapper is join point - -- (see Note [Don't w/w join points for CPR]) - - work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) - `setIdOccInfo` occInfo fn_info - -- Copy over occurrence info from parent - -- Notably whether it's a loop breaker - -- Doesn't matter much, since we will simplify next, but - -- seems right-er to do so - - `setInlinePragma` work_prag - - `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding - -- See Note [Worker-wrapper for INLINABLE functions] - - `setIdStrictness` mkClosedStrictSig work_demands div - -- Even though we may not be at top level, - -- it's ok to give it an empty DmdEnv - - `setIdCprInfo` mkCprSig work_arity work_cpr_info - - `setIdDemandInfo` worker_demand - - `setIdArity` work_arity - -- Set the arity so that the Core Lint check that the - -- arity is consistent with the demand type goes - -- through - `asJoinId_maybe` work_join_arity - - work_arity = length work_demands - - -- See Note [Demand on the Worker] - single_call = saturatedByOneShots arity (demandInfo fn_info) - worker_demand | single_call = mkWorkerDemand work_arity - | otherwise = topDmd - - wrap_rhs = wrap_fn work_id - wrap_act = case fn_act of -- See Note [Wrapper activation] - ActiveAfter {} -> fn_act - NeverActive -> activeDuringFinal - _ -> activeAfterInitial - wrap_prag = InlinePragma { inl_src = SourceText "{-# INLINE" - , inl_inline = NoUserInline - , inl_sat = Nothing - , inl_act = wrap_act - , inl_rule = rule_match_info } - -- inl_act: see Note [Wrapper activation] - -- inl_inline: see Note [Wrapper NoUserInline] - -- inl_rule: RuleMatchInfo is (and must be) unaffected - - wrap_id = fn_id `setIdUnfolding` mkWwInlineRule dflags wrap_rhs arity - `setInlinePragma` wrap_prag - `setIdOccInfo` noOccInfo - -- Zap any loop-breaker-ness, to avoid bleating from Lint - -- about a loop breaker with an INLINE rule - - - - return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)] - -- Worker first, because wrapper mentions it - - Nothing -> return [(fn_id, rhs)] - where - rhs_fvs = exprFreeVars rhs - fn_inl_prag = inlinePragInfo fn_info - fn_inline_spec = inl_inline fn_inl_prag - fn_act = inl_act fn_inl_prag - rule_match_info = inlinePragmaRuleMatchInfo fn_inl_prag - fn_unfolding = unfoldingInfo fn_info - arity = arityInfo fn_info - -- The arity is set by the simplifier using exprEtaExpandArity - -- So it may be more than the number of top-level-visible lambdas - - -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points, - -- see Note [Don't w/w join points for CPR]. - use_cpr_info | isJoinId fn_id = topCpr - | otherwise = cpr - -- Even if we don't w/w join points for CPR, we might still do so for - -- strictness. In which case a join point worker keeps its original CPR - -- property; see Note [Don't w/w join points for CPR]. Otherwise, the worker - -- doesn't have the CPR property anymore. - work_cpr_info | isJoinId fn_id = cpr - | otherwise = topCpr - - -{- -Note [Demand on the worker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -If the original function is called once, according to its demand info, then -so is the worker. This is important so that the occurrence analyser can -attach OneShot annotations to the worker’s lambda binders. - - -Example: - - -- Original function - f [Demand=] :: (a,a) -> a - f = \p -> ... - - -- Wrapper - f [Demand=] :: a -> a -> a - f = \p -> case p of (a,b) -> $wf a b - - -- Worker - $wf [Demand=] :: Int -> Int - $wf = \a b -> ... - -We need to check whether the original function is called once, with -sufficiently many arguments. This is done using saturatedByOneShots, which -takes the arity of the original function (resp. the wrapper) and the demand on -the original function. - -The demand on the worker is then calculated using mkWorkerDemand, and always of -the form [Demand=] - - -Note [Do not split void functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this rather common form of binding: - $j = \x:Void# -> ...no use of x... - -Since x is not used it'll be marked as absent. But there is no point -in w/w-ing because we'll simply add (\y:Void#), see GHC.Core.Op.WorkWrap.Lib.mkWorerArgs. - -If x has a more interesting type (eg Int, or Int#), there *is* a point -in w/w so that we don't pass the argument at all. - -Note [Thunk splitting] -~~~~~~~~~~~~~~~~~~~~~~ -Suppose x is used strictly (never mind whether it has the CPR -property). - - let - x* = x-rhs - in body - -splitThunk transforms like this: - - let - x* = case x-rhs of { I# a -> I# a } - in body - -Now simplifier will transform to - - case x-rhs of - I# a -> let x* = I# a - in body - -which is what we want. Now suppose x-rhs is itself a case: - - x-rhs = case e of { T -> I# a; F -> I# b } - -The join point will abstract over a, rather than over (which is -what would have happened before) which is fine. - -Notice that x certainly has the CPR property now! - -In fact, splitThunk uses the function argument w/w splitting -function, so that if x's demand is deeper (say U(U(L,L),L)) -then the splitting will go deeper too. --} - --- See Note [Thunk splitting] --- splitThunk converts the *non-recursive* binding --- x = e --- into --- x = let x = e --- in case x of --- I# y -> let x = I# y in x } --- See comments above. Is it not beautifully short? --- Moreover, it works just as well when there are --- several binders, and if the binders are lifted --- E.g. x = e --- --> x = let x = e in --- case x of (a,b) -> let x = (a,b) in x - -splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)] -splitThunk dflags fam_envs is_rec fn_id rhs - = ASSERT(not (isJoinId fn_id)) - do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [fn_id] - ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] - ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive - return res - else return [(fn_id, rhs)] } diff --git a/compiler/GHC/Core/Op/WorkWrap/Lib.hs b/compiler/GHC/Core/Op/WorkWrap/Lib.hs deleted file mode 100644 --- a/compiler/GHC/Core/Op/WorkWrap/Lib.hs +++ /dev/null @@ -1,1247 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -A library for the ``worker\/wrapper'' back-end to the strictness analyser --} - -{-# LANGUAGE CPP #-} - -module GHC.Core.Op.WorkWrap.Lib - ( mkWwBodies, mkWWstr, mkWorkerArgs - , DataConAppContext(..), deepSplitProductType_maybe, wantToUnbox - , findTypeShape - , isWorkerSmallEnough - ) -where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Core -import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase ) -import GHC.Types.Id -import GHC.Types.Id.Info ( JoinArity ) -import GHC.Core.DataCon -import GHC.Types.Demand -import GHC.Types.Cpr -import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup - , mkCoreApp, mkCoreLet ) -import GHC.Types.Id.Make ( voidArgId, voidPrimId ) -import TysWiredIn ( tupleDataCon ) -import TysPrim ( voidPrimTy ) -import GHC.Types.Literal ( absentLiteralOf, rubbishLit ) -import GHC.Types.Var.Env ( mkInScopeSet ) -import GHC.Types.Var.Set ( VarSet ) -import GHC.Core.Type -import GHC.Core.Predicate ( isClassPred ) -import GHC.Types.RepType ( isVoidTy, typePrimRep ) -import GHC.Core.Coercion -import GHC.Core.FamInstEnv -import GHC.Types.Basic ( Boxity(..) ) -import GHC.Core.TyCon -import GHC.Types.Unique.Supply -import GHC.Types.Unique -import Maybes -import Util -import Outputable -import GHC.Driver.Session -import FastString -import ListSetOps - -{- -************************************************************************ -* * -\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@} -* * -************************************************************************ - -Here's an example. The original function is: - -\begin{verbatim} -g :: forall a . Int -> [a] -> a - -g = \/\ a -> \ x ys -> - case x of - 0 -> head ys - _ -> head (tail ys) -\end{verbatim} - -From this, we want to produce: -\begin{verbatim} --- wrapper (an unfolding) -g :: forall a . Int -> [a] -> a - -g = \/\ a -> \ x ys -> - case x of - I# x# -> $wg a x# ys - -- call the worker; don't forget the type args! - --- worker -$wg :: forall a . Int# -> [a] -> a - -$wg = \/\ a -> \ x# ys -> - let - x = I# x# - in - case x of -- note: body of g moved intact - 0 -> head ys - _ -> head (tail ys) -\end{verbatim} - -Something we have to be careful about: Here's an example: - -\begin{verbatim} --- "f" strictness: U(P)U(P) -f (I# a) (I# b) = a +# b - -g = f -- "g" strictness same as "f" -\end{verbatim} - -\tr{f} will get a worker all nice and friendly-like; that's good. -{\em But we don't want a worker for \tr{g}}, even though it has the -same strictness as \tr{f}. Doing so could break laziness, at best. - -Consequently, we insist that the number of strictness-info items is -exactly the same as the number of lambda-bound arguments. (This is -probably slightly paranoid, but OK in practice.) If it isn't the -same, we ``revise'' the strictness info, so that we won't propagate -the unusable strictness-info into the interfaces. - - -************************************************************************ -* * -\subsection{The worker wrapper core} -* * -************************************************************************ - -@mkWwBodies@ is called when doing the worker\/wrapper split inside a module. --} - -type WwResult - = ([Demand], -- Demands for worker (value) args - JoinArity, -- Number of worker (type OR value) args - Id -> CoreExpr, -- Wrapper body, lacking only the worker Id - CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs - -mkWwBodies :: DynFlags - -> FamInstEnvs - -> VarSet -- Free vars of RHS - -- See Note [Freshen WW arguments] - -> Id -- The original function - -> [Demand] -- Strictness of original function - -> CprResult -- Info about function result - -> UniqSM (Maybe WwResult) - --- wrap_fn_args E = \x y -> E --- work_fn_args E = E x y - --- wrap_fn_str E = case x of { (a,b) -> --- case a of { (a1,a2) -> --- E a1 a2 b y }} --- work_fn_str E = \a1 a2 b y -> --- let a = (a1,a2) in --- let x = (a,b) in --- E - -mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info - = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs) - -- See Note [Freshen WW arguments] - - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs empty_subst fun_ty demands - ; (useful1, work_args, wrap_fn_str, work_fn_str) - <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args - - -- Do CPR w/w. See Note [Always do CPR w/w] - ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) - <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty cpr_info - - ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty - worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v] - wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var - worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args - - ; if isWorkerSmallEnough dflags work_args - && not (too_many_args_for_join_point wrap_args) - && ((useful1 && not only_one_void_argument) || useful2) - then return (Just (worker_args_dmds, length work_call_args, - wrapper_body, worker_body)) - else return Nothing - } - -- We use an INLINE unconditionally, even if the wrapper turns out to be - -- something trivial like - -- fw = ... - -- f = __inline__ (coerce T fw) - -- The point is to propagate the coerce to f's call sites, so even though - -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent - -- fw from being inlined into f's RHS - where - fun_ty = idType fun_id - mb_join_arity = isJoinId_maybe fun_id - has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id) - -- See Note [Do not unpack class dictionaries] - - -- Note [Do not split void functions] - only_one_void_argument - | [d] <- demands - , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty - , isAbsDmd d && isVoidTy arg_ty1 - = True - | otherwise - = False - - -- Note [Join points returning functions] - too_many_args_for_join_point wrap_args - | Just join_arity <- mb_join_arity - , wrap_args `lengthExceeds` join_arity - = WARN(True, text "Unable to worker/wrapper join point with arity " <+> - int join_arity <+> text "but" <+> - int (length wrap_args) <+> text "args") - True - | otherwise - = False - --- See Note [Limit w/w arity] -isWorkerSmallEnough :: DynFlags -> [Var] -> Bool -isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags - -- We count only Free variables (isId) to skip Type, Kind - -- variables which have no runtime representation. - -{- -Note [Always do CPR w/w] -~~~~~~~~~~~~~~~~~~~~~~~~ -At one time we refrained from doing CPR w/w for thunks, on the grounds that -we might duplicate work. But that is already handled by the demand analyser, -which doesn't give the CPR property if w/w might waste work: see -Note [CPR for thunks] in GHC.Core.Op.DmdAnal. - -And if something *has* been given the CPR property and we don't w/w, it's -a disaster, because then the enclosing function might say it has the CPR -property, but now doesn't and there a cascade of disaster. A good example -is #5920. - -Note [Limit w/w arity] -~~~~~~~~~~~~~~~~~~~~~~~~ -Guard against high worker arity as it generates a lot of stack traffic. -A simplified example is #11565#comment:6 - -Current strategy is very simple: don't perform w/w transformation at all -if the result produces a wrapper with arity higher than -fmax-worker-args=. - -It is a bit all or nothing, consider - - f (x,y) (a,b,c,d,e ... , z) = rhs - -Currently we will remove all w/w ness entirely. But actually we could -w/w on the (x,y) pair... it's the huge product that is the problem. - -Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd -solve f. But we can get a lot of args from deeply-nested products: - - g (a, (b, (c, (d, ...)))) = rhs - -This is harder to spot on an arg-by-arg basis. Previously mkWwStr was -given some "fuel" saying how many arguments it could add; when we ran -out of fuel it would stop w/wing. -Still not very clever because it had a left-right bias. - -************************************************************************ -* * -\subsection{Making wrapper args} -* * -************************************************************************ - -During worker-wrapper stuff we may end up with an unlifted thing -which we want to let-bind without losing laziness. So we -add a void argument. E.g. - - f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z -==> - fw = /\ a -> \void -> E - f = /\ a -> \x y z -> fw realworld - -We use the state-token type which generates no code. --} - -mkWorkerArgs :: DynFlags -> [Var] - -> Type -- Type of body - -> ([Var], -- Lambda bound args - [Var]) -- Args at call site -mkWorkerArgs dflags args res_ty - | any isId args || not needsAValueLambda - = (args, args) - | otherwise - = (args ++ [voidArgId], args ++ [voidPrimId]) - where - -- See "Making wrapper args" section above - needsAValueLambda = - lifted - -- We may encounter a levity-polymorphic result, in which case we - -- conservatively assume that we have laziness that needs preservation. - -- See #15186. - || not (gopt Opt_FunToThunk dflags) - -- see Note [Protecting the last value argument] - - -- Might the result be lifted? - lifted = - case isLiftedType_maybe res_ty of - Just lifted -> lifted - Nothing -> True - -{- -Note [Protecting the last value argument] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the user writes (\_ -> E), they might be intentionally disallowing -the sharing of E. Since absence analysis and worker-wrapper are keen -to remove such unused arguments, we add in a void argument to prevent -the function from becoming a thunk. - -The user can avoid adding the void argument with the -ffun-to-thunk -flag. However, this can create sharing, which may be bad in two ways. 1) It can -create a space leak. 2) It can prevent inlining *under a lambda*. If w/w -removes the last argument from a function f, then f now looks like a thunk, and -so f can't be inlined *under a lambda*. - -Note [Join points and beta-redexes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Originally, the worker would invoke the original function by calling it with -arguments, thus producing a beta-redex for the simplifier to munch away: - - \x y z -> e => (\x y z -> e) wx wy wz - -Now that we have special rules about join points, however, this is Not Good if -the original function is itself a join point, as then it may contain invocations -of other join points: - - join j1 x = ... - join j2 y = if y == 0 then 0 else j1 y - - => - - join j1 x = ... - join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy - join j2 y = case y of I# y# -> jump $wj2 y# - -There can't be an intervening lambda between a join point's declaration and its -occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix: - - ... - let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y - ... - -Hence we simply do the beta-reduction here. (This would be harder if we had to -worry about hygiene, but luckily wy is freshly generated.) - -Note [Join points returning functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -It is crucial that the arity of a join point depends on its *callers,* not its -own syntax. What this means is that a join point can have "extra lambdas": - -f :: Int -> Int -> (Int, Int) -> Int -f x y = join j (z, w) = \(u, v) -> ... - in jump j (x, y) - -Typically this happens with functions that are seen as computing functions, -rather than being curried. (The real-life example was GraphOps.addConflicts.) - -When we create the wrapper, it *must* be in "eta-contracted" form so that the -jump has the right number of arguments: - -f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ... - j (z, w) = jump $wj z w - -(See Note [Join points and beta-redexes] for where the lets come from.) If j -were a function, we would instead say - -f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ... - j (z, w) (u, v) = $wj z w u v - -Notice that the worker ends up with the same lambdas; it's only the wrapper we -have to be concerned about. - -FIXME Currently the functionality to produce "eta-contracted" wrappers is -unimplemented; we simply give up. - -************************************************************************ -* * -\subsection{Coercion stuff} -* * -************************************************************************ - -We really want to "look through" coerces. -Reason: I've seen this situation: - - let f = coerce T (\s -> E) - in \x -> case x of - p -> coerce T' f - q -> \s -> E2 - r -> coerce T' f - -If only we w/w'd f, we'd get - let f = coerce T (\s -> fw s) - fw = \s -> E - in ... - -Now we'll inline f to get - - let fw = \s -> E - in \x -> case x of - p -> fw - q -> \s -> E2 - r -> fw - -Now we'll see that fw has arity 1, and will arity expand -the \x to get what we want. --} - --- mkWWargs just does eta expansion --- is driven off the function type and arity. --- It chomps bites off foralls, arrows, newtypes --- and keeps repeating that until it's satisfied the supplied arity - -mkWWargs :: TCvSubst -- Freshening substitution to apply to the type - -- See Note [Freshen WW arguments] - -> Type -- The type of the function - -> [Demand] -- Demands and one-shot info for value arguments - -> UniqSM ([Var], -- Wrapper args - CoreExpr -> CoreExpr, -- Wrapper fn - CoreExpr -> CoreExpr, -- Worker fn - Type) -- Type of wrapper body - -mkWWargs subst fun_ty demands - | null demands - = return ([], id, id, substTy subst fun_ty) - - | (dmd:demands') <- demands - , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty - = do { uniq <- getUniqueM - ; let arg_ty' = substTy subst arg_ty - id = mk_wrap_arg uniq arg_ty' dmd - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst fun_ty' demands' - ; return (id : wrap_args, - Lam id . wrap_fn_args, - apply_or_bind_then work_fn_args (varToCoreExpr id), - res_ty) } - - | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty - = do { uniq <- getUniqueM - ; let (subst', tv') = cloneTyVarBndr subst tv uniq - -- See Note [Freshen WW arguments] - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst' fun_ty' demands - ; return (tv' : wrap_args, - Lam tv' . wrap_fn_args, - apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')), - res_ty) } - - | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty - -- The newtype case is for when the function has - -- a newtype after the arrow (rare) - -- - -- It's also important when we have a function returning (say) a pair - -- wrapped in a newtype, at least if CPR analysis can look - -- through such newtypes, which it probably can since they are - -- simply coerces. - - = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst rep_ty demands - ; let co' = substCo subst co - ; return (wrap_args, - \e -> Cast (wrap_fn_args e) (mkSymCo co'), - \e -> work_fn_args (Cast e co'), - res_ty) } - - | otherwise - = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand - return ([], id, id, substTy subst fun_ty) -- then there should be a function arrow - where - -- See Note [Join points and beta-redexes] - apply_or_bind_then k arg (Lam bndr body) - = mkCoreLet (NonRec bndr arg) (k body) -- Important that arg is fresh! - apply_or_bind_then k arg fun - = k $ mkCoreApp (text "mkWWargs") fun arg -applyToVars :: [Var] -> CoreExpr -> CoreExpr -applyToVars vars fn = mkVarApps fn vars - -mk_wrap_arg :: Unique -> Type -> Demand -> Id -mk_wrap_arg uniq ty dmd - = mkSysLocalOrCoVar (fsLit "w") uniq ty - `setIdDemandInfo` dmd - -{- Note [Freshen WW arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Wen we do a worker/wrapper split, we must not in-scope names as the arguments -of the worker, else we'll get name capture. E.g. - - -- y1 is in scope from further out - f x = ..y1.. - -If we accidentally choose y1 as a worker argument disaster results: - - fww y1 y2 = let x = (y1,y2) in ...y1... - -To avoid this: - - * We use a fresh unique for both type-variable and term-variable binders - Originally we lacked this freshness for type variables, and that led - to the very obscure #12562. (A type variable in the worker shadowed - an outer term-variable binding.) - - * Because of this cloning we have to substitute in the type/kind of the - new binders. That's why we carry the TCvSubst through mkWWargs. - - So we need a decent in-scope set, just in case that type/kind - itself has foralls. We get this from the free vars of the RHS of the - function since those are the only variables that might be captured. - It's a lazy thunk, which will only be poked if the type/kind has a forall. - - Another tricky case was when f :: forall a. a -> forall a. a->a - (i.e. with shadowing), and then the worker used the same 'a' twice. - -************************************************************************ -* * -\subsection{Strictness stuff} -* * -************************************************************************ --} - -mkWWstr :: DynFlags - -> FamInstEnvs - -> Bool -- True <=> INLINEABLE pragma on this function defn - -- See Note [Do not unpack class dictionaries] - -> [Var] -- Wrapper args; have their demand info on them - -- *Includes type variables* - -> UniqSM (Bool, -- Is this useful - [Var], -- Worker args - CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call - -- and without its lambdas - -- This fn adds the unboxing - - CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function, - -- and lacking its lambdas. - -- This fn does the reboxing -mkWWstr dflags fam_envs has_inlineable_prag args - = go args - where - go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg - - go [] = return (False, [], nop_fn, nop_fn) - go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg - ; (useful2, args2, wrap_fn2, work_fn2) <- go args - ; return ( useful1 || useful2 - , args1 ++ args2 - , wrap_fn1 . wrap_fn2 - , work_fn1 . work_fn2) } - -{- -Note [Unpacking arguments with product and polymorphic demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The argument is unpacked in a case if it has a product type and has a -strict *and* used demand put on it. I.e., arguments, with demands such -as the following ones: - - - - -will be unpacked, but - - or - -will not, because the pieces aren't used. This is quite important otherwise -we end up unpacking massive tuples passed to the bottoming function. Example: - - f :: ((Int,Int) -> String) -> (Int,Int) -> a - f g pr = error (g pr) - - main = print (f fst (1, error "no")) - -Does 'main' print "error 1" or "error no"? We don't really want 'f' -to unbox its second argument. This actually happened in GHC's onwn -source code, in Packages.applyPackageFlag, which ended up un-boxing -the enormous DynFlags tuple, and being strict in the -as-yet-un-filled-in pkgState files. --} - ----------------------- --- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn) --- * wrap_fn assumes wrap_arg is in scope, --- brings into scope work_args (via cases) --- * work_fn assumes work_args are in scope, a --- brings into scope wrap_arg (via lets) --- See Note [How to do the worker/wrapper split] -mkWWstr_one :: DynFlags -> FamInstEnvs - -> Bool -- True <=> INLINEABLE pragma on this function defn - -- See Note [Do not unpack class dictionaries] - -> Var - -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) -mkWWstr_one dflags fam_envs has_inlineable_prag arg - | isTyVar arg - = return (False, [arg], nop_fn, nop_fn) - - | isAbsDmd dmd - , Just work_fn <- mk_absent_let dflags fam_envs arg - -- Absent case. We can't always handle absence for arbitrary - -- unlifted types, so we need to choose just the cases we can - -- (that's what mk_absent_let does) - = return (True, [], nop_fn, work_fn) - - | Just (cs, acdc) <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd - = unbox_one dflags fam_envs arg cs acdc - - | otherwise -- Other cases - = return (False, [arg], nop_fn, nop_fn) - - where - arg_ty = idType arg - dmd = idDemandInfo arg - -wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConAppContext) -wantToUnbox fam_envs has_inlineable_prag ty dmd = - case deepSplitProductType_maybe fam_envs ty of - Just dcac@DataConAppContext{ dcac_arg_tys = con_arg_tys } - | isStrictDmd dmd - -- See Note [Unpacking arguments with product and polymorphic demands] - , Just cs <- split_prod_dmd_arity dmd (length con_arg_tys) - -- See Note [Do not unpack class dictionaries] - , not (has_inlineable_prag && isClassPred ty) - -- See Note [mkWWstr and unsafeCoerce] - , cs `equalLength` con_arg_tys - -> Just (cs, dcac) - _ -> Nothing - where - split_prod_dmd_arity dmd arty - -- For seqDmd, splitProdDmd_maybe will return Nothing (because how would - -- it know the arity?), but it should behave like , for some - -- suitable arity - | isSeqDmd dmd = Just (replicate arty absDmd) - -- Otherwise splitProdDmd_maybe does the job - | otherwise = splitProdDmd_maybe dmd - -unbox_one :: DynFlags -> FamInstEnvs -> Var - -> [Demand] - -> DataConAppContext - -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) -unbox_one dflags fam_envs arg cs - DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys - , dcac_arg_tys = inst_con_arg_tys - , dcac_co = co } - = do { (uniq1:uniqs) <- getUniquesM - ; let -- See Note [Add demands for strict constructors] - cs' = addDataConStrictness data_con cs - unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs' - unbox_fn = mkUnpackCase (Var arg) co uniq1 - data_con unpk_args - arg_no_unf = zapStableUnfolding arg - -- See Note [Zap unfolding when beta-reducing] - -- in GHC.Core.Op.Simplify; and see #13890 - rebox_fn = Let (NonRec arg_no_unf con_app) - con_app = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co - ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args - ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) } - -- Don't pass the arg, rebox instead - where - mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd - ----------------------- -nop_fn :: CoreExpr -> CoreExpr -nop_fn body = body - -addDataConStrictness :: DataCon -> [Demand] -> [Demand] --- See Note [Add demands for strict constructors] -addDataConStrictness con ds - = ASSERT2( equalLength strs ds, ppr con $$ ppr strs $$ ppr ds ) - zipWith add ds strs - where - strs = dataConRepStrictness con - add dmd str | isMarkedStrict str = strictifyDmd dmd - | otherwise = dmd - -{- Note [How to do the worker/wrapper split] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The worker-wrapper transformation, mkWWstr_one, takes into account -several possibilities to decide if the function is worthy for -splitting: - -1. If an argument is absent, it would be silly to pass it to - the worker. Hence the isAbsDmd case. This case must come - first because a demand like or is possible. - E.g. comes from a function like - f x = error "urk" - and can come from Note [Add demands for strict constructors] - -2. If the argument is evaluated strictly, and we can split the - product demand (splitProdDmd_maybe), then unbox it and w/w its - pieces. For example - - f :: (Int, Int) -> Int - f p = (case p of (a,b) -> a) + 1 - is split to - f :: (Int, Int) -> Int - f p = case p of (a,b) -> $wf a - - $wf :: Int -> Int - $wf a = a + 1 - - and - g :: Bool -> (Int, Int) -> Int - g c p = case p of (a,b) -> - if c then a else b - is split to - g c p = case p of (a,b) -> $gw c a b - $gw c a b = if c then a else b - -2a But do /not/ split if the components are not used; that is, the - usage is just 'Used' rather than 'UProd'. In this case - splitProdDmd_maybe returns Nothing. Otherwise we risk decomposing - a massive tuple which is barely used. Example: - - f :: ((Int,Int) -> String) -> (Int,Int) -> a - f g pr = error (g pr) - - main = print (f fst (1, error "no")) - - Here, f does not take 'pr' apart, and it's stupid to do so. - Imagine that it had millions of fields. This actually happened - in GHC itself where the tuple was DynFlags - -3. A plain 'seqDmd', which is head-strict with usage UHead, can't - be split by splitProdDmd_maybe. But we want it to behave just - like U(AAAA) for suitable number of absent demands. So we have - a special case for it, with arity coming from the data constructor. - -Note [Worker-wrapper for bottoming functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used not to split if the result is bottom. -[Justification: there's no efficiency to be gained.] - -But it's sometimes bad not to make a wrapper. Consider - fw = \x# -> let x = I# x# in case e of - p1 -> error_fn x - p2 -> error_fn x - p3 -> the real stuff -The re-boxing code won't go away unless error_fn gets a wrapper too. -[We don't do reboxing now, but in general it's better to pass an -unboxed thing to f, and have it reboxed in the error cases....] - -Note [Add demands for strict constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this program (due to Roman): - - data X a = X !a - - foo :: X Int -> Int -> Int - foo (X a) n = go 0 - where - go i | i < n = a + go (i+1) - | otherwise = 0 - -We want the worker for 'foo' too look like this: - - $wfoo :: Int# -> Int# -> Int# - -with the first argument unboxed, so that it is not eval'd each time -around the 'go' loop (which would otherwise happen, since 'foo' is not -strict in 'a'). It is sound for the wrapper to pass an unboxed arg -because X is strict, so its argument must be evaluated. And if we -*don't* pass an unboxed argument, we can't even repair it by adding a -`seq` thus: - - foo (X a) n = a `seq` go 0 - -because the seq is discarded (very early) since X is strict! - -So here's what we do - -* We leave the demand-analysis alone. The demand on 'a' in the - definition of 'foo' is ; the strictness info is Lazy - because foo's body may or may not evaluate 'a'; but the usage info - says that 'a' is unpacked and its content is used. - -* During worker/wrapper, if we unpack a strict constructor (as we do - for 'foo'), we use 'addDataConStrictness' to bump up the strictness on - the strict arguments of the data constructor. - -* That in turn means that, if the usage info supports doing so - (i.e. splitProdDmd_maybe returns Just), we will unpack that argument - -- even though the original demand (e.g. on 'a') was lazy. - -* What does "bump up the strictness" mean? Just add a head-strict - demand to the strictness! Even for a demand like we can - safely turn it into ; remember case (1) of - Note [How to do the worker/wrapper split]. - -The net effect is that the w/w transformation is more aggressive about -unpacking the strict arguments of a data constructor, when that -eagerness is supported by the usage info. - -There is the usual danger of reboxing, which as usual we ignore. But -if X is monomorphic, and has an UNPACK pragma, then this optimisation -is even more important. We don't want the wrapper to rebox an unboxed -argument, and pass an Int to $wfoo! - -This works in nested situations like - - data family Bar a - data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) - newtype instance Bar Int = Bar Int - - foo :: Bar ((Int, Int), Int) -> Int -> Int - foo f k = case f of BarPair x y -> - case burble of - True -> case x of - BarPair p q -> ... - False -> ... - -The extra eagerness lets us produce a worker of type: - $wfoo :: Int# -> Int# -> Int# -> Int -> Int - $wfoo p# q# y# = ... - -even though the `case x` is only lazily evaluated. - ---------- Historical note ------------ -We used to add data-con strictness demands when demand analysing case -expression. However, it was noticed in #15696 that this misses some cases. For -instance, consider the program (from T10482) - - data family Bar a - data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) - newtype instance Bar Int = Bar Int - - foo :: Bar ((Int, Int), Int) -> Int -> Int - foo f k = - case f of - BarPair x y -> case burble of - True -> case x of - BarPair p q -> ... - False -> ... - -We really should be able to assume that `p` is already evaluated since it came -from a strict field of BarPair. This strictness would allow us to produce a -worker of type: - - $wfoo :: Int# -> Int# -> Int# -> Int -> Int - $wfoo p# q# y# = ... - -even though the `case x` is only lazily evaluated - -Indeed before we fixed #15696 this would happen since we would float the inner -`case x` through the `case burble` to get: - - foo f k = - case f of - BarPair x y -> case x of - BarPair p q -> case burble of - True -> ... - False -> ... - -However, after fixing #15696 this could no longer happen (for the reasons -discussed in ticket:15696#comment:76). This means that the demand placed on `f` -would then be significantly weaker (since the False branch of the case on -`burble` is not strict in `p` or `q`). - -Consequently, we now instead account for data-con strictness in mkWWstr_one, -applying the strictness demands to the final result of DmdAnal. The result is -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 [mkWWstr and unsafeCoerce] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -By using unsafeCoerce, it is possible to make the number of demands fail to -match the number of constructor arguments; this happened in #8037. -If so, the worker/wrapper split doesn't work right and we get a Core Lint -bug. The fix here is simply to decline to do w/w if that happens. - -Note [Record evaluated-ness in worker/wrapper] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - data T = MkT !Int Int - - f :: T -> T - f x = e - -and f's is strict, and has the CPR property. The we are going to generate -this w/w split - - f x = case x of - MkT x1 x2 -> case $wf x1 x2 of - (# r1, r2 #) -> MkT r1 r2 - - $wfw x1 x2 = let x = MkT x1 x2 in - case e of - MkT r1 r2 -> (# r1, r2 #) - -Note that - -* In the worker $wf, inside 'e' we can be sure that x1 will be - evaluated (it came from unpacking the argument MkT. But that's no - immediately apparent in $wf - -* In the wrapper 'f', which we'll inline at call sites, we can be sure - that 'r1' has been evaluated (because it came from unpacking the result - MkT. But that is not immediately apparent from the wrapper code. - -Missing these facts isn't unsound, but it loses possible future -opportunities for optimisation. - -Solution: use setCaseBndrEvald when creating - (A) The arg binders x1,x2 in mkWstr_one - See #13077, test T13077 - (B) The result binders r1,r2 in mkWWcpr_help - See Trace #13077, test T13077a - And #13027 comment:20, item (4) -to record that the relevant binder is evaluated. - - -************************************************************************ -* * - Type scrutiny that is specific to demand analysis -* * -************************************************************************ - -Note [Do not unpack class dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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.Op.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. - -But in any other situation a dictionary is just an ordinary value, -and can be unpacked. So we track the INLINABLE pragma, and switch -off the unpacking in mkWWstr_one (see the isClassPred test). - -Historical note: #14955 describes how I got this fix wrong -the first time. --} - --- | Context for a 'DataCon' application with a hole for every field, including --- surrounding coercions. --- The result of 'deepSplitProductType_maybe' and 'deepSplitCprType_maybe'. --- --- Example: --- --- > DataConAppContext Just [Int] [(Lazy, Int)] (co :: Maybe Int ~ First Int) --- --- represents --- --- > Just @Int (_1 :: Int) |> co :: First Int --- --- where _1 is a hole for the first argument. The number of arguments is --- determined by the length of @arg_tys@. -data DataConAppContext - = DataConAppContext - { dcac_dc :: !DataCon - , dcac_tys :: ![Type] - , dcac_arg_tys :: ![(Type, StrictnessMark)] - , dcac_co :: !Coercion - } - -deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe DataConAppContext --- If deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co) --- then dc @ tys (args::arg_tys) :: rep_ty --- co :: ty ~ rep_ty --- Why do we return the strictness of the data-con arguments? --- Answer: see Note [Record evaluated-ness in worker/wrapper] -deepSplitProductType_maybe fam_envs ty - | let (co, ty1) = topNormaliseType_maybe fam_envs ty - `orElse` (mkRepReflCo ty, ty) - , Just (tc, tc_args) <- splitTyConApp_maybe ty1 - , Just con <- isDataProductTyCon_maybe tc - , let arg_tys = dataConInstArgTys con tc_args - strict_marks = dataConRepStrictness con - = Just DataConAppContext { dcac_dc = con - , dcac_tys = tc_args - , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks - , dcac_co = co } -deepSplitProductType_maybe _ _ = Nothing - -deepSplitCprType_maybe - :: FamInstEnvs -> ConTag -> Type -> Maybe DataConAppContext --- If deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co) --- then dc @ tys (args::arg_tys) :: rep_ty --- co :: ty ~ rep_ty --- Why do we return the strictness of the data-con arguments? --- Answer: see Note [Record evaluated-ness in worker/wrapper] -deepSplitCprType_maybe fam_envs con_tag ty - | let (co, ty1) = topNormaliseType_maybe fam_envs ty - `orElse` (mkRepReflCo ty, ty) - , Just (tc, tc_args) <- splitTyConApp_maybe ty1 - , isDataTyCon tc - , let cons = tyConDataCons tc - , cons `lengthAtLeast` con_tag -- This might not be true if we import the - -- type constructor via a .hs-bool file (#8743) - , let con = cons `getNth` (con_tag - fIRST_TAG) - arg_tys = dataConInstArgTys con tc_args - strict_marks = dataConRepStrictness con - = Just DataConAppContext { dcac_dc = con - , dcac_tys = tc_args - , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks - , dcac_co = co } -deepSplitCprType_maybe _ _ _ = Nothing - -findTypeShape :: FamInstEnvs -> Type -> TypeShape --- Uncover the arrow and product shape of a type --- The data type TypeShape is defined in GHC.Types.Demand --- See Note [Trimming a demand to a type] in GHC.Types.Demand -findTypeShape fam_envs ty - | Just (tc, tc_args) <- splitTyConApp_maybe ty - , Just con <- isDataProductTyCon_maybe tc - = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args) - - | Just (_, res) <- splitFunTy_maybe ty - = TsFun (findTypeShape fam_envs res) - - | Just (_, ty') <- splitForAllTy_maybe ty - = findTypeShape fam_envs ty' - - | Just (_, ty') <- topNormaliseType_maybe fam_envs ty - = findTypeShape fam_envs ty' - - | otherwise - = TsUnk - -{- -************************************************************************ -* * -\subsection{CPR stuff} -* * -************************************************************************ - - -@mkWWcpr@ takes the worker/wrapper pair produced from the strictness -info and adds in the CPR transformation. The worker returns an -unboxed tuple containing non-CPR components. The wrapper takes this -tuple and re-produces the correct structured output. - -The non-CPR results appear ordered in the unboxed tuple as if by a -left-to-right traversal of the result structure. --} - -mkWWcpr :: Bool - -> FamInstEnvs - -> Type -- function body type - -> CprResult -- CPR analysis results - -> UniqSM (Bool, -- Is w/w'ing useful? - CoreExpr -> CoreExpr, -- New wrapper - CoreExpr -> CoreExpr, -- New worker - Type) -- Type of worker's body - -mkWWcpr opt_CprAnal fam_envs body_ty cpr - -- CPR explicitly turned off (or in -O0) - | not opt_CprAnal = return (False, id, id, body_ty) - -- CPR is turned on by default for -O and O2 - | otherwise - = case asConCpr cpr of - Nothing -> return (False, id, id, body_ty) -- No CPR info - Just con_tag | Just dcac <- deepSplitCprType_maybe fam_envs con_tag body_ty - -> mkWWcpr_help dcac - | otherwise - -- See Note [non-algebraic or open body type warning] - -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty ) - return (False, id, id, body_ty) - -mkWWcpr_help :: DataConAppContext - -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type) - -mkWWcpr_help (DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys - , dcac_arg_tys = arg_tys, dcac_co = co }) - | [arg1@(arg_ty1, _)] <- arg_tys - , isUnliftedType arg_ty1 - -- Special case when there is a single result of unlifted type - -- - -- Wrapper: case (..call worker..) of x -> C x - -- Worker: case ( ..body.. ) of C x -> x - = do { (work_uniq : arg_uniq : _) <- getUniquesM - ; let arg = mk_ww_local arg_uniq arg1 - con_app = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co - - ; return ( True - , \ wkr_call -> mkDefaultCase wkr_call arg con_app - , \ body -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg) - -- varToCoreExpr important here: arg can be a coercion - -- Lacking this caused #10658 - , arg_ty1 ) } - - | otherwise -- The general case - -- Wrapper: case (..call worker..) of (# a, b #) -> C a b - -- Worker: case ( ...body... ) of C a b -> (# a, b #) - = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM - ; let wrap_wild = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict) - args = zipWith mk_ww_local uniqs arg_tys - ubx_tup_ty = exprType ubx_tup_app - ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args) - con_app = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co - tup_con = tupleDataCon Unboxed (length arg_tys) - - ; return (True - , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild - (DataAlt tup_con) args con_app - , \ body -> mkUnpackCase body co work_uniq data_con args ubx_tup_app - , ubx_tup_ty ) } - -mkUnpackCase :: CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr --- (mkUnpackCase e co uniq Con args body) --- returns --- case e |> co of bndr { Con args -> body } - -mkUnpackCase (Tick tickish e) co uniq con args body -- See Note [Profiling and unpacking] - = Tick tickish (mkUnpackCase e co uniq con args body) -mkUnpackCase scrut co uniq boxing_con unpk_args body - = mkSingleAltCase casted_scrut bndr - (DataAlt boxing_con) unpk_args body - where - casted_scrut = scrut `mkCast` co - bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict) - -{- -Note [non-algebraic or open body type warning] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are a few cases where the W/W transformation is told that something -returns a constructor, but the type at hand doesn't really match this. One -real-world example involves unsafeCoerce: - foo = IO a - foo = unsafeCoerce c_exit - foreign import ccall "c_exit" c_exit :: IO () -Here CPR will tell you that `foo` returns a () constructor for sure, but trying -to create a worker/wrapper for type `a` obviously fails. -(This was a real example until ee8e792 in libraries/base.) - -It does not seem feasible to avoid all such cases already in the analyser (and -after all, the analysis is not really wrong), so we simply do nothing here in -mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch -other cases where something went avoidably wrong. - -This warning also triggers for the stream fusion library within `text`. -We can'easily W/W constructed results like `Stream` because we have no simple -way to express existential types in the worker's type signature. - -Note [Profiling and unpacking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the original function looked like - f = \ x -> {-# SCC "foo" #-} E - -then we want the CPR'd worker to look like - \ x -> {-# SCC "foo" #-} (case E of I# x -> x) -and definitely not - \ x -> case ({-# SCC "foo" #-} E) of I# x -> x) - -This transform doesn't move work or allocation -from one cost centre to another. - -Later [SDM]: presumably this is because we want the simplifier to -eliminate the case, and the scc would get in the way? I'm ok with -including the case itself in the cost centre, since it is morally -part of the function (post transformation) anyway. - - -************************************************************************ -* * -\subsection{Utilities} -* * -************************************************************************ - -Note [Absent errors] -~~~~~~~~~~~~~~~~~~~~ -We make a new binding for Ids that are marked absent, thus - let x = absentError "x :: Int" -The idea is that this binding will never be used; but if it -buggily is used we'll get a runtime error message. - -Coping with absence for *unlifted* types is important; see, for -example, #4306 and #15627. In the UnliftedRep case, we can -use LitRubbish, which we need to apply to the required type. -For the unlifted types of singleton kind like Float#, Addr#, etc. we -also find a suitable literal, using Literal.absentLiteralOf. We don't -have literals for every primitive type, so the function is partial. - -Note: I did try the experiment of using an error thunk for unlifted -things too, relying on the simplifier to drop it as dead code. -But this is fragile - - - It fails when profiling is on, which disables various optimisations - - - It fails when reboxing happens. E.g. - data T = MkT Int Int# - f p@(MkT a _) = ...g p.... - where g is /lazy/ in 'p', but only uses the first component. Then - 'f' is /strict/ in 'p', and only uses the first component. So we only - pass that component to the worker for 'f', which reconstructs 'p' to - pass it to 'g'. Alas we can't say - ...f (MkT a (absentError Int# "blah"))... - bacause `MkT` is strict in its Int# argument, so we get an absentError - exception when we shouldn't. Very annoying! - -So absentError is only used for lifted types. --} - --- | Tries to find a suitable dummy RHS to bind the given absent identifier to. --- --- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding --- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be --- found (currently only happens for bindings of 'VecRep' representation). -mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Maybe (CoreExpr -> CoreExpr) -mk_absent_let dflags fam_envs arg - -- The lifted case: Bind 'absentError' - -- See Note [Absent errors] - | not (isUnliftedType arg_ty) - = Just (Let (NonRec lifted_arg abs_rhs)) - -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@ - -- See Note [Absent errors] - | [UnliftedRep] <- typePrimRep arg_ty - = Just (Let (NonRec arg unlifted_rhs)) - -- The monomorphic unlifted cases: Bind to some literal, if possible - -- See Note [Absent errors] - | Just tc <- tyConAppTyCon_maybe nty - , Just lit <- absentLiteralOf tc - = Just (Let (NonRec arg (Lit lit `mkCast` mkSymCo co))) - | nty `eqType` voidPrimTy - = Just (Let (NonRec arg (Var voidPrimId `mkCast` mkSymCo co))) - | otherwise - = WARN( True, text "No absent value for" <+> ppr arg_ty ) - Nothing -- Can happen for 'State#' and things of 'VecRep' - where - lifted_arg = arg `setIdStrictness` botSig `setIdCprInfo` mkCprSig 0 botCpr - -- Note in strictness signature that this is bottoming - -- (for the sake of the "empty case scrutinee not known to - -- diverge for sure lint" warning) - arg_ty = idType arg - - -- Normalise the type to have best chance of finding an absent literal - -- e.g. (#17852) data unlifted N = MkN Int# - -- f :: N -> a -> a - -- f _ x = x - (co, nty) = topNormaliseType_maybe fam_envs arg_ty - `orElse` (mkRepReflCo arg_ty, arg_ty) - - abs_rhs = mkAbsentErrorApp arg_ty msg - msg = showSDoc (gopt_set dflags Opt_SuppressUniques) - (ppr arg <+> ppr (idType arg)) - -- We need to suppress uniques here because otherwise they'd - -- end up in the generated code as strings. This is bad for - -- determinism, because with different uniques the strings - -- will have different lengths and hence different costs for - -- the inliner leading to different inlining. - -- See also Note [Unique Determinism] in GHC.Types.Unique - unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty] - -mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id --- The StrictnessMark comes form the data constructor and says --- whether this field is strict --- See Note [Record evaluated-ness in worker/wrapper] -mk_ww_local uniq (ty,str) - = setCaseBndrEvald str $ - mkSysLocalOrCoVar (fsLit "ww") uniq ty diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -0,0 +1,799 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section{Common subexpression} +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core.Subst +import GHC.Types.Var ( Var ) +import GHC.Types.Var.Env ( mkInScopeSet ) +import GHC.Types.Id ( Id, idType, idHasRules + , idInlineActivation, setInlineActivation + , zapIdOccInfo, zapIdUsageInfo, idInlinePragma + , isJoinId, isJoinId_maybe ) +import GHC.Core.Utils ( mkAltExpr, eqExpr + , exprIsTickedString + , stripTicksE, stripTicksT, mkTicks ) +import GHC.Core.FVs ( exprFreeVars ) +import GHC.Core.Type ( tyConAppArgs ) +import GHC.Core +import GHC.Utils.Outputable +import GHC.Types.Basic +import GHC.Core.Map +import GHC.Utils.Misc ( filterOut, equalLength, debugIsOn ) +import Data.List ( mapAccumL ) + +{- + Simple common sub-expression + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see + x1 = C a b + x2 = C x1 b +we build up a reverse mapping: C a b -> x1 + C x1 b -> x2 +and apply that to the rest of the program. + +When we then see + y1 = C a b + y2 = C y1 b +we replace the C a b with x1. But then we *dont* want to +add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1 +so that a subsequent binding + y2 = C y1 b +will get transformed to C x1 b, and then to x2. + +So we carry an extra var->var substitution which we apply *before* looking up in the +reverse mapping. + + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +We have to be careful about shadowing. +For example, consider + f = \x -> let y = x+x in + h = \x -> x+x + in ... + +Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no +shadowing, but it doesn't any more (it proved too hard), so we clone as we go. +We can simply add clones to the substitution already described. + + +Note [CSE for bindings] +~~~~~~~~~~~~~~~~~~~~~~~ +Let-bindings have two cases, implemented by addBinding. + +* SUBSTITUTE: applies when the RHS is a variable + + let x = y in ...(h x).... + + Here we want to extend the /substitution/ with x -> y, so that the + (h x) in the body might CSE with an enclosing (let v = h y in ...). + NB: the substitution maps InIds, so we extend the substitution with + a binding for the original InId 'x' + + How can we have a variable on the RHS? Doesn't the simplifier inline them? + + - First, the original RHS might have been (g z) which has CSE'd + with an enclosing (let y = g z in ...). This is super-important. + See #5996: + x1 = C a b + x2 = C x1 b + y1 = C a b + y2 = C y1 b + Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to + the substitution so that we can CSE the binding for y2. + + - Second, we use addBinding for case expression scrutinees too; + see Note [CSE for case expressions] + +* EXTEND THE REVERSE MAPPING: applies in all other cases + + let x = h y in ...(h y)... + + Here we want to extend the /reverse mapping (cs_map)/ so that + we CSE the (h y) call to x. + + Note that we use EXTEND even for a trivial expression, provided it + is not a variable or literal. In particular this /includes/ type + applications. This can be important (#13156); e.g. + case f @ Int of { r1 -> + case f @ Int of { r2 -> ... + Here we want to common-up the two uses of (f @ Int) so we can + remove one of the case expressions. + + See also Note [Corner case for case expressions] for another + reason not to use SUBSTITUTE for all trivial expressions. + +Notice that + - The SUBSTITUTE situation extends the substitution (cs_subst) + - The EXTEND situation extends the reverse mapping (cs_map) + +Notice also that in the SUBSTITUTE case we leave behind a binding + x = y +even though we /also/ carry a substitution x -> y. Can we just drop +the binding instead? Well, not at top level! See Note [Top level and +postInlineUnconditionally] in GHC.Core.Opt.Simplify.Utils; and in any +case CSE applies only to the /bindings/ of the program, and we leave +it to the simplifier to propate effects to the RULES. Finally, it +doesn't seem worth the effort to discard the nested bindings because +the simplifier will do it next. + +Note [CSE for case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case scrut_expr of x { ...alts... } +This is very like a strict let-binding + let !x = scrut_expr in ... +So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a +result all the stuff under Note [CSE for bindings] applies directly. + +For example: + +* Trivial scrutinee + f = \x -> case x of wild { + (a:as) -> case a of wild1 { + (p,q) -> ...(wild1:as)... + + Here, (wild1:as) is morally the same as (a:as) and hence equal to + wild. But that's not quite obvious. In the rest of the compiler we + want to keep it as (wild1:as), but for CSE purpose that's a bad + idea. + + By using addBinding we add the binding (wild1 -> a) to the substitution, + which does exactly the right thing. + + (Notice this is exactly backwards to what the simplifier does, which + is to try to replaces uses of 'a' with uses of 'wild1'.) + + This is the main reason that addBinding is called with a trivial rhs. + +* Non-trivial scrutinee + case (f x) of y { pat -> ...let z = f x in ... } + + By using addBinding we'll add (f x :-> y) to the cs_map, and + thereby CSE the inner (f x) to y. + +Note [CSE for INLINE and NOINLINE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are some subtle interactions of CSE with functions that the user +has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.) +Consider + + yes :: Int {-# NOINLINE yes #-} + yes = undefined + + no :: Int {-# NOINLINE no #-} + no = undefined + + foo :: Int -> Int -> Int {-# NOINLINE foo #-} + foo m n = n + + {-# RULES "foo/no" foo no = id #-} + + bar :: Int -> Int + bar = foo yes + +We do not expect the rule to fire. But if we do CSE, then we risk +getting yes=no, and the rule does fire. Actually, it won't because +NOINLINE means that 'yes' will never be inlined, not even if we have +yes=no. So that's fine (now; perhaps in the olden days, yes=no would +have substituted even if 'yes' was NOINLINE). + +But we do need to take care. Consider + + {-# NOINLINE bar #-} + bar = -- Same rhs as foo + + foo = + +If CSE produces + foo = bar +then foo will never be inlined to (when it should be, if +is small). The conclusion here is this: + + We should not add + :-> bar + to the CSEnv if 'bar' has any constraints on when it can inline; + that is, if its 'activation' not always active. Otherwise we + might replace by 'bar', and then later be unable to see that it + really was . + +An except to the rule is when the INLINE pragma is not from the user, e.g. from +WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec +is then true. + +Note that we do not (currently) do CSE on the unfolding stored inside +an Id, even if it is a 'stable' unfolding. That means that when an +unfolding happens, it is always faithful to what the stable unfolding +originally was. + +Note [CSE for stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + {-# Unf = Stable (\pq. build blah) #-} + foo = x + +Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial. +(Turns out that this actually happens for the enumFromTo method of +the Integer instance of Enum in GHC.Enum.) Suppose moreover that foo's +stable unfolding originates from an INLINE or INLINEABLE pragma on foo. +Then we obviously do NOT want to extend the substitution with (foo->x), +because we promised to inline foo as what the user wrote. See similar Note +[Stable unfoldings and postInlineUnconditionally] in GHC.Core.Opt.Simplify.Utils. + +Nor do we want to change the reverse mapping. Suppose we have + + {-# Unf = Stable (\pq. build blah) #-} + foo = + bar = + +There could conceivably be merit in rewriting the RHS of bar: + bar = foo +but now bar's inlining behaviour will change, and importing +modules might see that. So it seems dodgy and we don't do it. + +Stable unfoldings are also created during worker/wrapper when we decide +that a function's definition is so small that it should always inline. +In this case we still want to do CSE (#13340). Hence the use of +isAnyInlinePragma rather than isStableUnfolding. + +Note [Corner case for case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is another reason that we do not use SUBSTITUTE for +all trivial expressions. Consider + case x |> co of (y::Array# Int) { ... } + +We do not want to extend the substitution with (y -> x |> co); since y +is of unlifted type, this would destroy the let/app invariant if (x |> +co) was not ok-for-speculation. + +But surely (x |> co) is ok-for-speculation, because it's a trivial +expression, and x's type is also unlifted, presumably. Well, maybe +not if you are using unsafe casts. I actually found a case where we +had + (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int) + +Note [CSE for join points?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must not be naive about join points in CSE: + join j = e in + if b then jump j else 1 + e +The expression (1 + jump j) is not good (see Note [Invariants on join points] in +GHC.Core). This seems to come up quite seldom, but it happens (first seen +compiling ppHtml in Haddock.Backends.Xhtml). + +We could try and be careful by tracking which join points are still valid at +each subexpression, but since join points aren't allocated or shared, there's +less to gain by trying to CSE them. (#13219) + +Note [Look inside join-point binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Another way how CSE for join points is tricky is + + let join foo x = (x, 42) + join bar x = (x, 42) + in … jump foo 1 … jump bar 2 … + +naively, CSE would turn this into + + let join foo x = (x, 42) + join bar = foo + in … jump foo 1 … jump bar 2 … + +but now bar is a join point that claims arity one, but its right-hand side +is not a lambda, breaking the join-point invariant (this was #15002). + +So `cse_bind` must zoom past the lambdas of a join point (using +`collectNBinders`) and resume searching for CSE opportunities only in +the body of the join point. + +Note [CSE for recursive bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = \x ... f.... + g = \y ... g ... +where the "..." are identical. Could we CSE them? In full generality +with mutual recursion it's quite hard; but for self-recursive bindings +(which are very common) it's rather easy: + +* Maintain a separate cs_rec_map, that maps + (\f. (\x. ...f...) ) -> f + Note the \f in the domain of the mapping! + +* When we come across the binding for 'g', look up (\g. (\y. ...g...)) + Bingo we get a hit. So we can replace the 'g' binding with + g = f + +We can't use cs_map for this, because the key isn't an expression of +the program; it's a kind of synthetic key for recursive bindings. + + +************************************************************************ +* * +\section{Common subexpression} +* * +************************************************************************ +-} + +cseProgram :: CoreProgram -> CoreProgram +cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds) + +cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind) +cseBind toplevel env (NonRec b e) + = (env2, NonRec b2 e2) + where + (env1, b1) = addBinder env b + (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1 + +cseBind toplevel env (Rec [(in_id, rhs)]) + | noCSE in_id + = (env1, Rec [(out_id, rhs')]) + + -- See Note [CSE for recursive bindings] + | Just previous <- lookupCSRecEnv env out_id rhs'' + , let previous' = mkTicks ticks previous + out_id' = delayInlining toplevel out_id + = -- We have a hit in the recursive-binding cache + (extendCSSubst env1 in_id previous', NonRec out_id' previous') + + | otherwise + = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')]) + + where + (env1, [out_id]) = addRecBinders env [in_id] + rhs' = cseExpr env1 rhs + rhs'' = stripTicksE tickishFloatable rhs' + ticks = stripTicksT tickishFloatable rhs' + id_expr' = varToCoreExpr out_id + zapped_id = zapIdUsageInfo out_id + +cseBind toplevel env (Rec pairs) + = (env2, Rec pairs') + where + (env1, bndrs1) = addRecBinders env (map fst pairs) + (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1) + + do_one env (pr, b1) = cse_bind toplevel env pr b1 + +-- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer +-- to @in_id@ (@out_id@, created from addBinder or addRecBinders), +-- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd) +-- binding to the 'CSEnv', so that we attempt to CSE any expressions +-- which are equal to @out_rhs@. +cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr)) +cse_bind toplevel env (in_id, in_rhs) out_id + | isTopLevel toplevel, exprIsTickedString in_rhs + -- See Note [Take care with literal strings] + = (env', (out_id', in_rhs)) + + | Just arity <- isJoinId_maybe in_id + -- See Note [Look inside join-point binders] + = let (params, in_body) = collectNBinders arity in_rhs + (env', params') = addBinders env params + out_body = tryForCSE env' in_body + in (env, (out_id, mkLams params' out_body)) + + | otherwise + = (env', (out_id'', out_rhs)) + where + (env', out_id') = addBinding env in_id out_id out_rhs + (cse_done, out_rhs) = try_for_cse env in_rhs + out_id'' | cse_done = delayInlining toplevel out_id' + | otherwise = out_id' + +delayInlining :: TopLevelFlag -> Id -> Id +-- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already +-- See Note [Delay inlining after CSE] +delayInlining top_lvl bndr + | isTopLevel top_lvl + , isAlwaysActive (idInlineActivation bndr) + , idHasRules bndr -- Only if the Id has some RULES, + -- which might otherwise get lost + -- These rules are probably auto-generated specialisations, + -- since Ids with manual rules usually have manually-inserted + -- delayed inlining anyway + = bndr `setInlineActivation` activeAfterInitial + | otherwise + = bndr + +addBinding :: CSEnv -- Includes InId->OutId cloning + -> InVar -- Could be a let-bound type + -> OutId -> OutExpr -- Processed binding + -> (CSEnv, OutId) -- Final env, final bndr +-- Extend the CSE env with a mapping [rhs -> out-id] +-- unless we can instead just substitute [in-id -> rhs] +-- +-- It's possible for the binder to be a type variable (see +-- Note [Type-let] in GHC.Core), in which case we can just substitute. +addBinding env in_id out_id rhs' + | not (isId in_id) = (extendCSSubst env in_id rhs', out_id) + | noCSE in_id = (env, out_id) + | use_subst = (extendCSSubst env in_id rhs', out_id) + | otherwise = (extendCSEnv env rhs' id_expr', zapped_id) + where + id_expr' = varToCoreExpr out_id + zapped_id = zapIdUsageInfo out_id + -- Putting the Id into the cs_map makes it possible that + -- it'll become shared more than it is now, which would + -- invalidate (the usage part of) its demand info. + -- This caused #100218. + -- Easiest thing is to zap the usage info; subsequently + -- performing late demand-analysis will restore it. Don't zap + -- the strictness info; it's not necessary to do so, and losing + -- it is bad for performance if you don't do late demand + -- analysis + + -- Should we use SUBSTITUTE or EXTEND? + -- See Note [CSE for bindings] + use_subst = case rhs' of + Var {} -> True + _ -> False + +-- | Given a binder `let x = e`, this function +-- determines whether we should add `e -> x` to the cs_map +noCSE :: InId -> Bool +noCSE id = not (isAlwaysActive (idInlineActivation id)) && + not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id))) + -- See Note [CSE for INLINE and NOINLINE] + || isAnyInlinePragma (idInlinePragma id) + -- See Note [CSE for stable unfoldings] + || isJoinId id + -- See Note [CSE for join points?] + + +{- Note [Take care with literal strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example: + + x = "foo"# + y = "foo"# + ...x...y...x...y.... + +We would normally turn this into: + + x = "foo"# + y = x + ...x...x...x...x.... + +But this breaks an invariant of Core, namely that the RHS of a top-level binding +of type Addr# must be a string literal, not another variable. See Note +[Core top-level string literals] in GHC.Core. + +For this reason, we special case top-level bindings to literal strings and leave +the original RHS unmodified. This produces: + + x = "foo"# + y = "foo"# + ...x...x...x...x.... + +Now 'y' will be discarded as dead code, and we are done. + +The net effect is that for the y-binding we want to + - Use SUBSTITUTE, by extending the substitution with y :-> x + - but leave the original binding for y undisturbed + +This is done by cse_bind. I got it wrong the first time (#13367). + +Note [Delay inlining after CSE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose (#15445) we have + f,g :: Num a => a -> a + f x = ...f (x-1)..... + g y = ...g (y-1) .... + +and we make some specialisations of 'g', either automatically, or via +a SPECIALISE pragma. Then CSE kicks in and notices that the RHSs of +'f' and 'g' are identical, so we get + f x = ...f (x-1)... + g = f + {-# RULES g @Int _ = $sg #-} + +Now there is terrible danger that, in an importing module, we'll inline +'g' before we have a chance to run its specialisation! + +Solution: during CSE, after a "hit" in the CSE cache + * when adding a binding + g = f + * for a top-level function g + * and g has specialisation RULES +add a NOINLINE[2] activation to it, to ensure it's not inlined +right away. + +Notes: +* Why top level only? Because for nested bindings we are already past + phase 2 and will never return there. + +* Why "only if g has RULES"? Because there is no point in + doing this if there are no RULES; and other things being + equal it delays optimisation to delay inlining (#17409) + + +---- Historical note --- + +This patch is simpler and more direct than an earlier +version: + + commit 2110738b280543698407924a16ac92b6d804dc36 + Author: Simon Peyton Jones + Date: Mon Jul 30 13:43:56 2018 +0100 + + Don't inline functions with RULES too early + +We had to revert this patch because it made GHC itself slower. + +Why? It delayed inlining of /all/ functions with RULES, and that was +very bad in GHC.Tc.Solver.Flatten.flatten_ty_con_app + +* It delayed inlining of liftM +* That delayed the unravelling of the recursion in some dictionary + bindings. +* That delayed some eta expansion, leaving + flatten_ty_con_app = \x y. let in \z. blah +* That allowed the float-out pass to put sguff between + the \y and \z. +* And that permanently stopped eta expansion of the function, + even once was simplified. + +-} + +tryForCSE :: CSEnv -> InExpr -> OutExpr +tryForCSE env expr = snd (try_for_cse env expr) + +try_for_cse :: CSEnv -> InExpr -> (Bool, OutExpr) +-- (False, e') => We did not CSE the entire expression, +-- but we might have CSE'd some sub-expressions, +-- yielding e' +-- +-- (True, te') => We CSE'd the entire expression, +-- yielding the trivial expression te' +try_for_cse env expr + | Just e <- lookupCSEnv env expr'' = (True, mkTicks ticks e) + | otherwise = (False, expr') + -- The varToCoreExpr is needed if we have + -- case e of xco { ...case e of yco { ... } ... } + -- Then CSE will substitute yco -> xco; + -- but these are /coercion/ variables + where + expr' = cseExpr env expr + expr'' = stripTicksE tickishFloatable expr' + ticks = stripTicksT tickishFloatable expr' + -- We don't want to lose the source notes when a common sub + -- expression gets eliminated. Hence we push all (!) of them on + -- top of the replaced sub-expression. This is probably not too + -- useful in practice, but upholds our semantics. + +-- | Runs CSE on a single expression. +-- +-- This entry point is not used in the compiler itself, but is provided +-- as a convenient entry point for users of the GHC API. +cseOneExpr :: InExpr -> OutExpr +cseOneExpr e = cseExpr env e + where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) } + +cseExpr :: CSEnv -> InExpr -> OutExpr +cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) +cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) +cseExpr _ (Lit lit) = Lit lit +cseExpr env (Var v) = lookupSubst env v +cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) +cseExpr env (Tick t e) = Tick t (cseExpr env e) +cseExpr env (Cast e co) = Cast (tryForCSE env e) (substCo (csEnvSubst env) co) +cseExpr env (Lam b e) = let (env', b') = addBinder env b + in Lam b' (cseExpr env' e) +cseExpr env (Let bind e) = let (env', bind') = cseBind NotTopLevel env bind + in Let bind' (cseExpr env' e) +cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts + +cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr +cseCase env scrut bndr ty alts + = Case scrut1 bndr3 ty' $ + combineAlts alt_env (map cse_alt alts) + where + ty' = substTy (csEnvSubst env) ty + scrut1 = tryForCSE env scrut + + bndr1 = zapIdOccInfo bndr + -- Zapping the OccInfo is needed because the extendCSEnv + -- in cse_alt may mean that a dead case binder + -- becomes alive, and Lint rejects that + (env1, bndr2) = addBinder env bndr1 + (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1 + -- addBinding: see Note [CSE for case expressions] + + con_target :: OutExpr + con_target = lookupSubst alt_env bndr + + arg_tys :: [OutType] + arg_tys = tyConAppArgs (idType bndr3) + + -- See Note [CSE for case alternatives] + cse_alt (DataAlt con, args, rhs) + = (DataAlt con, args', tryForCSE new_env rhs) + where + (env', args') = addBinders alt_env args + new_env = extendCSEnv env' con_expr con_target + con_expr = mkAltExpr (DataAlt con) args' arg_tys + + cse_alt (con, args, rhs) + = (con, args', tryForCSE env' rhs) + where + (env', args') = addBinders alt_env args + +combineAlts :: CSEnv -> [OutAlt] -> [OutAlt] +-- See Note [Combine case alternatives] +combineAlts env alts + | (Just alt1, rest_alts) <- find_bndr_free_alt alts + , (_,bndrs1,rhs1) <- alt1 + , let filtered_alts = filterOut (identical_alt rhs1) rest_alts + , not (equalLength rest_alts filtered_alts) + = ASSERT2( null bndrs1, ppr alts ) + (DEFAULT, [], rhs1) : filtered_alts + + | otherwise + = alts + where + in_scope = substInScope (csEnvSubst env) + + find_bndr_free_alt :: [CoreAlt] -> (Maybe CoreAlt, [CoreAlt]) + -- The (Just alt) is a binder-free alt + -- See Note [Combine case alts: awkward corner] + find_bndr_free_alt [] + = (Nothing, []) + find_bndr_free_alt (alt@(_,bndrs,_) : alts) + | null bndrs = (Just alt, alts) + | otherwise = case find_bndr_free_alt alts of + (mb_bf, alts) -> (mb_bf, alt:alts) + + identical_alt rhs1 (_,_,rhs) = eqExpr in_scope rhs1 rhs + -- Even if this alt has binders, they will have been cloned + -- If any of these binders are mentioned in 'rhs', then + -- 'rhs' won't compare equal to 'rhs1' (which is from an + -- alt with no binders). + +{- Note [CSE for case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider case e of x + K1 y -> ....(K1 y)... + K2 -> ....K2.... + +We definitely want to CSE that (K1 y) into just x. + +But what about the lone K2? At first you would think "no" because +turning K2 into 'x' increases the number of live variables. But + +* Turning K2 into x increases the chance of combining identical alts. + Example case xs of + (_:_) -> f xs + [] -> f [] + See #17901 and simplCore/should_compile/T17901 for more examples + of this kind. + +* The next run of the simplifier will turn 'x' back into K2, so we won't + permanently bloat the free-var count. + + +Note [Combine case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +combineAlts is just a more heavyweight version of the use of +combineIdenticalAlts in GHC.Core.Opt.Simplify.Utils.prepareAlts. The basic idea is +to transform + + DEFAULT -> e1 + K x -> e1 + W y z -> e2 +===> + DEFAULT -> e1 + W y z -> e2 + +In the simplifier we use cheapEqExpr, because it is called a lot. +But here in CSE we use the full eqExpr. After all, two alternatives usually +differ near the root, so it probably isn't expensive to compare the full +alternative. It seems like the same kind of thing that CSE is supposed +to be doing, which is why I put it here. + +I actually saw some examples in the wild, where some inlining made e1 too +big for cheapEqExpr to catch it. + +Note [Combine case alts: awkward corner] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We would really like to check isDeadBinder on the binders in the +alternative. But alas, the simplifer zaps occ-info on binders in case +alternatives; see Note [Case alternative occ info] in GHC.Core.Opt.Simplify. + +* One alternative (perhaps a good one) would be to do OccAnal + just before CSE. Then perhaps we could get rid of combineIdenticalAlts + in the Simplifier, which might save work. + +* Another would be for CSE to return free vars as it goes. + +* But the current solution is to find a nullary alternative (including + the DEFAULT alt, if any). This will not catch + case x of + A y -> blah + B z p -> blah + where no alternative is nullary or DEFAULT. But the current + solution is at least cheap. + + +************************************************************************ +* * +\section{The CSE envt} +* * +************************************************************************ +-} + +data CSEnv + = CS { cs_subst :: Subst -- Maps InBndrs to OutExprs + -- The substitution variables to + -- /trivial/ OutExprs, not arbitrary expressions + + , cs_map :: CoreMap OutExpr -- The reverse mapping + -- Maps a OutExpr to a /trivial/ OutExpr + -- The key of cs_map is stripped of all Ticks + + , cs_rec_map :: CoreMap OutExpr + -- See Note [CSE for recursive bindings] + } + +emptyCSEnv :: CSEnv +emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap + , cs_subst = emptySubst } + +lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr +lookupCSEnv (CS { cs_map = csmap }) expr + = lookupCoreMap csmap expr + +extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv +extendCSEnv cse expr triv_expr + = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr } + where + sexpr = stripTicksE tickishFloatable expr + +extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv +-- See Note [CSE for recursive bindings] +extendCSRecEnv cse bndr expr triv_expr + = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr } + +lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr +-- See Note [CSE for recursive bindings] +lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr + = lookupCoreMap csmap (Lam bndr expr) + +csEnvSubst :: CSEnv -> Subst +csEnvSubst = cs_subst + +lookupSubst :: CSEnv -> Id -> OutExpr +lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x + +extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv +extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs } + +-- | Add clones to the substitution to deal with shadowing. See +-- Note [Shadowing] for more details. You should call this whenever +-- you go under a binder. +addBinder :: CSEnv -> Var -> (CSEnv, Var) +addBinder cse v = (cse { cs_subst = sub' }, v') + where + (sub', v') = substBndr (cs_subst cse) v + +addBinders :: CSEnv -> [Var] -> (CSEnv, [Var]) +addBinders cse vs = (cse { cs_subst = sub' }, vs') + where + (sub', vs') = substBndrs (cs_subst cse) vs + +addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) +addRecBinders cse vs = (cse { cs_subst = sub' }, vs') + where + (sub', vs') = substRecBndrs (cs_subst cse) vs diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -0,0 +1,763 @@ +-- +-- Copyright (c) 2014 Joachim Breitner +-- + +module GHC.Core.Opt.CallArity + ( callArityAnalProgram + , callArityRHS -- for testing + ) where + +import GHC.Prelude + +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Driver.Session ( DynFlags ) + +import GHC.Types.Basic +import GHC.Core +import GHC.Types.Id +import GHC.Core.Arity ( typeArity ) +import GHC.Core.Utils ( exprIsCheap, exprIsTrivial ) +import GHC.Data.Graph.UnVar +import GHC.Types.Demand +import GHC.Utils.Misc + +import Control.Arrow ( first, second ) + + +{- +%************************************************************************ +%* * + Call Arity Analysis +%* * +%************************************************************************ + +Note [Call Arity: The goal] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The goal of this analysis is to find out if we can eta-expand a local function, +based on how it is being called. The motivating example is this code, +which comes up when we implement foldl using foldr, and do list fusion: + + let go = \x -> let d = case ... of + False -> go (x+1) + True -> id + in \z -> d (x + z) + in go 1 0 + +If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of +partial function applications, which would be bad. + +The function `go` has a type of arity two, but only one lambda is manifest. +Furthermore, an analysis that only looks at the RHS of go cannot be sufficient +to eta-expand go: If `go` is ever called with one argument (and the result used +multiple times), we would be doing the work in `...` multiple times. + +So `callArityAnalProgram` looks at the whole let expression to figure out if +all calls are nice, i.e. have a high enough arity. It then stores the result in +the `calledArity` field of the `IdInfo` of `go`, which the next simplifier +phase will eta-expand. + +The specification of the `calledArity` field is: + + No work will be lost if you eta-expand me to the arity in `calledArity`. + +What we want to know for a variable +----------------------------------- + +For every let-bound variable we'd like to know: + 1. A lower bound on the arity of all calls to the variable, and + 2. whether the variable is being called at most once or possible multiple + times. + +It is always ok to lower the arity, or pretend that there are multiple calls. +In particular, "Minimum arity 0 and possible called multiple times" is always +correct. + + +What we want to know from an expression +--------------------------------------- + +In order to obtain that information for variables, we analyze expression and +obtain bits of information: + + I. The arity analysis: + For every variable, whether it is absent, or called, + and if called, which what arity. + + II. The Co-Called analysis: + For every two variables, whether there is a possibility that both are being + called. + We obtain as a special case: For every variables, whether there is a + possibility that it is being called twice. + +For efficiency reasons, we gather this information only for a set of +*interesting variables*, to avoid spending time on, e.g., variables from pattern matches. + +The two analysis are not completely independent, as a higher arity can improve +the information about what variables are being called once or multiple times. + +Note [Analysis I: The arity analysis] +------------------------------------ + +The arity analysis is quite straight forward: The information about an +expression is an + VarEnv Arity +where absent variables are bound to Nothing and otherwise to a lower bound to +their arity. + +When we analyze an expression, we analyze it with a given context arity. +Lambdas decrease and applications increase the incoming arity. Analysizing a +variable will put that arity in the environment. In lets or cases all the +results from the various subexpressions are lubed, which takes the point-wise +minimum (considering Nothing an infinity). + + +Note [Analysis II: The Co-Called analysis] +------------------------------------------ + +The second part is more sophisticated. For reasons explained below, it is not +sufficient to simply know how often an expression evaluates a variable. Instead +we need to know which variables are possibly called together. + +The data structure here is an undirected graph of variables, which is provided +by the abstract + UnVarGraph + +It is safe to return a larger graph, i.e. one with more edges. The worst case +(i.e. the least useful and always correct result) is the complete graph on all +free variables, which means that anything can be called together with anything +(including itself). + +Notation for the following: +C(e) is the co-called result for e. +G₁∪G₂ is the union of two graphs +fv is the set of free variables (conveniently the domain of the arity analysis result) +S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ } +S² is the complete graph on the set of variables S, S² = S×S +C'(e) is a variant for bound expression: + If e is called at most once, or it is and stays a thunk (after the analysis), + it is simply C(e). Otherwise, the expression can be called multiple times + and we return (fv e)² + +The interesting cases of the analysis: + * Var v: + No other variables are being called. + Return {} (the empty graph) + * Lambda v e, under arity 0: + This means that e can be evaluated many times and we cannot get + any useful co-call information. + Return (fv e)² + * Case alternatives alt₁,alt₂,...: + Only one can be execuded, so + Return (alt₁ ∪ alt₂ ∪...) + * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂: + We get the results from both sides, with the argument evaluated at most once. + Additionally, anything called by e₁ can possibly be called with anything + from e₂. + Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂) + * App e₁ x: + As this is already in A-normal form, CorePrep will not separately lambda + bind (and hence share) x. So we conservatively assume multiple calls to x here + Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)} + * Let v = rhs in body: + In addition to the results from the subexpressions, add all co-calls from + everything that the body calls together with v to everything that is called + by v. + Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)} + * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body + Tricky. + We assume that it is really mutually recursive, i.e. that every variable + calls one of the others, and that this is strongly connected (otherwise we + return an over-approximation, so that's ok), see note [Recursion and fixpointing]. + + Let V = {v₁,...vₙ}. + Assume that the vs have been analysed with an incoming demand and + cardinality consistent with the final result (this is the fixed-pointing). + Again we can use the results from all subexpressions. + In addition, for every variable vᵢ, we need to find out what it is called + with (call this set Sᵢ). There are two cases: + * If vᵢ is a function, we need to go through all right-hand-sides and bodies, + and collect every variable that is called together with any variable from V: + Sᵢ = {v' | j ∈ {1,...,n}, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) } + * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to + exclude it from this set: + Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) } + Finally, combine all this: + Return: C(body) ∪ + C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ + (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ) + +Using the result: Eta-Expansion +------------------------------- + +We use the result of these two analyses to decide whether we can eta-expand the +rhs of a let-bound variable. + +If the variable is already a function (exprIsCheap), and all calls to the +variables have a higher arity than the current manifest arity (i.e. the number +of lambdas), expand. + +If the variable is a thunk we must be careful: Eta-Expansion will prevent +sharing of work, so this is only safe if there is at most one call to the +function. Therefore, we check whether {v,v} ∈ G. + + Example: + + let n = case .. of .. -- A thunk! + in n 0 + n 1 + + vs. + + let n = case .. of .. + in case .. of T -> n 0 + F -> n 1 + + We are only allowed to eta-expand `n` if it is going to be called at most + once in the body of the outer let. So we need to know, for each variable + individually, that it is going to be called at most once. + + +Why the co-call graph? +---------------------- + +Why is it not sufficient to simply remember which variables are called once and +which are called multiple times? It would be in the previous example, but consider + + let n = case .. of .. + in case .. of + True -> let go = \y -> case .. of + True -> go (y + n 1) + False > n + in go 1 + False -> n + +vs. + + let n = case .. of .. + in case .. of + True -> let go = \y -> case .. of + True -> go (y+1) + False > n + in go 1 + False -> n + +In both cases, the body and the rhs of the inner let call n at most once. +But only in the second case that holds for the whole expression! The +crucial difference is that in the first case, the rhs of `go` can call +*both* `go` and `n`, and hence can call `n` multiple times as it recurses, +while in the second case find out that `go` and `n` are not called together. + + +Why co-call information for functions? +-------------------------------------- + +Although for eta-expansion we need the information only for thunks, we still +need to know whether functions are being called once or multiple times, and +together with what other functions. + + Example: + + let n = case .. of .. + f x = n (x+1) + in f 1 + f 2 + + vs. + + let n = case .. of .. + f x = n (x+1) + in case .. of T -> f 0 + F -> f 1 + + Here, the body of f calls n exactly once, but f itself is being called + multiple times, so eta-expansion is not allowed. + + +Note [Analysis type signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The work-hourse of the analysis is the function `callArityAnal`, with the +following type: + + type CallArityRes = (UnVarGraph, VarEnv Arity) + callArityAnal :: + Arity -> -- The arity this expression is called with + VarSet -> -- The set of interesting variables + CoreExpr -> -- The expression to analyse + (CallArityRes, CoreExpr) + +and the following specification: + + ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr + + <=> + + Assume the expression `expr` is being passed `arity` arguments. Then it holds that + * The domain of `callArityEnv` is a subset of `interestingIds`. + * Any variable from `interestingIds` that is not mentioned in the `callArityEnv` + is absent, i.e. not called at all. + * Every call from `expr` to a variable bound to n in `callArityEnv` has at + least n value arguments. + * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`, + then in no execution of `expr` both are being called. + Furthermore, expr' is expr with the callArity field of the `IdInfo` updated. + + +Note [Which variables are interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The analysis would quickly become prohibitive expensive if we would analyse all +variables; for most variables we simply do not care about how often they are +called, i.e. variables bound in a pattern match. So interesting are variables that are + * top-level or let bound + * and possibly functions (typeArity > 0) + +Note [Taking boring variables into account] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If we decide that the variable bound in `let x = e1 in e2` is not interesting, +the analysis of `e2` will not report anything about `x`. To ensure that +`callArityBind` does still do the right thing we have to take that into account +every time we would be lookup up `x` in the analysis result of `e2`. + * Instead of calling lookupCallArityRes, we return (0, True), indicating + that this variable might be called many times with no arguments. + * Instead of checking `calledWith x`, we assume that everything can be called + with it. + * In the recursive case, when calclulating the `cross_calls`, if there is + any boring variable in the recursive group, we ignore all co-call-results + and directly go to a very conservative assumption. + +The last point has the nice side effect that the relatively expensive +integration of co-call results in a recursive groups is often skipped. This +helped to avoid the compile time blowup in some real-world code with large +recursive groups (#10293). + +Note [Recursion and fixpointing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For a mutually recursive let, we begin by + 1. analysing the body, using the same incoming arity as for the whole expression. + 2. Then we iterate, memoizing for each of the bound variables the last + analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes. + 3. We combine the analysis result from the body and the memoized results for + the arguments (if already present). + 4. For each variable, we find out the incoming arity and whether it is called + once, based on the current analysis result. If this differs from the + memoized results, we re-analyse the rhs and update the memoized table. + 5. If nothing had to be reanalyzed, we are done. + Otherwise, repeat from step 3. + + +Note [Thunks in recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We never eta-expand a thunk in a recursive group, on the grounds that if it is +part of a recursive group, then it will be called multiple times. + +This is not necessarily true, e.g. it would be safe to eta-expand t2 (but not +t1) in the following code: + + let go x = t1 + t1 = if ... then t2 else ... + t2 = if ... then go 1 else ... + in go 0 + +Detecting this would require finding out what variables are only ever called +from thunks. While this is certainly possible, we yet have to see this to be +relevant in the wild. + + +Note [Analysing top-level binds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We can eta-expand top-level-binds if they are not exported, as we see all calls +to them. The plan is as follows: Treat the top-level binds as nested lets around +a body representing “all external calls”, which returns a pessimistic +CallArityRes (the co-call graph is the complete graph, all arityies 0). + +Note [Trimming arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the Call Arity papers, we are working on an untyped lambda calculus with no +other id annotations, where eta-expansion is always possible. But this is not +the case for Core! + 1. We need to ensure the invariant + callArity e <= typeArity (exprType e) + for the same reasons that exprArity needs this invariant (see Note + [exprArity invariant] in GHC.Core.Arity). + + If we are not doing that, a too-high arity annotation will be stored with + the id, confusing the simplifier later on. + + 2. Eta-expanding a right hand side might invalidate existing annotations. In + particular, if an id has a strictness annotation of <...><...>b, then + passing two arguments to it will definitely bottom out, so the simplifier + will throw away additional parameters. This conflicts with Call Arity! So + we ensure that we never eta-expand such a value beyond the number of + arguments mentioned in the strictness signature. + See #10176 for a real-world-example. + +Note [What is a thunk] +~~~~~~~~~~~~~~~~~~~~~~ + +Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a +thunk, not eta-expanded, to avoid losing any sharing. This is also how the +published papers on Call Arity describe it. + +In practice, there are thunks that do a just little work, such as +pattern-matching on a variable, and the benefits of eta-expansion likely +outweigh the cost of doing that repeatedly. Therefore, this implementation of +Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk. + +Note [Call Arity and Join Points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The Call Arity analysis does not care about join points, and treats them just +like normal functions. This is ok. + +The analysis *could* make use of the fact that join points are always evaluated +in the same context as the join-binding they are defined in and are always +one-shot, and handle join points separately, as suggested in +https://gitlab.haskell.org/ghc/ghc/issues/13479#note_134870. +This *might* be more efficient (for example, join points would not have to be +considered interesting variables), but it would also add redundant code. So for +now we do not do that. + +The simplifier never eta-expands join points (it instead pushes extra arguments from +an eta-expanded context into the join point’s RHS), so the call arity +annotation on join points is not actually used. As it would be equally valid +(though less efficient) to eta-expand join points, this is the simplifier's +choice, and hence Call Arity sets the call arity for join points as well. +-} + +-- Main entry point + +callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram +callArityAnalProgram _dflags binds = binds' + where + (_, binds') = callArityTopLvl [] emptyVarSet binds + +-- See Note [Analysing top-level-binds] +callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind]) +callArityTopLvl exported _ [] + = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported]) + , [] ) +callArityTopLvl exported int1 (b:bs) + = (ae2, b':bs') + where + int2 = bindersOf b + exported' = filter isExportedId int2 ++ exported + int' = int1 `addInterestingBinds` b + (ae1, bs') = callArityTopLvl exported' int' bs + (ae2, b') = callArityBind (boringBinds b) ae1 int1 b + + +callArityRHS :: CoreExpr -> CoreExpr +callArityRHS = snd . callArityAnal 0 emptyVarSet + +-- The main analysis function. See Note [Analysis type signature] +callArityAnal :: + Arity -> -- The arity this expression is called with + VarSet -> -- The set of interesting variables + CoreExpr -> -- The expression to analyse + (CallArityRes, CoreExpr) + -- How this expression uses its interesting variables + -- and the expression with IdInfo updated + +-- The trivial base cases +callArityAnal _ _ e@(Lit _) + = (emptyArityRes, e) +callArityAnal _ _ e@(Type _) + = (emptyArityRes, e) +callArityAnal _ _ e@(Coercion _) + = (emptyArityRes, e) +-- The transparent cases +callArityAnal arity int (Tick t e) + = second (Tick t) $ callArityAnal arity int e +callArityAnal arity int (Cast e co) + = second (\e -> Cast e co) $ callArityAnal arity int e + +-- The interesting case: Variables, Lambdas, Lets, Applications, Cases +callArityAnal arity int e@(Var v) + | v `elemVarSet` int + = (unitArityRes v arity, e) + | otherwise + = (emptyArityRes, e) + +-- Non-value lambdas are ignored +callArityAnal arity int (Lam v e) | not (isId v) + = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e + +-- We have a lambda that may be called multiple times, so its free variables +-- can all be co-called. +callArityAnal 0 int (Lam v e) + = (ae', Lam v e') + where + (ae, e') = callArityAnal 0 (int `delVarSet` v) e + ae' = calledMultipleTimes ae +-- We have a lambda that we are calling. decrease arity. +callArityAnal arity int (Lam v e) + = (ae, Lam v e') + where + (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e + +-- Application. Increase arity for the called expression, nothing to know about +-- the second +callArityAnal arity int (App e (Type t)) + = second (\e -> App e (Type t)) $ callArityAnal arity int e +callArityAnal arity int (App e1 e2) + = (final_ae, App e1' e2') + where + (ae1, e1') = callArityAnal (arity + 1) int e1 + (ae2, e2') = callArityAnal 0 int e2 + -- If the argument is trivial (e.g. a variable), then it will _not_ be + -- let-bound in the Core to STG transformation (CorePrep actually), + -- so no sharing will happen here, and we have to assume many calls. + ae2' | exprIsTrivial e2 = calledMultipleTimes ae2 + | otherwise = ae2 + final_ae = ae1 `both` ae2' + +-- Case expression. +callArityAnal arity int (Case scrut bndr ty alts) + = -- pprTrace "callArityAnal:Case" + -- (vcat [ppr scrut, ppr final_ae]) + (final_ae, Case scrut' bndr ty alts') + where + (alt_aes, alts') = unzip $ map go alts + go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e + in (ae, (dc, bndrs, e')) + alt_ae = lubRess alt_aes + (scrut_ae, scrut') = callArityAnal 0 int scrut + final_ae = scrut_ae `both` alt_ae + +-- For lets, use callArityBind +callArityAnal arity int (Let bind e) + = -- pprTrace "callArityAnal:Let" + -- (vcat [ppr v, ppr arity, ppr n, ppr final_ae ]) + (final_ae, Let bind' e') + where + int_body = int `addInterestingBinds` bind + (ae_body, e') = callArityAnal arity int_body e + (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind + +-- Which bindings should we look at? +-- See Note [Which variables are interesting] +isInteresting :: Var -> Bool +isInteresting v = not $ null (typeArity (idType v)) + +interestingBinds :: CoreBind -> [Var] +interestingBinds = filter isInteresting . bindersOf + +boringBinds :: CoreBind -> VarSet +boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf + +addInterestingBinds :: VarSet -> CoreBind -> VarSet +addInterestingBinds int bind + = int `delVarSetList` bindersOf bind -- Possible shadowing + `extendVarSetList` interestingBinds bind + +-- Used for both local and top-level binds +-- Second argument is the demand from the body +callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind) +-- Non-recursive let +callArityBind boring_vars ae_body int (NonRec v rhs) + | otherwise + = -- pprTrace "callArityBind:NonRec" + -- (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity]) + (final_ae, NonRec v' rhs') + where + is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk] + -- If v is boring, we will not find it in ae_body, but always assume (0, False) + boring = v `elemVarSet` boring_vars + + (arity, called_once) + | boring = (0, False) -- See Note [Taking boring variables into account] + | otherwise = lookupCallArityRes ae_body v + safe_arity | called_once = arity + | is_thunk = 0 -- A thunk! Do not eta-expand + | otherwise = arity + + -- See Note [Trimming arity] + trimmed_arity = trimArity v safe_arity + + (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs + + + ae_rhs'| called_once = ae_rhs + | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once + | otherwise = calledMultipleTimes ae_rhs + + called_by_v = domRes ae_rhs' + called_with_v + | boring = domRes ae_body + | otherwise = calledWith ae_body v `delUnVarSet` v + final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body + + v' = v `setIdCallArity` trimmed_arity + + +-- Recursive let. See Note [Recursion and fixpointing] +callArityBind boring_vars ae_body int b@(Rec binds) + = -- (if length binds > 300 then + -- pprTrace "callArityBind:Rec" + -- (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $ + (final_ae, Rec binds') + where + -- See Note [Taking boring variables into account] + any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds] + + int_body = int `addInterestingBinds` b + (ae_rhs, binds') = fix initial_binds + final_ae = bindersOf b `resDelList` ae_rhs + + initial_binds = [(i,Nothing,e) | (i,e) <- binds] + + fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)]) + fix ann_binds + | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $ + any_change + = fix ann_binds' + | otherwise + = (ae, map (\(i, _, e) -> (i, e)) ann_binds') + where + aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ] + ae = callArityRecEnv any_boring aes_old ae_body + + rerun (i, mbLastRun, rhs) + | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae) + -- No call to this yet, so do nothing + = (False, (i, Nothing, rhs)) + + | Just (old_called_once, old_arity, _) <- mbLastRun + , called_once == old_called_once + , new_arity == old_arity + -- No change, no need to re-analyze + = (False, (i, mbLastRun, rhs)) + + | otherwise + -- We previously analyzed this with a different arity (or not at all) + = let is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk] + + safe_arity | is_thunk = 0 -- See Note [Thunks in recursive groups] + | otherwise = new_arity + + -- See Note [Trimming arity] + trimmed_arity = trimArity i safe_arity + + (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs + + ae_rhs' | called_once = ae_rhs + | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once + | otherwise = calledMultipleTimes ae_rhs + + i' = i `setIdCallArity` trimmed_arity + + in (True, (i', Just (called_once, new_arity, ae_rhs'), rhs')) + where + -- See Note [Taking boring variables into account] + (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False) + | otherwise = lookupCallArityRes ae i + + (changes, ann_binds') = unzip $ map rerun ann_binds + any_change = or changes + +-- Combining the results from body and rhs, (mutually) recursive case +-- See Note [Analysis II: The Co-Called analysis] +callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes +callArityRecEnv any_boring ae_rhss ae_body + = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $ + ae_new + where + vars = map fst ae_rhss + + ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body + + cross_calls + -- See Note [Taking boring variables into account] + | any_boring = completeGraph (domRes ae_combined) + -- Also, calculating cross_calls is expensive. Simply be conservative + -- if the mutually recursive group becomes too large. + | lengthExceeds ae_rhss 25 = completeGraph (domRes ae_combined) + | otherwise = unionUnVarGraphs $ map cross_call ae_rhss + cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v + where + is_thunk = idCallArity v == 0 + -- What rhs are relevant as happening before (or after) calling v? + -- If v is a thunk, everything from all the _other_ variables + -- If v is not a thunk, everything can happen. + ae_before_v | is_thunk = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body + | otherwise = ae_combined + -- What do we want to know from these? + -- Which calls can happen next to any recursive call. + called_with_v + = unionUnVarSets $ map (calledWith ae_before_v) vars + called_by_v = domRes ae_rhs + + ae_new = first (cross_calls `unionUnVarGraph`) ae_combined + +-- See Note [Trimming arity] +trimArity :: Id -> Arity -> Arity +trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig] + where + max_arity_by_type = length (typeArity (idType v)) + max_arity_by_strsig + | isBotDiv result_info = length demands + | otherwise = a + + (demands, result_info) = splitStrictSig (idStrictness v) + +--------------------------------------- +-- Functions related to CallArityRes -- +--------------------------------------- + +-- Result type for the two analyses. +-- See Note [Analysis I: The arity analysis] +-- and Note [Analysis II: The Co-Called analysis] +type CallArityRes = (UnVarGraph, VarEnv Arity) + +emptyArityRes :: CallArityRes +emptyArityRes = (emptyUnVarGraph, emptyVarEnv) + +unitArityRes :: Var -> Arity -> CallArityRes +unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity) + +resDelList :: [Var] -> CallArityRes -> CallArityRes +resDelList vs ae = foldr resDel ae vs + +resDel :: Var -> CallArityRes -> CallArityRes +resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v) + +domRes :: CallArityRes -> UnVarSet +domRes (_, ae) = varEnvDom ae + +-- In the result, find out the minimum arity and whether the variable is called +-- at most once. +lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool) +lookupCallArityRes (g, ae) v + = case lookupVarEnv ae v of + Just a -> (a, not (g `hasLoopAt` v)) + Nothing -> (0, False) + +calledWith :: CallArityRes -> Var -> UnVarSet +calledWith (g, _) v = neighbors g v + +addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes +addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`) + +-- Replaces the co-call graph by a complete graph (i.e. no information) +calledMultipleTimes :: CallArityRes -> CallArityRes +calledMultipleTimes res = first (const (completeGraph (domRes res))) res + +-- Used for application and cases +both :: CallArityRes -> CallArityRes -> CallArityRes +both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2 + +-- Used when combining results from alternative cases; take the minimum +lubRes :: CallArityRes -> CallArityRes -> CallArityRes +lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2) + +lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity +lubArityEnv = plusVarEnv_C min + +lubRess :: [CallArityRes] -> CallArityRes +lubRess = foldl' lubRes emptyArityRes diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -0,0 +1,653 @@ +{-# LANGUAGE CPP #-} + +-- | Constructed Product Result analysis. Identifies functions that surely +-- return heap-allocated records on every code path, so that we can eliminate +-- said heap allocation by performing a worker/wrapper split. +-- +-- See https://www.microsoft.com/en-us/research/publication/constructed-product-result-analysis-haskell/. +-- CPR analysis should happen after strictness analysis. +-- See Note [Phase ordering]. +module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core +import GHC.Core.Seq +import GHC.Utils.Outputable +import GHC.Types.Var.Env +import GHC.Types.Basic +import Data.List +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram ) +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.FamInstEnv +import GHC.Core.Opt.WorkWrap.Utils +import GHC.Utils.Misc +import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Data.Maybe ( isJust, isNothing ) + +{- Note [Constructed Product Result] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The goal of Constructed Product Result analysis is to identify functions that +surely return heap-allocated records on every code path, so that we can +eliminate said heap allocation by performing a worker/wrapper split. + +@swap@ below is such a function: + + swap (a, b) = (b, a) + +A @case@ on an application of @swap@, like +@case swap (10, 42) of (a, b) -> a + b@ could cancel away +(by case-of-known-constructor) if we "inlined" @swap@ and simplified. We then +say that @swap@ has the CPR property. + +We can't inline recursive functions, but similar reasoning applies there: + + f x n = case n of + 0 -> (x, 0) + _ -> f (x+1) (n-1) + +Inductively, @case f 1 2 of (a, b) -> a + b@ could cancel away the constructed +product with the case. So @f@, too, has the CPR property. But we can't really +"inline" @f@, because it's recursive. Also, non-recursive functions like @swap@ +might be too big to inline (or even marked NOINLINE). We still want to exploit +the CPR property, and that is exactly what the worker/wrapper transformation +can do for us: + + $wf x n = case n of + 0 -> case (x, 0) of -> (a, b) -> (# a, b #) + _ -> case f (x+1) (n-1) of (a, b) -> (# a, b #) + f x n = case $wf x n of (# a, b #) -> (a, b) + +where $wf readily simplifies (by case-of-known-constructor and inlining @f@) to: + + $wf x n = case n of + 0 -> (# x, 0 #) + _ -> $wf (x+1) (n-1) + +Now, a call site like @case f 1 2 of (a, b) -> a + b@ can inline @f@ and +eliminate the heap-allocated pair constructor. + +Note [Phase ordering] +~~~~~~~~~~~~~~~~~~~~~ +We need to perform strictness analysis before CPR analysis, because that might +unbox some arguments, in turn leading to more constructed products. +Ideally, we would want the following pipeline: + +1. Strictness +2. worker/wrapper (for strictness) +3. CPR +4. worker/wrapper (for CPR) + +Currently, we omit 2. and anticipate the results of worker/wrapper. +See Note [CPR in a DataAlt case alternative] +and Note [CPR for binders that will be unboxed]. +An additional w/w pass would simplify things, but probably add slight overhead. +So currently we have + +1. Strictness +2. CPR +3. worker/wrapper (for strictness and CPR) +-} + +-- +-- * Analysing programs +-- + +cprAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram +cprAnalProgram dflags fam_envs binds = do + let env = emptyAnalEnv fam_envs + let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds + dumpIfSet_dyn dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ + dumpIdInfoOfProgram (ppr . cprInfo) binds_plus_cpr + -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal + seqBinds binds_plus_cpr `seq` return binds_plus_cpr + +-- Analyse a (group of) top-level binding(s) +cprAnalTopBind :: AnalEnv + -> CoreBind + -> (AnalEnv, CoreBind) +cprAnalTopBind env (NonRec id rhs) + = (extendAnalEnv env id' (idCprInfo id'), NonRec id' rhs') + where + (id', rhs') = cprAnalBind TopLevel env id rhs + +cprAnalTopBind env (Rec pairs) + = (env', Rec pairs') + where + (env', pairs') = cprFix TopLevel env pairs + +-- +-- * Analysing expressions +-- + +-- | The abstract semantic function ⟦_⟧ : Expr -> Env -> A from +-- "Constructed Product Result Analysis for Haskell" +cprAnal, cprAnal' + :: AnalEnv + -> CoreExpr -- ^ expression to be denoted by a 'CprType' + -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType' + +cprAnal env e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $ + cprAnal' env e + +cprAnal' _ (Lit lit) = (topCprType, Lit lit) +cprAnal' _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact +cprAnal' _ (Coercion co) = (topCprType, Coercion co) + +cprAnal' env (Var var) = (cprTransform env var, Var var) + +cprAnal' env (Cast e co) + = (cpr_ty, Cast e' co) + where + (cpr_ty, e') = cprAnal env e + +cprAnal' env (Tick t e) + = (cpr_ty, Tick t e') + where + (cpr_ty, e') = cprAnal env e + +cprAnal' env (App fun (Type ty)) + = (fun_ty, App fun' (Type ty)) + where + (fun_ty, fun') = cprAnal env fun + +cprAnal' env (App fun arg) + = (res_ty, App fun' arg') + where + (fun_ty, fun') = cprAnal env fun + -- In contrast to DmdAnal, there is no useful (non-nested) CPR info to be + -- had by looking into the CprType of arg. + (_, arg') = cprAnal env arg + res_ty = applyCprTy fun_ty + +cprAnal' env (Lam var body) + | isTyVar var + , (body_ty, body') <- cprAnal env body + = (body_ty, Lam var body') + | otherwise + = (lam_ty, Lam var body') + where + env' = extendAnalEnvForDemand env var (idDemandInfo var) + (body_ty, body') = cprAnal env' body + lam_ty = abstractCprTy body_ty + +cprAnal' env (Case scrut case_bndr ty alts) + = (res_ty, Case scrut' case_bndr ty alts') + where + (_, scrut') = cprAnal env scrut + -- Regardless whether scrut had the CPR property or not, the case binder + -- certainly has it. See 'extendEnvForDataAlt'. + (alt_tys, alts') = mapAndUnzip (cprAnalAlt env scrut case_bndr) alts + res_ty = foldl' lubCprType botCprType alt_tys + +cprAnal' env (Let (NonRec id rhs) body) + = (body_ty, Let (NonRec id' rhs') body') + where + (id', rhs') = cprAnalBind NotTopLevel env id rhs + env' = extendAnalEnv env id' (idCprInfo id') + (body_ty, body') = cprAnal env' body + +cprAnal' env (Let (Rec pairs) body) + = body_ty `seq` (body_ty, Let (Rec pairs') body') + where + (env', pairs') = cprFix NotTopLevel env pairs + (body_ty, body') = cprAnal env' body + +cprAnalAlt + :: AnalEnv + -> CoreExpr -- ^ scrutinee + -> Id -- ^ case binder + -> Alt Var -- ^ current alternative + -> (CprType, Alt Var) +cprAnalAlt env scrut case_bndr (con@(DataAlt dc),bndrs,rhs) + -- See 'extendEnvForDataAlt' and Note [CPR in a DataAlt case alternative] + = (rhs_ty, (con, bndrs, rhs')) + where + env_alt = extendEnvForDataAlt env scrut case_bndr dc bndrs + (rhs_ty, rhs') = cprAnal env_alt rhs +cprAnalAlt env _ _ (con,bndrs,rhs) + = (rhs_ty, (con, bndrs, rhs')) + where + (rhs_ty, rhs') = cprAnal env rhs + +-- +-- * CPR transformer +-- + +cprTransform :: AnalEnv -- ^ The analysis environment + -> Id -- ^ The function + -> CprType -- ^ The demand type of the function +cprTransform env id + = -- pprTrace "cprTransform" (vcat [ppr id, ppr sig]) + sig + where + sig + | isGlobalId id -- imported function or data con worker + = getCprSig (idCprInfo id) + | Just sig <- lookupSigEnv env id -- local let-bound + = getCprSig sig + | otherwise + = topCprType + +-- +-- * Bindings +-- + +-- Recursive bindings +cprFix :: TopLevelFlag + -> AnalEnv -- Does not include bindings for this binding + -> [(Id,CoreExpr)] + -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info + +cprFix top_lvl env orig_pairs + = loop 1 initial_pairs + where + bot_sig = mkCprSig 0 botCpr + -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal + initial_pairs | ae_virgin env = [(setIdCprInfo id bot_sig, rhs) | (id, rhs) <- orig_pairs ] + | otherwise = orig_pairs + + -- The fixed-point varies the idCprInfo field of the binders, and terminates if that + -- annotation does not change any more. + loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)]) + loop n pairs + | found_fixpoint = (final_anal_env, pairs') + | otherwise = loop (n+1) pairs' + where + found_fixpoint = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs + first_round = n == 1 + pairs' = step first_round pairs + final_anal_env = extendAnalEnvs env (map fst pairs') + + step :: Bool -> [(Id, CoreExpr)] -> [(Id, CoreExpr)] + step first_round pairs = pairs' + where + -- In all but the first iteration, delete the virgin flag + start_env | first_round = env + | otherwise = nonVirgin env + + start = extendAnalEnvs start_env (map fst pairs) + + (_, pairs') = mapAccumL my_downRhs start pairs + + my_downRhs env (id,rhs) + = (env', (id', rhs')) + where + (id', rhs') = cprAnalBind top_lvl env id rhs + env' = extendAnalEnv env id (idCprInfo id') + +-- | Process the RHS of the binding for a sensible arity, add the CPR signature +-- to the Id, and augment the environment with the signature as well. +cprAnalBind + :: TopLevelFlag + -> AnalEnv + -> Id + -> CoreExpr + -> (Id, CoreExpr) +cprAnalBind top_lvl env id rhs + = (id', rhs') + where + (rhs_ty, rhs') = cprAnal env rhs + -- possibly trim thunk CPR info + rhs_ty' + -- See Note [CPR for thunks] + | stays_thunk = trimCprTy rhs_ty + -- See Note [CPR for sum types] + | returns_sum = trimCprTy rhs_ty + | otherwise = rhs_ty + -- See Note [Arity trimming for CPR signatures] + sig = mkCprSigForArity (idArity id) rhs_ty' + id' = setIdCprInfo id sig + + -- See Note [CPR for thunks] + stays_thunk = is_thunk && not_strict + is_thunk = not (exprIsHNF rhs) && not (isJoinId id) + not_strict = not (isStrictDmd (idDemandInfo id)) + -- See Note [CPR for sum types] + (_, ret_ty) = splitPiTys (idType id) + not_a_prod = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty) + returns_sum = not (isTopLevel top_lvl) && not_a_prod + +{- Note [Arity trimming for CPR signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Although it doesn't affect correctness of the analysis per se, we have to trim +CPR signatures to idArity. Here's what might happen if we don't: + + f x = if expensive + then \y. Box y + else \z. Box z + g a b = f a b + +The two lambdas will have a CPR type of @1m@ (so construct a product after +applied to one argument). Thus, @f@ will have a CPR signature of @2m@ +(constructs a product after applied to two arguments). +But WW will never eta-expand @f@! In this case that would amount to possibly +duplicating @expensive@ work. + +(Side note: Even if @f@'s 'idArity' happened to be 2, it would not do so, see +Note [Don't eta expand in w/w].) + +So @f@ will not be worker/wrappered. But @g@ also inherited its CPR signature +from @f@'s, so it *will* be WW'd: + + f x = if expensive + then \y. Box y + else \z. Box z + $wg a b = case f a b of Box x -> x + g a b = Box ($wg a b) + +And the case in @g@ can never cancel away, thus we introduced extra reboxing. +Hence we always trim the CPR signature of a binding to idArity. +-} + +data AnalEnv + = AE + { ae_sigs :: SigEnv + -- ^ Current approximation of signatures for local ids + , ae_virgin :: Bool + -- ^ True only on every first iteration in a fixed-point + -- iteration. See Note [Initialising strictness] in "DmdAnal" + , ae_fam_envs :: FamInstEnvs + -- ^ Needed when expanding type families and synonyms of product types. + } + +type SigEnv = VarEnv CprSig + +instance Outputable AnalEnv where + ppr (AE { ae_sigs = env, ae_virgin = virgin }) + = text "AE" <+> braces (vcat + [ text "ae_virgin =" <+> ppr virgin + , text "ae_sigs =" <+> ppr env ]) + +emptyAnalEnv :: FamInstEnvs -> AnalEnv +emptyAnalEnv fam_envs + = AE + { ae_sigs = emptyVarEnv + , ae_virgin = True + , ae_fam_envs = fam_envs + } + +-- | Extend an environment with the strictness IDs attached to the id +extendAnalEnvs :: AnalEnv -> [Id] -> AnalEnv +extendAnalEnvs env ids + = env { ae_sigs = sigs' } + where + sigs' = extendVarEnvList (ae_sigs env) [ (id, idCprInfo id) | id <- ids ] + +extendAnalEnv :: AnalEnv -> Id -> CprSig -> AnalEnv +extendAnalEnv env id sig + = env { ae_sigs = extendVarEnv (ae_sigs env) id sig } + +lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig +lookupSigEnv env id = lookupVarEnv (ae_sigs env) id + +nonVirgin :: AnalEnv -> AnalEnv +nonVirgin env = env { ae_virgin = False } + +-- | A version of 'extendAnalEnv' for a binder of which we don't see the RHS +-- needed to compute a 'CprSig' (e.g. lambdas and DataAlt field binders). +-- In this case, we can still look at their demand to attach CPR signatures +-- anticipating the unboxing done by worker/wrapper. +-- See Note [CPR for binders that will be unboxed]. +extendAnalEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv +extendAnalEnvForDemand env id dmd + | isId id + , Just (_, DataConAppContext { dcac_dc = dc }) + <- wantToUnbox (ae_fam_envs env) has_inlineable_prag (idType id) dmd + = extendAnalEnv env id (CprSig (conCprType (dataConTag dc))) + | otherwise + = env + where + -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE + -- function, we just assume that we aren't. That flag is only relevant + -- to Note [Do not unpack class dictionaries], the few unboxing + -- opportunities on dicts it prohibits are probably irrelevant to CPR. + has_inlineable_prag = False + +extendEnvForDataAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv +-- See Note [CPR in a DataAlt case alternative] +extendEnvForDataAlt env scrut case_bndr dc bndrs + = foldl' do_con_arg env' ids_w_strs + where + env' = extendAnalEnv env case_bndr (CprSig case_bndr_ty) + + ids_w_strs = filter isId bndrs `zip` dataConRepStrictness dc + + tycon = dataConTyCon dc + is_product = isJust (isDataProductTyCon_maybe tycon) + is_sum = isJust (isDataSumTyCon_maybe tycon) + case_bndr_ty + | is_product || is_sum = conCprType (dataConTag dc) + -- Any of the constructors had existentials. This is a little too + -- conservative (after all, we only care about the particular data con), + -- but there is no easy way to write is_sum and this won't happen much. + | otherwise = topCprType + + -- We could have much deeper CPR info here with Nested CPR, which could + -- propagate available unboxed things from the scrutinee, getting rid of + -- the is_var_scrut heuristic. See Note [CPR in a DataAlt case alternative]. + -- Giving strict binders the CPR property only makes sense for products, as + -- the arguments in Note [CPR for binders that will be unboxed] don't apply + -- to sums (yet); we lack WW for strict binders of sum type. + do_con_arg env (id, str) + | is_var scrut + -- See Note [Add demands for strict constructors] in GHC.Core.Opt.WorkWrap.Utils + , let dmd = applyWhen (isMarkedStrict str) strictifyDmd (idDemandInfo id) + = extendAnalEnvForDemand env id dmd + | otherwise + = env + + is_var (Cast e _) = is_var e + is_var (Var v) = isLocalId v + is_var _ = False + +{- Note [Safe abortion in the fixed-point iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Fixed-point iteration may fail to terminate. But we cannot simply give up and +return the environment and code unchanged! We still need to do one additional +round, to ensure that all expressions have been traversed at least once, and any +unsound CPR annotations have been updated. + +Note [CPR in a DataAlt case alternative] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a case alternative, we want to give some of the binders the CPR property. +Specifically + + * The case binder; inside the alternative, the case binder always has + the CPR property, meaning that a case on it will successfully cancel. + Example: + f True x = case x of y { I# x' -> if x' ==# 3 + then y + else I# 8 } + f False x = I# 3 + + By giving 'y' the CPR property, we ensure that 'f' does too, so we get + f b x = case fw b x of { r -> I# r } + fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } + fw False x = 3 + + Of course there is the usual risk of re-boxing: we have 'x' available + boxed and unboxed, but we return the unboxed version for the wrapper to + box. If the wrapper doesn't cancel with its caller, we'll end up + re-boxing something that we did have available in boxed form. + + * Any strict binders with product type, can use + Note [CPR for binders that will be unboxed] + to anticipate worker/wrappering for strictness info. + But we can go a little further. Consider + + data T = MkT !Int Int + + f2 (MkT x y) | y>0 = f2 (MkT x (y-1)) + | otherwise = x + + For $wf2 we are going to unbox the MkT *and*, since it is strict, the + first argument of the MkT; see Note [Add demands for strict constructors]. + But then we don't want box it up again when returning it! We want + 'f2' to have the CPR property, so we give 'x' the CPR property. + + * It's a bit delicate because we're brittly anticipating worker/wrapper here. + If the case above is scrutinising something other than an argument the + original function, we really don't have the unboxed version available. E.g + g v = case foo v of + MkT x y | y>0 -> ... + | otherwise -> x + Here we don't have the unboxed 'x' available. Hence the + is_var_scrut test when making use of the strictness annotation. + Slightly ad-hoc, because even if the scrutinee *is* a variable it + might not be a onre of the arguments to the original function, or a + sub-component thereof. But it's simple, and nothing terrible + happens if we get it wrong. e.g. Trac #10694. + +Note [CPR for binders that will be unboxed] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a lambda-bound variable will be unboxed by worker/wrapper (so it must be +demanded strictly), then give it a CPR signature. Here's a concrete example +('f1' in test T10482a), assuming h is strict: + + f1 :: Int -> Int + f1 x = case h x of + A -> x + B -> f1 (x-1) + C -> x+1 + +If we notice that 'x' is used strictly, we can give it the CPR +property; and hence f1 gets the CPR property too. It's sound (doesn't +change strictness) to give it the CPR property because by the time 'x' +is returned (case A above), it'll have been evaluated (by the wrapper +of 'h' in the example). + +Moreover, if f itself is strict in x, then we'll pass x unboxed to +f1, and so the boxed version *won't* be available; in that case it's +very helpful to give 'x' the CPR property. + +Note that + + * We only want to do this for something that definitely + has product type, else we may get over-optimistic CPR results + (e.g. from \x -> x!). + + * This also (approximately) applies to DataAlt field binders; + See Note [CPR in a DataAlt case alternative]. + + * See Note [CPR examples] + +Note [CPR for sum types] +~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment we do not do CPR for let-bindings that + * non-top level + * bind a sum type +Reason: I found that in some benchmarks we were losing let-no-escapes, +which messed it all up. Example + let j = \x. .... + in case y of + True -> j False + False -> j True +If we w/w this we get + let j' = \x. .... + in case y of + True -> case j' False of { (# a #) -> Just a } + False -> case j' True of { (# a #) -> Just a } +Notice that j' is not a let-no-escape any more. + +However this means in turn that the *enclosing* function +may be CPR'd (via the returned Justs). But in the case of +sums, there may be Nothing alternatives; and that messes +up the sum-type CPR. + +Conclusion: only do this for products. It's still not +guaranteed OK for products, but sums definitely lose sometimes. + +Note [CPR for thunks] +~~~~~~~~~~~~~~~~~~~~~ +If the rhs is a thunk, we usually forget the CPR info, because +it is presumably shared (else it would have been inlined, and +so we'd lose sharing if w/w'd it into a function). E.g. + + let r = case expensive of + (a,b) -> (b,a) + in ... + +If we marked r as having the CPR property, then we'd w/w into + + let $wr = \() -> case expensive of + (a,b) -> (# b, a #) + r = case $wr () of + (# b,a #) -> (b,a) + in ... + +But now r is a thunk, which won't be inlined, so we are no further ahead. +But consider + + f x = let r = case expensive of (a,b) -> (b,a) + in if foo r then r else (x,x) + +Does f have the CPR property? Well, no. + +However, if the strictness analyser has figured out (in a previous +iteration) that it's strict, then we DON'T need to forget the CPR info. +Instead we can retain the CPR info and do the thunk-splitting transform +(see WorkWrap.splitThunk). + +This made a big difference to PrelBase.modInt, which had something like + modInt = \ x -> let r = ... -> I# v in + ...body strict in r... +r's RHS isn't a value yet; but modInt returns r in various branches, so +if r doesn't have the CPR property then neither does modInt +Another case I found in practice (in Complex.magnitude), looks like this: + let k = if ... then I# a else I# b + in ... body strict in k .... +(For this example, it doesn't matter whether k is returned as part of +the overall result; but it does matter that k's RHS has the CPR property.) +Left to itself, the simplifier will make a join point thus: + let $j k = ...body strict in k... + if ... then $j (I# a) else $j (I# b) +With thunk-splitting, we get instead + let $j x = let k = I#x in ...body strict in k... + in if ... then $j a else $j b +This is much better; there's a good chance the I# won't get allocated. + +But what about botCpr? Consider + lvl = error "boom" + fac -1 = lvl + fac 0 = 1 + fac n = n * fac (n-1) +fac won't have the CPR property here when we trim every thunk! But the +assumption is that error cases are rarely entered and we are diverging anyway, +so WW doesn't hurt. + +Note [CPR examples] +~~~~~~~~~~~~~~~~~~~~ +Here are some examples (stranal/should_compile/T10482a) of the +usefulness of Note [CPR in a DataAlt case alternative]. The main +point: all of these functions can have the CPR property. + + ------- f1 ----------- + -- x is used strictly by h, so it'll be available + -- unboxed before it is returned in the True branch + + f1 :: Int -> Int + f1 x = case h x x of + True -> x + False -> f1 (x-1) + + ------- f3 ----------- + -- h is strict in x, so x will be unboxed before it + -- is rerturned in the otherwise case. + + data T3 = MkT3 Int Int + + f1 :: T3 -> Int + f1 (MkT3 x y) | h x y = f3 (MkT3 x (y-1)) + | otherwise = x +-} diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -0,0 +1,1259 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + + ----------------- + A demand analysis + ----------------- +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.DmdAnal ( dmdAnalProgram ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Core.Opt.WorkWrap.Utils ( findTypeShape ) +import GHC.Types.Demand -- All of it +import GHC.Core +import GHC.Core.Seq ( seqBinds ) +import GHC.Utils.Outputable +import GHC.Types.Var.Env +import GHC.Types.Basic +import Data.List ( mapAccumL ) +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.Utils +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Coercion ( Coercion, coVarsOfCo ) +import GHC.Core.FamInstEnv +import GHC.Utils.Misc +import GHC.Data.Maybe ( isJust ) +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) +import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Types.Unique.Set + +{- +************************************************************************ +* * +\subsection{Top level stuff} +* * +************************************************************************ +-} + +dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram +dmdAnalProgram dflags fam_envs binds = do + let env = emptyAnalEnv dflags fam_envs + let binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds + dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $ + dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds + -- See Note [Stamp out space leaks in demand analysis] + seqBinds binds_plus_dmds `seq` return binds_plus_dmds + +-- Analyse a (group of) top-level binding(s) +dmdAnalTopBind :: AnalEnv + -> CoreBind + -> (AnalEnv, CoreBind) +dmdAnalTopBind env (NonRec id rhs) + = (extendAnalEnv TopLevel env id' (idStrictness id'), NonRec id' rhs') + where + ( _, id', rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs + +dmdAnalTopBind env (Rec pairs) + = (env', Rec pairs') + where + (env', _, pairs') = dmdFix TopLevel env cleanEvalDmd pairs + -- We get two iterations automatically + -- c.f. the NonRec case above + +{- Note [Stamp out space leaks in demand analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand analysis pass outputs a new copy of the Core program in +which binders have been annotated with demand and strictness +information. It's tiresome to ensure that this information is fully +evaluated everywhere that we produce it, so we just run a single +seqBinds over the output before returning it, to ensure that there are +no references holding on to the input Core program. + +This makes a ~30% reduction in peak memory usage when compiling +DynFlags (cf #9675 and #13426). + +This is particularly important when we are doing late demand analysis, +since we don't do a seqBinds at any point thereafter. Hence code +generation would hold on to an extra copy of the Core program, via +unforced thunks in demand or strictness information; and it is the +most memory-intensive part of the compilation process, so this added +seqBinds makes a big difference in peak memory usage. +-} + + +{- +************************************************************************ +* * +\subsection{The analyser itself} +* * +************************************************************************ + +Note [Ensure demand is strict] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important not to analyse e with a lazy demand because +a) When we encounter case s of (a,b) -> + we demand s with U(d1d2)... but if the overall demand is lazy + that is wrong, and we'd need to reduce the demand on s, + which is inconvenient +b) More important, consider + f (let x = R in x+x), where f is lazy + We still want to mark x as demanded, because it will be when we + enter the let. If we analyse f's arg with a Lazy demand, we'll + just mark x as Lazy +c) The application rule wouldn't be right either + Evaluating (f x) in a L demand does *not* cause + evaluation of f in a C(L) demand! +-} + +-- If e is complicated enough to become a thunk, its contents will be evaluated +-- at most once, so oneify it. +dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand +dmdTransformThunkDmd e + | exprIsTrivial e = id + | otherwise = oneifyDmd + +-- Do not process absent demands +-- Otherwise act like in a normal demand analysis +-- See ↦* relation in the Cardinality Analysis paper +dmdAnalStar :: AnalEnv + -> Demand -- This one takes a *Demand* + -> CoreExpr -- Should obey the let/app invariant + -> (BothDmdArg, CoreExpr) +dmdAnalStar env dmd e + | (dmd_shell, cd) <- toCleanDmd dmd + , (dmd_ty, e') <- dmdAnal env cd e + = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e ) + -- The argument 'e' should satisfy the let/app invariant + -- See Note [Analysing with absent demand] in GHC.Types.Demand + (postProcessDmdType dmd_shell dmd_ty, e') + +-- Main Demand Analsysis machinery +dmdAnal, dmdAnal' :: AnalEnv + -> CleanDemand -- The main one takes a *CleanDemand* + -> CoreExpr -> (DmdType, CoreExpr) + +-- The CleanDemand is always strict and not absent +-- See Note [Ensure demand is strict] + +dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ + dmdAnal' env d e + +dmdAnal' _ _ (Lit lit) = (nopDmdType, Lit lit) +dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact +dmdAnal' _ _ (Coercion co) + = (unitDmdType (coercionDmdEnv co), Coercion co) + +dmdAnal' env dmd (Var var) + = (dmdTransform env var dmd, Var var) + +dmdAnal' env dmd (Cast e co) + = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co) + where + (dmd_ty, e') = dmdAnal env dmd e + +dmdAnal' env dmd (Tick t e) + = (dmd_ty, Tick t e') + where + (dmd_ty, e') = dmdAnal env dmd e + +dmdAnal' env dmd (App fun (Type ty)) + = (fun_ty, App fun' (Type ty)) + where + (fun_ty, fun') = dmdAnal env dmd fun + +-- Lots of the other code is there to make this +-- beautiful, compositional, application rule :-) +dmdAnal' env dmd (App fun arg) + = -- This case handles value arguments (type args handled above) + -- Crucially, coercions /are/ handled here, because they are + -- value arguments (#10288) + let + call_dmd = mkCallDmd dmd + (fun_ty, fun') = dmdAnal env call_dmd fun + (arg_dmd, res_ty) = splitDmdTy fun_ty + (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg + in +-- pprTrace "dmdAnal:app" (vcat +-- [ text "dmd =" <+> ppr dmd +-- , text "expr =" <+> ppr (App fun arg) +-- , text "fun dmd_ty =" <+> ppr fun_ty +-- , text "arg dmd =" <+> ppr arg_dmd +-- , text "arg dmd_ty =" <+> ppr arg_ty +-- , text "res dmd_ty =" <+> ppr res_ty +-- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ]) + (res_ty `bothDmdType` arg_ty, App fun' arg') + +dmdAnal' env dmd (Lam var body) + | isTyVar var + = let + (body_ty, body') = dmdAnal env dmd body + in + (body_ty, Lam var body') + + | otherwise + = let (body_dmd, defer_and_use) = peelCallDmd dmd + -- body_dmd: a demand to analyze the body + + (body_ty, body') = dmdAnal env body_dmd body + (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty var + in + (postProcessUnsat defer_and_use lam_ty, Lam var' body') + +dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)]) + -- Only one alternative with a product constructor + | let tycon = dataConTyCon dc + , isJust (isDataProductTyCon_maybe tycon) + , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon + = let + env_alt = env { ae_rec_tc = rec_tc' } + (rhs_ty, rhs') = dmdAnal env_alt dmd rhs + (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs + (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr + id_dmds = addCaseBndrDmd case_bndr_dmd dmds + alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2 + | otherwise = alt_ty2 + + -- Compute demand on the scrutinee + -- See Note [Demand on scrutinee of a product case] + scrut_dmd = mkProdDmd id_dmds + (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut + res_ty = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty + case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd + bndrs' = setBndrsDemandInfo bndrs id_dmds + in +-- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut +-- , text "dmd" <+> ppr dmd +-- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') +-- , text "id_dmds" <+> ppr id_dmds +-- , text "scrut_dmd" <+> ppr scrut_dmd +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty" <+> ppr alt_ty2 +-- , text "res_ty" <+> ppr res_ty ]) $ + (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')]) + +dmdAnal' env dmd (Case scrut case_bndr ty alts) + = let -- Case expression with multiple alternatives + (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts + (scrut_ty, scrut') = dmdAnal env cleanEvalDmd scrut + (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr + -- NB: Base case is botDmdType, for empty case alternatives + -- This is a unit for lubDmdType, and the right result + -- when there really are no alternatives + res_ty = alt_ty `bothDmdType` toBothDmdArg scrut_ty + in +-- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_tys" <+> ppr alt_tys +-- , text "alt_ty" <+> ppr alt_ty +-- , text "res_ty" <+> ppr res_ty ]) $ + (res_ty, Case scrut' case_bndr' ty alts') + +-- Let bindings can be processed in two ways: +-- Down (RHS before body) or Up (body before RHS). +-- The following case handle the up variant. +-- +-- It is very simple. For let x = rhs in body +-- * Demand-analyse 'body' in the current environment +-- * Find the demand, 'rhs_dmd' placed on 'x' by 'body' +-- * Demand-analyse 'rhs' in 'rhs_dmd' +-- +-- This is used for a non-recursive local let without manifest lambdas. +-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”. +dmdAnal' env dmd (Let (NonRec id rhs) body) + | useLetUp id + = (final_ty, Let (NonRec id' rhs') body') + where + (body_ty, body') = dmdAnal env dmd body + (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id + id' = setIdDemandInfo id id_dmd + + (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs + final_ty = body_ty' `bothDmdType` rhs_ty + +dmdAnal' env dmd (Let (NonRec id rhs) body) + = (body_ty2, Let (NonRec id2 rhs') body') + where + (lazy_fv, id1, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs + env1 = extendAnalEnv NotTopLevel env id1 (idStrictness id1) + (body_ty, body') = dmdAnal env1 dmd body + (body_ty1, id2) = annotateBndr env body_ty id1 + body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables] + + -- If the actual demand is better than the vanilla call + -- demand, you might think that we might do better to re-analyse + -- the RHS with the stronger demand. + -- But (a) That seldom happens, because it means that *every* path in + -- the body of the let has to use that stronger demand + -- (b) It often happens temporarily in when fixpointing, because + -- the recursive function at first seems to place a massive demand. + -- But we don't want to go to extra work when the function will + -- probably iterate to something less demanding. + -- In practice, all the times the actual demand on id2 is more than + -- the vanilla call demand seem to be due to (b). So we don't + -- bother to re-analyse the RHS. + +dmdAnal' env dmd (Let (Rec pairs) body) + = let + (env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs + (body_ty, body') = dmdAnal env' dmd body + body_ty1 = deleteFVs body_ty (map fst pairs) + body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables] + in + body_ty2 `seq` + (body_ty2, Let (Rec pairs') body') + +io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool +-- See Note [IO hack in the demand analyser] +io_hack_reqd scrut con bndrs + | (bndr:_) <- bndrs + , con == tupleDataCon Unboxed 2 + , idType bndr `eqType` realWorldStatePrimTy + , (fun, _) <- collectArgs scrut + = case fun of + Var f -> not (isPrimOpId f) + _ -> True + | otherwise + = False + +dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var) +dmdAnalAlt env dmd case_bndr (con,bndrs,rhs) + | null bndrs -- Literals, DEFAULT, and nullary constructors + , (rhs_ty, rhs') <- dmdAnal env dmd rhs + = (rhs_ty, (con, [], rhs')) + + | otherwise -- Non-nullary data constructors + , (rhs_ty, rhs') <- dmdAnal env dmd rhs + , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs + , let case_bndr_dmd = findIdDemand alt_ty case_bndr + id_dmds = addCaseBndrDmd case_bndr_dmd dmds + = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs')) + + +{- Note [IO hack in the demand analyser] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's a hack here for I/O operations. Consider + + case foo x s of { (# s', r #) -> y } + +Is this strict in 'y'? Often not! If foo x s performs some observable action +(including raising an exception with raiseIO#, modifying a mutable variable, or +even ending the program normally), then we must not force 'y' (which may fail +to terminate) until we have performed foo x s. + +Hackish solution: spot the IO-like situation and add a virtual branch, +as if we had + case foo x s of + (# s, r #) -> y + other -> return () +So the 'y' isn't necessarily going to be evaluated + +A more complete example (#148, #1592) where this shows up is: + do { let len = ; + ; when (...) (exitWith ExitSuccess) + ; print len } + +However, consider + f x s = case getMaskingState# s of + (# s, r #) -> + case x of I# x2 -> ... + +Here it is terribly sad to make 'f' lazy in 's'. After all, +getMaskingState# is not going to diverge or throw an exception! This +situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle +(on an MVar not an Int), and made a material difference. + +So if the scrutinee is a primop call, we *don't* apply the +state hack: + - If it is a simple, terminating one like getMaskingState, + applying the hack is over-conservative. + - If the primop is raise# then it returns bottom, so + the case alternatives are already discarded. + - If the primop can raise a non-IO exception, like + divide by zero or seg-fault (eg writing an array + out of bounds) then we don't mind evaluating 'x' first. + +Note [Demand on the scrutinee of a product case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When figuring out the demand on the scrutinee of a product case, +we use the demands of the case alternative, i.e. id_dmds. +But note that these include the demand on the case binder; +see Note [Demand on case-alternative binders] in GHC.Types.Demand. +This is crucial. Example: + f x = case x of y { (a,b) -> k y a } +If we just take scrut_demand = U(L,A), then we won't pass x to the +worker, so the worker will rebuild + x = (a, absent-error) +and that'll crash. + +Note [Aggregated demand for cardinality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use different strategies for strictness and usage/cardinality to +"unleash" demands captured on free variables by bindings. Let us +consider the example: + +f1 y = let {-# NOINLINE h #-} + h = y + in (h, h) + +We are interested in obtaining cardinality demand U1 on |y|, as it is +used only in a thunk, and, therefore, is not going to be updated any +more. Therefore, the demand on |y|, captured and unleashed by usage of +|h| is U1. However, if we unleash this demand every time |h| is used, +and then sum up the effects, the ultimate demand on |y| will be U1 + +U1 = U. In order to avoid it, we *first* collect the aggregate demand +on |h| in the body of let-expression, and only then apply the demand +transformer: + +transf[x](U) = {y |-> U1} + +so the resulting demand on |y| is U1. + +The situation is, however, different for strictness, where this +aggregating approach exhibits worse results because of the nature of +|both| operation for strictness. Consider the example: + +f y c = + let h x = y |seq| x + in case of + True -> h True + False -> y + +It is clear that |f| is strict in |y|, however, the suggested analysis +will infer from the body of |let| that |h| is used lazily (as it is +used in one branch only), therefore lazy demand will be put on its +free variable |y|. Conversely, if the demand on |h| is unleashed right +on the spot, we will get the desired result, namely, that |f| is +strict in |y|. + + +************************************************************************ +* * + Demand transformer +* * +************************************************************************ +-} + +dmdTransform :: AnalEnv -- The strictness environment + -> Id -- The function + -> CleanDemand -- The demand on the function + -> DmdType -- The demand type of the function in this context + -- Returned DmdEnv includes the demand on + -- this function plus demand on its free variables + +dmdTransform env var dmd + | isDataConWorkId var -- Data constructor + = dmdTransformDataConSig (idArity var) dmd + + | gopt Opt_DmdTxDictSel (ae_dflags env), + Just _ <- isClassOpId_maybe var -- Dictionary component selector + = dmdTransformDictSelSig (idStrictness var) dmd + + | isGlobalId var -- Imported function + , let res = dmdTransformSig (idStrictness var) dmd + = -- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) + res + + | Just (sig, top_lvl) <- lookupSigEnv env var -- Local letrec bound thing + , let fn_ty = dmdTransformSig sig dmd + = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $ + if isTopLevel top_lvl + then fn_ty -- Don't record top level things + else addVarDmd fn_ty var (mkOnceUsedDmd dmd) + + | otherwise -- Local non-letrec-bound thing + = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd)) + +{- +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ +-} + +-- Recursive bindings +dmdFix :: TopLevelFlag + -> AnalEnv -- Does not include bindings for this binding + -> CleanDemand + -> [(Id,CoreExpr)] + -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info + +dmdFix top_lvl env let_dmd orig_pairs + = loop 1 initial_pairs + where + bndrs = map fst orig_pairs + + -- See Note [Initialising strictness] + initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ] + | otherwise = orig_pairs + + -- If fixed-point iteration does not yield a result we use this instead + -- See Note [Safe abortion in the fixed-point iteration] + abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)]) + abort = (env, lazy_fv', zapped_pairs) + where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs) + -- Note [Lazy and unleashable free variables] + non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs' + lazy_fv' = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs + zapped_pairs = zapIdStrictness pairs' + + -- The fixed-point varies the idStrictness field of the binders, and terminates if that + -- annotation does not change any more. + loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) + loop n pairs + | found_fixpoint = (final_anal_env, lazy_fv, pairs') + | n == 10 = abort + | otherwise = loop (n+1) pairs' + where + found_fixpoint = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs + first_round = n == 1 + (lazy_fv, pairs') = step first_round pairs + final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') + + step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) + step first_round pairs = (lazy_fv, pairs') + where + -- In all but the first iteration, delete the virgin flag + start_env | first_round = env + | otherwise = nonVirgin env + + start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv) + + ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs + -- mapAccumL: Use the new signature to do the next pair + -- The occurrence analyser has arranged them in a good order + -- so this can significantly reduce the number of iterations needed + + my_downRhs (env, lazy_fv) (id,rhs) + = ((env', lazy_fv'), (id', rhs')) + where + (lazy_fv1, id', rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs + lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1 + env' = extendAnalEnv top_lvl env id (idStrictness id') + + + zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] + zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ] + +{- +Note [Safe abortion in the fixed-point iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Fixed-point iteration may fail to terminate. But we cannot simply give up and +return the environment and code unchanged! We still need to do one additional +round, for two reasons: + + * To get information on used free variables (both lazy and strict!) + (see Note [Lazy and unleashable free variables]) + * To ensure that all expressions have been traversed at least once, and any left-over + strictness annotations have been updated. + +This final iteration does not add the variables to the strictness signature +environment, which effectively assigns them 'nopSig' (see "getStrictness") + +-} + +-- Let bindings can be processed in two ways: +-- Down (RHS before body) or Up (body before RHS). +-- dmdAnalRhsLetDown implements the Down variant: +-- * assuming a demand of +-- * looking at the definition +-- * determining a strictness signature +-- +-- It is used for toplevel definition, recursive definitions and local +-- non-recursive definitions that have manifest lambdas. +-- Local non-recursive definitions without a lambda are handled with LetUp. +-- +-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. +dmdAnalRhsLetDown + :: Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive + -> AnalEnv -> CleanDemand + -> Id -> CoreExpr + -> (DmdEnv, Id, CoreExpr) +-- Process the RHS of the binding, add the strictness signature +-- to the Id, and augment the environment with the signature as well. +dmdAnalRhsLetDown rec_flag env let_dmd id rhs + = (lazy_fv, id', rhs') + where + rhs_arity = idArity id + rhs_dmd + -- See Note [Demand analysis for join points] + -- See Note [Invariants on join points] invariant 2b, in GHC.Core + -- rhs_arity matches the join arity of the join point + | isJoinId id + = mkCallDmds rhs_arity let_dmd + | otherwise + -- NB: rhs_arity + -- See Note [Demand signatures are computed for a threshold demand based on idArity] + = mkRhsDmd env rhs_arity rhs + (DmdType rhs_fv rhs_dmds rhs_div, rhs') + = dmdAnal env rhs_dmd rhs + -- TODO: Won't the following line unnecessarily trim down arity for join + -- points returning a lambda in a C(S) context? + sig = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div) + id' = setIdStrictness id sig + -- See Note [NOINLINE and strictness] + + + -- See Note [Aggregated demand for cardinality] + rhs_fv1 = case rec_flag of + Just bs -> reuseEnv (delVarEnvList rhs_fv bs) + Nothing -> rhs_fv + + -- See Note [Lazy and unleashable free variables] + (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1 + is_thunk = not (exprIsHNF rhs) && not (isJoinId id) + +-- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for +-- unleashing on the given function's @rhs@, by creating +-- a call demand of @rhs_arity@ +-- See Historical Note [Product demands for function body] +mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand +mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity cleanEvalDmd + +-- | If given the let-bound 'Id', 'useLetUp' determines whether we should +-- process the binding up (body before rhs) or down (rhs before body). +-- +-- We use LetDown if there is a chance to get a useful strictness signature to +-- unleash at call sites. LetDown is generally more precise than LetUp if we can +-- correctly guess how it will be used in the body, that is, for which incoming +-- demand the strictness signature should be computed, which allows us to +-- unleash higher-order demands on arguments at call sites. This is mostly the +-- case when +-- +-- * The binding takes any arguments before performing meaningful work (cf. +-- 'idArity'), in which case we are interested to see how it uses them. +-- * The binding is a join point, hence acting like a function, not a value. +-- As a big plus, we know *precisely* how it will be used in the body; since +-- it's always tail-called, we can directly unleash the incoming demand of +-- the let binding on its RHS when computing a strictness signature. See +-- [Demand analysis for join points]. +-- +-- Thus, if the binding is not a join point and its arity is 0, we have a thunk +-- and use LetUp, implying that we have no usable demand signature available +-- when we analyse the let body. +-- +-- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free +-- vars at most once, regardless of how many times it was forced in the body. +-- This makes a real difference wrt. usage demands. The other reason is being +-- able to unleash a more precise product demand on its RHS once we know how the +-- thunk was used in the let body. +-- +-- Characteristic examples, always assuming a single evaluation: +-- +-- * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that +-- the expression uses @y@ at most once. +-- * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that +-- @b@ is absent. +-- * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that +-- the expression uses @y@ strictly, because we have @f@'s demand signature +-- available at the call site. +-- * @join exit = 2*y in if a then exit else if b then exit else 3*y@ => +-- LetDown. Compared to LetUp, we find out that the expression uses @y@ +-- strictly, because we can unleash @exit@'s signature at each call site. +-- * For a more convincing example with join points, see Note [Demand analysis +-- for join points]. +-- +useLetUp :: Var -> Bool +useLetUp f = idArity f == 0 && not (isJoinId f) + +{- Note [Demand analysis for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + g :: (Int,Int) -> Int + g (p,q) = p+q + + f :: T -> Int -> Int + f x p = g (join j y = (p,y) + in case x of + A -> j 3 + B -> j 4 + C -> (p,7)) + +If j was a vanilla function definition, we'd analyse its body with +evalDmd, and think that it was lazy in p. But for join points we can +do better! We know that j's body will (if called at all) be evaluated +with the demand that consumes the entire join-binding, in this case +the argument demand from g. Whizzo! g evaluates both components of +its argument pair, so p will certainly be evaluated if j is called. + +For f to be strict in p, we need /all/ paths to evaluate p; in this +case the C branch does so too, so we are fine. So, as usual, we need +to transport demands on free variables to the call site(s). Compare +Note [Lazy and unleashable free variables]. + +The implementation is easy. When analysing a join point, we can +analyse its body with the demand from the entire join-binding (written +let_dmd here). + +Another win for join points! #13543. + +However, note that the strictness signature for a join point can +look a little puzzling. E.g. + + (join j x = \y. error "urk") + (in case v of ) + ( A -> j 3 ) x + ( B -> j 4 ) + ( C -> \y. blah ) + +The entire thing is in a C(S) context, so j's strictness signature +will be [A]b +meaning one absent argument, returns bottom. That seems odd because +there's a \y inside. But it's right because when consumed in a C(1) +context the RHS of the join point is indeed bottom. + +Note [Demand signatures are computed for a threshold demand based on idArity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We compute demand signatures assuming idArity incoming arguments to approximate +behavior for when we have a call site with at least that many arguments. 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]). + +Because idArity of a function varies independently of its cardinality properties +(cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode +the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth' +(cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand). It is unsound to +unleash a demand signature when the incoming number of arguments is less than +that. See Note [What are demand signatures?] for more details on soundness. + +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. + +There might be functions for which we might want to analyse for more incoming +arguments than idArity. Example: + + f x = + if expensive + then \y -> ... y ... + else \y -> ... y ... + +We'd analyse `f` under a unary call demand C(S), corresponding to idArity +being 1. That's enough to look under the manifest lambda and find out how a +unary call would use `x`, but not enough to look into the lambdas in the if +branches. + +On the other hand, if we analysed for call demand C(C(S)), we'd get useful +strictness info for `y` (and more precise info on `x`) and possibly CPR +information, but + + * We would no longer be able to unleash the signature at unary call sites + * Performing the worker/wrapper split based on this information would be + implicitly eta-expanding `f`, playing fast and loose with divergence and + even being unsound in the presence of newtypes, so we refrain from doing so. + Also see Note [Don't eta expand in w/w] in GHC.Core.Opt.WorkWrap. + +Since we only compute one signature, we do so for arity 1. Computing multiple +signatures for different arities (i.e., polyvariance) would be entirely +possible, if it weren't for the additional runtime and implementation +complexity. + +Note [idArity varies independently of dmdTypeDepth] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to check in GHC.Core.Lint that dmdTypeDepth <= idArity for a let-bound +identifier. But that means we would have to zap demand signatures every time we +reset or decrease arity. That's an unnecessary dependency, because + + * The demand signature captures a semantic property that is independent of + what the binding's current arity is + * idArity is analysis information itself, thus volatile + * We already *have* dmdTypeDepth, wo why not just use it to encode the + threshold for when to unleash the signature + (cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand) + +Consider the following expression, for example: + + (let go x y = `x` seq ... in go) |> co + +`go` might have a strictness signature of ``. The simplifier will identify +`go` as a nullary join point through `joinPointBinding_maybe` and float the +coercion into the binding, leading to an arity decrease: + + join go = (\x y -> `x` seq ...) |> co in go + +With the CoreLint check, we would have to zap `go`'s perfectly viable strictness +signature. + +Note [What are demand signatures?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Demand analysis interprets expressions in the abstract domain of demand +transformers. Given an incoming demand we put an expression under, its abstract +transformer gives us back a demand type denoting how other things (like +arguments and free vars) were used when the expression was evaluated. +Here's an example: + + f x y = + if x + expensive + then \z -> z + y * ... + else \z -> z * ... + +The abstract transformer (let's call it F_e) of the if expression (let's call it +e) would transform an incoming head demand into a demand type like +{x->,y->}. In pictures: + + Demand ---F_e---> DmdType + {x->,y->} + +Let's assume that the demand transformers we compute for an expression are +correct wrt. to some concrete semantics for Core. How do demand signatures fit +in? They are strange beasts, given that they come with strict rules when to +it's sound to unleash them. + +Fortunately, we can formalise the rules with Galois connections. Consider +f's strictness signature, {}. It's a single-point approximation of +the actual abstract transformer of f's RHS for arity 2. So, what happens is that +we abstract *once more* from the abstract domain we already are in, replacing +the incoming Demand by a simple lattice with two elements denoting incoming +arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom +element). Here's the diagram: + + A_2 -----f_f----> DmdType + ^ | + | α γ | + | v + Demand ---F_f---> DmdType + +With + α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness + α(_) = <2 + γ(ty) = ty +and F_f being the abstract transformer of f's RHS and f_f being the abstracted +abstract transformer computable from our demand signature simply by + + f_f(>=2) = {} + f_f(<2) = postProcessUnsat {} + +where postProcessUnsat makes a proper top element out of the given demand type. + +Note [Demand analysis for trivial right-hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + foo = plusInt |> co +where plusInt is an arity-2 function with known strictness. Clearly +we want plusInt's strictness to propagate to foo! But because it has +no manifest lambdas, it won't do so automatically, and indeed 'co' might +have type (Int->Int->Int) ~ T. + +Fortunately, GHC.Core.Arity gives 'foo' arity 2, which is enough for LetDown to +forward plusInt's demand signature, and all is well (see Note [Newtype arity] in +GHC.Core.Arity)! A small example is the test case NewtypeArity. + + +Historical Note [Product demands for function body] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In 2013 I spotted this example, in shootout/binary_trees: + + Main.check' = \ b z ds. case z of z' { I# ip -> + case ds_d13s of + Main.Nil -> z' + Main.Node s14k s14l s14m -> + Main.check' (not b) + (Main.check' b + (case b { + False -> I# (-# s14h s14k); + True -> I# (+# s14h s14k) + }) + s14l) + s14m } } } + +Here we *really* want to unbox z, even though it appears to be used boxed in +the Nil case. Partly the Nil case is not a hot path. But more specifically, +the whole function gets the CPR property if we do. + +That motivated using a demand of C(C(C(S(L,L)))) for the RHS, where +(solely because the result was a product) we used a product demand +(albeit with lazy components) for the body. But that gives very silly +behaviour -- see #17932. Happily it turns out now to be entirely +unnecessary: we get good results with C(C(C(S))). So I simply +deleted the special case. + +************************************************************************ +* * +\subsection{Strictness signatures and types} +* * +************************************************************************ +-} + +unitDmdType :: DmdEnv -> DmdType +unitDmdType dmd_env = DmdType dmd_env [] topDiv + +coercionDmdEnv :: Coercion -> DmdEnv +coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co) + -- The VarSet from coVarsOfCo is really a VarEnv Var + +addVarDmd :: DmdType -> Var -> Demand -> DmdType +addVarDmd (DmdType fv ds res) var dmd + = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res + +addLazyFVs :: DmdType -> DmdEnv -> DmdType +addLazyFVs dmd_ty lazy_fvs + = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs + -- Using bothDmdType (rather than just both'ing the envs) + -- is vital. Consider + -- let f = \x -> (x,y) + -- in error (f 3) + -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L + -- demand with the bottom coming up from 'error' + -- + -- I got a loop in the fixpointer without this, due to an interaction + -- with the lazy_fv filtering in dmdAnalRhsLetDown. Roughly, it was + -- letrec f n x + -- = letrec g y = x `fatbar` + -- letrec h z = z + ...g... + -- in h (f (n-1) x) + -- in ... + -- In the initial iteration for f, f=Bot + -- Suppose h is found to be strict in z, but the occurrence of g in its RHS + -- is lazy. Now consider the fixpoint iteration for g, esp the demands it + -- places on its free variables. Suppose it places none. Then the + -- x `fatbar` ...call to h... + -- will give a x->V demand for x. That turns into a L demand for x, + -- which floats out of the defn for h. Without the modifyEnv, that + -- L demand doesn't get both'd with the Bot coming up from the inner + -- call to f. So we just get an L demand for x for g. + +{- +Note [Do not strictify the argument dictionaries of a dfun] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The typechecker can tie recursive knots involving dfuns, so we do the +conservative thing and refrain from strictifying a dfun's argument +dictionaries. +-} + +setBndrsDemandInfo :: [Var] -> [Demand] -> [Var] +setBndrsDemandInfo (b:bs) (d:ds) + | isTyVar b = b : setBndrsDemandInfo bs (d:ds) + | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds +setBndrsDemandInfo [] ds = ASSERT( null ds ) [] +setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) + +annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var) +-- The returned env has the var deleted +-- The returned var is annotated with demand info +-- according to the result demand of the provided demand type +-- No effect on the argument demands +annotateBndr env dmd_ty var + | isId var = (dmd_ty', setIdDemandInfo var dmd) + | otherwise = (dmd_ty, var) + where + (dmd_ty', dmd) = findBndrDmd env False dmd_ty var + +annotateLamIdBndr :: AnalEnv + -> DFunFlag -- is this lambda at the top of the RHS of a dfun? + -> DmdType -- Demand type of body + -> Id -- Lambda binder + -> (DmdType, -- Demand type of lambda + Id) -- and binder annotated with demand + +annotateLamIdBndr env arg_of_dfun dmd_ty id +-- For lambdas we add the demand to the argument demands +-- Only called for Ids + = ASSERT( isId id ) + -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $ + (final_ty, setIdDemandInfo id dmd) + where + -- Watch out! See note [Lambda-bound unfoldings] + final_ty = case maybeUnfoldingTemplate (idUnfolding id) of + Nothing -> main_ty + Just unf -> main_ty `bothDmdType` unf_ty + where + (unf_ty, _) = dmdAnalStar env dmd unf + + main_ty = addDemand dmd dmd_ty' + (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id + +deleteFVs :: DmdType -> [Var] -> DmdType +deleteFVs (DmdType fvs dmds res) bndrs + = DmdType (delVarEnvList fvs bndrs) dmds res + +{- +Note [NOINLINE and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The strictness analyser used to have a HACK which ensured that NOINLNE +things were not strictness-analysed. The reason was unsafePerformIO. +Left to itself, the strictness analyser would discover this strictness +for unsafePerformIO: + unsafePerformIO: C(U(AV)) +But then consider this sub-expression + unsafePerformIO (\s -> let r = f x in + case writeIORef v r s of (# s1, _ #) -> + (# s1, r #) +The strictness analyser will now find that r is sure to be eval'd, +and may then hoist it out. This makes tests/lib/should_run/memo002 +deadlock. + +Solving this by making all NOINLINE things have no strictness info is overkill. +In particular, it's overkill for runST, which is perfectly respectable. +Consider + f x = runST (return x) +This should be strict in x. + +So the new plan is to define unsafePerformIO using the 'lazy' combinator: + + unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) + +Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is +magically NON-STRICT, and is inlined after strictness analysis. So +unsafePerformIO will look non-strict, and that's what we want. + +Now we don't need the hack in the strictness analyser. HOWEVER, this +decision does mean that even a NOINLINE function is not entirely +opaque: some aspect of its implementation leaks out, notably its +strictness. For example, if you have a function implemented by an +error stub, but which has RULES, you may want it not to be eliminated +in favour of error! + +Note [Lazy and unleashable free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We put the strict and once-used FVs in the DmdType of the Id, so +that at its call sites we unleash demands on its strict fvs. +An example is 'roll' in imaginary/wheel-sieve2 +Something like this: + roll x = letrec + go y = if ... then roll (x-1) else x+1 + in + go ms +We want to see that roll is strict in x, which is because +go is called. So we put the DmdEnv for x in go's DmdType. + +Another example: + + f :: Int -> Int -> Int + f x y = let t = x+1 + h z = if z==0 then t else + if z==1 then x+1 else + x + h (z-1) + in h y + +Calling h does indeed evaluate x, but we can only see +that if we unleash a demand on x at the call site for t. + +Incidentally, here's a place where lambda-lifting h would +lose the cigar --- we couldn't see the joint strictness in t/x + + ON THE OTHER HAND + +We don't want to put *all* the fv's from the RHS into the +DmdType. Because + + * it makes the strictness signatures larger, and hence slows down fixpointing + +and + + * it is useless information at the call site anyways: + For lazy, used-many times fv's we will never get any better result than + that, no matter how good the actual demand on the function at the call site + is (unless it is always absent, but then the whole binder is useless). + +Therefore we exclude lazy multiple-used fv's from the environment in the +DmdType. + +But now the signature lies! (Missing variables are assumed to be absent.) To +make up for this, the code that analyses the binding keeps the demand on those +variable separate (usually called "lazy_fv") and adds it to the demand of the +whole binding later. + +What if we decide _not_ to store a strictness signature for a binding at all, as +we do when aborting a fixed-point iteration? The we risk losing the information +that the strict variables are being used. In that case, we take all free variables +mentioned in the (unsound) strictness signature, conservatively approximate the +demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix". + + +Note [Lambda-bound unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow a lambda-bound variable to carry an unfolding, a facility that is used +exclusively for join points; see Note [Case binders and join points]. If so, +we must be careful to demand-analyse the RHS of the unfolding! Example + \x. \y{=Just x}. +Then if uses 'y', then transitively it uses 'x', and we must not +forget that fact, otherwise we might make 'x' absent when it isn't. + + +************************************************************************ +* * +\subsection{Strictness signatures} +* * +************************************************************************ +-} + +type DFunFlag = Bool -- indicates if the lambda being considered is in the + -- sequence of lambdas at the top of the RHS of a dfun +notArgOfDfun :: DFunFlag +notArgOfDfun = False + +data AnalEnv + = AE { ae_dflags :: DynFlags + , ae_sigs :: SigEnv + , ae_virgin :: Bool -- True on first iteration only + -- See Note [Initialising strictness] + , ae_rec_tc :: RecTcChecker + , ae_fam_envs :: FamInstEnvs + } + + -- We use the se_env to tell us whether to + -- record info about a variable in the DmdEnv + -- We do so if it's a LocalId, but not top-level + -- + -- The DmdEnv gives the demand on the free vars of the function + -- when it is given enough args to satisfy the strictness signature + +type SigEnv = VarEnv (StrictSig, TopLevelFlag) + +instance Outputable AnalEnv where + ppr (AE { ae_sigs = env, ae_virgin = virgin }) + = text "AE" <+> braces (vcat + [ text "ae_virgin =" <+> ppr virgin + , text "ae_sigs =" <+> ppr env ]) + +emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv +emptyAnalEnv dflags fam_envs + = AE { ae_dflags = dflags + , ae_sigs = emptySigEnv + , ae_virgin = True + , ae_rec_tc = initRecTc + , ae_fam_envs = fam_envs + } + +emptySigEnv :: SigEnv +emptySigEnv = emptyVarEnv + +-- | Extend an environment with the strictness IDs attached to the id +extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv +extendAnalEnvs top_lvl env vars + = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } + +extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv +extendSigEnvs top_lvl sigs vars + = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars] + +extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv +extendAnalEnv top_lvl env var sig + = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig } + +extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv +extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) + +lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag) +lookupSigEnv env id = lookupVarEnv (ae_sigs env) id + +nonVirgin :: AnalEnv -> AnalEnv +nonVirgin env = env { ae_virgin = False } + +findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand]) +-- Return the demands on the Ids in the [Var] +findBndrsDmds env dmd_ty bndrs + = go dmd_ty bndrs + where + go dmd_ty [] = (dmd_ty, []) + go dmd_ty (b:bs) + | isId b = let (dmd_ty1, dmds) = go dmd_ty bs + (dmd_ty2, dmd) = findBndrDmd env False dmd_ty1 b + in (dmd_ty2, dmd : dmds) + | otherwise = go dmd_ty bs + +findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand) +-- See Note [Trimming a demand to a type] in GHC.Types.Demand +findBndrDmd env arg_of_dfun dmd_ty id + = (dmd_ty', dmd') + where + dmd' = strictify $ + trimToType starting_dmd (findTypeShape fam_envs id_ty) + + (dmd_ty', starting_dmd) = peelFV dmd_ty id + + id_ty = idType id + + strictify dmd + | gopt Opt_DictsStrict (ae_dflags env) + -- We never want to strictify a recursive let. At the moment + -- annotateBndr is only call for non-recursive lets; if that + -- changes, we need a RecFlag parameter and another guard here. + , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun] + = strictifyDictDmd id_ty dmd + | otherwise + = dmd + + fam_envs = ae_fam_envs env + +{- Note [Initialising strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See section 9.2 (Finding fixpoints) of the paper. + +Our basic plan is to initialise the strictness of each Id in a +recursive group to "bottom", and find a fixpoint from there. However, +this group B might be inside an *enclosing* recursive group A, in +which case we'll do the entire fixpoint shebang on for each iteration +of A. This can be illustrated by the following example: + +Example: + + f [] = [] + f (x:xs) = let g [] = f xs + g (y:ys) = y+1 : g ys + in g (h x) + +At each iteration of the fixpoint for f, the analyser has to find a +fixpoint for the enclosed function g. In the meantime, the demand +values for g at each iteration for f are *greater* than those we +encountered in the previous iteration for f. Therefore, we can begin +the fixpoint for g not with the bottom value but rather with the +result of the previous analysis. I.e., when beginning the fixpoint +process for g, we can start from the demand signature computed for g +previously and attached to the binding occurrence of g. + +To speed things up, we initialise each iteration of A (the enclosing +one) from the result of the last one, which is neatly recorded in each +binder. That way we make use of earlier iterations of the fixpoint +algorithm. (Cunning plan.) + +But on the *first* iteration we want to *ignore* the current strictness +of the Id, and start from "bottom". Nowadays the Id can have a current +strictness, because interface files record strictness for nested bindings. +To know when we are in the first iteration, we look at the ae_virgin +field of the AnalEnv. + + +Note [Final Demand Analyser run] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some of the information that the demand analyser determines is not always +preserved by the simplifier. For example, the simplifier will happily rewrite + \y [Demand=1*U] let x = y in x + x +to + \y [Demand=1*U] y + y +which is quite a lie. + +The once-used information is (currently) only used by the code +generator, though. So: + + * We zap the used-once info in the worker-wrapper; + see Note [Zapping Used Once info in WorkWrap] in + GHC.Core.Opt.WorkWrap. + If it's not reliable, it's better not to have it at all. + + * Just before TidyCore, we add a pass of the demand analyser, + but WITHOUT subsequent worker/wrapper and simplifier, + right before TidyCore. See SimplCore.getCoreToDo. + + This way, correct information finds its way into the module interface + (strictness signatures!) and the code generator (single-entry thunks!) + +Note that, in contrast, the single-call information (C1(..)) /can/ be +relied upon, as the simplifier tends to be very careful about not +duplicating actual function calls. + +Also see #11731. +-} diff --git a/compiler/GHC/Core/Opt/Driver.hs b/compiler/GHC/Core/Opt/Driver.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Driver.hs @@ -0,0 +1,1037 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[SimplCore]{Driver for simplifying @Core@ programs} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.Driver ( core2core, simplifyExpr ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Core +import GHC.Driver.Types +import GHC.Core.Opt.CSE ( cseProgram ) +import GHC.Core.Rules ( mkRuleBase, unionRuleBase, + extendRuleBaseList, ruleCheckProgram, addRuleInfo, + getRules ) +import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) +import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) +import GHC.Types.Id.Info +import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) +import GHC.Core.Utils ( mkTicks, stripTicksTop ) +import GHC.Core.Lint ( endPass, lintPassResult, dumpPassResult, + lintAnnots ) +import GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) +import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding ) +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Opt.Monad +import qualified GHC.Utils.Error as Err +import GHC.Core.Opt.FloatIn ( floatInwards ) +import GHC.Core.Opt.FloatOut ( floatOutwards ) +import GHC.Core.FamInstEnv +import GHC.Types.Id +import GHC.Utils.Error ( withTiming, withTimingD, DumpFormat (..) ) +import GHC.Types.Basic ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma ) +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Core.Opt.LiberateCase ( liberateCase ) +import GHC.Core.Opt.StaticArgs ( doStaticArgs ) +import GHC.Core.Opt.Specialise ( specProgram) +import GHC.Core.Opt.SpecConstr ( specConstrProgram) +import GHC.Core.Opt.DmdAnal ( dmdAnalProgram ) +import GHC.Core.Opt.CprAnal ( cprAnalProgram ) +import GHC.Core.Opt.CallArity ( callArityAnalProgram ) +import GHC.Core.Opt.Exitify ( exitifyProgram ) +import GHC.Core.Opt.WorkWrap ( wwTopBinds ) +import GHC.Types.SrcLoc +import GHC.Utils.Misc +import GHC.Unit.Module.Env +import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) +import GHC.Runtime.Loader -- ( initializePlugins ) + +import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) +import GHC.Types.Unique.FM +import GHC.Utils.Outputable +import Control.Monad +import qualified GHC.LanguageExtensions as LangExt +{- +************************************************************************ +* * +\subsection{The driver for the simplifier} +* * +************************************************************************ +-} + +core2core :: HscEnv -> ModGuts -> IO ModGuts +core2core hsc_env guts@(ModGuts { mg_module = mod + , mg_loc = loc + , mg_deps = deps + , mg_rdr_env = rdr_env }) + = do { -- make sure all plugins are loaded + + ; let builtin_passes = getCoreToDo dflags + orph_mods = mkModuleSet (mod : dep_orphs deps) + uniq_mask = 's' + ; + ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod + orph_mods print_unqual loc $ + do { hsc_env' <- getHscEnv + ; dflags' <- liftIO $ initializePlugins hsc_env' + (hsc_dflags hsc_env') + ; all_passes <- withPlugins dflags' + installCoreToDos + builtin_passes + ; runCorePasses all_passes guts } + + ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats + "Grand total simplifier statistics" + FormatText + (pprSimplCount stats) + + ; return guts2 } + where + dflags = hsc_dflags hsc_env + home_pkg_rules = hptRules hsc_env (dep_mods deps) + hpt_rule_base = mkRuleBase home_pkg_rules + print_unqual = mkPrintUnqualified dflags rdr_env + -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. + -- This is very convienent for the users of the monad (e.g. plugins do not have to + -- consume the ModGuts to find the module) but somewhat ugly because mg_module may + -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which + -- would mean our cached value would go out of date. + +{- +************************************************************************ +* * + Generating the main optimisation pipeline +* * +************************************************************************ +-} + +getCoreToDo :: DynFlags -> [CoreToDo] +getCoreToDo dflags + = flatten_todos core_todo + where + opt_level = optLevel dflags + phases = simplPhases dflags + max_iter = maxSimplIterations dflags + rule_check = ruleCheck dflags + call_arity = gopt Opt_CallArity dflags + exitification = gopt Opt_Exitification dflags + strictness = gopt Opt_Strictness dflags + full_laziness = gopt Opt_FullLaziness dflags + do_specialise = gopt Opt_Specialise dflags + do_float_in = gopt Opt_FloatIn dflags + cse = gopt Opt_CSE dflags + spec_constr = gopt Opt_SpecConstr dflags + liberate_case = gopt Opt_LiberateCase dflags + late_dmd_anal = gopt Opt_LateDmdAnal dflags + late_specialise = gopt Opt_LateSpecialise dflags + static_args = gopt Opt_StaticArgumentTransformation dflags + rules_on = gopt Opt_EnableRewriteRules dflags + eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags + ww_on = gopt Opt_WorkerWrapper dflags + static_ptrs = xopt LangExt.StaticPointers dflags + + maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) + + maybe_strictness_before phase + = runWhen (phase `elem` strictnessBefore dflags) CoreDoDemand + + base_mode = SimplMode { sm_phase = panic "base_mode" + , sm_names = [] + , sm_dflags = dflags + , sm_rules = rules_on + , sm_eta_expand = eta_expand_on + , sm_inline = True + , sm_case_case = True } + + simpl_phase phase names iter + = CoreDoPasses + $ [ maybe_strictness_before phase + , CoreDoSimplify iter + (base_mode { sm_phase = Phase phase + , sm_names = names }) + + , maybe_rule_check (Phase phase) ] + + simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter + | phase <- [phases, phases-1 .. 1] ] + + + -- initial simplify: mk specialiser happy: minimum effort please + simpl_gently = CoreDoSimplify max_iter + (base_mode { sm_phase = InitialPhase + , sm_names = ["Gentle"] + , sm_rules = rules_on -- Note [RULEs enabled in InitialPhase] + , sm_inline = True + -- See Note [Inline in InitialPhase] + , sm_case_case = False }) + -- Don't do case-of-case transformations. + -- This makes full laziness work better + + dmd_cpr_ww = if ww_on then [CoreDoDemand,CoreDoCpr,CoreDoWorkerWrapper] + else [CoreDoDemand,CoreDoCpr] + + + demand_analyser = (CoreDoPasses ( + dmd_cpr_ww ++ + [simpl_phase 0 ["post-worker-wrapper"] max_iter] + )) + + -- Static forms are moved to the top level with the FloatOut pass. + -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. + static_ptrs_float_outwards = + runWhen static_ptrs $ CoreDoPasses + [ simpl_gently -- Float Out can't handle type lets (sometimes created + -- by simpleOptPgm via mkParallelBindings) + , CoreDoFloatOutwards FloatOutSwitches + { floatOutLambdas = Just 0 + , floatOutConstants = True + , floatOutOverSatApps = False + , floatToTopLevelOnly = True + } + ] + + core_todo = + if opt_level == 0 then + [ static_ptrs_float_outwards, + CoreDoSimplify max_iter + (base_mode { sm_phase = Phase 0 + , sm_names = ["Non-opt simplification"] }) + ] + + else {- opt_level >= 1 -} [ + + -- We want to do the static argument transform before full laziness as it + -- may expose extra opportunities to float things outwards. However, to fix + -- up the output of the transformation we need at do at least one simplify + -- after this before anything else + runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), + + -- initial simplify: mk specialiser happy: minimum effort please + simpl_gently, + + -- Specialisation is best done before full laziness + -- so that overloaded functions have all their dictionary lambdas manifest + runWhen do_specialise CoreDoSpecialising, + + if full_laziness then + CoreDoFloatOutwards FloatOutSwitches { + floatOutLambdas = Just 0, + floatOutConstants = True, + floatOutOverSatApps = False, + floatToTopLevelOnly = False } + -- Was: gentleFloatOutSwitches + -- + -- I have no idea why, but not floating constants to + -- top level is very bad in some cases. + -- + -- Notably: p_ident in spectral/rewrite + -- Changing from "gentle" to "constantsOnly" + -- improved rewrite's allocation by 19%, and + -- made 0.0% difference to any other nofib + -- benchmark + -- + -- Not doing floatOutOverSatApps yet, we'll do + -- that later on when we've had a chance to get more + -- accurate arity information. In fact it makes no + -- difference at all to performance if we do it here, + -- but maybe we save some unnecessary to-and-fro in + -- the simplifier. + else + -- Even with full laziness turned off, we still need to float static + -- forms to the top level. See Note [Grand plan for static forms] in + -- GHC.Iface.Tidy.StaticPtrTable. + static_ptrs_float_outwards, + + simpl_phases, + + -- Phase 0: allow all Ids to be inlined now + -- This gets foldr inlined before strictness analysis + + -- At least 3 iterations because otherwise we land up with + -- huge dead expressions because of an infelicity in the + -- simplifier. + -- let k = BIG in foldr k z xs + -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs + -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs + -- Don't stop now! + simpl_phase 0 ["main"] (max max_iter 3), + + runWhen do_float_in CoreDoFloatInwards, + -- Run float-inwards immediately before the strictness analyser + -- Doing so pushes bindings nearer their use site and hence makes + -- them more likely to be strict. These bindings might only show + -- up after the inlining from simplification. Example in fulsom, + -- Csg.calc, where an arg of timesDouble thereby becomes strict. + + runWhen call_arity $ CoreDoPasses + [ CoreDoCallArity + , simpl_phase 0 ["post-call-arity"] max_iter + ], + + runWhen strictness demand_analyser, + + runWhen exitification CoreDoExitify, + -- See note [Placement of the exitification pass] + + runWhen full_laziness $ + CoreDoFloatOutwards FloatOutSwitches { + floatOutLambdas = floatLamArgs dflags, + floatOutConstants = True, + floatOutOverSatApps = True, + floatToTopLevelOnly = False }, + -- nofib/spectral/hartel/wang doubles in speed if you + -- do full laziness late in the day. It only happens + -- after fusion and other stuff, so the early pass doesn't + -- catch it. For the record, the redex is + -- f_el22 (f_el21 r_midblock) + + + runWhen cse CoreCSE, + -- We want CSE to follow the final full-laziness pass, because it may + -- succeed in commoning up things floated out by full laziness. + -- CSE used to rely on the no-shadowing invariant, but it doesn't any more + + runWhen do_float_in CoreDoFloatInwards, + + maybe_rule_check (Phase 0), + + -- Case-liberation for -O2. This should be after + -- strictness analysis and the simplification which follows it. + runWhen liberate_case (CoreDoPasses [ + CoreLiberateCase, + simpl_phase 0 ["post-liberate-case"] max_iter + ]), -- Run the simplifier after LiberateCase to vastly + -- reduce the possibility of shadowing + -- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr + + runWhen spec_constr CoreDoSpecConstr, + + maybe_rule_check (Phase 0), + + runWhen late_specialise + (CoreDoPasses [ CoreDoSpecialising + , simpl_phase 0 ["post-late-spec"] max_iter]), + + -- LiberateCase can yield new CSE opportunities because it peels + -- off one layer of a recursive function (concretely, I saw this + -- in wheel-sieve1), and I'm guessing that SpecConstr can too + -- And CSE is a very cheap pass. So it seems worth doing here. + runWhen ((liberate_case || spec_constr) && cse) CoreCSE, + + -- Final clean-up simplification: + simpl_phase 0 ["final"] max_iter, + + runWhen late_dmd_anal $ CoreDoPasses ( + dmd_cpr_ww ++ + [simpl_phase 0 ["post-late-ww"] max_iter] + ), + + -- Final run of the demand_analyser, ensures that one-shot thunks are + -- really really one-shot thunks. Only needed if the demand analyser + -- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal + -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution + -- can become /exponentially/ more expensive. See #11731, #12996. + runWhen (strictness || late_dmd_anal) CoreDoDemand, + + maybe_rule_check (Phase 0) + ] + + -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity. + flatten_todos [] = [] + flatten_todos (CoreDoNothing : rest) = flatten_todos rest + flatten_todos (CoreDoPasses passes : rest) = + flatten_todos passes ++ flatten_todos rest + flatten_todos (todo : rest) = todo : flatten_todos rest + +{- Note [Inline in InitialPhase] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is +confusing for users because when they say INLINE they expect the function to inline +right away. + +So now we do inlining immediately, even in the InitialPhase, assuming that the +Id's Activation allows it. + +This is a surprisingly big deal. Compiler performance improved a lot +when I made this change: + + perf/compiler/T5837.run T5837 [stat too good] (normal) + perf/compiler/parsing001.run parsing001 [stat too good] (normal) + perf/compiler/T12234.run T12234 [stat too good] (optasm) + perf/compiler/T9020.run T9020 [stat too good] (optasm) + perf/compiler/T3064.run T3064 [stat too good] (normal) + perf/compiler/T9961.run T9961 [stat too good] (normal) + perf/compiler/T13056.run T13056 [stat too good] (optasm) + perf/compiler/T9872d.run T9872d [stat too good] (normal) + perf/compiler/T783.run T783 [stat too good] (normal) + perf/compiler/T12227.run T12227 [stat too good] (normal) + perf/should_run/lazy-bs-alloc.run lazy-bs-alloc [stat too good] (normal) + perf/compiler/T1969.run T1969 [stat too good] (normal) + perf/compiler/T9872a.run T9872a [stat too good] (normal) + perf/compiler/T9872c.run T9872c [stat too good] (normal) + perf/compiler/T9872b.run T9872b [stat too good] (normal) + perf/compiler/T9872d.run T9872d [stat too good] (normal) + +Note [RULEs enabled in InitialPhase] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +RULES are enabled when doing "gentle" simplification in InitialPhase, +or with -O0. Two reasons: + + * We really want the class-op cancellation to happen: + op (df d1 d2) --> $cop3 d1 d2 + because this breaks the mutual recursion between 'op' and 'df' + + * I wanted the RULE + lift String ===> ... + to work in Template Haskell when simplifying + splices, so we get simpler code for literal strings + +But watch out: list fusion can prevent floating. So use phase control +to switch off those rules until after floating. + +************************************************************************ +* * + The CoreToDo interpreter +* * +************************************************************************ +-} + +runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts +runCorePasses passes guts + = foldM do_pass guts passes + where + do_pass guts CoreDoNothing = return guts + do_pass guts (CoreDoPasses ps) = runCorePasses ps guts + do_pass guts pass = do + withTimingD (ppr pass <+> brackets (ppr mod)) + (const ()) $ do + { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts + ; endPass pass (mg_binds guts') (mg_rules guts') + ; return guts' } + + mod = mg_module guts + +doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts +doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} + simplifyPgm pass + +doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} + doPass cseProgram + +doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} + doPassD liberateCase + +doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} + floatInwards + +doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} + doPassDUM (floatOutwards f) + +doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} + doPassU doStaticArgs + +doCorePass CoreDoCallArity = {-# SCC "CallArity" #-} + doPassD callArityAnalProgram + +doCorePass CoreDoExitify = {-# SCC "Exitify" #-} + doPass exitifyProgram + +doCorePass CoreDoDemand = {-# SCC "DmdAnal" #-} + doPassDFM dmdAnalProgram + +doCorePass CoreDoCpr = {-# SCC "CprAnal" #-} + doPassDFM cprAnalProgram + +doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} + doPassDFU wwTopBinds + +doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} + specProgram + +doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} + specConstrProgram + +doCorePass CoreDoPrintCore = observe printCore +doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat +doCorePass CoreDoNothing = return +doCorePass (CoreDoPasses passes) = runCorePasses passes + +doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass + +doCorePass pass@CoreDesugar = pprPanic "doCorePass" (ppr pass) +doCorePass pass@CoreDesugarOpt = pprPanic "doCorePass" (ppr pass) +doCorePass pass@CoreTidy = pprPanic "doCorePass" (ppr pass) +doCorePass pass@CorePrep = pprPanic "doCorePass" (ppr pass) +doCorePass pass@CoreOccurAnal = pprPanic "doCorePass" (ppr pass) + +{- +************************************************************************ +* * +\subsection{Core pass combinators} +* * +************************************************************************ +-} + +printCore :: DynFlags -> CoreProgram -> IO () +printCore dflags binds + = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds) + +ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts +ruleCheckPass current_phase pat guts = + withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) + (const ()) $ do + { rb <- getRuleBase + ; dflags <- getDynFlags + ; vis_orphs <- getVisibleOrphanMods + ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn + ++ (mg_rules guts) + ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan + (defaultDumpStyle dflags) + (ruleCheckProgram current_phase pat + rule_fn (mg_binds guts)) + ; return guts } + +doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDUM do_pass = doPassM $ \binds -> do + dflags <- getDynFlags + us <- getUniqueSupplyM + liftIO $ do_pass dflags us binds + +doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags)) + +doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags) + +doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us) + +doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPassU do_pass = doPassDU (const do_pass) + +doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDFM do_pass guts = do + dflags <- getDynFlags + p_fam_env <- getPackageFamInstEnv + let fam_envs = (p_fam_env, mg_fam_inst_env guts) + doPassM (liftIO . do_pass dflags fam_envs) guts + +doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDFU do_pass guts = do + dflags <- getDynFlags + us <- getUniqueSupplyM + p_fam_env <- getPackageFamInstEnv + let fam_envs = (p_fam_env, mg_fam_inst_env guts) + doPass (do_pass dflags fam_envs us) guts + +-- Most passes return no stats and don't change rules: these combinators +-- let us lift them to the full blown ModGuts+CoreM world +doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts +doPassM bind_f guts = do + binds' <- bind_f (mg_binds guts) + return (guts { mg_binds = binds' }) + +doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) } + +-- Observer passes just peek; don't modify the bindings at all +observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts +observe do_pass = doPassM $ \binds -> do + dflags <- getDynFlags + _ <- liftIO $ do_pass dflags binds + return binds + +{- +************************************************************************ +* * + Gentle simplification +* * +************************************************************************ +-} + +simplifyExpr :: HscEnv -- includes spec of what core-to-core passes to do + -> CoreExpr + -> IO CoreExpr +-- simplifyExpr is called by the driver to simplify an +-- expression typed in at the interactive prompt +simplifyExpr hsc_env expr + = withTiming dflags (text "Simplify [expr]") (const ()) $ + do { eps <- hscEPS hsc_env ; + ; let rule_env = mkRuleEnv (eps_rule_base eps) [] + fi_env = ( eps_fam_inst_env eps + , extendFamInstEnvList emptyFamInstEnv $ + snd $ ic_instances $ hsc_IC hsc_env ) + simpl_env = simplEnvForGHCi dflags + + ; us <- mkSplitUniqSupply 's' + ; let sz = exprSize expr + + ; (expr', counts) <- initSmpl dflags rule_env fi_env us sz $ + simplExprGently simpl_env expr + + ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags) + "Simplifier statistics" (pprSimplCount counts) + + ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" + FormatCore + (pprCoreExpr expr') + + ; return expr' + } + where + dflags = hsc_dflags hsc_env + +simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr +-- Simplifies an expression +-- does occurrence analysis, then simplification +-- and repeats (twice currently) because one pass +-- alone leaves tons of crud. +-- Used (a) for user expressions typed in at the interactive prompt +-- (b) the LHS and RHS of a RULE +-- (c) Template Haskell splices +-- +-- The name 'Gently' suggests that the SimplMode is InitialPhase, +-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't +-- enforce that; it just simplifies the expression twice + +-- It's important that simplExprGently does eta reduction; see +-- Note [Simplifying the left-hand side of a RULE] above. The +-- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam) +-- but only if -O is on. + +simplExprGently env expr = do + expr1 <- simplExpr env (occurAnalyseExpr expr) + simplExpr env (occurAnalyseExpr expr1) + +{- +************************************************************************ +* * +\subsection{The driver for the simplifier} +* * +************************************************************************ +-} + +simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts +simplifyPgm pass guts + = do { hsc_env <- getHscEnv + ; us <- getUniqueSupplyM + ; rb <- getRuleBase + ; liftIOWithCount $ + simplifyPgmIO pass hsc_env us rb guts } + +simplifyPgmIO :: CoreToDo + -> HscEnv + -> UniqSupply + -> RuleBase + -> ModGuts + -> IO (SimplCount, ModGuts) -- New bindings + +simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) + hsc_env us hpt_rule_base + guts@(ModGuts { mg_module = this_mod + , mg_rdr_env = rdr_env + , mg_deps = deps + , mg_binds = binds, mg_rules = rules + , mg_fam_inst_env = fam_inst_env }) + = do { (termination_msg, it_count, counts_out, guts') + <- do_iteration us 1 [] binds rules + + ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags && + dopt Opt_D_dump_simpl_stats dflags) + "Simplifier statistics for following pass" + (vcat [text termination_msg <+> text "after" <+> ppr it_count + <+> text "iterations", + blankLine, + pprSimplCount counts_out]) + + ; return (counts_out, guts') + } + where + dflags = hsc_dflags hsc_env + print_unqual = mkPrintUnqualified dflags rdr_env + simpl_env = mkSimplEnv mode + active_rule = activeRule mode + active_unf = activeUnfolding mode + + do_iteration :: UniqSupply + -> Int -- Counts iterations + -> [SimplCount] -- Counts from earlier iterations, reversed + -> CoreProgram -- Bindings in + -> [CoreRule] -- and orphan rules + -> IO (String, Int, SimplCount, ModGuts) + + do_iteration us iteration_no counts_so_far binds rules + -- iteration_no is the number of the iteration we are + -- about to begin, with '1' for the first + | iteration_no > max_iterations -- Stop if we've run out of iterations + = WARN( debugIsOn && (max_iterations > 2) + , hang (text "Simplifier bailing out after" <+> int max_iterations + <+> text "iterations" + <+> (brackets $ hsep $ punctuate comma $ + map (int . simplCountN) (reverse counts_so_far))) + 2 (text "Size =" <+> ppr (coreBindsStats binds))) + + -- Subtract 1 from iteration_no to get the + -- number of iterations we actually completed + return ( "Simplifier baled out", iteration_no - 1 + , totalise counts_so_far + , guts { mg_binds = binds, mg_rules = rules } ) + + -- Try and force thunks off the binds; significantly reduces + -- space usage, especially with -O. JRS, 000620. + | let sz = coreBindsSize binds + , () <- sz `seq` () -- Force it + = do { + -- Occurrence analysis + let { tagged_binds = {-# SCC "OccAnal" #-} + occurAnalysePgm this_mod active_unf active_rule rules + binds + } ; + Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + FormatCore + (pprCoreBindings tagged_binds); + + -- Get any new rules, and extend the rule base + -- See Note [Overall plumbing for rules] in GHC.Core.Rules + -- We need to do this regularly, because simplification can + -- poke on IdInfo thunks, which in turn brings in new rules + -- behind the scenes. Otherwise there's a danger we'll simply + -- miss the rules for Ids hidden inside imported inlinings + eps <- hscEPS hsc_env ; + let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps) + ; rule_base2 = extendRuleBaseList rule_base1 rules + ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) + ; vis_orphs = this_mod : dep_orphs deps } ; + + -- Simplify the program + ((binds1, rules1), counts1) <- + initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $ + do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} + simplTopBinds simpl_env tagged_binds + + -- Apply the substitution to rules defined in this module + -- for imported Ids. Eg RULE map my_f = blah + -- If we have a substitution my_f :-> other_f, we'd better + -- apply it to the rule to, or it'll never match + ; rules1 <- simplRules env1 Nothing rules Nothing + + ; return (getTopFloatBinds floats, rules1) } ; + + -- Stop if nothing happened; don't dump output + -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Monad + if isZeroSimplCount counts1 then + return ( "Simplifier reached fixed point", iteration_no + , totalise (counts1 : counts_so_far) -- Include "free" ticks + , guts { mg_binds = binds1, mg_rules = rules1 } ) + else do { + -- Short out indirections + -- We do this *after* at least one run of the simplifier + -- because indirection-shorting uses the export flag on *occurrences* + -- and that isn't guaranteed to be ok until after the first run propagates + -- stuff from the binding site to its occurrences + -- + -- ToDo: alas, this means that indirection-shorting does not happen at all + -- if the simplifier does nothing (not common, I know, but unsavoury) + let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; + + -- Dump the result of this iteration + dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ; + lintPassResult hsc_env pass binds2 ; + + -- Loop + do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 + } } +#if __GLASGOW_HASKELL__ <= 810 + | otherwise = panic "do_iteration" +#endif + where + (us1, us2) = splitUniqSupply us + + -- Remember the counts_so_far are reversed + totalise :: [SimplCount] -> SimplCount + totalise = foldr (\c acc -> acc `plusSimplCount` c) + (zeroSimplCount dflags) + +simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO" + +------------------- +dump_end_iteration :: DynFlags -> PrintUnqualified -> Int + -> SimplCount -> CoreProgram -> [CoreRule] -> IO () +dump_end_iteration dflags print_unqual iteration_no counts binds rules + = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules + where + mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations + | otherwise = Nothing + -- Show details if Opt_D_dump_simpl_iterations is on + + hdr = text "Simplifier iteration=" <> int iteration_no + pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr + , pprSimplCount counts + , text "---- End of simplifier counts for" <+> hdr ] + +{- +************************************************************************ +* * + Shorting out indirections +* * +************************************************************************ + +If we have this: + + x_local = + ...bindings... + x_exported = x_local + +where x_exported is exported, and x_local is not, then we replace it with this: + + x_exported = + x_local = x_exported + ...bindings... + +Without this we never get rid of the x_exported = x_local thing. This +save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and +makes strictness information propagate better. This used to happen in +the final phase, but it's tidier to do it here. + +Note [Messing up the exported Id's RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must be careful about discarding (obviously) or even merging the +RULES on the exported Id. The example that went bad on me at one stage +was this one: + + iterate :: (a -> a) -> a -> [a] + [Exported] + iterate = iterateList + + iterateFB c f x = x `c` iterateFB c f (f x) + iterateList f x = x : iterateList f (f x) + [Not exported] + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterateList + #-} + +This got shorted out to: + + iterateList :: (a -> a) -> a -> [a] + iterateList = iterate + + iterateFB c f x = x `c` iterateFB c f (f x) + iterate f x = x : iterate f (f x) + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterate + #-} + +And now we get an infinite loop in the rule system + iterate f x -> build (\cn -> iterateFB c f x) + -> iterateFB (:) f x + -> iterate f x + +Old "solution": + use rule switching-off pragmas to get rid + of iterateList in the first place + +But in principle the user *might* want rules that only apply to the Id +he says. And inline pragmas are similar + {-# NOINLINE f #-} + f = local + local = +Then we do not want to get rid of the NOINLINE. + +Hence hasShortableIdinfo. + + +Note [Rules and indirection-zapping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: what if x_exported has a RULE that mentions something in ...bindings...? +Then the things mentioned can be out of scope! Solution + a) Make sure that in this pass the usage-info from x_exported is + available for ...bindings... + b) If there are any such RULES, rec-ify the entire top-level. + It'll get sorted out next time round + +Other remarks +~~~~~~~~~~~~~ +If more than one exported thing is equal to a local thing (i.e., the +local thing really is shared), then we do one only: +\begin{verbatim} + x_local = .... + x_exported1 = x_local + x_exported2 = x_local +==> + x_exported1 = .... + + x_exported2 = x_exported1 +\end{verbatim} + +We rely on prior eta reduction to simplify things like +\begin{verbatim} + x_exported = /\ tyvars -> x_local tyvars +==> + x_exported = x_local +\end{verbatim} +Hence,there's a possibility of leaving unchanged something like this: +\begin{verbatim} + x_local = .... + x_exported1 = x_local Int +\end{verbatim} +By the time we've thrown away the types in STG land this +could be eliminated. But I don't think it's very common +and it's dangerous to do this fiddling in STG land +because we might eliminate a binding that's mentioned in the +unfolding for something. + +Note [Indirection zapping and ticks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unfortunately this is another place where we need a special case for +ticks. The following happens quite regularly: + + x_local = + x_exported = tick x_local + +Which we want to become: + + x_exported = tick + +As it makes no sense to keep the tick and the expression on separate +bindings. Note however that that this might increase the ticks scoping +over the execution of x_local, so we can only do this for floatable +ticks. More often than not, other references will be unfoldings of +x_exported, and therefore carry the tick anyway. +-} + +type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks + +shortOutIndirections :: CoreProgram -> CoreProgram +shortOutIndirections binds + | isEmptyVarEnv ind_env = binds + | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping] + | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff + where + ind_env = makeIndEnv binds + -- These exported Ids are the subjects of the indirection-elimination + exp_ids = map fst $ nonDetEltsUFM ind_env + -- It's OK to use nonDetEltsUFM here because we forget the ordering + -- by immediately converting to a set or check if all the elements + -- satisfy a predicate. + exp_id_set = mkVarSet exp_ids + no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids + binds' = concatMap zap binds + + zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] + zap (Rec pairs) = [Rec (concatMap zapPair pairs)] + + zapPair (bndr, rhs) + | bndr `elemVarSet` exp_id_set + = [] -- Kill the exported-id binding + + | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr + , (exp_id', lcl_id') <- transferIdInfo exp_id bndr + = -- Turn a local-id binding into two bindings + -- exp_id = rhs; lcl_id = exp_id + [ (exp_id', mkTicks ticks rhs), + (lcl_id', Var exp_id') ] + + | otherwise + = [(bndr,rhs)] + +makeIndEnv :: [CoreBind] -> IndEnv +makeIndEnv binds + = foldl' add_bind emptyVarEnv binds + where + add_bind :: IndEnv -> CoreBind -> IndEnv + add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs) + add_bind env (Rec pairs) = foldl' add_pair env pairs + + add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv + add_pair env (exported_id, exported) + | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported + , shortMeOut env exported_id local_id + = extendVarEnv env local_id (exported_id, ticks) + add_pair env _ = env + +----------------- +shortMeOut :: IndEnv -> Id -> Id -> Bool +shortMeOut ind_env exported_id local_id +-- The if-then-else stuff is just so I can get a pprTrace to see +-- how often I don't get shorting out because of IdInfo stuff + = if isExportedId exported_id && -- Only if this is exported + + isLocalId local_id && -- Only if this one is defined in this + -- module, so that we *can* change its + -- binding to be the exported thing! + + not (isExportedId local_id) && -- Only if this one is not itself exported, + -- since the transformation will nuke it + + not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for + then + if hasShortableIdInfo exported_id + then True -- See Note [Messing up the exported Id's IdInfo] + else WARN( True, text "Not shorting out:" <+> ppr exported_id ) + False + else + False + +----------------- +hasShortableIdInfo :: Id -> Bool +-- True if there is no user-attached IdInfo on exported_id, +-- so we can safely discard it +-- See Note [Messing up the exported Id's IdInfo] +hasShortableIdInfo id + = isEmptyRuleInfo (ruleInfo info) + && isDefaultInlinePragma (inlinePragInfo info) + && not (isStableUnfolding (unfoldingInfo info)) + where + info = idInfo id + +----------------- +{- Note [Transferring IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + lcl_id = e; exp_id = lcl_id + +and lcl_id has useful IdInfo, we don't want to discard it by going + gbl_id = e; lcl_id = gbl_id + +Instead, transfer IdInfo from lcl_id to exp_id, specifically +* (Stable) unfolding +* Strictness +* Rules +* Inline pragma + +Overwriting, rather than merging, seems to work ok. + +We also zap the InlinePragma on the lcl_id. It might originally +have had a NOINLINE, which we have now transferred; and we really +want the lcl_id to inline now that its RHS is trivial! +-} + +transferIdInfo :: Id -> Id -> (Id, Id) +-- See Note [Transferring IdInfo] +transferIdInfo exported_id local_id + = ( modifyIdInfo transfer exported_id + , local_id `setInlinePragma` defaultInlinePragma ) + where + local_info = idInfo local_id + transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info + `setCprInfo` cprInfo local_info + `setUnfoldingInfo` unfoldingInfo local_info + `setInlinePragInfo` inlinePragInfo local_info + `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info + new_info = setRuleInfoHead (idName exported_id) + (ruleInfo local_info) + -- Remember to set the function-name field of the + -- rules as we transfer them from one function to another diff --git a/compiler/GHC/Core/Opt/Exitify.hs b/compiler/GHC/Core/Opt/Exitify.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Exitify.hs @@ -0,0 +1,499 @@ +module GHC.Core.Opt.Exitify ( exitifyProgram ) where + +{- +Note [Exitification] +~~~~~~~~~~~~~~~~~~~~ + +This module implements Exitification. The goal is to pull as much code out of +recursive functions as possible, as the simplifier is better at inlining into +call-sites that are not in recursive functions. + +Example: + + let t = foo bar + joinrec go 0 x y = t (x*x) + go (n-1) x y = jump go (n-1) (x+y) + in … + +We’d like to inline `t`, but that does not happen: Because t is a thunk and is +used in a recursive function, doing so might lose sharing in general. In +this case, however, `t` is on the _exit path_ of `go`, so called at most once. +How do we make this clearly visible to the simplifier? + +A code path (i.e., an expression in a tail-recursive position) in a recursive +function is an exit path if it does not contain a recursive call. We can bind +this expression outside the recursive function, as a join-point. + +Example result: + + let t = foo bar + join exit x = t (x*x) + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … + +Now `t` is no longer in a recursive function, and good things happen! +-} + +import GHC.Prelude +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core +import GHC.Core.Utils +import GHC.Utils.Monad.State +import GHC.Types.Unique +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Core.FVs +import GHC.Data.FastString +import GHC.Core.Type +import GHC.Utils.Misc( mapSnd ) + +import Data.Bifunctor +import Control.Monad + +-- | Traverses the AST, simply to find all joinrecs and call 'exitify' on them. +-- The really interesting function is exitifyRec +exitifyProgram :: CoreProgram -> CoreProgram +exitifyProgram binds = map goTopLvl binds + where + goTopLvl (NonRec v e) = NonRec v (go in_scope_toplvl e) + goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs) + -- Top-level bindings are never join points + + in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds + + go :: InScopeSet -> CoreExpr -> CoreExpr + go _ e@(Var{}) = e + go _ e@(Lit {}) = e + go _ e@(Type {}) = e + go _ e@(Coercion {}) = e + go in_scope (Cast e' c) = Cast (go in_scope e') c + go in_scope (Tick t e') = Tick t (go in_scope e') + go in_scope (App e1 e2) = App (go in_scope e1) (go in_scope e2) + + go in_scope (Lam v e') + = Lam v (go in_scope' e') + where in_scope' = in_scope `extendInScopeSet` v + + go in_scope (Case scrut bndr ty alts) + = Case (go in_scope scrut) bndr ty (map go_alt alts) + where + in_scope1 = in_scope `extendInScopeSet` bndr + go_alt (dc, pats, rhs) = (dc, pats, go in_scope' rhs) + where in_scope' = in_scope1 `extendInScopeSetList` pats + + go in_scope (Let (NonRec bndr rhs) body) + = Let (NonRec bndr (go in_scope rhs)) (go in_scope' body) + where + in_scope' = in_scope `extendInScopeSet` bndr + + go in_scope (Let (Rec pairs) body) + | is_join_rec = mkLets (exitifyRec in_scope' pairs') body' + | otherwise = Let (Rec pairs') body' + where + is_join_rec = any (isJoinId . fst) pairs + in_scope' = in_scope `extendInScopeSetList` bindersOf (Rec pairs) + pairs' = mapSnd (go in_scope') pairs + body' = go in_scope' body + + +-- | State Monad used inside `exitify` +type ExitifyM = State [(JoinId, CoreExpr)] + +-- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as +-- join-points outside the joinrec. +exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind] +exitifyRec in_scope pairs + = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs'] + where + -- We need the set of free variables of many subexpressions here, so + -- annotate the AST with them + -- see Note [Calculating free variables] + ann_pairs = map (second freeVars) pairs + + -- Which are the recursive calls? + recursive_calls = mkVarSet $ map fst pairs + + (pairs',exits) = (`runState` []) $ do + forM ann_pairs $ \(x,rhs) -> do + -- go past the lambdas of the join point + let (args, body) = collectNAnnBndrs (idJoinArity x) rhs + body' <- go args body + let rhs' = mkLams args body' + return (x, rhs') + + --------------------- + -- 'go' is the main working function. + -- It goes through the RHS (tail-call positions only), + -- checks if there are no more recursive calls, if so, abstracts over + -- variables bound on the way and lifts it out as a join point. + -- + -- ExitifyM is a state monad to keep track of floated binds + go :: [Var] -- ^ Variables that are in-scope here, but + -- not in scope at the joinrec; that is, + -- we must potentially abstract over them. + -- Invariant: they are kept in dependency order + -> CoreExprWithFVs -- ^ Current expression in tail position + -> ExitifyM CoreExpr + + -- We first look at the expression (no matter what it shape is) + -- and determine if we can turn it into a exit join point + go captured ann_e + | -- An exit expression has no recursive calls + let fvs = dVarSetToVarSet (freeVarsOf ann_e) + , disjointVarSet fvs recursive_calls + = go_exit captured (deAnnotate ann_e) fvs + + -- We could not turn it into a exit join point. So now recurse + -- into all expression where eligible exit join points might sit, + -- i.e. into all tail-call positions: + + -- Case right hand sides are in tail-call position + go captured (_, AnnCase scrut bndr ty alts) = do + alts' <- forM alts $ \(dc, pats, rhs) -> do + rhs' <- go (captured ++ [bndr] ++ pats) rhs + return (dc, pats, rhs') + return $ Case (deAnnotate scrut) bndr ty alts' + + go captured (_, AnnLet ann_bind body) + -- join point, RHS and body are in tail-call position + | AnnNonRec j rhs <- ann_bind + , Just join_arity <- isJoinId_maybe j + = do let (params, join_body) = collectNAnnBndrs join_arity rhs + join_body' <- go (captured ++ params) join_body + let rhs' = mkLams params join_body' + body' <- go (captured ++ [j]) body + return $ Let (NonRec j rhs') body' + + -- rec join point, RHSs and body are in tail-call position + | AnnRec pairs <- ann_bind + , isJoinId (fst (head pairs)) + = do let js = map fst pairs + pairs' <- forM pairs $ \(j,rhs) -> do + let join_arity = idJoinArity j + (params, join_body) = collectNAnnBndrs join_arity rhs + join_body' <- go (captured ++ js ++ params) join_body + let rhs' = mkLams params join_body' + return (j, rhs') + body' <- go (captured ++ js) body + return $ Let (Rec pairs') body' + + -- normal Let, only the body is in tail-call position + | otherwise + = do body' <- go (captured ++ bindersOf bind ) body + return $ Let bind body' + where bind = deAnnBind ann_bind + + -- Cannot be turned into an exit join point, but also has no + -- tail-call subexpression. Nothing to do here. + go _ ann_e = return (deAnnotate ann_e) + + --------------------- + go_exit :: [Var] -- Variables captured locally + -> CoreExpr -- An exit expression + -> VarSet -- Free vars of the expression + -> ExitifyM CoreExpr + -- go_exit deals with a tail expression that is floatable + -- out as an exit point; that is, it mentions no recursive calls + go_exit captured e fvs + -- Do not touch an expression that is already a join jump where all arguments + -- are captured variables. See Note [Idempotency] + -- But _do_ float join jumps with interesting arguments. + -- See Note [Jumps can be interesting] + | (Var f, args) <- collectArgs e + , isJoinId f + , all isCapturedVarArg args + = return e + + -- Do not touch a boring expression (see Note [Interesting expression]) + | not is_interesting + = return e + + -- Cannot float out if local join points are used, as + -- we cannot abstract over them + | captures_join_points + = return e + + -- We have something to float out! + | otherwise + = do { -- Assemble the RHS of the exit join point + let rhs = mkLams abs_vars e + avoid = in_scope `extendInScopeSetList` captured + -- Remember this binding under a suitable name + ; v <- addExit avoid (length abs_vars) rhs + -- And jump to it from here + ; return $ mkVarApps (Var v) abs_vars } + + where + -- Used to detect exit expressions that are already proper exit jumps + isCapturedVarArg (Var v) = v `elem` captured + isCapturedVarArg _ = False + + -- An interesting exit expression has free, non-imported + -- variables from outside the recursive group + -- See Note [Interesting expression] + is_interesting = anyVarSet isLocalId $ + fvs `minusVarSet` mkVarSet captured + + -- The arguments of this exit join point + -- See Note [Picking arguments to abstract over] + abs_vars = snd $ foldr pick (fvs, []) captured + where + pick v (fvs', acc) | v `elemVarSet` fvs' = (fvs' `delVarSet` v, zap v : acc) + | otherwise = (fvs', acc) + + -- We are going to abstract over these variables, so we must + -- zap any IdInfo they have; see #15005 + -- cf. GHC.Core.Opt.SetLevels.abstractVars + zap v | isId v = setIdInfo v vanillaIdInfo + | otherwise = v + + -- We cannot abstract over join points + captures_join_points = any isJoinId abs_vars + + +-- Picks a new unique, which is disjoint from +-- * the free variables of the whole joinrec +-- * any bound variables (captured) +-- * any exit join points created so far. +mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId +mkExitJoinId in_scope ty join_arity = do + fs <- get + let avoid = in_scope `extendInScopeSetList` (map fst fs) + `extendInScopeSet` exit_id_tmpl -- just cosmetics + return (uniqAway avoid exit_id_tmpl) + where + exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ty + `asJoinId` join_arity + +addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId +addExit in_scope join_arity rhs = do + -- Pick a suitable name + let ty = exprType rhs + v <- mkExitJoinId in_scope ty join_arity + fs <- get + put ((v,rhs):fs) + return v + +{- +Note [Interesting expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not want this to happen: + + joinrec go 0 x y = x + go (n-1) x y = jump go (n-1) (x+y) + in … +==> + join exit x = x + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … + +because the floated exit path (`x`) is simply a parameter of `go`; there are +not useful interactions exposed this way. + +Neither do we want this to happen + + joinrec go 0 x y = x+x + go (n-1) x y = jump go (n-1) (x+y) + in … +==> + join exit x = x+x + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … + +where the floated expression `x+x` is a bit more complicated, but still not +intersting. + +Expressions are interesting when they move an occurrence of a variable outside +the recursive `go` that can benefit from being obviously called once, for example: + * a local thunk that can then be inlined (see example in note [Exitification]) + * the parameter of a function, where the demand analyzer then can then + see that it is called at most once, and hence improve the function’s + strictness signature + +So we only hoist an exit expression out if it mentiones at least one free, +non-imported variable. + +Note [Jumps can be interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A jump to a join point can be interesting, if its arguments contain free +non-exported variables (z in the following example): + + joinrec go 0 x y = jump j (x+z) + go (n-1) x y = jump go (n-1) (x+y) + in … +==> + join exit x y = jump j (x+z) + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + + +The join point itself can be interesting, even if none if its +arguments have free variables free in the joinrec. For example + + join j p = case p of (x,y) -> x+y + joinrec go 0 x y = jump j (x,y) + go (n-1) x y = jump go (n-1) (x+y) y + in … + +Here, `j` would not be inlined because we do not inline something that looks +like an exit join point (see Note [Do not inline exit join points]). But +if we exitify the 'jump j (x,y)' we get + + join j p = case p of (x,y) -> x+y + join exit x y = jump j (x,y) + joinrec go 0 x y = jump exit x y + go (n-1) x y = jump go (n-1) (x+y) y + in … + +and now 'j' can inline, and we get rid of the pair. Here's another +example (assume `g` to be an imported function that, on its own, +does not make this interesting): + + join j y = map f y + joinrec go 0 x y = jump j (map g x) + go (n-1) x y = jump go (n-1) (x+y) + in … + +Again, `j` would not be inlined because we do not inline something that looks +like an exit join point (see Note [Do not inline exit join points]). + +But after exitification we have + + join j y = map f y + join exit x = jump j (map g x) + joinrec go 0 x y = jump j (map g x) + go (n-1) x y = jump go (n-1) (x+y) + in … + +and now we can inline `j` and this will allow `map/map` to fire. + + +Note [Idempotency] +~~~~~~~~~~~~~~~~~~ + +We do not want this to happen, where we replace the floated expression with +essentially the same expression: + + join exit x = t (x*x) + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … +==> + join exit x = t (x*x) + join exit' x = jump exit x + joinrec go 0 x y = jump exit' x + go (n-1) x y = jump go (n-1) (x+y) + in … + +So when the RHS is a join jump, and all of its arguments are captured variables, +then we leave it in place. + +Note that `jump exit x` in this example looks interesting, as `exit` is a free +variable. Therefore, idempotency does not simply follow from floating only +interesting expressions. + +Note [Calculating free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have two options where to annotate the tree with free variables: + + A) The whole tree. + B) Each individual joinrec as we come across it. + +Downside of A: We pay the price on the whole module, even outside any joinrecs. +Downside of B: We pay the price per joinrec, possibly multiple times when +joinrecs are nested. + +Further downside of A: If the exitify function returns annotated expressions, +it would have to ensure that the annotations are correct. + +We therefore choose B, and calculate the free variables in `exitify`. + + +Note [Do not inline exit join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have + + let t = foo bar + join exit x = t (x*x) + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … + +we do not want the simplifier to simply inline `exit` back in (which it happily +would). + +To prevent this, we need to recognize exit join points, and then disable +inlining. + +Exit join points, recognizeable using `isExitJoinId` are join points with an +occurrence in a recursive group, and can be recognized (after the occurrence +analyzer ran!) using `isExitJoinId`. +This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`, +because the lambdas of a non-recursive join point are not considered for +`occ_in_lam`. For example, in the following code, `j1` is /not/ marked +occ_in_lam, because `j2` is called only once. + + join j1 x = x+1 + join j2 y = join j1 (y+2) + +To prevent inlining, we check for isExitJoinId +* In `preInlineUnconditionally` directly. +* In `simplLetUnfolding` we simply give exit join points no unfolding, which + prevents inlining in `postInlineUnconditionally` and call sites. + +Note [Placement of the exitification pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I (Joachim) experimented with multiple positions for the Exitification pass in +the Core2Core pipeline: + + A) Before the `simpl_phases` + B) Between the `simpl_phases` and the "main" simplifier pass + C) After demand_analyser + D) Before the final simplification phase + +Here is the table (this is without inlining join exit points in the final +simplifier run): + + Program | Allocs | Instrs + | ABCD.log A.log B.log C.log D.log | ABCD.log A.log B.log C.log D.log +----------------|---------------------------------------------------|------------------------------------------------- + fannkuch-redux | -99.9% +0.0% -99.9% -99.9% -99.9% | -3.9% +0.5% -3.0% -3.9% -3.9% + fasta | -0.0% +0.0% +0.0% -0.0% -0.0% | -8.5% +0.0% +0.0% -0.0% -8.5% + fem | 0.0% 0.0% 0.0% 0.0% +0.0% | -2.2% -0.1% -0.1% -2.1% -2.1% + fish | 0.0% 0.0% 0.0% 0.0% +0.0% | -3.1% +0.0% -1.1% -1.1% -0.0% + k-nucleotide | -91.3% -91.0% -91.0% -91.3% -91.3% | -6.3% +11.4% +11.4% -6.3% -6.2% + scs | -0.0% -0.0% -0.0% -0.0% -0.0% | -3.4% -3.0% -3.1% -3.3% -3.3% + simple | -6.0% 0.0% -6.0% -6.0% +0.0% | -3.4% +0.0% -5.2% -3.4% -0.1% + spectral-norm | -0.0% 0.0% 0.0% -0.0% +0.0% | -2.7% +0.0% -2.7% -5.4% -5.4% +----------------|---------------------------------------------------|------------------------------------------------- + Min | -95.0% -91.0% -95.0% -95.0% -95.0% | -8.5% -3.0% -5.2% -6.3% -8.5% + Max | +0.2% +0.2% +0.2% +0.2% +1.5% | +0.4% +11.4% +11.4% +0.4% +1.5% + Geometric Mean | -4.7% -2.1% -4.7% -4.7% -4.6% | -0.4% +0.1% -0.1% -0.3% -0.2% + +Position A is disqualified, as it does not get rid of the allocations in +fannkuch-redux. +Position A and B are disqualified because it increases instructions in k-nucleotide. +Positions C and D have their advantages: C decreases allocations in simpl, but D instructions in fasta. + +Assuming we have a budget of _one_ run of Exitification, then C wins (but we +could get more from running it multiple times, as seen in fish). + +Note [Picking arguments to abstract over] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When we create an exit join point, so we need to abstract over those of its +free variables that are be out-of-scope at the destination of the exit join +point. So we go through the list `captured` and pick those that are actually +free variables of the join point. + +We do not just `filter (`elemVarSet` fvs) captured`, as there might be +shadowing, and `captured` may contain multiple variables with the same Unique. I +these cases we want to abstract only over the last occurrence, hence the `foldr` +(with emphasis on the `r`). This is #15110. + +-} diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -0,0 +1,777 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +************************************************************************ +* * +\section[FloatIn]{Floating Inwards pass} +* * +************************************************************************ + +The main purpose of @floatInwards@ is floating into branches of a +case, so that we don't allocate things, save them on the stack, and +then discover that they aren't needed in the chosen branch. +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fprof-auto #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Core.Opt.FloatIn ( floatInwards ) where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Platform + +import GHC.Core +import GHC.Core.Make hiding ( wrapFloats ) +import GHC.Driver.Types ( ModGuts(..) ) +import GHC.Core.Utils +import GHC.Core.FVs +import GHC.Core.Opt.Monad ( CoreM ) +import GHC.Types.Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) +import GHC.Types.Var +import GHC.Core.Type +import GHC.Types.Var.Set +import GHC.Utils.Misc +import GHC.Driver.Session +import GHC.Utils.Outputable +-- import Data.List ( mapAccumL ) +import GHC.Types.Basic ( RecFlag(..), isRec ) + +{- +Top-level interface function, @floatInwards@. Note that we do not +actually float any bindings downwards from the top-level. +-} + +floatInwards :: ModGuts -> CoreM ModGuts +floatInwards pgm@(ModGuts { mg_binds = binds }) + = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; return (pgm { mg_binds = map (fi_top_bind platform) binds }) } + where + fi_top_bind platform (NonRec binder rhs) + = NonRec binder (fiExpr platform [] (freeVars rhs)) + fi_top_bind platform (Rec pairs) + = Rec [ (b, fiExpr platform [] (freeVars rhs)) | (b, rhs) <- pairs ] + + +{- +************************************************************************ +* * +\subsection{Mail from Andr\'e [edited]} +* * +************************************************************************ + +{\em Will wrote: What??? I thought the idea was to float as far +inwards as possible, no matter what. This is dropping all bindings +every time it sees a lambda of any kind. Help! } + +You are assuming we DO DO full laziness AFTER floating inwards! We +have to [not float inside lambdas] if we don't. + +If we indeed do full laziness after the floating inwards (we could +check the compilation flags for that) then I agree we could be more +aggressive and do float inwards past lambdas. + +Actually we are not doing a proper full laziness (see below), which +was another reason for not floating inwards past a lambda. + +This can easily be fixed. The problem is that we float lets outwards, +but there are a few expressions which are not let bound, like case +scrutinees and case alternatives. After floating inwards the +simplifier could decide to inline the let and the laziness would be +lost, e.g. + +\begin{verbatim} +let a = expensive ==> \b -> case expensive of ... +in \ b -> case a of ... +\end{verbatim} +The fix is +\begin{enumerate} +\item +to let bind the algebraic case scrutinees (done, I think) and +the case alternatives (except the ones with an +unboxed type)(not done, I think). This is best done in the +GHC.Core.Opt.SetLevels.hs module, which tags things with their level numbers. +\item +do the full laziness pass (floating lets outwards). +\item +simplify. The simplifier inlines the (trivial) lets that were + created but were not floated outwards. +\end{enumerate} + +With the fix I think Will's suggestion that we can gain even more from +strictness by floating inwards past lambdas makes sense. + +We still gain even without going past lambdas, as things may be +strict in the (new) context of a branch (where it was floated to) or +of a let rhs, e.g. +\begin{verbatim} +let a = something case x of +in case x of alt1 -> case something of a -> a + a + alt1 -> a + a ==> alt2 -> b + alt2 -> b + +let a = something let b = case something of a -> a + a +in let b = a + a ==> in (b,b) +in (b,b) +\end{verbatim} +Also, even if a is not found to be strict in the new context and is +still left as a let, if the branch is not taken (or b is not entered) +the closure for a is not built. + +************************************************************************ +* * +\subsection{Main floating-inwards code} +* * +************************************************************************ +-} + +type FreeVarSet = DIdSet +type BoundVarSet = DIdSet + +data FloatInBind = FB BoundVarSet FreeVarSet FloatBind + -- The FreeVarSet is the free variables of the binding. In the case + -- of recursive bindings, the set doesn't include the bound + -- variables. + +type FloatInBinds = [FloatInBind] + -- In reverse dependency order (innermost binder first) + +fiExpr :: Platform + -> FloatInBinds -- Binds we're trying to drop + -- as far "inwards" as possible + -> CoreExprWithFVs -- Input expr + -> CoreExpr -- Result + +fiExpr _ to_drop (_, AnnLit lit) = wrapFloats to_drop (Lit lit) + -- See Note [Dead bindings] +fiExpr _ to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty +fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) +fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) +fiExpr platform to_drop (_, AnnCast expr (co_ann, co)) + = wrapFloats (drop_here ++ co_drop) $ + Cast (fiExpr platform e_drop expr) co + where + [drop_here, e_drop, co_drop] + = sepBindsByDropPoint platform False + [freeVarsOf expr, freeVarsOfAnn co_ann] + to_drop + +{- +Applications: we do float inside applications, mainly because we +need to get at all the arguments. The next simplifier run will +pull out any silly ones. +-} + +fiExpr platform to_drop ann_expr@(_,AnnApp {}) + = wrapFloats drop_here $ wrapFloats extra_drop $ + mkTicks ticks $ + mkApps (fiExpr platform fun_drop ann_fun) + (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args) + -- use zipWithEqual, we should have + -- length ann_args = length arg_fvs = length arg_drops + where + (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr + fun_ty = exprType (deAnnotate ann_fun) + fun_fvs = freeVarsOf ann_fun + arg_fvs = map freeVarsOf ann_args + + (drop_here : extra_drop : fun_drop : arg_drops) + = sepBindsByDropPoint platform False + (extra_fvs : fun_fvs : arg_fvs) + to_drop + -- Shortcut behaviour: if to_drop is empty, + -- sepBindsByDropPoint returns a suitable bunch of empty + -- lists without evaluating extra_fvs, and hence without + -- peering into each argument + + (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args + extra_fvs0 = case ann_fun of + (_, AnnVar _) -> fun_fvs + _ -> emptyDVarSet + -- Don't float the binding for f into f x y z; see Note [Join points] + -- for why we *can't* do it when f is a join point. (If f isn't a + -- join point, floating it in isn't especially harmful but it's + -- useless since the simplifier will immediately float it back out.) + + add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet) + add_arg (fun_ty, extra_fvs) (_, AnnType ty) + = (piResultTy fun_ty ty, extra_fvs) + + add_arg (fun_ty, extra_fvs) (arg_fvs, arg) + | noFloatIntoArg arg arg_ty + = (res_ty, extra_fvs `unionDVarSet` arg_fvs) + | otherwise + = (res_ty, extra_fvs) + where + (arg_ty, res_ty) = splitFunTy fun_ty + +{- Note [Dead bindings] +~~~~~~~~~~~~~~~~~~~~~~~ +At a literal we won't usually have any floated bindings; the +only way that can happen is if the binding wrapped the literal +/in the original input program/. e.g. + case x of { DEFAULT -> 1# } +But, while this may be unusual it is not actually wrong, and it did +once happen (#15696). + +Note [Do not destroy the let/app invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Watch out for + f (x +# y) +We don't want to float bindings into here + f (case ... of { x -> x +# y }) +because that might destroy the let/app invariant, which requires +unlifted function arguments to be ok-for-speculation. + +Note [Join points] +~~~~~~~~~~~~~~~~~~ +Generally, we don't need to worry about join points - there are places we're +not allowed to float them, but since they can't have occurrences in those +places, we're not tempted. + +We do need to be careful about jumps, however: + + joinrec j x y z = ... in + jump j a b c + +Previous versions often floated the definition of a recursive function into its +only non-recursive occurrence. But for a join point, this is a disaster: + + (joinrec j x y z = ... in + jump j) a b c -- wrong! + +Every jump must be exact, so the jump to j must have three arguments. Hence +we're careful not to float into the target of a jump (though we can float into +the arguments just fine). + +Note [Floating in past a lambda group] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* We must be careful about floating inside a value lambda. + That risks losing laziness. + The float-out pass might rescue us, but then again it might not. + +* We must be careful about type lambdas too. At one time we did, and + there is no risk of duplicating work thereby, but we do need to be + careful. In particular, here is a bad case (it happened in the + cichelli benchmark: + let v = ... + in let f = /\t -> \a -> ... + ==> + let f = /\t -> let v = ... in \a -> ... + This is bad as now f is an updatable closure (update PAP) + and has arity 0. + +* Hack alert! We only float in through one-shot lambdas, + not (as you might guess) through lone big lambdas. + Reason: we float *out* past big lambdas (see the test in the Lam + case of FloatOut.floatExpr) and we don't want to float straight + back in again. + + It *is* important to float into one-shot lambdas, however; + see the remarks with noFloatIntoRhs. + +So we treat lambda in groups, using the following rule: + + Float in if (a) there is at least one Id, + and (b) there are no non-one-shot Ids + + Otherwise drop all the bindings outside the group. + +This is what the 'go' function in the AnnLam case is doing. + +(Join points are handled similarly: a join point is considered one-shot iff +it's non-recursive, so we float only into non-recursive join points.) + +Urk! if all are tyvars, and we don't float in, we may miss an + opportunity to float inside a nested case branch + + +Note [Floating coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We could, in principle, have a coercion binding like + case f x of co { DEFAULT -> e1 e2 } +It's not common to have a function that returns a coercion, but nothing +in Core prohibits it. If so, 'co' might be mentioned in e1 or e2 +/only in a type/. E.g. suppose e1 was + let (x :: Int |> co) = blah in blah2 + + +But, with coercions appearing in types, there is a complication: we +might be floating in a "strict let" -- that is, a case. Case expressions +mention their return type. We absolutely can't float a coercion binding +inward to the point that the type of the expression it's about to wrap +mentions the coercion. So we include the union of the sets of free variables +of the types of all the drop points involved. If any of the floaters +bind a coercion variable mentioned in any of the types, that binder must +be dropped right away. + +-} + +fiExpr platform to_drop lam@(_, AnnLam _ _) + | noFloatIntoLam bndrs -- Dump it all here + -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088 + = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body)) + + | otherwise -- Float inside + = mkLams bndrs (fiExpr platform to_drop body) + + where + (bndrs, body) = collectAnnBndrs lam + +{- +We don't float lets inwards past an SCC. + ToDo: keep info on current cc, and when passing + one, if it is not the same, annotate all lets in binds with current + cc, change current cc to the new one and float binds into expr. +-} + +fiExpr platform to_drop (_, AnnTick tickish expr) + | tickish `tickishScopesLike` SoftScope + = Tick tickish (fiExpr platform to_drop expr) + + | otherwise -- Wimp out for now - we could push values in + = wrapFloats to_drop (Tick tickish (fiExpr platform [] expr)) + +{- +For @Lets@, the possible ``drop points'' for the \tr{to_drop} +bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding, +or~(b2), in each of the RHSs of the pairs of a @Rec@. + +Note that we do {\em weird things} with this let's binding. Consider: +\begin{verbatim} +let + w = ... +in { + let v = ... w ... + in ... v .. w ... +} +\end{verbatim} +Look at the inner \tr{let}. As \tr{w} is used in both the bind and +body of the inner let, we could panic and leave \tr{w}'s binding where +it is. But \tr{v} is floatable further into the body of the inner let, and +{\em then} \tr{w} will also be only in the body of that inner let. + +So: rather than drop \tr{w}'s binding here, we add it onto the list of +things to drop in the outer let's body, and let nature take its +course. + +Note [extra_fvs (1): avoid floating into RHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider let x=\y....t... in body. We do not necessarily want to float +a binding for t into the RHS, because it'll immediately be floated out +again. (It won't go inside the lambda else we risk losing work.) +In letrec, we need to be more careful still. We don't want to transform + let x# = y# +# 1# + in + letrec f = \z. ...x#...f... + in ... +into + letrec f = let x# = y# +# 1# in \z. ...x#...f... in ... +because now we can't float the let out again, because a letrec +can't have unboxed bindings. + +So we make "extra_fvs" which is the rhs_fvs of such bindings, and +arrange to dump bindings that bind extra_fvs before the entire let. + +Note [extra_fvs (2): free variables of rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let x{rule mentioning y} = rhs in body +Here y is not free in rhs or body; but we still want to dump bindings +that bind y outside the let. So we augment extra_fvs with the +idRuleAndUnfoldingVars of x. No need for type variables, hence not using +idFreeVars. +-} + +fiExpr platform to_drop (_,AnnLet bind body) + = fiExpr platform (after ++ new_float : before) body + -- to_drop is in reverse dependency order + where + (before, new_float, after) = fiBind platform to_drop bind body_fvs + body_fvs = freeVarsOf body + +{- Note [Floating primops] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We try to float-in a case expression over an unlifted type. The +motivating example was #5658: in particular, this change allows +array indexing operations, which have a single DEFAULT alternative +without any binders, to be floated inward. + +SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed +scalars also need to be floated inward, but unpacks have a single non-DEFAULT +alternative that binds the elements of the tuple. We now therefore also support +floating in cases with a single alternative that may bind values. + +But there are wrinkles + +* Which unlifted cases do we float? See GHC.Builtin.PrimOps + Note [PrimOp can_fail and has_side_effects] which explains: + - We can float-in can_fail primops, but we can't float them out. + - But we can float a has_side_effects primop, but NOT inside a lambda, + so for now we don't float them at all. + Hence exprOkForSideEffects + +* Because we can float can-fail primops (array indexing, division) inwards + but not outwards, we must be careful not to transform + case a /# b of r -> f (F# r) + ===> + f (case a /# b of r -> F# r) + because that creates a new thunk that wasn't there before. And + because it can't be floated out (can_fail), the thunk will stay + there. Disaster! (This happened in nofib 'simple' and 'scs'.) + + Solution: only float cases into the branches of other cases, and + not into the arguments of an application, or the RHS of a let. This + is somewhat conservative, but it's simple. And it still hits the + cases like #5658. This is implemented in sepBindsByJoinPoint; + if is_case is False we dump all floating cases right here. + +* #14511 is another example of why we want to restrict float-in + of case-expressions. Consider + case indexArray# a n of (# r #) -> writeArray# ma i (f r) + Now, floating that indexing operation into the (f r) thunk will + not create any new thunks, but it will keep the array 'a' alive + for much longer than the programmer expected. + + So again, not floating a case into a let or argument seems like + the Right Thing + +For @Case@, the possible drop points for the 'to_drop' +bindings are: + (a) inside the scrutinee + (b) inside one of the alternatives/default (default FVs always /first/!). + +-} + +fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) + | isUnliftedType (idType case_bndr) + , exprOkForSideEffects (deAnnotate scrut) + -- See Note [Floating primops] + = wrapFloats shared_binds $ + fiExpr platform (case_float : rhs_binds) rhs + where + case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs + (FloatCase scrut' case_bndr con alt_bndrs) + scrut' = fiExpr platform scrut_binds scrut + rhs_fvs = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs) + scrut_fvs = freeVarsOf scrut + + [shared_binds, scrut_binds, rhs_binds] + = sepBindsByDropPoint platform False + [scrut_fvs, rhs_fvs] + to_drop + +fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts) + = wrapFloats drop_here1 $ + wrapFloats drop_here2 $ + Case (fiExpr platform scrut_drops scrut) case_bndr ty + (zipWithEqual "fiExpr" fi_alt alts_drops_s alts) + -- use zipWithEqual, we should have length alts_drops_s = length alts + where + -- Float into the scrut and alts-considered-together just like App + [drop_here1, scrut_drops, alts_drops] + = sepBindsByDropPoint platform False + [scrut_fvs, all_alts_fvs] + to_drop + + -- Float into the alts with the is_case flag set + (drop_here2 : alts_drops_s) + | [ _ ] <- alts = [] : [alts_drops] + | otherwise = sepBindsByDropPoint platform True alts_fvs alts_drops + + scrut_fvs = freeVarsOf scrut + alts_fvs = map alt_fvs alts + all_alts_fvs = unionDVarSets alts_fvs + alt_fvs (_con, args, rhs) + = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args) + -- Delete case_bndr and args from free vars of rhs + -- to get free vars of alt + + fi_alt to_drop (con, args, rhs) = (con, args, fiExpr platform to_drop rhs) + +------------------ +fiBind :: Platform + -> FloatInBinds -- Binds we're trying to drop + -- as far "inwards" as possible + -> CoreBindWithFVs -- Input binding + -> DVarSet -- Free in scope of binding + -> ( FloatInBinds -- Land these before + , FloatInBind -- The binding itself + , FloatInBinds) -- Land these after + +fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs + = ( extra_binds ++ shared_binds -- Land these before + -- See Note [extra_fvs (1,2)] + , FB (unitDVarSet id) rhs_fvs' -- The new binding itself + (FloatLet (NonRec id rhs')) + , body_binds ) -- Land these after + + where + body_fvs2 = body_fvs `delDVarSet` id + + rule_fvs = bndrRuleAndUnfoldingVarsDSet id -- See Note [extra_fvs (2): free variables of rules] + extra_fvs | noFloatIntoRhs NonRecursive id rhs + = rule_fvs `unionDVarSet` rhs_fvs + | otherwise + = rule_fvs + -- See Note [extra_fvs (1): avoid floating into RHS] + -- No point in floating in only to float straight out again + -- We *can't* float into ok-for-speculation unlifted RHSs + -- But do float into join points + + [shared_binds, extra_binds, rhs_binds, body_binds] + = sepBindsByDropPoint platform False + [extra_fvs, rhs_fvs, body_fvs2] + to_drop + + -- Push rhs_binds into the right hand side of the binding + rhs' = fiRhs platform rhs_binds id ann_rhs + rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs + -- Don't forget the rule_fvs; the binding mentions them! + +fiBind platform to_drop (AnnRec bindings) body_fvs + = ( extra_binds ++ shared_binds + , FB (mkDVarSet ids) rhs_fvs' + (FloatLet (Rec (fi_bind rhss_binds bindings))) + , body_binds ) + where + (ids, rhss) = unzip bindings + rhss_fvs = map freeVarsOf rhss + + -- See Note [extra_fvs (1,2)] + rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids + extra_fvs = rule_fvs `unionDVarSet` + unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings + , noFloatIntoRhs Recursive bndr rhs ] + + (shared_binds:extra_binds:body_binds:rhss_binds) + = sepBindsByDropPoint platform False + (extra_fvs:body_fvs:rhss_fvs) + to_drop + + rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet` + unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet` + rule_fvs -- Don't forget the rule variables! + + -- Push rhs_binds into the right hand side of the binding + fi_bind :: [FloatInBinds] -- one per "drop pt" conjured w/ fvs_of_rhss + -> [(Id, CoreExprWithFVs)] + -> [(Id, CoreExpr)] + + fi_bind to_drops pairs + = [ (binder, fiRhs platform to_drop binder rhs) + | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] + +------------------ +fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr +fiRhs platform to_drop bndr rhs + | Just join_arity <- isJoinId_maybe bndr + , let (bndrs, body) = collectNAnnBndrs join_arity rhs + = mkLams bndrs (fiExpr platform to_drop body) + | otherwise + = fiExpr platform to_drop rhs + +------------------ +noFloatIntoLam :: [Var] -> Bool +noFloatIntoLam bndrs = any bad bndrs + where + bad b = isId b && not (isOneShotBndr b) + -- Don't float inside a non-one-shot lambda + +noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool +-- ^ True if it's a bad idea to float bindings into this RHS +noFloatIntoRhs is_rec bndr rhs + | isJoinId bndr + = isRec is_rec -- Joins are one-shot iff non-recursive + + | otherwise + = noFloatIntoArg rhs (idType bndr) + +noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool +noFloatIntoArg expr expr_ty + | isUnliftedType expr_ty + = True -- See Note [Do not destroy the let/app invariant] + + | AnnLam bndr e <- expr + , (bndrs, _) <- collectAnnBndrs e + = noFloatIntoLam (bndr:bndrs) -- Wrinkle 1 (a) + || all isTyVar (bndr:bndrs) -- Wrinkle 1 (b) + -- See Note [noFloatInto considerations] wrinkle 2 + + | otherwise -- Note [noFloatInto considerations] wrinkle 2 + = exprIsTrivial deann_expr || exprIsHNF deann_expr + where + deann_expr = deAnnotate' expr + +{- Note [noFloatInto considerations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When do we want to float bindings into + - noFloatIntoRHs: the RHS of a let-binding + - noFloatIntoArg: the argument of a function application + +Definitely don't float in if it has unlifted type; that +would destroy the let/app invariant. + +* Wrinkle 1: do not float in if + (a) any non-one-shot value lambdas + or (b) all type lambdas + In both cases we'll float straight back out again + NB: Must line up with fiExpr (AnnLam...); see #7088 + + (a) is important: we /must/ float into a one-shot lambda group + (which includes join points). This makes a big difference + for things like + f x# = let x = I# x# + in let j = \() -> ...x... + in if then normal-path else j () + If x is used only in the error case join point, j, we must float the + boxing constructor into it, else we box it every time which is very + bad news indeed. + +* Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right + back out again... not tragic, but a waste of time. + + For function arguments we will still end up with this + in-then-out stuff; consider + letrec x = e in f x + Here x is not a HNF, so we'll produce + f (letrec x = e in x) + which is OK... it's not that common, and we'll end up + floating out again, in CorePrep if not earlier. + Still, we use exprIsTrivial to catch this case (sigh) + + +************************************************************************ +* * +\subsection{@sepBindsByDropPoint@} +* * +************************************************************************ + +This is the crucial function. The idea is: We have a wad of bindings +that we'd like to distribute inside a collection of {\em drop points}; +insides the alternatives of a \tr{case} would be one example of some +drop points; the RHS and body of a non-recursive \tr{let} binding +would be another (2-element) collection. + +So: We're given a list of sets-of-free-variables, one per drop point, +and a list of floating-inwards bindings. If a binding can go into +only one drop point (without suddenly making something out-of-scope), +in it goes. If a binding is used inside {\em multiple} drop points, +then it has to go in a you-must-drop-it-above-all-these-drop-points +point. + +We have to maintain the order on these drop-point-related lists. +-} + +-- pprFIB :: FloatInBinds -> SDoc +-- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs] + +sepBindsByDropPoint + :: Platform + -> Bool -- True <=> is case expression + -> [FreeVarSet] -- One set of FVs per drop point + -- Always at least two long! + -> FloatInBinds -- Candidate floaters + -> [FloatInBinds] -- FIRST one is bindings which must not be floated + -- inside any drop point; the rest correspond + -- one-to-one with the input list of FV sets + +-- Every input floater is returned somewhere in the result; +-- none are dropped, not even ones which don't seem to be +-- free in *any* of the drop-point fvs. Why? Because, for example, +-- a binding (let x = E in B) might have a specialised version of +-- x (say x') stored inside x, but x' isn't free in E or B. + +type DropBox = (FreeVarSet, FloatInBinds) + +sepBindsByDropPoint platform is_case drop_pts floaters + | null floaters -- Shortcut common case + = [] : [[] | _ <- drop_pts] + + | otherwise + = ASSERT( drop_pts `lengthAtLeast` 2 ) + go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts)) + where + n_alts = length drop_pts + + go :: FloatInBinds -> [DropBox] -> [FloatInBinds] + -- The *first* one in the argument list is the drop_here set + -- The FloatInBinds in the lists are in the reverse of + -- the normal FloatInBinds order; that is, they are the right way round! + + go [] drop_boxes = map (reverse . snd) drop_boxes + + go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes) + = go binds new_boxes + where + -- "here" means the group of bindings dropped at the top of the fork + + (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs + | (fvs, _) <- drop_boxes] + + drop_here = used_here || cant_push + + n_used_alts = count id used_in_flags -- returns number of Trues in list. + + cant_push + | is_case = n_used_alts == n_alts -- Used in all, don't push + -- Remember n_alts > 1 + || (n_used_alts > 1 && not (floatIsDupable platform bind)) + -- floatIsDupable: see Note [Duplicating floats] + + | otherwise = floatIsCase bind || n_used_alts > 1 + -- floatIsCase: see Note [Floating primops] + + new_boxes | drop_here = (insert here_box : fork_boxes) + | otherwise = (here_box : new_fork_boxes) + + new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe + fork_boxes used_in_flags + + insert :: DropBox -> DropBox + insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops) + + insert_maybe box True = insert box + insert_maybe box False = box + + go _ _ = panic "sepBindsByDropPoint/go" + + +{- Note [Duplicating floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For case expressions we duplicate the binding if it is reasonably +small, and if it is not used in all the RHSs This is good for +situations like + let x = I# y in + case e of + C -> error x + D -> error x + E -> ...not mentioning x... + +If the thing is used in all RHSs there is nothing gained, +so we don't duplicate then. +-} + +floatedBindsFVs :: FloatInBinds -> FreeVarSet +floatedBindsFVs binds = mapUnionDVarSet fbFVs binds + +fbFVs :: FloatInBind -> DVarSet +fbFVs (FB _ fvs _) = fvs + +wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr +-- Remember FloatInBinds is in *reverse* dependency order +wrapFloats [] e = e +wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e) + +floatIsDupable :: Platform -> FloatBind -> Bool +floatIsDupable platform (FloatCase scrut _ _ _) = exprIsDupable platform scrut +floatIsDupable platform (FloatLet (Rec prs)) = all (exprIsDupable platform . snd) prs +floatIsDupable platform (FloatLet (NonRec _ r)) = exprIsDupable platform r + +floatIsCase :: FloatBind -> Bool +floatIsCase (FloatCase {}) = True +floatIsCase (FloatLet {}) = False diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -0,0 +1,757 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[FloatOut]{Float bindings outwards (towards the top level)} + +``Long-distance'' floating of bindings towards the top level. +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.FloatOut ( floatOutwards ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Make +import GHC.Core.Arity ( etaExpand ) +import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) + +import GHC.Driver.Session +import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Types.Id ( Id, idArity, idType, isBottomingId, + isJoinId, isJoinId_maybe ) +import GHC.Core.Opt.SetLevels +import GHC.Types.Unique.Supply ( UniqSupply ) +import GHC.Data.Bag +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Core.Type +import qualified Data.IntMap as M + +import Data.List ( partition ) + +#include "HsVersions.h" + +{- + ----------------- + Overall game plan + ----------------- + +The Big Main Idea is: + + To float out sub-expressions that can thereby get outside + a non-one-shot value lambda, and hence may be shared. + + +To achieve this we may need to do two things: + + a) Let-bind the sub-expression: + + f (g x) ==> let lvl = f (g x) in lvl + + Now we can float the binding for 'lvl'. + + b) More than that, we may need to abstract wrt a type variable + + \x -> ... /\a -> let v = ...a... in .... + + Here the binding for v mentions 'a' but not 'x'. So we + abstract wrt 'a', to give this binding for 'v': + + vp = /\a -> ...a... + v = vp a + + Now the binding for vp can float out unimpeded. + I can't remember why this case seemed important enough to + deal with, but I certainly found cases where important floats + didn't happen if we did not abstract wrt tyvars. + +With this in mind we can also achieve another goal: lambda lifting. +We can make an arbitrary (function) binding float to top level by +abstracting wrt *all* local variables, not just type variables, leaving +a binding that can be floated right to top level. Whether or not this +happens is controlled by a flag. + + +Random comments +~~~~~~~~~~~~~~~ + +At the moment we never float a binding out to between two adjacent +lambdas. For example: + +@ + \x y -> let t = x+x in ... +===> + \x -> let t = x+x in \y -> ... +@ +Reason: this is less efficient in the case where the original lambda +is never partially applied. + +But there's a case I've seen where this might not be true. Consider: +@ +elEm2 x ys + = elem' x ys + where + elem' _ [] = False + elem' x (y:ys) = x==y || elem' x ys +@ +It turns out that this generates a subexpression of the form +@ + \deq x ys -> let eq = eqFromEqDict deq in ... +@ +which might usefully be separated to +@ + \deq -> let eq = eqFromEqDict deq in \xy -> ... +@ +Well, maybe. We don't do this at the moment. + +Note [Join points] +~~~~~~~~~~~~~~~~~~ +Every occurrence of a join point must be a tail call (see Note [Invariants on +join points] in GHC.Core), so we must be careful with how far we float them. The +mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling] +in GHC.Core.Opt.SetLevels. For us, the significance is that a binder might be marked to be +dropped at the nearest boundary between tail calls and non-tail calls. For +example: + + (< join j = ... in + let x = < ... > in + case < ... > of + A -> ... + B -> ... + >) < ... > < ... > + +Here the join ceilings are marked with angle brackets. Either side of an +application is a join ceiling, as is the scrutinee position of a case +expression or the RHS of a let binding (but not a join point). + +Why do we *want* do float join points at all? After all, they're never +allocated, so there's no sharing to be gained by floating them. However, the +other benefit of floating is making RHSes small, and this can have a significant +impact. In particular, stream fusion has been known to produce nested loops like +this: + + joinrec j1 x1 = + joinrec j2 x2 = + joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ... + in jump j3 x2 + in jump j2 x1 + in jump j1 x + +(Assume x1 and x2 do *not* occur free in j3.) + +Here j1 and j2 are wholly superfluous---each of them merely forwards its +argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make +everything one big mutual recursion: + + joinrec j1 x1 = jump j2 x1 + j2 x2 = jump j3 x2 + j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ... + in jump j1 x + +Now the simplifier will happily inline the trivial j1 and j2, leaving only j3. +Without floating, we're stuck with three loops instead of one. + +************************************************************************ +* * +\subsection[floatOutwards]{@floatOutwards@: let-floating interface function} +* * +************************************************************************ +-} + +floatOutwards :: FloatOutSwitches + -> DynFlags + -> UniqSupply + -> CoreProgram -> IO CoreProgram + +floatOutwards float_sws dflags us pgm + = do { + let { annotated_w_levels = setLevels float_sws pgm us ; + (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) + } ; + + dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:" + FormatCore + (vcat (map ppr annotated_w_levels)); + + let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; + + dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:" + FormatText + (hcat [ int tlets, text " Lets floated to top level; ", + int ntlets, text " Lets floated elsewhere; from ", + int lams, text " Lambda groups"]); + + return (bagToList (unionManyBags binds_s')) + } + +floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind) +floatTopBind bind + = case (floatBind bind) of { (fs, floats, bind') -> + let float_bag = flattenTopFloats floats + in case bind' of + -- bind' can't have unlifted values or join points, so can only be one + -- value bind, rec or non-rec (see comment on floatBind) + [Rec prs] -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs))) + [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e) + _ -> pprPanic "floatTopBind" (ppr bind') } + +{- +************************************************************************ +* * +\subsection[FloatOut-Bind]{Floating in a binding (the business end)} +* * +************************************************************************ +-} + +floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind]) + -- Returns a list with either + -- * A single non-recursive binding (value or join point), or + -- * The following, in order: + -- * Zero or more non-rec unlifted bindings + -- * One or both of: + -- * A recursive group of join binds + -- * A recursive group of value binds + -- See Note [Floating out of Rec rhss] for why things get arranged this way. +floatBind (NonRec (TB var _) rhs) + = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') -> + + -- A tiresome hack: + -- see Note [Bottoming floats: eta expansion] in GHC.Core.Opt.SetLevels + let rhs'' | isBottomingId var = etaExpand (idArity var) rhs' + | otherwise = rhs' + + in (fs, rhs_floats, [NonRec var rhs'']) } + +floatBind (Rec pairs) + = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) -> + let (new_ul_pairss, new_other_pairss) = unzip new_pairs + (new_join_pairs, new_l_pairs) = partition (isJoinId . fst) + (concat new_other_pairss) + -- Can't put the join points and the values in the same rec group + new_rec_binds | null new_join_pairs = [ Rec new_l_pairs ] + | null new_l_pairs = [ Rec new_join_pairs ] + | otherwise = [ Rec new_l_pairs + , Rec new_join_pairs ] + new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ] + in + (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) } + where + do_pair :: (LevelledBndr, LevelledExpr) + -> (FloatStats, FloatBinds, + ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings + [(Id,CoreExpr)])) -- Join points and lifted value bindings + do_pair (TB name spec, rhs) + | isTopLvl dest_lvl -- See Note [floatBind for top level] + = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') -> + (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats) + [(name, rhs')]))} + | otherwise -- Note [Floating out of Rec rhss] + = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') -> + case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) -> + case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) -> + let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in + (fs, rhs_floats', (ul_pairs, pairs')) }}} + where + dest_lvl = floatSpecLevel spec + +splitRecFloats :: Bag FloatBind + -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings + [(Id,CoreExpr)], -- Join points and lifted value bindings + Bag FloatBind) -- A tail of further bindings +-- The "tail" begins with a case +-- See Note [Floating out of Rec rhss] +splitRecFloats fs + = go [] [] (bagToList fs) + where + go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b) + , not (isJoinId b) + = go ((b,r):ul_prs) prs fs + | otherwise + = go ul_prs ((b,r):prs) fs + go ul_prs prs (FloatLet (Rec prs') : fs) = go ul_prs (prs' ++ prs) fs + go ul_prs prs fs = (reverse ul_prs, prs, + listToBag fs) + -- Order only matters for + -- non-rec + +installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr +-- Note [Floating out of Rec rhss] +installUnderLambdas floats e + | isEmptyBag floats = e + | otherwise = go e + where + go (Lam b e) = Lam b (go e) + go e = install floats e + +--------------- +floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b]) +floatList _ [] = (zeroStats, emptyFloats, []) +floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> + case floatList f as of { (fs_as, binds_as, bs) -> + (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }} + +{- +Note [Floating out of Rec rhss] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider Rec { f<1,0> = \xy. body } +From the body we may get some floats. The ones with level <1,0> must +stay here, since they may mention f. Ideally we'd like to make them +part of the Rec block pairs -- but we can't if there are any +FloatCases involved. + +Nor is it a good idea to dump them in the rhs, but outside the lambda + f = case x of I# y -> \xy. body +because now f's arity might get worse, which is Not Good. (And if +there's an SCC around the RHS it might not get better again. +See #5342.) + +So, gruesomely, we split the floats into + * the outer FloatLets, which can join the Rec, and + * an inner batch starting in a FloatCase, which are then + pushed *inside* the lambdas. +This loses full-laziness the rare situation where there is a +FloatCase and a Rec interacting. + +If there are unlifted FloatLets (that *aren't* join points) among the floats, +we can't add them to the recursive group without angering Core Lint, but since +they must be ok-for-speculation, they can't actually be making any recursive +calls, so we can safely pull them out and keep them non-recursive. + +(Why is something getting floated to <1,0> that doesn't make a recursive call? +The case that came up in testing was that f *and* the unlifted binding were +getting floated *to the same place*: + + \x<2,0> -> + ... <3,0> + letrec { f> = + ... let x'> = x +# 1# in ... + } in ... + +Everything gets labeled "float to <2,0>" because it all depends on x, but this +makes f and x' look mutually recursive when they're not. + +The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the +wip/join-points branch. + +TODO: This can probably be solved somehow in GHC.Core.Opt.SetLevels. The difference between +"this *is at* level <2,0>" and "this *depends on* level <2,0>" is very +important.) + +Note [floatBind for top level] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus + letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... } +The binding for bar will be in the "tops" part of the floating binds, +and thus not partioned by floatBody. + +We could perhaps get rid of the 'tops' component of the floating binds, +but this case works just as well. + + +************************************************************************ + +\subsection[FloatOut-Expr]{Floating in expressions} +* * +************************************************************************ +-} + +floatBody :: Level + -> LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) + +floatBody lvl arg -- Used rec rhss, and case-alternative rhss + = case (floatExpr arg) of { (fsa, floats, arg') -> + case (partitionByLevel lvl floats) of { (floats', heres) -> + -- Dump bindings are bound here + (fsa, floats', install heres arg') }} + +----------------- + +{- Note [Floating past breakpoints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We used to disallow floating out of breakpoint ticks (see #10052). However, I +think this is too restrictive. + +Consider the case of an expression scoped over by a breakpoint tick, + + tick<...> (let x = ... in f x) + +In this case it is completely legal to float out x, despite the fact that +breakpoint ticks are scoped, + + let x = ... in (tick<...> f x) + +The reason here is that we know that the breakpoint will still be hit when the +expression is entered since the tick still scopes over the RHS. + +-} + +floatExpr :: LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) +floatExpr (Var v) = (zeroStats, emptyFloats, Var v) +floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty) +floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co) +floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit) + +floatExpr (App e a) + = case (atJoinCeiling $ floatExpr e) of { (fse, floats_e, e') -> + case (atJoinCeiling $ floatExpr a) of { (fsa, floats_a, a') -> + (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }} + +floatExpr lam@(Lam (TB _ lam_spec) _) + = let (bndrs_w_lvls, body) = collectBinders lam + bndrs = [b | TB b _ <- bndrs_w_lvls] + bndr_lvl = asJoinCeilLvl (floatSpecLevel lam_spec) + -- All the binders have the same level + -- See GHC.Core.Opt.SetLevels.lvlLamBndrs + -- Use asJoinCeilLvl to make this the join ceiling + in + case (floatBody bndr_lvl body) of { (fs, floats, body') -> + (add_to_stats fs floats, floats, mkLams bndrs body') } + +floatExpr (Tick tickish expr) + | tickish `tickishScopesLike` SoftScope -- not scoped, can just float + = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> + (fs, floating_defns, Tick tickish expr') } + + | not (tickishCounts tickish) || tickishCanSplit tickish + = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> + let -- Annotate bindings floated outwards past an scc expression + -- with the cc. We mark that cc as "duplicated", though. + annotated_defns = wrapTick (mkNoCount tickish) floating_defns + in + (fs, annotated_defns, Tick tickish expr') } + + -- Note [Floating past breakpoints] + | Breakpoint{} <- tickish + = case (floatExpr expr) of { (fs, floating_defns, expr') -> + (fs, floating_defns, Tick tickish expr') } + + | otherwise + = pprPanic "floatExpr tick" (ppr tickish) + +floatExpr (Cast expr co) + = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> + (fs, floating_defns, Cast expr' co) } + +floatExpr (Let bind body) + = case bind_spec of + FloatMe dest_lvl + -> case (floatBind bind) of { (fsb, bind_floats, binds') -> + case (floatExpr body) of { (fse, body_floats, body') -> + let new_bind_floats = foldr plusFloats emptyFloats + (map (unitLetFloat dest_lvl) binds') in + ( add_stats fsb fse + , bind_floats `plusFloats` new_bind_floats + `plusFloats` body_floats + , body') }} + + StayPut bind_lvl -- See Note [Avoiding unnecessary floating] + -> case (floatBind bind) of { (fsb, bind_floats, binds') -> + case (floatBody bind_lvl body) of { (fse, body_floats, body') -> + ( add_stats fsb fse + , bind_floats `plusFloats` body_floats + , foldr Let body' binds' ) }} + where + bind_spec = case bind of + NonRec (TB _ s) _ -> s + Rec ((TB _ s, _) : _) -> s + Rec [] -> panic "floatExpr:rec" + +floatExpr (Case scrut (TB case_bndr case_spec) ty alts) + = case case_spec of + FloatMe dest_lvl -- Case expression moves + | [(con@(DataAlt {}), bndrs, rhs)] <- alts + -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') -> + case floatExpr rhs of { (fsb, fdb, rhs') -> + let + float = unitCaseFloat dest_lvl scrut' + case_bndr con [b | TB b _ <- bndrs] + in + (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }} + | otherwise + -> pprPanic "Floating multi-case" (ppr alts) + + StayPut bind_lvl -- Case expression stays put + -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') -> + case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts') -> + (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') + }} + where + float_alt bind_lvl (con, bs, rhs) + = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') -> + (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) } + +floatRhs :: CoreBndr + -> LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) +floatRhs bndr rhs + | Just join_arity <- isJoinId_maybe bndr + , Just (bndrs, body) <- try_collect join_arity rhs [] + = case bndrs of + [] -> floatExpr rhs + (TB _ lam_spec):_ -> + let lvl = floatSpecLevel lam_spec in + case floatBody lvl body of { (fs, floats, body') -> + (fs, floats, mkLams [b | TB b _ <- bndrs] body') } + | otherwise + = atJoinCeiling $ floatExpr rhs + where + try_collect 0 expr acc = Just (reverse acc, expr) + try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc) + try_collect _ _ _ = Nothing + +{- +Note [Avoiding unnecessary floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we want to avoid floating a let unnecessarily, because +it might worsen strictness: + let + x = ...(let y = e in y+y).... +Here y is demanded. If we float it outside the lazy 'x=..' then +we'd have to zap its demand info, and it may never be restored. + +So at a 'let' we leave the binding right where the are unless +the binding will escape a value lambda, e.g. + +(\x -> let y = fac 100 in y) + +That's what the partitionByMajorLevel does in the floatExpr (Let ...) +case. + +Notice, though, that we must take care to drop any bindings +from the body of the let that depend on the staying-put bindings. + +We used instead to do the partitionByMajorLevel on the RHS of an '=', +in floatRhs. But that was quite tiresome. We needed to test for +values or trivial rhss, because (in particular) we don't want to insert +new bindings between the "=" and the "\". E.g. + f = \x -> let in +We do not want + f = let in \x -> +(a) The simplifier will immediately float it further out, so we may + as well do so right now; in general, keeping rhss as manifest + values is good +(b) If a float-in pass follows immediately, it might add yet more + bindings just after the '='. And some of them might (correctly) + be strict even though the 'let f' is lazy, because f, being a value, + gets its demand-info zapped by the simplifier. +And even all that turned out to be very fragile, and broke +altogether when profiling got in the way. + +So now we do the partition right at the (Let..) itself. + +************************************************************************ +* * +\subsection{Utility bits for floating stats} +* * +************************************************************************ + +I didn't implement this with unboxed numbers. I don't want to be too +strict in this stuff, as it is rarely turned on. (WDP 95/09) +-} + +data FloatStats + = FlS Int -- Number of top-floats * lambda groups they've been past + Int -- Number of non-top-floats * lambda groups they've been past + Int -- Number of lambda (groups) seen + +get_stats :: FloatStats -> (Int, Int, Int) +get_stats (FlS a b c) = (a, b, c) + +zeroStats :: FloatStats +zeroStats = FlS 0 0 0 + +sum_stats :: [FloatStats] -> FloatStats +sum_stats xs = foldr add_stats zeroStats xs + +add_stats :: FloatStats -> FloatStats -> FloatStats +add_stats (FlS a1 b1 c1) (FlS a2 b2 c2) + = FlS (a1 + a2) (b1 + b2) (c1 + c2) + +add_to_stats :: FloatStats -> FloatBinds -> FloatStats +add_to_stats (FlS a b c) (FB tops ceils others) + = FlS (a + lengthBag tops) + (b + lengthBag ceils + lengthBag (flattenMajor others)) + (c + 1) + +{- +************************************************************************ +* * +\subsection{Utility bits for floating} +* * +************************************************************************ + +Note [Representation of FloatBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The FloatBinds types is somewhat important. We can get very large numbers +of floating bindings, often all destined for the top level. A typical example +is x = [4,2,5,2,5, .... ] +Then we get lots of small expressions like (fromInteger 4), which all get +lifted to top level. + +The trouble is that + (a) we partition these floating bindings *at every binding site* + (b) GHC.Core.Opt.SetLevels introduces a new bindings site for every float +So we had better not look at each binding at each binding site! + +That is why MajorEnv is represented as a finite map. + +We keep the bindings destined for the *top* level separate, because +we float them out even if they don't escape a *value* lambda; see +partitionByMajorLevel. +-} + +type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted +type MajorEnv = M.IntMap MinorEnv -- Keyed by major level +type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level + +data FloatBinds = FB !(Bag FloatLet) -- Destined for top level + !(Bag FloatBind) -- Destined for join ceiling + !MajorEnv -- Other levels + -- See Note [Representation of FloatBinds] + +instance Outputable FloatBinds where + ppr (FB fbs ceils defs) + = text "FB" <+> (braces $ vcat + [ text "tops =" <+> ppr fbs + , text "ceils =" <+> ppr ceils + , text "non-tops =" <+> ppr defs ]) + +flattenTopFloats :: FloatBinds -> Bag CoreBind +flattenTopFloats (FB tops ceils defs) + = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs ) + ASSERT2( isEmptyBag ceils, ppr ceils ) + tops + +addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] +addTopFloatPairs float_bag prs + = foldr add prs float_bag + where + add (NonRec b r) prs = (b,r):prs + add (Rec prs1) prs2 = prs1 ++ prs2 + +flattenMajor :: MajorEnv -> Bag FloatBind +flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag + +flattenMinor :: MinorEnv -> Bag FloatBind +flattenMinor = M.foldr unionBags emptyBag + +emptyFloats :: FloatBinds +emptyFloats = FB emptyBag emptyBag M.empty + +unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds +unitCaseFloat (Level major minor t) e b con bs + | t == JoinCeilLvl + = FB emptyBag floats M.empty + | otherwise + = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats)) + where + floats = unitBag (FloatCase e b con bs) + +unitLetFloat :: Level -> FloatLet -> FloatBinds +unitLetFloat lvl@(Level major minor t) b + | isTopLvl lvl = FB (unitBag b) emptyBag M.empty + | t == JoinCeilLvl = FB emptyBag floats M.empty + | otherwise = FB emptyBag emptyBag (M.singleton major + (M.singleton minor floats)) + where + floats = unitBag (FloatLet b) + +plusFloats :: FloatBinds -> FloatBinds -> FloatBinds +plusFloats (FB t1 c1 l1) (FB t2 c2 l2) + = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2) + +plusMajor :: MajorEnv -> MajorEnv -> MajorEnv +plusMajor = M.unionWith plusMinor + +plusMinor :: MinorEnv -> MinorEnv -> MinorEnv +plusMinor = M.unionWith unionBags + +install :: Bag FloatBind -> CoreExpr -> CoreExpr +install defn_groups expr + = foldr wrapFloat expr defn_groups + +partitionByLevel + :: Level -- Partitioning level + -> FloatBinds -- Defns to be divided into 2 piles... + -> (FloatBinds, -- Defns with level strictly < partition level, + Bag FloatBind) -- The rest + +{- +-- ---- partitionByMajorLevel ---- +-- Float it if we escape a value lambda, +-- *or* if we get to the top level +-- *or* if it's a case-float and its minor level is < current +-- +-- If we can get to the top level, say "yes" anyway. This means that +-- x = f e +-- transforms to +-- lvl = e +-- x = f lvl +-- which is as it should be + +partitionByMajorLevel (Level major _) (FB tops defns) + = (FB tops outer, heres `unionBags` flattenMajor inner) + where + (outer, mb_heres, inner) = M.splitLookup major defns + heres = case mb_heres of + Nothing -> emptyBag + Just h -> flattenMinor h +-} + +partitionByLevel (Level major minor typ) (FB tops ceils defns) + = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min), + here_min `unionBags` here_ceil + `unionBags` flattenMinor inner_min + `unionBags` flattenMajor inner_maj) + + where + (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns + (outer_min, mb_here_min, inner_min) = case mb_here_maj of + Nothing -> (M.empty, Nothing, M.empty) + Just min_defns -> M.splitLookup minor min_defns + here_min = mb_here_min `orElse` emptyBag + (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag) + | otherwise = (emptyBag, ceils) + +-- Like partitionByLevel, but instead split out the bindings that are marked +-- to float to the nearest join ceiling (see Note [Join points]) +partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind) +partitionAtJoinCeiling (FB tops ceils defs) + = (FB tops emptyBag defs, ceils) + +-- Perform some action at a join ceiling, i.e., don't let join points float out +-- (see Note [Join points]) +atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr) + -> (FloatStats, FloatBinds, CoreExpr) +atJoinCeiling (fs, floats, expr') + = (fs, floats', install ceils expr') + where + (floats', ceils) = partitionAtJoinCeiling floats + +wrapTick :: Tickish Id -> FloatBinds -> FloatBinds +wrapTick t (FB tops ceils defns) + = FB (mapBag wrap_bind tops) (wrap_defns ceils) + (M.map (M.map wrap_defns) defns) + where + wrap_defns = mapBag wrap_one + + wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs) + wrap_bind (Rec pairs) = Rec (mapSnd maybe_tick pairs) + + wrap_one (FloatLet bind) = FloatLet (wrap_bind bind) + wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs + + maybe_tick e | exprIsHNF e = tickHNFArgs t e + | otherwise = mkTick t e + -- we don't need to wrap a tick around an HNF when we float it + -- outside a tick: that is an invariant of the tick semantics + -- Conversely, inlining of HNFs inside an SCC is allowed, and + -- indeed the HNF we're floating here might well be inlined back + -- again, and we don't want to end up with duplicate ticks. diff --git a/compiler/GHC/Core/Opt/LiberateCase.hs b/compiler/GHC/Core/Opt/LiberateCase.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/LiberateCase.hs @@ -0,0 +1,442 @@ +{- +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} +-} + +{-# LANGUAGE CPP #-} +module GHC.Core.Opt.LiberateCase ( liberateCase ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Core +import GHC.Core.Unfold ( couldBeSmallEnoughToInline ) +import GHC.Builtin.Types ( unitDataConId ) +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Utils.Misc ( notNull ) + +{- +The liberate-case transformation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module walks over @Core@, and looks for @case@ on free variables. +The criterion is: + if there is case on a free on the route to the recursive call, + then the recursive call is replaced with an unfolding. + +Example + + f = \ t -> case v of + V a b -> a : f t + +=> the inner f is replaced. + + f = \ t -> case v of + V a b -> a : (letrec + f = \ t -> case v of + V a b -> a : f t + in f) t +(note the NEED for shadowing) + +=> Simplify + + f = \ t -> case v of + V a b -> a : (letrec + f = \ t -> a : f t + in f t) + +Better code, because 'a' is free inside the inner letrec, rather +than needing projection from v. + +Note that this deals with *free variables*. SpecConstr deals with +*arguments* that are of known form. E.g. + + last [] = error + last (x:[]) = x + last (x:xs) = last xs + + +Note [Scrutinee with cast] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + f = \ t -> case (v `cast` co) of + V a b -> a : f t + +Exactly the same optimisation (unrolling one call to f) will work here, +despite the cast. See mk_alt_env in the Case branch of libCase. + + +To think about (Apr 94) +~~~~~~~~~~~~~~ +Main worry: duplicating code excessively. At the moment we duplicate +the entire binding group once at each recursive call. But there may +be a group of recursive calls which share a common set of evaluated +free variables, in which case the duplication is a plain waste. + +Another thing we could consider adding is some unfold-threshold thing, +so that we'll only duplicate if the size of the group rhss isn't too +big. + +Data types +~~~~~~~~~~ +The ``level'' of a binder tells how many +recursive defns lexically enclose the binding +A recursive defn "encloses" its RHS, not its +scope. For example: +\begin{verbatim} + letrec f = let g = ... in ... + in + let h = ... + in ... +\end{verbatim} +Here, the level of @f@ is zero, the level of @g@ is one, +and the level of @h@ is zero (NB not one). + + +************************************************************************ +* * + Top-level code +* * +************************************************************************ +-} + +liberateCase :: DynFlags -> CoreProgram -> CoreProgram +liberateCase dflags binds = do_prog (initEnv dflags) binds + where + do_prog _ [] = [] + do_prog env (bind:binds) = bind' : do_prog env' binds + where + (env', bind') = libCaseBind env bind + +{- +************************************************************************ +* * + Main payload +* * +************************************************************************ + +Bindings +~~~~~~~~ +-} + +libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind) + +libCaseBind env (NonRec binder rhs) + = (addBinders env [binder], NonRec binder (libCase env rhs)) + +libCaseBind env (Rec pairs) + = (env_body, Rec pairs') + where + binders = map fst pairs + + env_body = addBinders env binders + + pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs] + + -- We extend the rec-env by binding each Id to its rhs, first + -- processing the rhs with an *un-extended* environment, so + -- that the same process doesn't occur for ever! + env_rhs | is_dupable_bind = addRecBinds env dup_pairs + | otherwise = env + + dup_pairs = [ (localiseId binder, libCase env_body rhs) + | (binder, rhs) <- pairs ] + -- localiseID : see Note [Need to localiseId in libCaseBind] + + is_dupable_bind = small_enough && all ok_pair pairs + + -- Size: we are going to duplicate dup_pairs; to find their + -- size, build a fake binding (let { dup_pairs } in (), + -- and find the size of that + -- See Note [Small enough] + small_enough = case bombOutSize env of + Nothing -> True -- Infinity + Just size -> couldBeSmallEnoughToInline (lc_dflags env) size $ + Let (Rec dup_pairs) (Var unitDataConId) + + ok_pair (id,_) + = idArity id > 0 -- Note [Only functions!] + && not (isBottomingId id) -- Note [Not bottoming ids] + +{- Note [Not bottoming Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do not specialise error-functions (this is unusual, but I once saw it, +(actually in Data.Typable.Internal) + +Note [Only functions!] +~~~~~~~~~~~~~~~~~~~~~~ +Consider the following code + + f = g (case v of V a b -> a : t f) + +where g is expensive. If we aren't careful, liberate case will turn this into + + f = g (case v of + V a b -> a : t (letrec f = g (case v of V a b -> a : f t) + in f) + ) + +Yikes! We evaluate g twice. This leads to a O(2^n) explosion +if g calls back to the same code recursively. + +Solution: make sure that we only do the liberate-case thing on *functions* + +Note [Small enough] +~~~~~~~~~~~~~~~~~~~ +Consider + \fv. letrec + f = \x. BIG...(case fv of { (a,b) -> ...g.. })... + g = \y. SMALL...f... + +Then we *can* in principle do liberate-case on 'g' (small RHS) but not +for 'f' (too big). But doing so is not profitable, because duplicating +'g' at its call site in 'f' doesn't get rid of any cases. So we just +ask for the whole group to be small enough. + +Note [Need to localiseId in libCaseBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The call to localiseId is needed for two subtle reasons +(a) Reset the export flags on the binders so + that we don't get name clashes on exported things if the + local binding floats out to top level. This is most unlikely + to happen, since the whole point concerns free variables. + But resetting the export flag is right regardless. + +(b) Make the name an Internal one. External Names should never be + nested; if it were floated to the top level, we'd get a name + clash at code generation time. + +Expressions +~~~~~~~~~~~ +-} + +libCase :: LibCaseEnv + -> CoreExpr + -> CoreExpr + +libCase env (Var v) = libCaseApp env v [] +libCase _ (Lit lit) = Lit lit +libCase _ (Type ty) = Type ty +libCase _ (Coercion co) = Coercion co +libCase env e@(App {}) | let (fun, args) = collectArgs e + , Var v <- fun + = libCaseApp env v args +libCase env (App fun arg) = App (libCase env fun) (libCase env arg) +libCase env (Tick tickish body) = Tick tickish (libCase env body) +libCase env (Cast e co) = Cast (libCase env e) co + +libCase env (Lam binder body) + = Lam binder (libCase (addBinders env [binder]) body) + +libCase env (Let bind body) + = Let bind' (libCase env_body body) + where + (env_body, bind') = libCaseBind env bind + +libCase env (Case scrut bndr ty alts) + = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts) + where + env_alts = addBinders (mk_alt_env scrut) [bndr] + mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var + mk_alt_env (Cast scrut _) = mk_alt_env scrut -- Note [Scrutinee with cast] + mk_alt_env _ = env + +libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr) + -> (AltCon, [CoreBndr], CoreExpr) +libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs) + +{- +Ids +~~~ + +To unfold, we can't just wrap the id itself in its binding if it's a join point: + + jump j a b c => (joinrec j x y z = ... in jump j) a b c -- wrong!!! + +Every jump must provide all arguments, so we have to be careful to wrap the +whole jump instead: + + jump j a b c => joinrec j x y z = ... in jump j a b c -- right + +-} + +libCaseApp :: LibCaseEnv -> Id -> [CoreExpr] -> CoreExpr +libCaseApp env v args + | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing + , notNull free_scruts -- with free vars scrutinised in RHS + = Let the_bind expr' + + | otherwise + = expr' + + where + rec_id_level = lookupLevel env v + free_scruts = freeScruts env rec_id_level + expr' = mkApps (Var v) (map (libCase env) args) + +freeScruts :: LibCaseEnv + -> LibCaseLevel -- Level of the recursive Id + -> [Id] -- Ids that are scrutinised between the binding + -- of the recursive Id and here +freeScruts env rec_bind_lvl + = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env + , scrut_bind_lvl <= rec_bind_lvl + , scrut_at_lvl > rec_bind_lvl] + -- Note [When to specialise] + -- Note [Avoiding fruitless liberate-case] + +{- +Note [When to specialise] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = \x. letrec g = \y. case x of + True -> ... (f a) ... + False -> ... (g b) ... + +We get the following levels + f 0 + x 1 + g 1 + y 2 + +Then 'x' is being scrutinised at a deeper level than its binding, so +it's added to lc_sruts: [(x,1)] + +We do *not* want to specialise the call to 'f', because 'x' is not free +in 'f'. So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0). + +We *do* want to specialise the call to 'g', because 'x' is free in g. +Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1). + +Note [Avoiding fruitless liberate-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider also: + f = \x. case top_lvl_thing of + I# _ -> let g = \y. ... g ... + in ... + +Here, top_lvl_thing is scrutinised at a level (1) deeper than its +binding site (0). Nevertheless, we do NOT want to specialise the call +to 'g' because all the structure in its free variables is already +visible at the definition site for g. Hence, when considering specialising +an occurrence of 'g', we want to check that there's a scruted-var v st + + a) v's binding site is *outside* g + b) v's scrutinisation site is *inside* g + + +************************************************************************ +* * + Utility functions +* * +************************************************************************ +-} + +addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv +addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders + = env { lc_lvl_env = lvl_env' } + where + lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl) + +addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv +addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env, + lc_rec_env = rec_env}) pairs + = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' } + where + lvl' = lvl + 1 + lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs] + rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs] + +addScrutedVar :: LibCaseEnv + -> Id -- This Id is being scrutinised by a case expression + -> LibCaseEnv + +addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env, + lc_scruts = scruts }) scrut_var + | bind_lvl < lvl + = env { lc_scruts = scruts' } + -- Add to scruts iff the scrut_var is being scrutinised at + -- a deeper level than its defn + + | otherwise = env + where + scruts' = (scrut_var, bind_lvl, lvl) : scruts + bind_lvl = case lookupVarEnv lvl_env scrut_var of + Just lvl -> lvl + Nothing -> topLevel + +lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind +lookupRecId env id = lookupVarEnv (lc_rec_env env) id + +lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel +lookupLevel env id + = case lookupVarEnv (lc_lvl_env env) id of + Just lvl -> lvl + Nothing -> topLevel + +{- +************************************************************************ +* * + The environment +* * +************************************************************************ +-} + +type LibCaseLevel = Int + +topLevel :: LibCaseLevel +topLevel = 0 + +data LibCaseEnv + = LibCaseEnv { + lc_dflags :: DynFlags, + + lc_lvl :: LibCaseLevel, -- Current level + -- The level is incremented when (and only when) going + -- inside the RHS of a (sufficiently small) recursive + -- function. + + lc_lvl_env :: IdEnv LibCaseLevel, + -- Binds all non-top-level in-scope Ids (top-level and + -- imported things have a level of zero) + + lc_rec_env :: IdEnv CoreBind, + -- Binds *only* recursively defined ids, to their own + -- binding group, and *only* in their own RHSs + + lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)] + -- Each of these Ids was scrutinised by an enclosing + -- case expression, at a level deeper than its binding + -- level. + -- + -- The first LibCaseLevel is the *binding level* of + -- the scrutinised Id, + -- The second is the level *at which it was scrutinised*. + -- (see Note [Avoiding fruitless liberate-case]) + -- The former is a bit redundant, since you could always + -- look it up in lc_lvl_env, but it's just cached here + -- + -- The order is insignificant; it's a bag really + -- + -- There's one element per scrutinisation; + -- in principle the same Id may appear multiple times, + -- although that'd be unusual: + -- case x of { (a,b) -> ....(case x of ...) .. } + } + +initEnv :: DynFlags -> LibCaseEnv +initEnv dflags + = LibCaseEnv { lc_dflags = dflags, + lc_lvl = 0, + lc_lvl_env = emptyVarEnv, + lc_rec_env = emptyVarEnv, + lc_scruts = [] } + +-- Bomb-out size for deciding if +-- potential liberatees are too big. +-- (passed in from cmd-line args) +bombOutSize :: LibCaseEnv -> Maybe Int +bombOutSize = liberateCaseThreshold . lc_dflags diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -0,0 +1,1771 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{GHC.Core.Opt.SetLevels} + + *************************** + Overview + *************************** + +1. We attach binding levels to Core bindings, in preparation for floating + outwards (@FloatOut@). + +2. We also let-ify many expressions (notably case scrutinees), so they + will have a fighting chance of being floated sensible. + +3. Note [Need for cloning during float-out] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We clone the binders of any floatable let-binding, so that when it is + floated out it will be unique. Example + (let x=2 in x) + (let x=3 in x) + we must clone before floating so we get + let x1=2 in + let x2=3 in + x1+x2 + + NOTE: this can't be done using the uniqAway idea, because the variable + must be unique in the whole program, not just its current scope, + because two variables in different scopes may float out to the + same top level place + + NOTE: Very tiresomely, we must apply this substitution to + the rules stored inside a variable too. + + We do *not* clone top-level bindings, because some of them must not change, + but we *do* clone bindings that are heading for the top level + +4. Note [Binder-swap during float-out] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + In the expression + case x of wild { p -> ...wild... } + we substitute x for wild in the RHS of the case alternatives: + case x of wild { p -> ...x... } + This means that a sub-expression involving x is not "trapped" inside the RHS. + And it's not inconvenient because we already have a substitution. + + Note that this is EXACTLY BACKWARDS from the what the simplifier does. + The simplifier tries to get rid of occurrences of x, in favour of wild, + in the hope that there will only be one remaining occurrence of x, namely + the scrutinee of the case, and we can inline it. +-} + +{-# LANGUAGE CPP, MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module GHC.Core.Opt.SetLevels ( + setLevels, + + Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl, + LevelledBind, LevelledExpr, LevelledBndr, + FloatSpec(..), floatSpecLevel, + + incMinorLvl, ltMajLvl, ltLvl, isTopLvl + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) +import GHC.Core.Utils ( exprType, exprIsHNF + , exprOkForSpeculation + , exprIsTopLevelBindable + , isExprLevPoly + , collectMakeStaticArgs + ) +import GHC.Core.Arity ( exprBotStrictness_maybe ) +import GHC.Core.FVs -- all of it +import GHC.Core.Subst +import GHC.Core.Make ( sortQuantVars ) + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Unique.Set ( nonDetFoldUniqSet ) +import GHC.Types.Unique.DSet ( getUniqDSet ) +import GHC.Types.Var.Env +import GHC.Types.Literal ( litIsTrivial ) +import GHC.Types.Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity ) +import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Types.Name ( getOccName, mkSystemVarName ) +import GHC.Types.Name.Occurrence ( occNameString ) +import GHC.Core.Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType + , mightBeUnliftedType, closeOverKindsDSet ) +import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) +import GHC.Core.DataCon ( dataConOrigResTy ) +import GHC.Builtin.Types +import GHC.Types.Unique.Supply +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Unique.DFM +import GHC.Utils.FV +import Data.Maybe +import GHC.Utils.Monad ( mapAccumLM ) + +{- +************************************************************************ +* * +\subsection{Level numbers} +* * +************************************************************************ +-} + +type LevelledExpr = TaggedExpr FloatSpec +type LevelledBind = TaggedBind FloatSpec +type LevelledBndr = TaggedBndr FloatSpec + +data Level = Level Int -- Level number of enclosing lambdas + Int -- Number of big-lambda and/or case expressions and/or + -- context boundaries between + -- here and the nearest enclosing lambda + LevelType -- Binder or join ceiling? +data LevelType = BndrLvl | JoinCeilLvl deriving (Eq) + +data FloatSpec + = FloatMe Level -- Float to just inside the binding + -- tagged with this level + | StayPut Level -- Stay where it is; binding is + -- tagged with this level + +floatSpecLevel :: FloatSpec -> Level +floatSpecLevel (FloatMe l) = l +floatSpecLevel (StayPut l) = l + +{- +The {\em level number} on a (type-)lambda-bound variable is the +nesting depth of the (type-)lambda which binds it. The outermost lambda +has level 1, so (Level 0 0) means that the variable is bound outside any lambda. + +On an expression, it's the maximum level number of its free +(type-)variables. On a let(rec)-bound variable, it's the level of its +RHS. On a case-bound variable, it's the number of enclosing lambdas. + +Top-level variables: level~0. Those bound on the RHS of a top-level +definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown +as ``subscripts'')... +\begin{verbatim} +a_0 = let b_? = ... in + x_1 = ... b ... in ... +\end{verbatim} + +The main function @lvlExpr@ carries a ``context level'' (@le_ctxt_lvl@). +That's meant to be the level number of the enclosing binder in the +final (floated) program. If the level number of a sub-expression is +less than that of the context, then it might be worth let-binding the +sub-expression so that it will indeed float. + +If you can float to level @Level 0 0@ worth doing so because then your +allocation becomes static instead of dynamic. We always start with +context @Level 0 0@. + + +Note [FloatOut inside INLINE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose: +to say "don't float anything out of here". That's exactly what we +want for the body of an INLINE, where we don't want to float anything +out at all. See notes with lvlMFE below. + +But, check this out: + +-- At one time I tried the effect of not floating anything out of an InlineMe, +-- but it sometimes works badly. For example, consider PrelArr.done. It +-- has the form __inline (\d. e) +-- where e doesn't mention d. If we float this to +-- __inline (let x = e in \d. x) +-- things are bad. The inliner doesn't even inline it because it doesn't look +-- like a head-normal form. So it seems a lesser evil to let things float. +-- In GHC.Core.Opt.SetLevels we do set the context to (Level 0 0) when we get to an InlineMe +-- which discourages floating out. + +So the conclusion is: don't do any floating at all inside an InlineMe. +(In the above example, don't float the {x=e} out of the \d.) + +One particular case is that of workers: we don't want to float the +call to the worker outside the wrapper, otherwise the worker might get +inlined into the floated expression, and an importing module won't see +the worker at all. + +Note [Join ceiling] +~~~~~~~~~~~~~~~~~~~ +Join points can't float very far; too far, and they can't remain join points +So, suppose we have: + + f x = (joinrec j y = ... x ... in jump j x) + 1 + +One may be tempted to float j out to the top of f's RHS, but then the jump +would not be a tail call. Thus we keep track of a level called the *join +ceiling* past which join points are not allowed to float. + +The troublesome thing is that, unlike most levels to which something might +float, there is not necessarily an identifier to which the join ceiling is +attached. Fortunately, if something is to be floated to a join ceiling, it must +be dropped at the *nearest* join ceiling. Thus each level is marked as to +whether it is a join ceiling, so that FloatOut can tell which binders are being +floated to the nearest join ceiling and which to a particular binder (or set of +binders). +-} + +instance Outputable FloatSpec where + ppr (FloatMe l) = char 'F' <> ppr l + ppr (StayPut l) = ppr l + +tOP_LEVEL :: Level +tOP_LEVEL = Level 0 0 BndrLvl + +incMajorLvl :: Level -> Level +incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl + +incMinorLvl :: Level -> Level +incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl + +asJoinCeilLvl :: Level -> Level +asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl + +maxLvl :: Level -> Level -> Level +maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _) + | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1 + | otherwise = l2 + +ltLvl :: Level -> Level -> Bool +ltLvl (Level maj1 min1 _) (Level maj2 min2 _) + = (maj1 < maj2) || (maj1 == maj2 && min1 < min2) + +ltMajLvl :: Level -> Level -> Bool + -- Tells if one level belongs to a difft *lambda* level to another +ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2 + +isTopLvl :: Level -> Bool +isTopLvl (Level 0 0 _) = True +isTopLvl _ = False + +isJoinCeilLvl :: Level -> Bool +isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl + +instance Outputable Level where + ppr (Level maj min typ) + = hcat [ char '<', int maj, char ',', int min, char '>' + , ppWhen (typ == JoinCeilLvl) (char 'C') ] + +instance Eq Level where + (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2 + +{- +************************************************************************ +* * +\subsection{Main level-setting code} +* * +************************************************************************ +-} + +setLevels :: FloatOutSwitches + -> CoreProgram + -> UniqSupply + -> [LevelledBind] + +setLevels float_lams binds us + = initLvl us (do_them init_env binds) + where + init_env = initialEnv float_lams + + do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind] + do_them _ [] = return [] + do_them env (b:bs) + = do { (lvld_bind, env') <- lvlTopBind env b + ; lvld_binds <- do_them env' bs + ; return (lvld_bind : lvld_binds) } + +lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv) +lvlTopBind env (NonRec bndr rhs) + = do { rhs' <- lvl_top env NonRecursive bndr rhs + ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr] + ; return (NonRec bndr' rhs', env') } + +lvlTopBind env (Rec pairs) + = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL + (map fst pairs) + ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs + ; return (Rec (bndrs' `zip` rhss'), env') } + +lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr +lvl_top env is_rec bndr rhs + = lvlRhs env is_rec + (isBottomingId bndr) + Nothing -- Not a join point + (freeVars rhs) + +{- +************************************************************************ +* * +\subsection{Setting expression levels} +* * +************************************************************************ + +Note [Floating over-saturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see (f x y), and (f x) is a redex (ie f's arity is 1), +we call (f x) an "over-saturated application" + +Should we float out an over-sat app, if can escape a value lambda? +It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2). +But we don't want to do it for class selectors, because the work saved +is minimal, and the extra local thunks allocated cost money. + +Arguably we could float even class-op applications if they were going to +top level -- but then they must be applied to a constant dictionary and +will almost certainly be optimised away anyway. +-} + +lvlExpr :: LevelEnv -- Context + -> CoreExprWithFVs -- Input expression + -> LvlM LevelledExpr -- Result expression + +{- +The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing +binder. Here's an example + + v = \x -> ...\y -> let r = case (..x..) of + ..x.. + in .. + +When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's +the level of @r@, even though it's inside a level-2 @\y@. It's +important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we +don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE +--- because it isn't a *maximal* free expression. + +If there were another lambda in @r@'s rhs, it would get level-2 as well. +-} + +lvlExpr env (_, AnnType ty) = return (Type (GHC.Core.Subst.substTy (le_subst env) ty)) +lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co)) +lvlExpr env (_, AnnVar v) = return (lookupVar env v) +lvlExpr _ (_, AnnLit lit) = return (Lit lit) + +lvlExpr env (_, AnnCast expr (_, co)) = do + expr' <- lvlNonTailExpr env expr + return (Cast expr' (substCo (le_subst env) co)) + +lvlExpr env (_, AnnTick tickish expr) = do + expr' <- lvlNonTailExpr env expr + let tickish' = substTickish (le_subst env) tickish + return (Tick tickish' expr') + +lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr) + +-- We don't split adjacent lambdas. That is, given +-- \x y -> (x+1,y) +-- we don't float to give +-- \x -> let v = x+1 in \y -> (v,y) +-- Why not? Because partial applications are fairly rare, and splitting +-- lambdas makes them more expensive. + +lvlExpr env expr@(_, AnnLam {}) + = do { new_body <- lvlNonTailMFE new_env True body + ; return (mkLams new_bndrs new_body) } + where + (bndrs, body) = collectAnnBndrs expr + (env1, bndrs1) = substBndrsSL NonRecursive env bndrs + (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1 + -- At one time we called a special version of collectBinders, + -- which ignored coercions, because we don't want to split + -- a lambda like this (\x -> coerce t (\s -> ...)) + -- This used to happen quite a bit in state-transformer programs, + -- but not nearly so much now non-recursive newtypes are transparent. + -- [See GHC.Core.Opt.SetLevels rev 1.50 for a version with this approach.] + +lvlExpr env (_, AnnLet bind body) + = do { (bind', new_env) <- lvlBind env bind + ; body' <- lvlExpr new_env body + -- No point in going via lvlMFE here. If the binding is alive + -- (mentioned in body), and the whole let-expression doesn't + -- float, then neither will the body + ; return (Let bind' body') } + +lvlExpr env (_, AnnCase scrut case_bndr ty alts) + = do { scrut' <- lvlNonTailMFE env True scrut + ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts } + +lvlNonTailExpr :: LevelEnv -- Context + -> CoreExprWithFVs -- Input expression + -> LvlM LevelledExpr -- Result expression +lvlNonTailExpr env expr + = lvlExpr (placeJoinCeiling env) expr + +------------------------------------------- +lvlApp :: LevelEnv + -> CoreExprWithFVs + -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application + -> LvlM LevelledExpr -- Result expression +lvlApp env orig_expr ((_,AnnVar fn), args) + | floatOverSat env -- See Note [Floating over-saturated applications] + , arity > 0 + , arity < n_val_args + , Nothing <- isClassOpId_maybe fn + = do { rargs' <- mapM (lvlNonTailMFE env False) rargs + ; lapp' <- lvlNonTailMFE env False lapp + ; return (foldl' App lapp' rargs') } + + | otherwise + = do { (_, args') <- mapAccumLM lvl_arg stricts args + -- Take account of argument strictness; see + -- Note [Floating to the top] + ; return (foldl' App (lookupVar env fn) args') } + where + n_val_args = count (isValArg . deAnnotate) args + arity = idArity fn + + stricts :: [Demand] -- True for strict /value/ arguments + stricts = case splitStrictSig (idStrictness fn) of + (arg_ds, _) | arg_ds `lengthExceeds` n_val_args + -> [] + | otherwise + -> arg_ds + + -- Separate out the PAP that we are floating from the extra + -- arguments, by traversing the spine until we have collected + -- (n_val_args - arity) value arguments. + (lapp, rargs) = left (n_val_args - arity) orig_expr [] + + left 0 e rargs = (e, rargs) + left n (_, AnnApp f a) rargs + | isValArg (deAnnotate a) = left (n-1) f (a:rargs) + | otherwise = left n f (a:rargs) + left _ _ _ = panic "GHC.Core.Opt.SetLevels.lvlExpr.left" + + is_val_arg :: CoreExprWithFVs -> Bool + is_val_arg (_, AnnType {}) = False + is_val_arg _ = True + + lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr) + lvl_arg strs arg | (str1 : strs') <- strs + , is_val_arg arg + = do { arg' <- lvlMFE env (isStrictDmd str1) arg + ; return (strs', arg') } + | otherwise + = do { arg' <- lvlMFE env False arg + ; return (strs, arg') } + +lvlApp env _ (fun, args) + = -- No PAPs that we can float: just carry on with the + -- arguments and the function. + do { args' <- mapM (lvlNonTailMFE env False) args + ; fun' <- lvlNonTailExpr env fun + ; return (foldl' App fun' args') } + +------------------------------------------- +lvlCase :: LevelEnv -- Level of in-scope names/tyvars + -> DVarSet -- Free vars of input scrutinee + -> LevelledExpr -- Processed scrutinee + -> Id -> Type -- Case binder and result type + -> [CoreAltWithFVs] -- Input alternatives + -> LvlM LevelledExpr -- Result expression +lvlCase env scrut_fvs scrut' case_bndr ty alts + -- See Note [Floating single-alternative cases] + | [(con@(DataAlt {}), bs, body)] <- alts + , exprIsHNF (deTagExpr scrut') -- See Note [Check the output scrutinee for exprIsHNF] + , not (isTopLvl dest_lvl) -- Can't have top-level cases + , not (floatTopLvlOnly env) -- Can float anywhere + = -- Always float the case if possible + -- Unlike lets we don't insist that it escapes a value lambda + do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs) + ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut' + ; body' <- lvlMFE rhs_env True body + ; let alt' = (con, map (stayPut dest_lvl) bs', body') + ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) } + + | otherwise -- Stays put + = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr] + alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut' + ; alts' <- mapM (lvl_alt alts_env) alts + ; return (Case scrut' case_bndr' ty' alts') } + where + ty' = substTy (le_subst env) ty + + incd_lvl = incMinorLvl (le_ctxt_lvl env) + dest_lvl = maxFvLevel (const True) env scrut_fvs + -- Don't abstract over type variables, hence const True + + lvl_alt alts_env (con, bs, rhs) + = do { rhs' <- lvlMFE new_env True rhs + ; return (con, bs', rhs') } + where + (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs + +{- Note [Floating single-alternative cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + data T a = MkT !a + f :: T Int -> blah + f x vs = case x of { MkT y -> + let f vs = ...(case y of I# w -> e)...f.. + in f vs + +Here we can float the (case y ...) out, because y is sure +to be evaluated, to give + f x vs = case x of { MkT y -> + case y of I# w -> + let f vs = ...(e)...f.. + in f vs + +That saves unboxing it every time round the loop. It's important in +some DPH stuff where we really want to avoid that repeated unboxing in +the inner loop. + +Things to note: + + * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation. + + - exrpIsHNF catches the key case of an evaluated variable + + - exprOkForSpeculation is /false/ of an evaluated variable; + See Note [exprOkForSpeculation and evaluated variables] in GHC.Core.Utils + So we'd actually miss the key case! + + - Nothing is gained from the extra generality of exprOkForSpeculation + since we only consider floating a case whose single alternative + is a DataAlt K a b -> rhs + + * We can't float a case to top level + + * It's worth doing this float even if we don't float + the case outside a value lambda. Example + case x of { + MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...) + If we floated the cases out we could eliminate one of them. + + * We only do this with a single-alternative case + + +Note [Setting levels when floating single-alternative cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Handling level-setting when floating a single-alternative case binding +is a bit subtle, as evidenced by #16978. In particular, we must keep +in mind that we are merely moving the case and its binders, not the +body. For example, suppose 'a' is known to be evaluated and we have + + \z -> case a of + (x,_) -> + +After floating we may have: + + case a of + (x,_) -> \z -> + {- some expression involving x and z -} + +When analysing we want to use the /ambient/ level, +and /not/ the destination level of the 'case a of (x,-) ->' binding. + +#16978 was caused by us setting the context level to the destination +level of `x` when analysing . This led us to conclude that we +needed to quantify over some of its free variables (e.g. z), resulting +in shadowing and very confusing Core Lint failures. + + +Note [Check the output scrutinee for exprIsHNF] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + case x of y { + A -> ....(case y of alts).... + } + +Because of the binder-swap, the inner case will get substituted to +(case x of ..). So when testing whether the scrutinee is in HNF we +must be careful to test the *result* scrutinee ('x' in this case), not +the *input* one 'y'. The latter *is* in HNF here (because y is +evaluated), but the former is not -- and indeed we can't float the +inner case out, at least not unless x is also evaluated at its binding +site. See #5453. + +That's why we apply exprIsHNF to scrut' and not to scrut. + +See Note [Floating single-alternative cases] for why +we use exprIsHNF in the first place. +-} + +lvlNonTailMFE :: LevelEnv -- Level of in-scope names/tyvars + -> Bool -- True <=> strict context [body of case + -- or let] + -> CoreExprWithFVs -- input expression + -> LvlM LevelledExpr -- Result expression +lvlNonTailMFE env strict_ctxt ann_expr + = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr + +lvlMFE :: LevelEnv -- Level of in-scope names/tyvars + -> Bool -- True <=> strict context [body of case or let] + -> CoreExprWithFVs -- input expression + -> LvlM LevelledExpr -- Result expression +-- lvlMFE is just like lvlExpr, except that it might let-bind +-- the expression, so that it can itself be floated. + +lvlMFE env _ (_, AnnType ty) + = return (Type (GHC.Core.Subst.substTy (le_subst env) ty)) + +-- No point in floating out an expression wrapped in a coercion or note +-- If we do we'll transform lvl = e |> co +-- to lvl' = e; lvl = lvl' |> co +-- and then inline lvl. Better just to float out the payload. +lvlMFE env strict_ctxt (_, AnnTick t e) + = do { e' <- lvlMFE env strict_ctxt e + ; let t' = substTickish (le_subst env) t + ; return (Tick t' e') } + +lvlMFE env strict_ctxt (_, AnnCast e (_, co)) + = do { e' <- lvlMFE env strict_ctxt e + ; return (Cast e' (substCo (le_subst env) co)) } + +lvlMFE env strict_ctxt e@(_, AnnCase {}) + | strict_ctxt -- Don't share cases in a strict context + = lvlExpr env e -- See Note [Case MFEs] + +lvlMFE env strict_ctxt ann_expr + | floatTopLvlOnly env && not (isTopLvl dest_lvl) + -- Only floating to the top level is allowed. + || anyDVarSet isJoinId fvs -- If there is a free join, don't float + -- See Note [Free join points] + || isExprLevPoly expr + -- We can't let-bind levity polymorphic expressions + -- See Note [Levity polymorphism invariants] in GHC.Core + || notWorthFloating expr abs_vars + || not float_me + = -- Don't float it out + lvlExpr env ann_expr + + | float_is_new_lam || exprIsTopLevelBindable expr expr_ty + -- No wrapping needed if the type is lifted, or is a literal string + -- or if we are wrapping it in one or more value lambdas + = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive + (isJust mb_bot_str) + join_arity_maybe + ann_expr + -- Treat the expr just like a right-hand side + ; var <- newLvlVar expr1 join_arity_maybe is_mk_static + ; let var2 = annotateBotStr var float_n_lams mb_bot_str + ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1) + (mkVarApps (Var var2) abs_vars)) } + + -- OK, so the float has an unlifted type (not top-level bindable) + -- and no new value lambdas (float_is_new_lam is False) + -- Try for the boxing strategy + -- See Note [Floating MFEs of unlifted type] + | escapes_value_lam + , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions + -- See Note [Test cheapness with exprOkForSpeculation] + , Just (tc, _) <- splitTyConApp_maybe expr_ty + , Just dc <- boxingDataCon_maybe tc + , let dc_res_ty = dataConOrigResTy dc -- No free type variables + [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty] + = do { expr1 <- lvlExpr rhs_env ann_expr + ; let l1r = incMinorLvlFrom rhs_env + float_rhs = mkLams abs_vars_w_lvls $ + Case expr1 (stayPut l1r ubx_bndr) dc_res_ty + [(DEFAULT, [], mkConApp dc [Var ubx_bndr])] + + ; var <- newLvlVar float_rhs Nothing is_mk_static + ; let l1u = incMinorLvlFrom env + use_expr = Case (mkVarApps (Var var) abs_vars) + (stayPut l1u bx_bndr) expr_ty + [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)] + ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs) + use_expr) } + + | otherwise -- e.g. do not float unboxed tuples + = lvlExpr env ann_expr + + where + expr = deAnnotate ann_expr + expr_ty = exprType expr + fvs = freeVarsOf ann_expr + fvs_ty = tyCoVarsOfType expr_ty + is_bot = isBottomThunk mb_bot_str + is_function = isFunction ann_expr + mb_bot_str = exprBotStrictness_maybe expr + -- See Note [Bottoming floats] + -- esp Bottoming floats (2) + expr_ok_for_spec = exprOkForSpeculation expr + dest_lvl = destLevel env fvs fvs_ty is_function is_bot False + abs_vars = abstractVars dest_lvl env fvs + + -- float_is_new_lam: the floated thing will be a new value lambda + -- replacing, say (g (x+4)) by (lvl x). No work is saved, nor is + -- allocation saved. The benefit is to get it to the top level + -- and hence out of the body of this function altogether, making + -- it smaller and more inlinable + float_is_new_lam = float_n_lams > 0 + float_n_lams = count isId abs_vars + + (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars + + join_arity_maybe = Nothing + + is_mk_static = isJust (collectMakeStaticArgs expr) + -- Yuk: See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable + + -- A decision to float entails let-binding this thing, and we only do + -- that if we'll escape a value lambda, or will go to the top level. + float_me = saves_work || saves_alloc || is_mk_static + + -- We can save work if we can move a redex outside a value lambda + -- But if float_is_new_lam is True, then the redex is wrapped in a + -- a new lambda, so no work is saved + saves_work = escapes_value_lam && not float_is_new_lam + + escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env) + -- See Note [Escaping a value lambda] + + -- See Note [Floating to the top] + saves_alloc = isTopLvl dest_lvl + && floatConsts env + && (not strict_ctxt || is_bot || exprIsHNF expr) + +isBottomThunk :: Maybe (Arity, s) -> Bool +-- See Note [Bottoming floats] (2) +isBottomThunk (Just (0, _)) = True -- Zero arity +isBottomThunk _ = False + +{- Note [Floating to the top] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are keen to float something to the top level, even if it does not +escape a value lambda (and hence save work), for two reasons: + + * Doing so makes the function smaller, by floating out + bottoming expressions, or integer or string literals. That in + turn makes it easier to inline, with less duplication. + + * (Minor) Doing so may turn a dynamic allocation (done by machine + instructions) into a static one. Minor because we are assuming + we are not escaping a value lambda. + +But do not so if: + - the context is a strict, and + - the expression is not a HNF, and + - the expression is not bottoming + +Exammples: + +* Bottoming + f x = case x of + 0 -> error + _ -> x+1 + Here we want to float (error ) to top level, abstracting + over 'x', so as to make f's RHS smaller. + +* HNF + f = case y of + True -> p:q + False -> blah + We may as well float the (p:q) so it becomes a static data structure. + +* Case scrutinee + f = case g True of .... + Don't float (g True) to top level; then we have the admin of a + top-level thunk to worry about, with zero gain. + +* Case alternative + h = case y of + True -> g True + False -> False + Don't float (g True) to the top level + +* Arguments + t = f (g True) + If f is lazy, we /do/ float (g True) because then we can allocate + the thunk statically rather than dynamically. But if f is strict + we don't (see the use of idStrictness in lvlApp). It's not clear + if this test is worth the bother: it's only about CAFs! + +It's controlled by a flag (floatConsts), because doing this too +early loses opportunities for RULES which (needless to say) are +important in some nofib programs (gcd is an example). [SPJ note: +I think this is obsolete; the flag seems always on.] + +Note [Floating join point bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Mostly we only float a join point if it can /stay/ a join point. But +there is one exception: if it can go to the top level (#13286). +Consider + f x = joinrec j y n = <...j y' n'...> + in jump j x 0 + +Here we may just as well produce + j y n = <....j y' n'...> + f x = j x 0 + +and now there is a chance that 'f' will be inlined at its call sites. +It shouldn't make a lot of difference, but these tests + perf/should_run/MethSharing + simplCore/should_compile/spec-inline +and one nofib program, all improve if you do float to top, because +of the resulting inlining of f. So ok, let's do it. + +Note [Free join points] +~~~~~~~~~~~~~~~~~~~~~~~ +We never float a MFE that has a free join-point variable. You might think +this can never occur. After all, consider + join j x = ... + in ....(jump j x).... +How might we ever want to float that (jump j x)? + * If it would escape a value lambda, thus + join j x = ... in (\y. ...(jump j x)... ) + then 'j' isn't a valid join point in the first place. + +But consider + join j x = .... in + joinrec j2 y = ...(jump j x)...(a+b).... + +Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec. +But it is emphatically /not/ good to float the (jump j x) out: + (a) 'j' will stop being a join point + (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no + work would be saved by floating it out of the \y. + +Even if we floated 'j' to top level, (b) would still hold. + +Bottom line: never float a MFE that has a free JoinId. + +Note [Floating MFEs of unlifted type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + case f x of (r::Int#) -> blah +we'd like to float (f x). But it's not trivial because it has type +Int#, and we don't want to evaluate it too early. But we can instead +float a boxed version + y = case f x of r -> I# r +and replace the original (f x) with + case (case y of I# r -> r) of r -> blah + +Being able to float unboxed expressions is sometimes important; see +#12603. I'm not sure how /often/ it is important, but it's +not hard to achieve. + +We only do it for a fixed collection of types for which we have a +convenient boxing constructor (see boxingDataCon_maybe). In +particular we /don't/ do it for unboxed tuples; it's better to float +the components of the tuple individually. + +I did experiment with a form of boxing that works for any type, namely +wrapping in a function. In our example + + let y = case f x of r -> \v. f x + in case y void of r -> blah + +It works fine, but it's 50% slower (based on some crude benchmarking). +I suppose we could do it for types not covered by boxingDataCon_maybe, +but it's more code and I'll wait to see if anyone wants it. + +Note [Test cheapness with exprOkForSpeculation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't want to float very cheap expressions by boxing and unboxing. +But we use exprOkForSpeculation for the test, not exprIsCheap. +Why? Because it's important /not/ to transform + f (a /# 3) +to + f (case bx of I# a -> a /# 3) +and float bx = I# (a /# 3), because the application of f no +longer obeys the let/app invariant. But (a /# 3) is ok-for-spec +due to a special hack that says division operators can't fail +when the denominator is definitely non-zero. And yet that +same expression says False to exprIsCheap. Simplest way to +guarantee the let/app invariant is to use the same function! + +If an expression is okay for speculation, we could also float it out +*without* boxing and unboxing, since evaluating it early is okay. +However, it turned out to usually be better not to float such expressions, +since they tend to be extremely cheap things like (x +# 1#). Even the +cost of spilling the let-bound variable to the stack across a call may +exceed the cost of recomputing such an expression. (And we can't float +unlifted bindings to top-level.) + +We could try to do something smarter here, and float out expensive yet +okay-for-speculation things, such as division by non-zero constants. +But I suspect it's a narrow target. + +Note [Bottoming floats] +~~~~~~~~~~~~~~~~~~~~~~~ +If we see + f = \x. g (error "urk") +we'd like to float the call to error, to get + lvl = error "urk" + f = \x. g lvl + +But, as ever, we need to be careful: + +(1) We want to float a bottoming + expression even if it has free variables: + f = \x. g (let v = h x in error ("urk" ++ v)) + Then we'd like to abstract over 'x' can float the whole arg of g: + lvl = \x. let v = h x in error ("urk" ++ v) + f = \x. g (lvl x) + To achieve this we pass is_bot to destLevel + +(2) We do not do this for lambdas that return + bottom. Instead we treat the /body/ of such a function specially, + via point (1). For example: + f = \x. ....(\y z. if x then error y else error z).... + ===> + lvl = \x z y. if b then error y else error z + f = \x. ...(\y z. lvl x z y)... + (There is no guarantee that we'll choose the perfect argument order.) + +(3) If we have a /binding/ that returns bottom, we want to float it to top + level, even if it has free vars (point (1)), and even it has lambdas. + Example: + ... let { v = \y. error (show x ++ show y) } in ... + We want to abstract over x and float the whole thing to top: + lvl = \xy. errror (show x ++ show y) + ...let {v = lvl x} in ... + + Then of course we don't want to separately float the body (error ...) + as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot + argument. + +See Maessen's paper 1999 "Bottom extraction: factoring error handling out +of functional programs" (unpublished I think). + +When we do this, we set the strictness and arity of the new bottoming +Id, *immediately*, for three reasons: + + * To prevent the abstracted thing being immediately inlined back in again + via preInlineUnconditionally. The latter has a test for bottoming Ids + to stop inlining them, so we'd better make sure it *is* a bottoming Id! + + * So that it's properly exposed as such in the interface file, even if + this is all happening after strictness analysis. + + * In case we do CSE with the same expression that *is* marked bottom + lvl = error "urk" + x{str=bot) = error "urk" + Here we don't want to replace 'x' with 'lvl', else we may get Lint + errors, e.g. via a case with empty alternatives: (case x of {}) + Lint complains unless the scrutinee of such a case is clearly bottom. + + This was reported in #11290. But since the whole bottoming-float + thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure + that it'll nail all such cases. + +Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tiresomely, though, the simplifier has an invariant that the manifest +arity of the RHS should be the same as the arity; but we can't call +etaExpand during GHC.Core.Opt.SetLevels because it works over a decorated form of +CoreExpr. So we do the eta expansion later, in GHC.Core.Opt.FloatOut. + +Note [Case MFEs] +~~~~~~~~~~~~~~~~ +We don't float a case expression as an MFE from a strict context. Why not? +Because in doing so we share a tiny bit of computation (the switch) but +in exchange we build a thunk, which is bad. This case reduces allocation +by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem. +Doesn't change any other allocation at all. + +We will make a separate decision for the scrutinee and alternatives. + +However this can have a knock-on effect for fusion: consider + \v -> foldr k z (case x of I# y -> build ..y..) +Perhaps we can float the entire (case x of ...) out of the \v. Then +fusion will not happen, but we will get more sharing. But if we don't +float the case (as advocated here) we won't float the (build ...y..) +either, so fusion will happen. It can be a big effect, esp in some +artificial benchmarks (e.g. integer, queens), but there is no perfect +answer. + +-} + +annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id +-- See Note [Bottoming floats] for why we want to add +-- bottoming information right now +-- +-- n_extra are the number of extra value arguments added during floating +annotateBotStr id n_extra mb_str + = case mb_str of + Nothing -> id + Just (arity, sig) -> id `setIdArity` (arity + n_extra) + `setIdStrictness` (increaseStrictSigArity n_extra sig) + `setIdCprInfo` mkCprSig (arity + n_extra) botCpr + +notWorthFloating :: CoreExpr -> [Var] -> Bool +-- Returns True if the expression would be replaced by +-- something bigger than it is now. For example: +-- abs_vars = tvars only: return True if e is trivial, +-- but False for anything bigger +-- abs_vars = [x] (an Id): return True for trivial, or an application (f x) +-- but False for (f x x) +-- +-- One big goal is that floating should be idempotent. Eg if +-- we replace e with (lvl79 x y) and then run FloatOut again, don't want +-- to replace (lvl79 x y) with (lvl83 x y)! + +notWorthFloating e abs_vars + = go e (count isId abs_vars) + where + go (Var {}) n = n >= 0 + go (Lit lit) n = ASSERT( n==0 ) + litIsTrivial lit -- Note [Floating literals] + go (Tick t e) n = not (tickishIsCode t) && go e n + go (Cast e _) n = go e n + go (App e arg) n + -- See Note [Floating applications to coercions] + | Type {} <- arg = go e n + | n==0 = False + | is_triv arg = go e (n-1) + | otherwise = False + go _ _ = False + + is_triv (Lit {}) = True -- Treat all literals as trivial + is_triv (Var {}) = True -- (ie not worth floating) + is_triv (Cast e _) = is_triv e + is_triv (App e (Type {})) = is_triv e -- See Note [Floating applications to coercions] + is_triv (Tick t e) = not (tickishIsCode t) && is_triv e + is_triv _ = False + +{- +Note [Floating literals] +~~~~~~~~~~~~~~~~~~~~~~~~ +It's important to float Integer literals, so that they get shared, +rather than being allocated every time round the loop. +Hence the litIsTrivial. + +Ditto literal strings (LitString), which we'd like to float to top +level, which is now possible. + +Note [Floating applications to coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don’t float out variables applied only to type arguments, since the +extra binding would be pointless: type arguments are completely erased. +But *coercion* arguments aren’t (see Note [Coercion tokens] in +CoreToStg.hs and Note [Count coercion arguments in boring contexts] in +CoreUnfold.hs), so we still want to float out variables applied only to +coercion arguments. + +Note [Escaping a value lambda] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to float even cheap expressions out of value lambdas, +because that saves allocation. Consider + f = \x. .. (\y.e) ... +Then we'd like to avoid allocating the (\y.e) every time we call f, +(assuming e does not mention x). An example where this really makes a +difference is simplrun009. + +Another reason it's good is because it makes SpecContr fire on functions. +Consider + f = \x. ....(f (\y.e)).... +After floating we get + lvl = \y.e + f = \x. ....(f lvl)... +and that is much easier for SpecConstr to generate a robust +specialisation for. + +However, if we are wrapping the thing in extra value lambdas (in +abs_vars), then nothing is saved. E.g. + f = \xyz. ...(e1[y],e2).... +If we float + lvl = \y. (e1[y],e2) + f = \xyz. ...(lvl y)... +we have saved nothing: one pair will still be allocated for each +call of 'f'. Hence the (not float_is_lam) in float_me. + + +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ + +The binding stuff works for top level too. +-} + +lvlBind :: LevelEnv + -> CoreBindWithFVs + -> LvlM (LevelledBind, LevelEnv) + +lvlBind env (AnnNonRec bndr rhs) + | isTyVar bndr -- Don't do anything for TyVar binders + -- (simplifier gets rid of them pronto) + || isCoVar bndr -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv) + -- so we will ignore this case for now + || not (profitableFloat env dest_lvl) + || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty)) + -- We can't float an unlifted binding to top level (except + -- literal strings), so we don't float it at all. It's a + -- bit brutal, but unlifted bindings aren't expensive either + + = -- No float + do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs + ; let bind_lvl = incMinorLvl (le_ctxt_lvl env) + (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr] + ; return (NonRec bndr' rhs', env') } + + -- Otherwise we are going to float + | null abs_vars + = do { -- No type abstraction; clone existing binder + rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive + is_bot mb_join_arity rhs + ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr] + ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str + ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } + + | otherwise + = do { -- Yes, type abstraction; create a new binder, extend substitution, etc + rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive + is_bot mb_join_arity rhs + ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr] + ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str + ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } + + where + bndr_ty = idType bndr + ty_fvs = tyCoVarsOfType bndr_ty + rhs_fvs = freeVarsOf rhs + bind_fvs = rhs_fvs `unionDVarSet` dIdFreeVars bndr + abs_vars = abstractVars dest_lvl env bind_fvs + dest_lvl = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join + + deann_rhs = deAnnotate rhs + mb_bot_str = exprBotStrictness_maybe deann_rhs + is_bot = isJust mb_bot_str + -- NB: not isBottomThunk! See Note [Bottoming floats] point (3) + + n_extra = count isId abs_vars + mb_join_arity = isJoinId_maybe bndr + is_join = isJust mb_join_arity + +lvlBind env (AnnRec pairs) + | floatTopLvlOnly env && not (isTopLvl dest_lvl) + -- Only floating to the top level is allowed. + || not (profitableFloat env dest_lvl) + || (isTopLvl dest_lvl && any (mightBeUnliftedType . idType) bndrs) + -- This mightBeUnliftedType stuff is the same test as in the non-rec case + -- You might wonder whether we can have a recursive binding for + -- an unlifted value -- but we can if it's a /join binding/ (#16978) + -- (Ultimately I think we should not use GHC.Core.Opt.SetLevels to + -- float join bindings at all, but that's another story.) + = -- No float + do { let bind_lvl = incMinorLvl (le_ctxt_lvl env) + (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs + lvl_rhs (b,r) = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r + ; rhss' <- mapM lvl_rhs pairs + ; return (Rec (bndrs' `zip` rhss'), env') } + + -- Otherwise we are going to float + | null abs_vars + = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs + ; new_rhss <- mapM (do_rhs new_env) pairs + ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) + , new_env) } + +-- ToDo: when enabling the floatLambda stuff, +-- I think we want to stop doing this + | [(bndr,rhs)] <- pairs + , count isId abs_vars > 1 + = do -- Special case for self recursion where there are + -- several variables carried around: build a local loop: + -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars + -- This just makes the closures a bit smaller. If we don't do + -- this, allocation rises significantly on some programs + -- + -- We could elaborate it for the case where there are several + -- mutually recursive functions, but it's quite a bit more complicated + -- + -- This all seems a bit ad hoc -- sigh + let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars + rhs_lvl = le_ctxt_lvl rhs_env + + (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr] + let + (lam_bndrs, rhs_body) = collectAnnBndrs rhs + (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs + (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1 + new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body + (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr] + return (Rec [(TB poly_bndr (FloatMe dest_lvl) + , mkLams abs_vars_w_lvls $ + mkLams lam_bndrs2 $ + Let (Rec [( TB new_bndr (StayPut rhs_lvl) + , mkLams lam_bndrs2 new_rhs_body)]) + (mkVarApps (Var new_bndr) lam_bndrs1))] + , poly_env) + + | otherwise -- Non-null abs_vars + = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs + ; new_rhss <- mapM (do_rhs new_env) pairs + ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) + , new_env) } + + where + (bndrs,rhss) = unzip pairs + is_join = isJoinId (head bndrs) + -- bndrs is always non-empty and if one is a join they all are + -- Both are checked by Lint + is_fun = all isFunction rhss + is_bot = False -- It's odd to have an unconditionally divergent + -- function in a Rec, and we don't much care what + -- happens to it. False is simple! + + do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive + is_bot (get_join bndr) + rhs + + get_join bndr | need_zap = Nothing + | otherwise = isJoinId_maybe bndr + need_zap = dest_lvl `ltLvl` joinCeilingLevel env + + -- Finding the free vars of the binding group is annoying + bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs]) + `unionDVarSet` + (fvDVarSet $ unionsFV [ idFVs bndr + | (bndr, (_,_)) <- pairs])) + `delDVarSetList` + bndrs + + ty_fvs = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs + dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join + abs_vars = abstractVars dest_lvl env bind_fvs + +profitableFloat :: LevelEnv -> Level -> Bool +profitableFloat env dest_lvl + = (dest_lvl `ltMajLvl` le_ctxt_lvl env) -- Escapes a value lambda + || isTopLvl dest_lvl -- Going all the way to top level + + +---------------------------------------------------- +-- Three help functions for the type-abstraction case + +lvlRhs :: LevelEnv + -> RecFlag + -> Bool -- Is this a bottoming function + -> Maybe JoinArity + -> CoreExprWithFVs + -> LvlM LevelledExpr +lvlRhs env rec_flag is_bot mb_join_arity expr + = lvlFloatRhs [] (le_ctxt_lvl env) env + rec_flag is_bot mb_join_arity expr + +lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag + -> Bool -- Binding is for a bottoming function + -> Maybe JoinArity + -> CoreExprWithFVs + -> LvlM (Expr LevelledBndr) +-- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline +lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs + = do { body' <- if not is_bot -- See Note [Floating from a RHS] + && any isId bndrs + then lvlMFE body_env True body + else lvlExpr body_env body + ; return (mkLams bndrs' body') } + where + (bndrs, body) | Just join_arity <- mb_join_arity + = collectNAnnBndrs join_arity rhs + | otherwise + = collectAnnBndrs rhs + (env1, bndrs1) = substBndrsSL NonRecursive env bndrs + all_bndrs = abs_vars ++ bndrs1 + (body_env, bndrs') | Just _ <- mb_join_arity + = lvlJoinBndrs env1 dest_lvl rec all_bndrs + | otherwise + = case lvlLamBndrs env1 dest_lvl all_bndrs of + (env2, bndrs') -> (placeJoinCeiling env2, bndrs') + -- The important thing here is that we call lvlLamBndrs on + -- all these binders at once (abs_vars and bndrs), so they + -- all get the same major level. Otherwise we create stupid + -- let-bindings inside, joyfully thinking they can float; but + -- in the end they don't because we never float bindings in + -- between lambdas + +{- Note [Floating from a RHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When floating the RHS of a let-binding, we don't always want to apply +lvlMFE to the body of a lambda, as we usually do, because the entire +binding body is already going to the right place (dest_lvl). + +A particular example is the top level. Consider + concat = /\ a -> foldr ..a.. (++) [] +We don't want to float the body of the lambda to get + lvl = /\ a -> foldr ..a.. (++) [] + concat = /\ a -> lvl a +That would be stupid. + +Previously this was avoided in a much nastier way, by testing strict_ctxt +in float_me in lvlMFE. But that wasn't even right because it would fail +to float out the error sub-expression in + f = \x. case x of + True -> error ("blah" ++ show x) + False -> ... + +But we must be careful: + +* If we had + f = \x -> factorial 20 + we /would/ want to float that (factorial 20) out! Functions are treated + differently: see the use of isFunction in the calls to destLevel. If + there are only type lambdas, then destLevel will say "go to top, and + abstract over the free tyvars" and we don't want that here. + +* But if we had + f = \x -> error (...x....) + we would NOT want to float the bottoming expression out to give + lvl = \x -> error (...x...) + f = \x -> lvl x + +Conclusion: use lvlMFE if there are + * any value lambdas in the original function, and + * this is not a bottoming function (the is_bot argument) +Use lvlExpr otherwise. A little subtle, and I got it wrong at least twice +(e.g. #13369). +-} + +{- +************************************************************************ +* * +\subsection{Deciding floatability} +* * +************************************************************************ +-} + +substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr]) +substAndLvlBndrs is_rec env lvl bndrs + = lvlBndrs subst_env lvl subst_bndrs + where + (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs + +substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar]) +-- So named only to avoid the name clash with GHC.Core.Subst.substBndrs +substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs + = ( env { le_subst = subst' + , le_env = foldl' add_id id_env (bndrs `zip` bndrs') } + , bndrs') + where + (subst', bndrs') = case is_rec of + NonRecursive -> substBndrs subst bndrs + Recursive -> substRecBndrs subst bndrs + +lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr]) +-- Compute the levels for the binders of a lambda group +lvlLamBndrs env lvl bndrs + = lvlBndrs env new_lvl bndrs + where + new_lvl | any is_major bndrs = incMajorLvl lvl + | otherwise = incMinorLvl lvl + + is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr) + -- The "probably" part says "don't float things out of a + -- probable one-shot lambda" + -- See Note [Computing one-shot info] in GHC.Types.Demand + +lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar] + -> (LevelEnv, [LevelledBndr]) +lvlJoinBndrs env lvl rec bndrs + = lvlBndrs env new_lvl bndrs + where + new_lvl | isRec rec = incMajorLvl lvl + | otherwise = incMinorLvl lvl + -- Non-recursive join points are one-shot; recursive ones are not + +lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr]) +-- The binders returned are exactly the same as the ones passed, +-- apart from applying the substitution, but they are now paired +-- with a (StayPut level) +-- +-- The returned envt has le_ctxt_lvl updated to the new_lvl +-- +-- All the new binders get the same level, because +-- any floating binding is either going to float past +-- all or none. We never separate binders. +lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs + = ( env { le_ctxt_lvl = new_lvl + , le_join_ceil = new_lvl + , le_lvl_env = addLvls new_lvl lvl_env bndrs } + , map (stayPut new_lvl) bndrs) + +stayPut :: Level -> OutVar -> LevelledBndr +stayPut new_lvl bndr = TB bndr (StayPut new_lvl) + + -- Destination level is the max Id level of the expression + -- (We'll abstract the type variables, if any.) +destLevel :: LevelEnv + -> DVarSet -- Free vars of the term + -> TyCoVarSet -- Free in the /type/ of the term + -- (a subset of the previous argument) + -> Bool -- True <=> is function + -> Bool -- True <=> is bottom + -> Bool -- True <=> is a join point + -> Level +-- INVARIANT: if is_join=True then result >= join_ceiling +destLevel env fvs fvs_ty is_function is_bot is_join + | isTopLvl max_fv_id_level -- Float even joins if they get to top level + -- See Note [Floating join point bindings] + = tOP_LEVEL + + | is_join -- Never float a join point past the join ceiling + -- See Note [Join points] in GHC.Core.Opt.FloatOut + = if max_fv_id_level `ltLvl` join_ceiling + then join_ceiling + else max_fv_id_level + + | is_bot -- Send bottoming bindings to the top + = as_far_as_poss -- regardless; see Note [Bottoming floats] + -- Esp Bottoming floats (1) + + | Just n_args <- floatLams env + , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case + , is_function + , countFreeIds fvs <= n_args + = as_far_as_poss -- Send functions to top level; see + -- the comments with isFunction + + | otherwise = max_fv_id_level + where + join_ceiling = joinCeilingLevel env + max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the + -- tyvars will be abstracted + + as_far_as_poss = maxFvLevel' isId env fvs_ty + -- See Note [Floating and kind casts] + +{- Note [Floating and kind casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + case x of + K (co :: * ~# k) -> let v :: Int |> co + v = e + in blah + +Then, even if we are abstracting over Ids, or if e is bottom, we can't +float v outside the 'co' binding. Reason: if we did we'd get + v' :: forall k. (Int ~# Age) => Int |> co +and now 'co' isn't in scope in that type. The underlying reason is +that 'co' is a value-level thing and we can't abstract over that in a +type (else we'd get a dependent type). So if v's /type/ mentions 'co' +we can't float it out beyond the binding site of 'co'. + +That's why we have this as_far_as_poss stuff. Usually as_far_as_poss +is just tOP_LEVEL; but occasionally a coercion variable (which is an +Id) mentioned in type prevents this. + +Example #14270 comment:15. +-} + + +isFunction :: CoreExprWithFVs -> Bool +-- The idea here is that we want to float *functions* to +-- the top level. This saves no work, but +-- (a) it can make the host function body a lot smaller, +-- and hence inlinable. +-- (b) it can also save allocation when the function is recursive: +-- h = \x -> letrec f = \y -> ...f...y...x... +-- in f x +-- becomes +-- f = \x y -> ...(f x)...y...x... +-- h = \x -> f x x +-- No allocation for f now. +-- We may only want to do this if there are sufficiently few free +-- variables. We certainly only want to do it for values, and not for +-- constructors. So the simple thing is just to look for lambdas +isFunction (_, AnnLam b e) | isId b = True + | otherwise = isFunction e +-- isFunction (_, AnnTick _ e) = isFunction e -- dubious +isFunction _ = False + +countFreeIds :: DVarSet -> Int +countFreeIds = nonDetFoldUDFM add 0 . getUniqDSet + -- It's OK to use nonDetFoldUDFM here because we're just counting things. + where + add :: Var -> Int -> Int + add v n | isId v = n+1 + | otherwise = n + +{- +************************************************************************ +* * +\subsection{Free-To-Level Monad} +* * +************************************************************************ +-} + +data LevelEnv + = LE { le_switches :: FloatOutSwitches + , le_ctxt_lvl :: Level -- The current level + , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids + , le_join_ceil:: Level -- Highest level to which joins float + -- Invariant: always >= le_ctxt_lvl + + -- See Note [le_subst and le_env] + , le_subst :: Subst -- Domain is pre-cloned TyVars and Ids + -- The Id -> CoreExpr in the Subst is ignored + -- (since we want to substitute a LevelledExpr for + -- an Id via le_env) but we do use the Co/TyVar substs + , le_env :: IdEnv ([OutVar], LevelledExpr) -- Domain is pre-cloned Ids + } + +{- Note [le_subst and le_env] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We clone let- and case-bound variables so that they are still distinct +when floated out; hence the le_subst/le_env. (see point 3 of the +module overview comment). We also use these envs when making a +variable polymorphic because we want to float it out past a big +lambda. + +The le_subst and le_env always implement the same mapping, + in_x :-> out_x a b +where out_x is an OutVar, and a,b are its arguments (when +we perform abstraction at the same time as floating). + + le_subst maps to CoreExpr + le_env maps to LevelledExpr + +Since the range is always a variable or application, there is never +any difference between the two, but sadly the types differ. The +le_subst is used when substituting in a variable's IdInfo; the le_env +when we find a Var. + +In addition the le_env records a [OutVar] of variables free in the +OutExpr/LevelledExpr, just so we don't have to call freeVars +repeatedly. This list is always non-empty, and the first element is +out_x + +The domain of the both envs is *pre-cloned* Ids, though + +The domain of the le_lvl_env is the *post-cloned* Ids +-} + +initialEnv :: FloatOutSwitches -> LevelEnv +initialEnv float_lams + = LE { le_switches = float_lams + , le_ctxt_lvl = tOP_LEVEL + , le_join_ceil = panic "initialEnv" + , le_lvl_env = emptyVarEnv + , le_subst = emptySubst + , le_env = emptyVarEnv } + +addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level +addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl + +addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level +addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs + +floatLams :: LevelEnv -> Maybe Int +floatLams le = floatOutLambdas (le_switches le) + +floatConsts :: LevelEnv -> Bool +floatConsts le = floatOutConstants (le_switches le) + +floatOverSat :: LevelEnv -> Bool +floatOverSat le = floatOutOverSatApps (le_switches le) + +floatTopLvlOnly :: LevelEnv -> Bool +floatTopLvlOnly le = floatToTopLevelOnly (le_switches le) + +incMinorLvlFrom :: LevelEnv -> Level +incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env) + +-- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can +-- See Note [Binder-swap during float-out] +extendCaseBndrEnv :: LevelEnv + -> Id -- Pre-cloned case binder + -> Expr LevelledBndr -- Post-cloned scrutinee + -> LevelEnv +extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env }) + case_bndr (Var scrut_var) + = le { le_subst = extendSubstWithVar subst case_bndr scrut_var + , le_env = add_id id_env (case_bndr, scrut_var) } +extendCaseBndrEnv env _ _ = env + +-- See Note [Join ceiling] +placeJoinCeiling :: LevelEnv -> LevelEnv +placeJoinCeiling le@(LE { le_ctxt_lvl = lvl }) + = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' } + where + lvl' = asJoinCeilLvl (incMinorLvl lvl) + +maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level +maxFvLevel max_me env var_set + = foldDVarSet (maxIn max_me env) tOP_LEVEL var_set + +maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level +-- Same but for TyCoVarSet +maxFvLevel' max_me env var_set + = nonDetFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set + +maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level +maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl + = case lookupVarEnv id_env in_var of + Just (abs_vars, _) -> foldr max_out lvl abs_vars + Nothing -> max_out in_var lvl + where + max_out out_var lvl + | max_me out_var = case lookupVarEnv lvl_env out_var of + Just lvl' -> maxLvl lvl' lvl + Nothing -> lvl + | otherwise = lvl -- Ignore some vars depending on max_me + +lookupVar :: LevelEnv -> Id -> LevelledExpr +lookupVar le v = case lookupVarEnv (le_env le) v of + Just (_, expr) -> expr + _ -> Var v + +-- Level to which join points are allowed to float (boundary of current tail +-- context). See Note [Join ceiling] +joinCeilingLevel :: LevelEnv -> Level +joinCeilingLevel = le_join_ceil + +abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar] + -- Find the variables in fvs, free vars of the target expression, + -- whose level is greater than the destination level + -- These are the ones we are going to abstract out + -- + -- Note that to get reproducible builds, the variables need to be + -- abstracted in deterministic order, not dependent on the values of + -- Uniques. This is achieved by using DVarSets, deterministic free + -- variable computation and deterministic sort. + -- See Note [Unique Determinism] in GHC.Types.Unique for explanation of why + -- Uniques are not deterministic. +abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs + = -- NB: sortQuantVars might not put duplicates next to each other + map zap $ sortQuantVars $ + filter abstract_me $ + dVarSetElems $ + closeOverKindsDSet $ + substDVarSet subst in_fvs + -- NB: it's important to call abstract_me only on the OutIds the + -- come from substDVarSet (not on fv, which is an InId) + where + abstract_me v = case lookupVarEnv lvl_env v of + Just lvl -> dest_lvl `ltLvl` lvl + Nothing -> False + + -- We are going to lambda-abstract, so nuke any IdInfo, + -- and add the tyvars of the Id (if necessary) + zap v | isId v = WARN( isStableUnfolding (idUnfolding v) || + not (isEmptyRuleInfo (idSpecialisation v)), + text "absVarsOf: discarding info on" <+> ppr v ) + setIdInfo v vanillaIdInfo + | otherwise = v + +type LvlM result = UniqSM result + +initLvl :: UniqSupply -> UniqSM a -> a +initLvl = initUs_ + +newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId] + -> LvlM (LevelEnv, [OutId]) +-- The envt is extended to bind the new bndrs to dest_lvl, but +-- the le_ctxt_lvl is unaffected +newPolyBndrs dest_lvl + env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) + abs_vars bndrs + = ASSERT( all (not . isCoVar) bndrs ) -- What would we add to the CoSubst in this case. No easy answer. + do { uniqs <- getUniquesM + ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs + bndr_prs = bndrs `zip` new_bndrs + env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs + , le_subst = foldl' add_subst subst bndr_prs + , le_env = foldl' add_id id_env bndr_prs } + ; return (env', new_bndrs) } + where + add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars) + add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) + + mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id + transfer_join_info bndr $ + mkSysLocal (mkFastString str) uniq poly_ty + where + str = "poly_" ++ occNameString (getOccName bndr) + poly_ty = mkLamTypes abs_vars (GHC.Core.Subst.substTy subst (idType bndr)) + + -- If we are floating a join point to top level, it stops being + -- a join point. Otherwise it continues to be a join point, + -- but we may need to adjust its arity + dest_is_top = isTopLvl dest_lvl + transfer_join_info bndr new_bndr + | Just join_arity <- isJoinId_maybe bndr + , not dest_is_top + = new_bndr `asJoinId` join_arity + length abs_vars + | otherwise + = new_bndr + +newLvlVar :: LevelledExpr -- The RHS of the new binding + -> Maybe JoinArity -- Its join arity, if it is a join point + -> Bool -- True <=> the RHS looks like (makeStatic ...) + -> LvlM Id +newLvlVar lvld_rhs join_arity_maybe is_mk_static + = do { uniq <- getUniqueM + ; return (add_join_info (mk_id uniq rhs_ty)) + } + where + add_join_info var = var `asJoinId_maybe` join_arity_maybe + de_tagged_rhs = deTagExpr lvld_rhs + rhs_ty = exprType de_tagged_rhs + + mk_id uniq rhs_ty + -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. + | is_mk_static + = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr")) + rhs_ty + | otherwise + = mkSysLocal (mkFastString "lvl") uniq rhs_ty + +-- | Clone the binders bound by a single-alternative case. +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 + -- 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' + , le_subst = subst' + , le_env = foldl' add_id id_env (vs `zip` vs') } + + ; return (env', vs') } + +cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar] + -> LvlM (LevelEnv, [OutVar]) +-- See Note [Need for cloning during float-out] +-- Works for Ids bound by let(rec) +-- The dest_lvl is attributed to the binders in the new env, +-- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env +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 + -- 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 + env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2 + , le_subst = subst' + , le_env = foldl' add_id id_env prs } + + ; return (env', vs2) } + where + zap :: Var -> Var + zap v | isId v = zap_join (zapIdDemandInfo v) + | otherwise = v + + zap_join | isTopLvl dest_lvl = zapJoinId + | otherwise = id + +add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr) +add_id id_env (v, v1) + | isTyVar v = delVarEnv id_env v + | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1) + +{- +Note [Zapping the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +VERY IMPORTANT: we must zap the demand info if the thing is going to +float out, because it may be less demanded than at its original +binding site. Eg + f :: Int -> Int + f x = let v = 3*4 in v+x +Here v is strict; but if we float v to top level, it isn't any more. + +Similarly, if we're floating a join point, it won't be one anymore, so we zap +join point information as well. +-} diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -0,0 +1,3668 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[Simplify]{The main module of the simplifier} +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Platform +import GHC.Driver.Session +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Simplify.Utils +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.FamInstEnv ( FamInstEnv ) +import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 +import GHC.Types.Id +import GHC.Types.Id.Make ( seqId ) +import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) +import qualified GHC.Core.Make +import GHC.Types.Id.Info +import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) +import GHC.Core.Coercion hiding ( substCo, substCoVar ) +import GHC.Core.Coercion.Opt ( optCoercion ) +import GHC.Core.FamInstEnv ( topNormaliseType_maybe ) +import GHC.Core.DataCon + ( DataCon, dataConWorkId, dataConRepStrictness + , dataConRepArgTys, isUnboxedTupleCon + , StrictnessMark (..) ) +import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) ) +import GHC.Core +import GHC.Types.Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd + , mkClosedStrictSig, topDmd, botDiv ) +import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Core.Ppr ( pprCoreExpr ) +import GHC.Core.Unfold +import GHC.Core.Utils +import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg + , joinPointBinding_maybe, joinPointBindings_maybe ) +import GHC.Core.FVs ( mkRuleInfo ) +import GHC.Core.Rules ( lookupRule, getRules ) +import GHC.Types.Basic ( TopLevelFlag(..), isNotTopLevel, isTopLevel, + RecFlag(..), Arity ) +import GHC.Utils.Monad ( mapAccumLM, liftIO ) +import GHC.Types.Var ( isTyCoVar ) +import GHC.Data.Maybe ( orElse ) +import Control.Monad +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Utils.Error +import GHC.Unit.Module ( moduleName, pprModuleName ) +import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) + + +{- +The guts of the simplifier is in this module, but the driver loop for +the simplifier is in GHC.Core.Opt.Driver + +Note [The big picture] +~~~~~~~~~~~~~~~~~~~~~~ +The general shape of the simplifier is this: + + simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) + simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) + + * SimplEnv contains + - Simplifier mode (which includes DynFlags for convenience) + - Ambient substitution + - InScopeSet + + * SimplFloats contains + - Let-floats (which includes ok-for-spec case-floats) + - Join floats + - InScopeSet (including all the floats) + + * Expressions + simplExpr :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + The result of simplifying an /expression/ is (floats, expr) + - A bunch of floats (let bindings, join bindings) + - A simplified expression. + The overall result is effectively (let floats in expr) + + * Bindings + simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) + The result of simplifying a binding is + - A bunch of floats, the last of which is the simplified binding + There may be auxiliary bindings too; see prepareRhs + - An environment suitable for simplifying the scope of the binding + + The floats may also be empty, if the binding is inlined unconditionally; + in that case the returned SimplEnv will have an augmented substitution. + + The returned floats and env both have an in-scope set, and they are + guaranteed to be the same. + + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +The simplifier used to guarantee that the output had no shadowing, but +it does not do so any more. (Actually, it never did!) The reason is +documented with simplifyArgs. + + +Eta expansion +~~~~~~~~~~~~~~ +For eta expansion, we want to catch things like + + case e of (a,b) -> \x -> case a of (p,q) -> \y -> r + +If the \x was on the RHS of a let, we'd eta expand to bring the two +lambdas together. And in general that's a good thing to do. Perhaps +we should eta expand wherever we find a (value) lambda? Then the eta +expansion at a let RHS can concentrate solely on the PAP case. + +Note [In-scope set as a substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As per Note [Lookups in in-scope set], an in-scope set can act as +a substitution. Specifically, it acts as a substitution from variable to +variables /with the same unique/. + +Why do we need this? Well, during the course of the simplifier, we may want to +adjust inessential properties of a variable. For instance, when performing a +beta-reduction, we change + + (\x. e) u ==> let x = u in e + +We typically want to add an unfolding to `x` so that it inlines to (the +simplification of) `u`. + +We do that by adding the unfolding to the binder `x`, which is added to the +in-scope set. When simplifying occurrences of `x` (every occurrence!), they are +replaced by their “updated” version from the in-scope set, hence inherit the +unfolding. This happens in `SimplEnv.substId`. + +Another example. Consider + + case x of y { Node a b -> ...y... + ; Leaf v -> ...y... } + +In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we +want y's unfolding to be (Leaf v). We achieve this by adding the appropriate +unfolding to y, and re-adding it to the in-scope set. See the calls to +`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere. + +It's quite convenient. This way we don't need to manipulate the substitution all +the time: every update to a binder is automatically reflected to its bound +occurrences. + +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ +-} + +simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) +-- See Note [The big picture] +simplTopBinds env0 binds0 + = do { -- Put all the top-level binders into scope at the start + -- so that if a transformation rule has unexpectedly brought + -- anything into scope, then we don't get a complaint about that. + -- It's rather as if the top-level binders were imported. + -- See note [Glomming] in OccurAnal. + ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0) + ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0 + ; freeTick SimplifierDone + ; return (floats, env2) } + where + -- We need to track the zapped top-level binders, because + -- they should have their fragile IdInfo zapped (notably occurrence info) + -- That's why we run down binds and bndrs' simultaneously. + -- + simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) + simpl_binds env [] = return (emptyFloats env, env) + simpl_binds env (bind:binds) = do { (float, env1) <- simpl_bind env bind + ; (floats, env2) <- simpl_binds env1 binds + ; return (float `addFloats` floats, env2) } + + simpl_bind env (Rec pairs) + = simplRecBind env TopLevel Nothing pairs + simpl_bind env (NonRec b r) + = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing + ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r } + +{- +************************************************************************ +* * + Lazy bindings +* * +************************************************************************ + +simplRecBind is used for + * recursive bindings only +-} + +simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont + -> [(InId, InExpr)] + -> SimplM (SimplFloats, SimplEnv) +simplRecBind env0 top_lvl mb_cont pairs0 + = do { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0 + ; (rec_floats, env1) <- go env_with_info triples + ; return (mkRecFloats rec_floats, env1) } + where + add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) + -- Add the (substituted) rules to the binder + add_rules env (bndr, rhs) + = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) mb_cont + ; return (env', (bndr, bndr', rhs)) } + + go env [] = return (emptyFloats env, env) + + go env ((old_bndr, new_bndr, rhs) : pairs) + = do { (float, env1) <- simplRecOrTopPair env top_lvl Recursive mb_cont + old_bndr new_bndr rhs + ; (floats, env2) <- go env1 pairs + ; return (float `addFloats` floats, env2) } + +{- +simplOrTopPair is used for + * recursive bindings (whether top level or not) + * top-level non-recursive bindings + +It assumes the binder has already been simplified, but not its IdInfo. +-} + +simplRecOrTopPair :: SimplEnv + -> TopLevelFlag -> RecFlag -> MaybeJoinCont + -> InId -> OutBndr -> InExpr -- Binder and rhs + -> SimplM (SimplFloats, SimplEnv) + +simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs + | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env + = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} + trace_bind "pre-inline-uncond" $ + do { tick (PreInlineUnconditionally old_bndr) + ; return ( emptyFloats env, env' ) } + + | Just cont <- mb_cont + = {-#SCC "simplRecOrTopPair-join" #-} + ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr ) + trace_bind "join" $ + simplJoinBind env cont old_bndr new_bndr rhs env + + | otherwise + = {-#SCC "simplRecOrTopPair-normal" #-} + trace_bind "normal" $ + simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env + + where + dflags = seDynFlags env + + -- trace_bind emits a trace for each top-level binding, which + -- helps to locate the tracing for inlining and rule firing + trace_bind what thing_inside + | not (dopt Opt_D_verbose_core2core dflags) + = thing_inside + | otherwise + = traceAction dflags ("SimplBind " ++ what) + (ppr old_bndr) thing_inside + +-------------------------- +simplLazyBind :: SimplEnv + -> TopLevelFlag -> RecFlag + -> InId -> OutId -- Binder, both pre-and post simpl + -- Not a JoinId + -- The OutId has IdInfo, except arity, unfolding + -- Ids only, no TyVars + -> InExpr -> SimplEnv -- The RHS and its environment + -> SimplM (SimplFloats, SimplEnv) +-- Precondition: not a JoinId +-- Precondition: rhs obeys the let/app invariant +-- NOT used for JoinIds +simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se + = ASSERT( isId bndr ) + ASSERT2( not (isJoinId bndr), ppr bndr ) + -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ + do { let rhs_env = rhs_se `setInScopeFromE` env + (tvs, body) = case collectTyAndValBinders rhs of + (tvs, [], body) + | surely_not_lam body -> (tvs, body) + _ -> ([], rhs) + + surely_not_lam (Lam {}) = False + surely_not_lam (Tick t e) + | not (tickishFloatable t) = surely_not_lam e + -- eta-reduction could float + surely_not_lam _ = True + -- Do not do the "abstract tyvar" thing if there's + -- a lambda inside, because it defeats eta-reduction + -- f = /\a. \x. g a x + -- should eta-reduce. + + + ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs + -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils + + -- Simplify the RHS + ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) + ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont + + -- Never float join-floats out of a non-join let-binding + -- So wrap the body in the join-floats right now + -- Hence: body_floats1 consists only of let-floats + ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0 + + -- ANF-ise a constructor or PAP rhs + -- We get at most one float per argument here + ; (let_floats, body2) <- {-#SCC "prepareRhs" #-} prepareRhs (getMode env) top_lvl + (getOccFS bndr1) (idInfo bndr1) body1 + ; let body_floats2 = body_floats1 `addLetFloats` let_floats + + ; (rhs_floats, rhs') + <- if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2) + then -- No floating, revert to body1 + {-#SCC "simplLazyBind-no-floating" #-} + do { rhs' <- mkLam env tvs' (wrapFloats body_floats2 body1) rhs_cont + ; return (emptyFloats env, rhs') } + + else if null tvs then -- Simple floating + {-#SCC "simplLazyBind-simple-floating" #-} + do { tick LetFloatFromLet + ; return (body_floats2, body2) } + + else -- Do type-abstraction first + {-#SCC "simplLazyBind-type-abstraction-first" #-} + do { tick LetFloatFromLet + ; (poly_binds, body3) <- abstractFloats (seDynFlags env) top_lvl + tvs' body_floats2 body2 + ; let floats = foldl' extendFloats (emptyFloats env) poly_binds + ; rhs' <- mkLam env tvs' body3 rhs_cont + ; return (floats, rhs') } + + ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) + top_lvl Nothing bndr bndr1 rhs' + ; return (rhs_floats `addFloats` bind_float, env2) } + +-------------------------- +simplJoinBind :: SimplEnv + -> SimplCont + -> InId -> OutId -- Binder, both pre-and post simpl + -- The OutId has IdInfo, except arity, + -- unfolding + -> InExpr -> SimplEnv -- The right hand side and its env + -> SimplM (SimplFloats, SimplEnv) +simplJoinBind env cont old_bndr new_bndr rhs rhs_se + = do { let rhs_env = rhs_se `setInScopeFromE` env + ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont + ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' } + +-------------------------- +simplNonRecX :: SimplEnv + -> InId -- Old binder; not a JoinId + -> OutExpr -- Simplified RHS + -> SimplM (SimplFloats, SimplEnv) +-- A specialised variant of simplNonRec used when the RHS is already +-- simplified, notably in knownCon. It uses case-binding where necessary. +-- +-- Precondition: rhs satisfies the let/app invariant + +simplNonRecX env bndr new_rhs + | ASSERT2( not (isJoinId bndr), ppr bndr ) + isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } + = return (emptyFloats env, env) -- Here c is dead, and we avoid + -- creating the binding c = (a,b) + + | Coercion co <- new_rhs + = return (emptyFloats env, extendCvSubst env bndr co) + + | otherwise + = do { (env', bndr') <- simplBinder env bndr + ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } + -- simplNonRecX is only used for NotTopLevel things + +-------------------------- +completeNonRecX :: TopLevelFlag -> SimplEnv + -> Bool + -> InId -- Old binder; not a JoinId + -> OutId -- New binder + -> OutExpr -- Simplified RHS + -> SimplM (SimplFloats, SimplEnv) -- The new binding is in the floats +-- Precondition: rhs satisfies the let/app invariant +-- See Note [Core let/app invariant] in GHC.Core + +completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs + = ASSERT2( not (isJoinId new_bndr), ppr new_bndr ) + do { (prepd_floats, rhs1) <- prepareRhs (getMode env) top_lvl (getOccFS new_bndr) + (idInfo new_bndr) new_rhs + ; let floats = emptyFloats env `addLetFloats` prepd_floats + ; (rhs_floats, rhs2) <- + if doFloatFromRhs NotTopLevel NonRecursive is_strict floats rhs1 + then -- Add the floats to the main env + do { tick LetFloatFromLet + ; return (floats, rhs1) } + else -- Do not float; wrap the floats around the RHS + return (emptyFloats env, wrapFloats floats rhs1) + + ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) + NotTopLevel Nothing + old_bndr new_bndr rhs2 + ; return (rhs_floats `addFloats` bind_float, env2) } + + +{- ********************************************************************* +* * + prepareRhs, makeTrivial +* * +************************************************************************ + +Note [prepareRhs] +~~~~~~~~~~~~~~~~~ +prepareRhs takes a putative RHS, checks whether it's a PAP or +constructor application and, if so, converts it to ANF, so that the +resulting thing can be inlined more easily. Thus + x = (f a, g b) +becomes + t1 = f a + t2 = g b + x = (t1,t2) + +We also want to deal well cases like this + v = (f e1 `cast` co) e2 +Here we want to make e1,e2 trivial and get + x1 = e1; x2 = e2; v = (f x1 `cast` co) v2 +That's what the 'go' loop in prepareRhs does +-} + +prepareRhs :: SimplMode -> TopLevelFlag + -> FastString -- Base for any new variables + -> IdInfo -- IdInfo for the LHS of this binding + -> OutExpr + -> SimplM (LetFloats, OutExpr) +-- Transforms a RHS into a better RHS by adding floats +-- e.g x = Just e +-- becomes a = e +-- x = Just a +-- See Note [prepareRhs] +prepareRhs mode top_lvl occ info (Cast rhs co) -- Note [Float coercions] + | let ty1 = coercionLKind co -- Do *not* do this if rhs has an unlifted type + , not (isUnliftedType ty1) -- see Note [Float coercions (unlifted)] + = do { (floats, rhs') <- makeTrivialWithInfo mode top_lvl occ sanitised_info rhs + ; return (floats, Cast rhs' co) } + where + sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info + `setCprInfo` cprInfo info + `setDemandInfo` demandInfo info + +prepareRhs mode top_lvl occ _ rhs0 + = do { (_is_exp, floats, rhs1) <- go 0 rhs0 + ; return (floats, rhs1) } + where + go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr) + go n_val_args (Cast rhs co) + = do { (is_exp, floats, rhs') <- go n_val_args rhs + ; return (is_exp, floats, Cast rhs' co) } + go n_val_args (App fun (Type ty)) + = do { (is_exp, floats, rhs') <- go n_val_args fun + ; return (is_exp, floats, App rhs' (Type ty)) } + go n_val_args (App fun arg) + = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun + ; case is_exp of + False -> return (False, emptyLetFloats, App fun arg) + True -> do { (floats2, arg') <- makeTrivial mode top_lvl occ arg + ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } } + go n_val_args (Var fun) + = return (is_exp, emptyLetFloats, Var fun) + where + is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP + -- See Note [CONLIKE pragma] in GHC.Types.Basic + -- The definition of is_exp should match that in + -- OccurAnal.occAnalApp + + go n_val_args (Tick t rhs) + -- We want to be able to float bindings past this + -- tick. Non-scoping ticks don't care. + | tickishScoped t == NoScope + = do { (is_exp, floats, rhs') <- go n_val_args rhs + ; return (is_exp, floats, Tick t rhs') } + + -- On the other hand, for scoping ticks we need to be able to + -- copy them on the floats, which in turn is only allowed if + -- we can obtain non-counting ticks. + | (not (tickishCounts t) || tickishCanSplit t) + = do { (is_exp, floats, rhs') <- go n_val_args rhs + ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) + floats' = mapLetFloats floats tickIt + ; return (is_exp, floats', Tick t rhs') } + + go _ other + = return (False, emptyLetFloats, other) + +{- +Note [Float coercions] +~~~~~~~~~~~~~~~~~~~~~~ +When we find the binding + x = e `cast` co +we'd like to transform it to + x' = e + x = x `cast` co -- A trivial binding +There's a chance that e will be a constructor application or function, or something +like that, so moving the coercion to the usage site may well cancel the coercions +and lead to further optimisation. Example: + + data family T a :: * + data instance T Int = T Int + + foo :: Int -> Int -> Int + foo m n = ... + where + x = T m + go 0 = 0 + go n = case x of { T m -> go (n-m) } + -- This case should optimise + +Note [Preserve strictness when floating coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the Note [Float coercions] transformation, keep the strictness info. +Eg + f = e `cast` co -- f has strictness SSL +When we transform to + f' = e -- f' also has strictness SSL + f = f' `cast` co -- f still has strictness SSL + +Its not wrong to drop it on the floor, but better to keep it. + +Note [Float coercions (unlifted)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +BUT don't do [Float coercions] if 'e' has an unlifted type. +This *can* happen: + + foo :: Int = (error (# Int,Int #) "urk") + `cast` CoUnsafe (# Int,Int #) Int + +If do the makeTrivial thing to the error call, we'll get + foo = case error (# Int,Int #) "urk" of v -> v `cast` ... +But 'v' isn't in scope! + +These strange casts can happen as a result of case-of-case + bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of + (# p,q #) -> p+q +-} + +makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec) +makeTrivialArg mode (ValArg e) + = do { (floats, e') <- makeTrivial mode NotTopLevel (fsLit "arg") e + ; return (floats, ValArg e') } +makeTrivialArg _ arg + = return (emptyLetFloats, arg) -- CastBy, TyArg + +makeTrivial :: SimplMode -> TopLevelFlag + -> FastString -- ^ A "friendly name" to build the new binder from + -> OutExpr -- ^ This expression satisfies the let/app invariant + -> SimplM (LetFloats, OutExpr) +-- Binds the expression to a variable, if it's not trivial, returning the variable +makeTrivial mode top_lvl context expr + = makeTrivialWithInfo mode top_lvl context vanillaIdInfo expr + +makeTrivialWithInfo :: SimplMode -> TopLevelFlag + -> FastString -- ^ a "friendly name" to build the new binder from + -> IdInfo + -> OutExpr -- ^ This expression satisfies the let/app invariant + -> SimplM (LetFloats, OutExpr) +-- Propagate strictness and demand info to the new binder +-- Note [Preserve strictness when floating coercions] +-- Returned SimplEnv has same substitution as incoming one +makeTrivialWithInfo mode top_lvl occ_fs info expr + | exprIsTrivial expr -- Already trivial + || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise + -- See Note [Cannot trivialise] + = return (emptyLetFloats, expr) + + | otherwise + = do { (floats, expr1) <- prepareRhs mode top_lvl occ_fs info expr + ; if exprIsTrivial expr1 -- See Note [Trivial after prepareRhs] + then return (floats, expr1) + else do + { uniq <- getUniqueM + ; let name = mkSystemVarName uniq occ_fs + var = mkLocalIdWithInfo name expr_ty info + + -- Now something very like completeBind, + -- but without the postInlineUnconditionally part + ; (arity, is_bot, expr2) <- tryEtaExpandRhs mode var expr1 + ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2 + + ; let final_id = addLetBndrInfo var arity is_bot unf + bind = NonRec final_id expr2 + + ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }} + where + expr_ty = exprType expr + +bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool +-- True iff we can have a binding of this expression at this level +-- Precondition: the type is the type of the expression +bindingOk top_lvl expr expr_ty + | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty + | otherwise = True + +{- Note [Trivial after prepareRhs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we call makeTrival on (e |> co), the recursive use of prepareRhs +may leave us with + { a1 = e } and (a1 |> co) +Now the latter is trivial, so we don't want to let-bind it. + +Note [Cannot trivialise] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + f :: Int -> Addr# + + foo :: Bar + foo = Bar (f 3) + +Then we can't ANF-ise foo, even though we'd like to, because +we can't make a top-level binding for the Addr# (f 3). And if +so we don't want to turn it into + foo = let x = f 3 in Bar x +because we'll just end up inlining x back, and that makes the +simplifier loop. Better not to ANF-ise it at all. + +Literal strings are an exception. + + foo = Ptr "blob"# + +We want to turn this into: + + foo1 = "blob"# + foo = Ptr foo1 + +See Note [Core top-level string literals] in GHC.Core. + +************************************************************************ +* * + Completing a lazy binding +* * +************************************************************************ + +completeBind + * deals only with Ids, not TyVars + * takes an already-simplified binder and RHS + * is used for both recursive and non-recursive bindings + * is used for both top-level and non-top-level bindings + +It does the following: + - tries discarding a dead binding + - tries PostInlineUnconditionally + - add unfolding [this is the only place we add an unfolding] + - add arity + +It does *not* attempt to do let-to-case. Why? Because it is used for + - top-level bindings (when let-to-case is impossible) + - many situations where the "rhs" is known to be a WHNF + (so let-to-case is inappropriate). + +Nor does it do the atomic-argument thing +-} + +completeBind :: SimplEnv + -> TopLevelFlag -- Flag stuck into unfolding + -> MaybeJoinCont -- Required only for join point + -> InId -- Old binder + -> OutId -> OutExpr -- New binder and RHS + -> SimplM (SimplFloats, SimplEnv) +-- completeBind may choose to do its work +-- * by extending the substitution (e.g. let x = y in ...) +-- * or by adding to the floats in the envt +-- +-- Binder /can/ be a JoinId +-- Precondition: rhs obeys the let/app invariant +completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs + | isCoVar old_bndr + = case new_rhs of + Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co) + _ -> return (mkFloatBind env (NonRec new_bndr new_rhs)) + + | otherwise + = ASSERT( isId new_bndr ) + do { let old_info = idInfo old_bndr + old_unf = unfoldingInfo old_info + occ_info = occInfo old_info + + -- Do eta-expansion on the RHS of the binding + -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils + ; (new_arity, is_bot, final_rhs) <- tryEtaExpandRhs (getMode env) + new_bndr new_rhs + + -- Simplify the unfolding + ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr + final_rhs (idType new_bndr) old_unf + + ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding + -- See Note [In-scope set as a substitution] + + ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs + + then -- Inline and discard the binding + do { tick (PostInlineUnconditionally old_bndr) + ; return ( emptyFloats env + , extendIdSubst env old_bndr $ + DoneEx final_rhs (isJoinId_maybe new_bndr)) } + -- Use the substitution to make quite, quite sure that the + -- substitution will happen, since we are going to discard the binding + + else -- Keep the binding + -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $ + return (mkFloatBind env (NonRec final_bndr final_rhs)) } + +addLetBndrInfo :: OutId -> Arity -> Bool -> Unfolding -> OutId +addLetBndrInfo new_bndr new_arity is_bot new_unf + = new_bndr `setIdInfo` info5 + where + info1 = idInfo new_bndr `setArityInfo` new_arity + + -- Unfolding info: Note [Setting the new unfolding] + info2 = info1 `setUnfoldingInfo` new_unf + + -- Demand info: Note [Setting the demand info] + -- We also have to nuke demand info if for some reason + -- eta-expansion *reduces* the arity of the binding to less + -- than that of the strictness sig. This can happen: see Note [Arity decrease]. + info3 | isEvaldUnfolding new_unf + || (case strictnessInfo info2 of + StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty) + = zapDemandInfo info2 `orElse` info2 + | otherwise + = info2 + + -- Bottoming bindings: see Note [Bottoming bindings] + info4 | is_bot = info3 + `setStrictnessInfo` + mkClosedStrictSig (replicate new_arity topDmd) botDiv + `setCprInfo` mkCprSig new_arity botCpr + | otherwise = info3 + + -- Zap call arity info. We have used it by now (via + -- `tryEtaExpandRhs`), and the simplifier can invalidate this + -- information, leading to broken code later (e.g. #13479) + info5 = zapCallArityInfo info4 + + +{- Note [Arity decrease] +~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking the arity of a binding should not decrease. But it *can* +legitimately happen because of RULES. Eg + f = g Int +where g has arity 2, will have arity 2. But if there's a rewrite rule + g Int --> h +where h has arity 1, then f's arity will decrease. Here's a real-life example, +which is in the output of Specialise: + + Rec { + $dm {Arity 2} = \d.\x. op d + {-# RULES forall d. $dm Int d = $s$dm #-} + + dInt = MkD .... opInt ... + opInt {Arity 1} = $dm dInt + + $s$dm {Arity 0} = \x. op dInt } + +Here opInt has arity 1; but when we apply the rule its arity drops to 0. +That's why Specialise goes to a little trouble to pin the right arity +on specialised functions too. + +Note [Bottoming bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + let x = error "urk" + in ...(case x of )... +or + let f = \x. error (x ++ "urk") + in ...(case f "foo" of )... + +Then we'd like to drop the dead immediately. So it's good to +propagate the info that x's RHS is bottom to x's IdInfo as rapidly as +possible. + +We use tryEtaExpandRhs on every binding, and it turns ou that the +arity computation it performs (via GHC.Core.Arity.findRhsArity) already +does a simple bottoming-expression analysis. So all we need to do +is propagate that info to the binder's IdInfo. + +This showed up in #12150; see comment:16. + +Note [Setting the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the unfolding is a value, the demand info may +go pear-shaped, so we nuke it. Example: + let x = (a,b) in + case x of (p,q) -> h p q x +Here x is certainly demanded. But after we've nuked +the case, we'll get just + let x = (a,b) in h a b x +and now x is not demanded (I'm assuming h is lazy) +This really happens. Similarly + let f = \x -> e in ...f..f... +After inlining f at some of its call sites the original binding may +(for example) be no longer strictly demanded. +The solution here is a bit ad hoc... + + +************************************************************************ +* * +\subsection[Simplify-simplExpr]{The main function: simplExpr} +* * +************************************************************************ + +The reason for this OutExprStuff stuff is that we want to float *after* +simplifying a RHS, not before. If we do so naively we get quadratic +behaviour as things float out. + +To see why it's important to do it after, consider this (real) example: + + let t = f x + in fst t +==> + let t = let a = e1 + b = e2 + in (a,b) + in fst t +==> + let a = e1 + b = e2 + t = (a,b) + in + a -- Can't inline a this round, cos it appears twice +==> + e1 + +Each of the ==> steps is a round of simplification. We'd save a +whole round if we float first. This can cascade. Consider + + let f = g d + in \x -> ...f... +==> + let f = let d1 = ..d.. in \y -> e + in \x -> ...f... +==> + let d1 = ..d.. + in \x -> ...(\y ->e)... + +Only in this second round can the \y be applied, and it +might do the same again. +-} + +simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr +simplExpr env (Type ty) + = do { ty' <- simplType env ty -- See Note [Avoiding space leaks in OutType] + ; return (Type ty') } + +simplExpr env expr + = simplExprC env expr (mkBoringStop expr_out_ty) + where + expr_out_ty :: OutType + expr_out_ty = substTy env (exprType expr) + -- NB: Since 'expr' is term-valued, not (Type ty), this call + -- to exprType will succeed. exprType fails on (Type ty). + +simplExprC :: SimplEnv + -> InExpr -- A term-valued expression, never (Type ty) + -> SimplCont + -> SimplM OutExpr + -- Simplify an expression, given a continuation +simplExprC env expr cont + = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $ + do { (floats, expr') <- simplExprF env expr cont + ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ + -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ + -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $ + return (wrapFloats floats expr') } + +-------------------------------------------------- +simplExprF :: SimplEnv + -> InExpr -- A term-valued expression, never (Type ty) + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplExprF env e cont + = {- pprTrace "simplExprF" (vcat + [ ppr e + , text "cont =" <+> ppr cont + , text "inscope =" <+> ppr (seInScope env) + , text "tvsubst =" <+> ppr (seTvSubst env) + , text "idsubst =" <+> ppr (seIdSubst env) + , text "cvsubst =" <+> ppr (seCvSubst env) + ]) $ -} + simplExprF1 env e cont + +simplExprF1 :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplExprF1 _ (Type ty) _ + = pprPanic "simplExprF: type" (ppr ty) + -- simplExprF does only with term-valued expressions + -- The (Type ty) case is handled separately by simplExpr + -- and by the other callers of simplExprF + +simplExprF1 env (Var v) cont = {-#SCC "simplIdF" #-} simplIdF env v cont +simplExprF1 env (Lit lit) cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont +simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t expr cont +simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont +simplExprF1 env (Coercion co) cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont + +simplExprF1 env (App fun arg) cont + = {-#SCC "simplExprF1-App" #-} case arg of + Type ty -> do { -- The argument type will (almost) certainly be used + -- in the output program, so just force it now. + -- See Note [Avoiding space leaks in OutType] + arg' <- simplType env ty + + -- But use substTy, not simplType, to avoid forcing + -- the hole type; it will likely not be needed. + -- See Note [The hole type in ApplyToTy] + ; let hole' = substTy env (exprType fun) + + ; simplExprF env fun $ + ApplyToTy { sc_arg_ty = arg' + , sc_hole_ty = hole' + , sc_cont = cont } } + _ -> simplExprF env fun $ + ApplyToVal { sc_arg = arg, sc_env = env + , sc_dup = NoDup, sc_cont = cont } + +simplExprF1 env expr@(Lam {}) cont + = {-#SCC "simplExprF1-Lam" #-} + simplLam env zapped_bndrs body cont + -- The main issue here is under-saturated lambdas + -- (\x1. \x2. e) arg1 + -- Here x1 might have "occurs-once" occ-info, because occ-info + -- is computed assuming that a group of lambdas is applied + -- all at once. If there are too few args, we must zap the + -- occ-info, UNLESS the remaining binders are one-shot + where + (bndrs, body) = collectBinders expr + zapped_bndrs | need_to_zap = map zap bndrs + | otherwise = bndrs + + need_to_zap = any zappable_bndr (drop n_args bndrs) + n_args = countArgs cont + -- NB: countArgs counts all the args (incl type args) + -- and likewise drop counts all binders (incl type lambdas) + + zappable_bndr b = isId b && not (isOneShotBndr b) + zap b | isTyVar b = b + | otherwise = zapLamIdInfo b + +simplExprF1 env (Case scrut bndr _ alts) cont + = {-#SCC "simplExprF1-Case" #-} + simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr + , sc_alts = alts + , sc_env = env, sc_cont = cont }) + +simplExprF1 env (Let (Rec pairs) body) cont + | Just pairs' <- joinPointBindings_maybe pairs + = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont + + | otherwise + = {-#SCC "simplRecE" #-} simplRecE env pairs body cont + +simplExprF1 env (Let (NonRec bndr rhs) body) cont + | Type ty <- rhs -- First deal with type lets (let a = Type ty in e) + = {-#SCC "simplExprF1-NonRecLet-Type" #-} + ASSERT( isTyVar bndr ) + do { ty' <- simplType env ty + ; simplExprF (extendTvSubst env bndr ty') body cont } + + | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs + = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont + + | otherwise + = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) ([], body) cont + +{- Note [Avoiding space leaks in OutType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the simplifier is run for multiple iterations, we need to ensure +that any thunks in the output of one simplifier iteration are forced +by the evaluation of the next simplifier iteration. Otherwise we may +retain multiple copies of the Core program and leak a terrible amount +of memory (as in #13426). + +The simplifier is naturally strict in the entire "Expr part" of the +input Core program, because any expression may contain binders, which +we must find in order to extend the SimplEnv accordingly. But types +do not contain binders and so it is tempting to write things like + + simplExpr env (Type ty) = return (Type (substTy env ty)) -- Bad! + +This is Bad because the result includes a thunk (substTy env ty) which +retains a reference to the whole simplifier environment; and the next +simplifier iteration will not force this thunk either, because the +line above is not strict in ty. + +So instead our strategy is for the simplifier to fully evaluate +OutTypes when it emits them into the output Core program, for example + + simplExpr env (Type ty) = do { ty' <- simplType env ty -- Good + ; return (Type ty') } + +where the only difference from above is that simplType calls seqType +on the result of substTy. + +However, SimplCont can also contain OutTypes and it's not necessarily +a good idea to force types on the way in to SimplCont, because they +may end up not being used and forcing them could be a lot of wasted +work. T5631 is a good example of this. + +- For ApplyToTy's sc_arg_ty, we force the type on the way in because + the type will almost certainly appear as a type argument in the + output program. + +- For the hole types in Stop and ApplyToTy, we force the type when we + emit it into the output program, after obtaining it from + contResultType. (The hole type in ApplyToTy is only directly used + to form the result type in a new Stop continuation.) +-} + +--------------------------------- +-- Simplify a join point, adding the context. +-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do: +-- \x1 .. xn -> e => \x1 .. xn -> E[e] +-- Note that we need the arity of the join point, since e may be a lambda +-- (though this is unlikely). See Note [Join points and case-of-case]. +simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont + -> SimplM OutExpr +simplJoinRhs env bndr expr cont + | Just arity <- isJoinId_maybe bndr + = do { let (join_bndrs, join_body) = collectNBinders arity expr + ; (env', join_bndrs') <- simplLamBndrs env join_bndrs + ; join_body' <- simplExprC env' join_body cont + ; return $ mkLams join_bndrs' join_body' } + + | otherwise + = pprPanic "simplJoinRhs" (ppr bndr) + +--------------------------------- +simplType :: SimplEnv -> InType -> SimplM OutType + -- Kept monadic just so we can do the seqType + -- See Note [Avoiding space leaks in OutType] +simplType env ty + = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ + seqType new_ty `seq` return new_ty + where + new_ty = substTy env ty + +--------------------------------- +simplCoercionF :: SimplEnv -> InCoercion -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplCoercionF env co cont + = do { co' <- simplCoercion env co + ; rebuild env (Coercion co') cont } + +simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion +simplCoercion env co + = do { dflags <- getDynFlags + ; let opt_co = optCoercion dflags (getTCvSubst env) co + ; seqCo opt_co `seq` return opt_co } + +----------------------------------- +-- | Push a TickIt context outwards past applications and cases, as +-- long as this is a non-scoping tick, to let case and application +-- optimisations apply. + +simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplTick env tickish expr cont + -- A scoped tick turns into a continuation, so that we can spot + -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do + -- it this way, then it would take two passes of the simplifier to + -- reduce ((scc t (\x . e)) e'). + -- NB, don't do this with counting ticks, because if the expr is + -- bottom, then rebuildCall will discard the continuation. + +-- XXX: we cannot do this, because the simplifier assumes that +-- the context can be pushed into a case with a single branch. e.g. +-- scc case expensive of p -> e +-- becomes +-- case expensive of p -> scc e +-- +-- So I'm disabling this for now. It just means we will do more +-- simplifier iterations that necessary in some cases. + +-- | tickishScoped tickish && not (tickishCounts tickish) +-- = simplExprF env expr (TickIt tickish cont) + + -- For unscoped or soft-scoped ticks, we are allowed to float in new + -- cost, so we simply push the continuation inside the tick. This + -- has the effect of moving the tick to the outside of a case or + -- application context, allowing the normal case and application + -- optimisations to fire. + | tickish `tickishScopesLike` SoftScope + = do { (floats, expr') <- simplExprF env expr cont + ; return (floats, mkTick tickish expr') + } + + -- Push tick inside if the context looks like this will allow us to + -- do a case-of-case - see Note [case-of-scc-of-case] + | Select {} <- cont, Just expr' <- push_tick_inside + = simplExprF env expr' cont + + -- We don't want to move the tick, but we might still want to allow + -- floats to pass through with appropriate wrapping (or not, see + -- wrap_floats below) + --- | not (tickishCounts tickish) || tickishCanSplit tickish + -- = wrap_floats + + | otherwise + = no_floating_past_tick + + where + + -- Try to push tick inside a case, see Note [case-of-scc-of-case]. + push_tick_inside = + case expr0 of + Case scrut bndr ty alts + -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts) + _other -> Nothing + where (ticks, expr0) = stripTicksTop movable (Tick tickish expr) + movable t = not (tickishCounts t) || + t `tickishScopesLike` NoScope || + tickishCanSplit t + tickScrut e = foldr mkTick e ticks + -- Alternatives get annotated with all ticks that scope in some way, + -- but we don't want to count entries. + tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope) + ts_scope = map mkNoCount $ + filter (not . (`tickishScopesLike` NoScope)) ticks + + no_floating_past_tick = + do { let (inc,outc) = splitCont cont + ; (floats, expr1) <- simplExprF env expr inc + ; let expr2 = wrapFloats floats expr1 + tickish' = simplTickish env tickish + ; rebuild env (mkTick tickish' expr2) outc + } + +-- Alternative version that wraps outgoing floats with the tick. This +-- results in ticks being duplicated, as we don't make any attempt to +-- eliminate the tick if we re-inline the binding (because the tick +-- semantics allows unrestricted inlining of HNFs), so I'm not doing +-- this any more. FloatOut will catch any real opportunities for +-- floating. +-- +-- wrap_floats = +-- do { let (inc,outc) = splitCont cont +-- ; (env', expr') <- simplExprF (zapFloats env) expr inc +-- ; let tickish' = simplTickish env tickish +-- ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0), +-- mkTick (mkNoCount tickish') rhs) +-- -- when wrapping a float with mkTick, we better zap the Id's +-- -- strictness info and arity, because it might be wrong now. +-- ; let env'' = addFloats env (mapFloats env' wrap_float) +-- ; rebuild env'' expr' (TickIt tickish' outc) +-- } + + + simplTickish env tickish + | Breakpoint n ids <- tickish + = Breakpoint n (map (getDoneId . substId env) ids) + | otherwise = tickish + + -- Push type application and coercion inside a tick + splitCont :: SimplCont -> (SimplCont, SimplCont) + splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc) + where (inc,outc) = splitCont tail + splitCont (CastIt co c) = (CastIt co inc, outc) + where (inc,outc) = splitCont c + splitCont other = (mkBoringStop (contHoleType other), other) + + getDoneId (DoneId id) = id + getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst + getDoneId other = pprPanic "getDoneId" (ppr other) + +-- Note [case-of-scc-of-case] +-- It's pretty important to be able to transform case-of-case when +-- there's an SCC in the way. For example, the following comes up +-- in nofib/real/compress/Encode.hs: +-- +-- case scctick +-- case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje +-- of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) -> +-- (ww1_s13f, ww2_s13g, ww3_s13h) +-- } +-- of _ { (ww_s12Y, ww1_s12Z, ww2_s130) -> +-- tick +-- (ww_s12Y, +-- ww1_s12Z, +-- PTTrees.PT +-- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf) +-- } +-- +-- We really want this case-of-case to fire, because then the 3-tuple +-- will go away (indeed, the CPR optimisation is relying on this +-- happening). But the scctick is in the way - we need to push it +-- inside to expose the case-of-case. So we perform this +-- transformation on the inner case: +-- +-- scctick c (case e of { p1 -> e1; ...; pn -> en }) +-- ==> +-- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en } +-- +-- So we've moved a constant amount of work out of the scc to expose +-- the case. We only do this when the continuation is interesting: in +-- for now, it has to be another Case (maybe generalise this later). + +{- +************************************************************************ +* * +\subsection{The main rebuilder} +* * +************************************************************************ +-} + +rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) +-- At this point the substitution in the SimplEnv should be irrelevant; +-- only the in-scope set matters +rebuild env expr cont + = case cont of + Stop {} -> return (emptyFloats env, expr) + TickIt t cont -> rebuild env (mkTick t expr) cont + CastIt co cont -> rebuild env (mkCast expr co) cont + -- NB: mkCast implements the (Coercion co |> g) optimisation + + Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } + -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont + + StrictArg { sc_fun = fun, sc_cont = cont } + -> rebuildCall env (fun `addValArgTo` expr) cont + StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body + , sc_env = se, sc_cont = cont } + -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr + -- expr satisfies let/app since it started life + -- in a call to simplNonRecE + ; (floats2, expr') <- simplLam env' bs body cont + ; return (floats1 `addFloats` floats2, expr') } + + ApplyToTy { sc_arg_ty = ty, sc_cont = cont} + -> rebuild env (App expr (Type ty)) cont + + ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont} + -- See Note [Avoid redundant simplification] + -> do { (_, _, arg') <- simplArg env dup_flag se arg + ; rebuild env (App expr arg') cont } + +{- +************************************************************************ +* * +\subsection{Lambdas} +* * +************************************************************************ +-} + +{- Note [Optimising reflexivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important (for compiler performance) to get rid of reflexivity as soon +as it appears. See #11735, #14737, and #15019. + +In particular, we want to behave well on + + * e |> co1 |> co2 + where the two happen to cancel out entirely. That is quite common; + e.g. a newtype wrapping and unwrapping cancel. + + + * (f |> co) @t1 @t2 ... @tn x1 .. xm + Here we wil use pushCoTyArg and pushCoValArg successively, which + build up NthCo stacks. Silly to do that if co is reflexive. + +However, we don't want to call isReflexiveCo too much, because it uses +type equality which is expensive on big types (#14737 comment:7). + +A good compromise (determined experimentally) seems to be to call +isReflexiveCo + * when composing casts, and + * at the end + +In investigating this I saw missed opportunities for on-the-fly +coercion shrinkage. See #15090. +-} + + +simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplCast env body co0 cont0 + = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0 + ; cont1 <- {-#SCC "simplCast-addCoerce" #-} + if isReflCo co1 + then return cont0 -- See Note [Optimising reflexivity] + else addCoerce co1 cont0 + ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } + where + -- If the first parameter is MRefl, then simplifying revealed a + -- reflexive coercion. Omit. + addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont + addCoerceM MRefl cont = return cont + addCoerceM (MCo co) cont = addCoerce co cont + + addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont + addCoerce co1 (CastIt co2 cont) -- See Note [Optimising reflexivity] + | isReflexiveCo co' = return cont + | otherwise = addCoerce co' cont + where + co' = mkTransCo co1 co2 + + addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) + | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty + -- N.B. As mentioned in Note [The hole type in ApplyToTy] this is + -- only needed by `sc_hole_ty` which is often not forced. + -- Consequently it is worthwhile using a lazy pattern match here to + -- avoid unnecessary coercionKind evaluations. + , let hole_ty = coercionLKind co + = {-#SCC "addCoerce-pushCoTyArg" #-} + do { tail' <- addCoerceM m_co' tail + ; return (cont { sc_arg_ty = arg_ty' + , sc_hole_ty = hole_ty -- NB! As the cast goes past, the + -- type of the hole changes (#16312) + , sc_cont = tail' }) } + + addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup, sc_cont = tail }) + | Just (co1, m_co2) <- pushCoValArg co + , let new_ty = coercionRKind co1 + , not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg + -- See Note [Levity polymorphism invariants] in GHC.Core + -- test: typecheck/should_run/EtaExpandLevPoly + = {-#SCC "addCoerce-pushCoValArg" #-} + do { tail' <- addCoerceM m_co2 tail + ; if isReflCo co1 + then return (cont { sc_cont = tail' }) + -- Avoid simplifying if possible; + -- See Note [Avoiding exponential behaviour] + else do + { (dup', arg_se', arg') <- simplArg env dup arg_se arg + -- When we build the ApplyTo we can't mix the OutCoercion + -- 'co' with the InExpr 'arg', so we simplify + -- to make it all consistent. It's a bit messy. + -- But it isn't a common case. + -- Example of use: #995 + ; return (ApplyToVal { sc_arg = mkCast arg' co1 + , sc_env = arg_se' + , sc_dup = dup' + , sc_cont = tail' }) } } + + addCoerce co cont + | isReflexiveCo co = return cont -- Having this at the end makes a huge + -- difference in T12227, for some reason + -- See Note [Optimising reflexivity] + | otherwise = return (CastIt co cont) + +simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr + -> SimplM (DupFlag, StaticEnv, OutExpr) +simplArg env dup_flag arg_env arg + | isSimplified dup_flag + = return (dup_flag, arg_env, arg) + | otherwise + = do { arg' <- simplExpr (arg_env `setInScopeFromE` env) arg + ; return (Simplified, zapSubstEnv arg_env, arg') } + +{- +************************************************************************ +* * +\subsection{Lambdas} +* * +************************************************************************ +-} + +simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplLam env [] body cont + = simplExprF env body cont + +simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) + = do { tick (BetaReduction bndr) + ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont } + +simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_cont = cont, sc_dup = dup }) + | isSimplified dup -- Don't re-simplify if we've simplified it once + -- See Note [Avoiding exponential behaviour] + = do { tick (BetaReduction bndr) + ; (floats1, env') <- simplNonRecX env zapped_bndr arg + ; (floats2, expr') <- simplLam env' bndrs body cont + ; return (floats1 `addFloats` floats2, expr') } + + | otherwise + = do { tick (BetaReduction bndr) + ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont } + where + zapped_bndr -- See Note [Zap unfolding when beta-reducing] + | isId bndr = zapStableUnfolding bndr + | otherwise = bndr + + -- Discard a non-counting tick on a lambda. This may change the + -- cost attribution slightly (moving the allocation of the + -- lambda elsewhere), but we don't care: optimisation changes + -- cost attribution all the time. +simplLam env bndrs body (TickIt tickish cont) + | not (tickishCounts tickish) + = simplLam env bndrs body cont + + -- Not enough args, so there are real lambdas left to put in the result +simplLam env bndrs body cont + = do { (env', bndrs') <- simplLamBndrs env bndrs + ; body' <- simplExpr env' body + ; new_lam <- mkLam env bndrs' body' cont + ; rebuild env' new_lam cont } + +------------- +simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- Used for lambda binders. These sometimes have unfoldings added by +-- the worker/wrapper pass that must be preserved, because they can't +-- be reconstructed from context. For example: +-- f x = case x of (a,b) -> fw a b x +-- fw a b x{=(a,b)} = ... +-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise. +simplLamBndr env bndr + | isId bndr && hasCoreUnfolding old_unf -- Special case + = do { (env1, bndr1) <- simplBinder env bndr + ; unf' <- simplStableUnfolding env1 NotTopLevel Nothing bndr + old_unf (idType bndr1) + ; let bndr2 = bndr1 `setIdUnfolding` unf' + ; return (modifyInScope env1 bndr2, bndr2) } + + | otherwise + = simplBinder env bndr -- Normal case + where + old_unf = idUnfolding bndr + +simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) +simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs + +------------------ +simplNonRecE :: SimplEnv + -> InId -- The binder, always an Id + -- Never a join point + -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) + -> ([InBndr], InExpr) -- Body of the let/lambda + -- \xs.e + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- simplNonRecE is used for +-- * non-top-level non-recursive non-join-point lets in expressions +-- * beta reduction +-- +-- simplNonRec env b (rhs, rhs_se) (bs, body) k +-- = let env in +-- cont< let b = rhs_se(rhs) in \bs.body > +-- +-- It deals with strict bindings, via the StrictBind continuation, +-- which may abort the whole process +-- +-- Precondition: rhs satisfies the let/app invariant +-- Note [Core let/app invariant] in GHC.Core +-- +-- The "body" of the binding comes as a pair of ([InId],InExpr) +-- representing a lambda; so we recurse back to simplLam +-- Why? Because of the binder-occ-info-zapping done before +-- the call to simplLam in simplExprF (Lam ...) + +simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont + | ASSERT( isId bndr && not (isJoinId bndr) ) True + , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se + = do { tick (PreInlineUnconditionally bndr) + ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ + simplLam env' bndrs body cont } + + -- Deal with strict bindings + | isStrictId bndr -- Includes coercions + , sm_case_case (getMode env) + = simplExprF (rhs_se `setInScopeFromE` env) rhs + (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body + , sc_env = env, sc_cont = cont, sc_dup = NoDup }) + + -- Deal with lazy bindings + | otherwise + = ASSERT( not (isTyVar bndr) ) + do { (env1, bndr1) <- simplNonRecBndr env bndr + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing + ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se + ; (floats2, expr') <- simplLam env3 bndrs body cont + ; return (floats1 `addFloats` floats2, expr') } + +------------------ +simplRecE :: SimplEnv + -> [(InId, InExpr)] + -> InExpr + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- simplRecE is used for +-- * non-top-level recursive lets in expressions +simplRecE env pairs body cont + = do { let bndrs = map fst pairs + ; MASSERT(all (not . isJoinId) bndrs) + ; env1 <- simplRecBndrs env bndrs + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down + ; (floats1, env2) <- simplRecBind env1 NotTopLevel Nothing pairs + ; (floats2, expr') <- simplExprF env2 body cont + ; return (floats1 `addFloats` floats2, expr') } + +{- Note [Avoiding exponential behaviour] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One way in which we can get exponential behaviour is if we simplify a +big expression, and the re-simplify it -- and then this happens in a +deeply-nested way. So we must be jolly careful about re-simplifying +an expression. That is why completeNonRecX does not try +preInlineUnconditionally. + +Example: + f BIG, where f has a RULE +Then + * We simplify BIG before trying the rule; but the rule does not fire + * We inline f = \x. x True + * So if we did preInlineUnconditionally we'd re-simplify (BIG True) + +However, if BIG has /not/ already been simplified, we'd /like/ to +simplify BIG True; maybe good things happen. That is why + +* simplLam has + - a case for (isSimplified dup), which goes via simplNonRecX, and + - a case for the un-simplified case, which goes via simplNonRecE + +* We go to some efforts to avoid unnecessarily simplifying ApplyToVal, + in at least two places + - In simplCast/addCoerce, where we check for isReflCo + - In rebuildCall we avoid simplifying arguments before we have to + (see Note [Trying rewrite rules]) + + +Note [Zap unfolding when beta-reducing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Lambda-bound variables can have stable unfoldings, such as + $j = \x. \b{Unf=Just x}. e +See Note [Case binders and join points] below; the unfolding for lets +us optimise e better. However when we beta-reduce it we want to +revert to using the actual value, otherwise we can end up in the +stupid situation of + let x = blah in + let b{Unf=Just x} = y + in ...b... +Here it'd be far better to drop the unfolding and use the actual RHS. + +************************************************************************ +* * + Join points +* * +********************************************************************* -} + +{- Note [Rules and unfolding for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + simplExpr (join j x = rhs ) cont + ( {- RULE j (p:ps) = blah -} ) + ( {- StableUnfolding j = blah -} ) + (in blah ) + +Then we will push 'cont' into the rhs of 'j'. But we should *also* push +'cont' into the RHS of + * Any RULEs for j, e.g. generated by SpecConstr + * Any stable unfolding for j, e.g. the result of an INLINE pragma + +Simplifying rules and stable-unfoldings happens a bit after +simplifying the right-hand side, so we remember whether or not it +is a join point, and what 'cont' is, in a value of type MaybeJoinCont + +#13900 was caused by forgetting to push 'cont' into the RHS +of a SpecConstr-generated RULE for a join point. +-} + +type MaybeJoinCont = Maybe SimplCont + -- Nothing => Not a join point + -- Just k => This is a join binding with continuation k + -- See Note [Rules and unfolding for join points] + +simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr + -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplNonRecJoinPoint env bndr rhs body cont + | ASSERT( isJoinId bndr ) True + , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env + = do { tick (PreInlineUnconditionally bndr) + ; simplExprF env' body cont } + + | otherwise + = wrapJoinCont env cont $ \ env cont -> + do { -- We push join_cont into the join RHS and the body; + -- and wrap wrap_cont around the whole thing + ; let res_ty = contResultType cont + ; (env1, bndr1) <- simplNonRecJoinBndr env res_ty bndr + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (Just cont) + ; (floats1, env3) <- simplJoinBind env2 cont bndr bndr2 rhs env + ; (floats2, body') <- simplExprF env3 body cont + ; return (floats1 `addFloats` floats2, body') } + + +------------------ +simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] + -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplRecJoinPoint env pairs body cont + = wrapJoinCont env cont $ \ env cont -> + do { let bndrs = map fst pairs + res_ty = contResultType cont + ; env1 <- simplRecJoinBndrs env res_ty bndrs + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down + ; (floats1, env2) <- simplRecBind env1 NotTopLevel (Just cont) pairs + ; (floats2, body') <- simplExprF env2 body cont + ; return (floats1 `addFloats` floats2, body') } + +-------------------- +wrapJoinCont :: SimplEnv -> SimplCont + -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) + -> SimplM (SimplFloats, OutExpr) +-- Deal with making the continuation duplicable if necessary, +-- and with the no-case-of-case situation. +wrapJoinCont env cont thing_inside + | contIsStop cont -- Common case; no need for fancy footwork + = thing_inside env cont + + | not (sm_case_case (getMode env)) + -- See Note [Join points with -fno-case-of-case] + = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) + ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 + ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont + ; return (floats2 `addFloats` floats3, expr3) } + + | otherwise + -- Normal case; see Note [Join points and case-of-case] + = do { (floats1, cont') <- mkDupableCont env cont + ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' + ; return (floats1 `addFloats` floats2, result) } + + +-------------------- +trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont +-- Drop outer context from join point invocation (jump) +-- See Note [Join points and case-of-case] + +trimJoinCont _ Nothing cont + = cont -- Not a jump +trimJoinCont var (Just arity) cont + = trim arity cont + where + trim 0 cont@(Stop {}) + = cont + trim 0 cont + = mkBoringStop (contResultType cont) + trim n cont@(ApplyToVal { sc_cont = k }) + = cont { sc_cont = trim (n-1) k } + trim n cont@(ApplyToTy { sc_cont = k }) + = cont { sc_cont = trim (n-1) k } -- join arity counts types! + trim _ cont + = pprPanic "completeCall" $ ppr var $$ ppr cont + + +{- Note [Join points and case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we perform the case-of-case transform (or otherwise push continuations +inward), we want to treat join points specially. Since they're always +tail-called and we want to maintain this invariant, we can do this (for any +evaluation context E): + + E[join j = e + in case ... of + A -> jump j 1 + B -> jump j 2 + C -> f 3] + + --> + + join j = E[e] + in case ... of + A -> jump j 1 + B -> jump j 2 + C -> E[f 3] + +As is evident from the example, there are two components to this behavior: + + 1. When entering the RHS of a join point, copy the context inside. + 2. When a join point is invoked, discard the outer context. + +We need to be very careful here to remain consistent---neither part is +optional! + +We need do make the continuation E duplicable (since we are duplicating it) +with mkDupableCont. + + +Note [Join points with -fno-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Supose case-of-case is switched off, and we are simplifying + + case (join j x = in + case y of + A -> j 1 + B -> j 2 + C -> e) of + +Usually, we'd push the outer continuation (case . of ) into +both the RHS and the body of the join point j. But since we aren't doing +case-of-case we may then end up with this totally bogus result + + join x = case of in + case (case y of + A -> j 1 + B -> j 2 + C -> e) of + +This would be OK in the language of the paper, but not in GHC: j is no longer +a join point. We can only do the "push continuation into the RHS of the +join point j" if we also push the continuation right down to the /jumps/ to +j, so that it can evaporate there. If we are doing case-of-case, we'll get to + + join x = case of in + case y of + A -> j 1 + B -> j 2 + C -> case e of + +which is great. + +Bottom line: if case-of-case is off, we must stop pushing the continuation +inwards altogether at any join point. Instead simplify the (join ... in ...) +with a Stop continuation, and wrap the original continuation around the +outside. Surprisingly tricky! + + +************************************************************************ +* * + Variables +* * +************************************************************************ +-} + +simplVar :: SimplEnv -> InVar -> SimplM OutExpr +-- Look up an InVar in the environment +simplVar env var + | isTyVar var = return (Type (substTyVar env var)) + | isCoVar var = return (Coercion (substCoVar env var)) + | otherwise + = case substId env var of + ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e + DoneId var1 -> return (Var var1) + DoneEx e _ -> return e + +simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) +simplIdF env var cont + = case substId env var of + ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont + -- Don't trim; haven't already simplified e, + -- so the cont is not embodied in e + + DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont) + + DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont) + -- Note [zapSubstEnv] + -- The template is already simplified, so don't re-substitute. + -- This is VITAL. Consider + -- let x = e in + -- let y = \z -> ...x... in + -- \ x -> ...y... + -- We'll clone the inner \x, adding x->x' in the id_subst + -- Then when we inline y, we must *not* replace x by x' in + -- the inlined copy!! + +--------------------------------------------------------- +-- Dealing with a call site + +completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) +completeCall env var cont + | Just expr <- callSiteInline dflags var active_unf + lone_variable arg_infos interesting_cont + -- Inline the variable's RHS + = do { checkedTick (UnfoldingDone var) + ; dump_inline expr cont + ; simplExprF (zapSubstEnv env) expr cont } + + | otherwise + -- Don't inline; instead rebuild the call + = do { rule_base <- getSimplRules + ; let info = mkArgInfo env var (getRules rule_base var) + n_val_args call_cont + ; rebuildCall env info cont } + + where + dflags = seDynFlags env + (lone_variable, arg_infos, call_cont) = contArgs cont + n_val_args = length arg_infos + interesting_cont = interestingCallContext env call_cont + active_unf = activeUnfolding (getMode env) var + + log_inlining doc + = liftIO $ dumpAction dflags + (mkUserStyle dflags alwaysQualify AllTheWay) + (dumpOptionsFromFlag Opt_D_dump_inlinings) + "" FormatText doc + + dump_inline unfolding cont + | not (dopt Opt_D_dump_inlinings dflags) = return () + | not (dopt Opt_D_verbose_core2core dflags) + = when (isExternalName (idName var)) $ + log_inlining $ + sep [text "Inlining done:", nest 4 (ppr var)] + | otherwise + = liftIO $ log_inlining $ + sep [text "Inlining done: " <> ppr var, + nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr cont])] + +rebuildCall :: SimplEnv + -> ArgInfo + -> SimplCont + -> SimplM (SimplFloats, OutExpr) +-- We decided not to inline, so +-- - simplify the arguments +-- - try rewrite rules +-- - and rebuild + +---------- Bottoming applications -------------- +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont + -- When we run out of strictness args, it means + -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo + -- Then we want to discard the entire strict continuation. E.g. + -- * case (error "hello") of { ... } + -- * (error "Hello") arg + -- * f (error "Hello") where f is strict + -- etc + -- Then, especially in the first of these cases, we'd like to discard + -- the continuation, leaving just the bottoming expression. But the + -- type might not be right, so we may have to add a coerce. + | not (contIsTrivial cont) -- Only do this if there is a non-trivial + -- continuation to discard, else we do it + -- again and again! + = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] + return (emptyFloats env, castBottomExpr res cont_ty) + where + res = argInfoExpr fun rev_args + cont_ty = contResultType cont + +---------- Try rewrite RULES -------------- +-- See Note [Trying rewrite rules] +rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args + , ai_rules = Just (nr_wanted, rules) }) cont + | nr_wanted == 0 || no_more_args + , let info' = info { ai_rules = Nothing } + = -- We've accumulated a simplified call in + -- so try rewrite rules; see Note [RULEs apply to simplified arguments] + -- See also Note [Rules for recursive functions] + do { mb_match <- tryRules env rules fun (reverse rev_args) cont + ; case mb_match of + Just (env', rhs, cont') -> simplExprF env' rhs cont' + Nothing -> rebuildCall env info' cont } + where + no_more_args = case cont of + ApplyToTy {} -> False + ApplyToVal {} -> False + _ -> True + + +---------- Simplify applications and casts -------------- +rebuildCall env info (CastIt co cont) + = rebuildCall env (addCastTo info co) cont + +rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) + = rebuildCall env (addTyArgTo info arg_ty) cont + +rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty + , ai_strs = str:strs, ai_discs = disc:discs }) + (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup_flag, sc_cont = cont }) + | isSimplified dup_flag -- See Note [Avoid redundant simplification] + = rebuildCall env (addValArgTo info' arg) cont + + | str -- Strict argument + , sm_case_case (getMode env) + = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ + simplExprF (arg_se `setInScopeFromE` env) arg + (StrictArg { sc_fun = info', sc_cci = cci_strict + , sc_dup = Simplified, sc_cont = cont }) + -- Note [Shadowing] + + | otherwise -- Lazy argument + -- DO NOT float anything outside, hence simplExprC + -- There is no benefit (unlike in a let-binding), and we'd + -- have to be very careful about bogus strictness through + -- floating a demanded let. + = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg + (mkLazyArgStop arg_ty cci_lazy) + ; rebuildCall env (addValArgTo info' arg') cont } + where + info' = info { ai_strs = strs, ai_discs = discs } + arg_ty = funArgTy fun_ty + + -- Use this for lazy arguments + cci_lazy | encl_rules = RuleArgCtxt + | disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting + + -- ..and this for strict arguments + cci_strict | encl_rules = RuleArgCtxt + | disc > 0 = DiscArgCtxt + | otherwise = RhsCtxt + -- Why RhsCtxt? if we see f (g x) (h x), and f is strict, we + -- want to be a bit more eager to inline g, because it may + -- expose an eval (on x perhaps) that can be eliminated or + -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1 + -- It's worth an 18% improvement in allocation for this + -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier' + +---------- No further useful info, revert to generic rebuild ------------ +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont + = rebuild env (argInfoExpr fun rev_args) cont + +{- Note [Trying rewrite rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet +simplified. We want to simplify enough arguments to allow the rules +to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone +is sufficient. Example: class ops + (+) dNumInt e2 e3 +If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the +latter's strictness when simplifying e2, e3. Moreover, suppose we have + RULE f Int = \x. x True + +Then given (f Int e1) we rewrite to + (\x. x True) e1 +without simplifying e1. Now we can inline x into its unique call site, +and absorb the True into it all in the same pass. If we simplified +e1 first, we couldn't do that; see Note [Avoiding exponential behaviour]. + +So we try to apply rules if either + (a) no_more_args: we've run out of argument that the rules can "see" + (b) nr_wanted: none of the rules wants any more arguments + + +Note [RULES apply to simplified arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very desirable to try RULES once the arguments have been simplified, because +doing so ensures that rule cascades work in one pass. Consider + {-# RULES g (h x) = k x + f (k x) = x #-} + ...f (g (h x))... +Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If +we match f's rules against the un-simplified RHS, it won't match. This +makes a particularly big difference when superclass selectors are involved: + op ($p1 ($p2 (df d))) +We want all this to unravel in one sweep. + +Note [Avoid redundant simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because RULES apply to simplified arguments, there's a danger of repeatedly +simplifying already-simplified arguments. An important example is that of + (>>=) d e1 e2 +Here e1, e2 are simplified before the rule is applied, but don't really +participate in the rule firing. So we mark them as Simplified to avoid +re-simplifying them. + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +This part of the simplifier may break the no-shadowing invariant +Consider + f (...(\a -> e)...) (case y of (a,b) -> e') +where f is strict in its second arg +If we simplify the innermost one first we get (...(\a -> e)...) +Simplifying the second arg makes us float the case out, so we end up with + case y of (a,b) -> f (...(\a -> e)...) e' +So the output does not have the no-shadowing invariant. However, there is +no danger of getting name-capture, because when the first arg was simplified +we used an in-scope set that at least mentioned all the variables free in its +static environment, and that is enough. + +We can't just do innermost first, or we'd end up with a dual problem: + case x of (a,b) -> f e (...(\a -> e')...) + +I spent hours trying to recover the no-shadowing invariant, but I just could +not think of an elegant way to do it. The simplifier is already knee-deep in +continuations. We have to keep the right in-scope set around; AND we have +to get the effect that finding (error "foo") in a strict arg position will +discard the entire application and replace it with (error "foo"). Getting +all this at once is TOO HARD! + + +************************************************************************ +* * + Rewrite rules +* * +************************************************************************ +-} + +tryRules :: SimplEnv -> [CoreRule] + -> Id -> [ArgSpec] + -> SimplCont + -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) + +tryRules env rules fn args call_cont + | null rules + = return Nothing + +{- Disabled until we fix #8326 + | fn `hasKey` tagToEnumKey -- See Note [Optimising tagToEnum#] + , [_type_arg, val_arg] <- args + , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont + , isDeadBinder bndr + = do { let enum_to_tag :: CoreAlt -> CoreAlt + -- Takes K -> e into tagK# -> e + -- where tagK# is the tag of constructor K + enum_to_tag (DataAlt con, [], rhs) + = ASSERT( isEnumerationTyCon (dataConTyCon con) ) + (LitAlt tag, [], rhs) + where + tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG)) + enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt) + + new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts + new_bndr = setIdType bndr intPrimTy + -- The binder is dead, but should have the right type + ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) } +-} + + | Just (rule, rule_rhs) <- lookupRule dflags (getUnfoldingInRuleMatch env) + (activeRule (getMode env)) fn + (argInfoAppArgs args) rules + -- Fire a rule for the function + = do { checkedTick (RuleFired (ruleName rule)) + ; let cont' = pushSimplifiedArgs zapped_env + (drop (ruleArity rule) args) + call_cont + -- (ruleArity rule) says how + -- many args the rule consumed + + occ_anald_rhs = occurAnalyseExpr rule_rhs + -- See Note [Occurrence-analyse after rule firing] + ; dump rule rule_rhs + ; return (Just (zapped_env, occ_anald_rhs, cont')) } + -- The occ_anald_rhs and cont' are all Out things + -- hence zapping the environment + + | otherwise -- No rule fires + = do { nodump -- This ensures that an empty file is written + ; return Nothing } + + where + dflags = seDynFlags env + zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] + + printRuleModule rule + = parens (maybe (text "BUILTIN") + (pprModuleName . moduleName) + (ruleModule rule)) + + dump rule rule_rhs + | dopt Opt_D_dump_rule_rewrites dflags + = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat + [ text "Rule:" <+> ftext (ruleName rule) + , text "Module:" <+> printRuleModule rule + , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) + , text "After: " <+> pprCoreExpr rule_rhs + , text "Cont: " <+> ppr call_cont ] + + | dopt Opt_D_dump_rule_firings dflags + = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $ + ftext (ruleName rule) + <+> printRuleModule rule + + | otherwise + = return () + + nodump + | dopt Opt_D_dump_rule_rewrites dflags + = liftIO $ do + touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites) + + | dopt Opt_D_dump_rule_firings dflags + = liftIO $ do + touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings) + + | otherwise + = return () + + log_rule dflags flag hdr details + = liftIO $ do + let sty = mkDumpStyle dflags alwaysQualify + dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $ + sep [text hdr, nest 4 details] + +trySeqRules :: SimplEnv + -> OutExpr -> InExpr -- Scrutinee and RHS + -> SimplCont + -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) +-- See Note [User-defined RULES for seq] +trySeqRules in_env scrut rhs cont + = do { rule_base <- getSimplRules + ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont } + where + no_cast_scrut = drop_casts scrut + scrut_ty = exprType no_cast_scrut + seq_id_ty = idType seqId + res1_ty = piResultTy seq_id_ty rhs_rep + res2_ty = piResultTy res1_ty scrut_ty + rhs_ty = substTy in_env (exprType rhs) + rhs_rep = getRuntimeRep rhs_ty + out_args = [ TyArg { as_arg_ty = rhs_rep + , as_hole_ty = seq_id_ty } + , TyArg { as_arg_ty = scrut_ty + , as_hole_ty = res1_ty } + , TyArg { as_arg_ty = rhs_ty + , as_hole_ty = res2_ty } + , ValArg no_cast_scrut] + rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs + , sc_env = in_env, sc_cont = cont } + -- Lazily evaluated, so we don't do most of this + + drop_casts (Cast e _) = drop_casts e + drop_casts e = e + +{- Note [User-defined RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given + case (scrut |> co) of _ -> rhs +look for rules that match the expression + seq @t1 @t2 scrut +where scrut :: t1 + rhs :: t2 + +If you find a match, rewrite it, and apply to 'rhs'. + +Notice that we can simply drop casts on the fly here, which +makes it more likely that a rule will match. + +See Note [User-defined RULES for seq] in GHC.Types.Id.Make. + +Note [Occurrence-analyse after rule firing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After firing a rule, we occurrence-analyse the instantiated RHS before +simplifying it. Usually this doesn't make much difference, but it can +be huge. Here's an example (simplCore/should_compile/T7785) + + map f (map f (map f xs) + += -- Use build/fold form of map, twice + map f (build (\cn. foldr (mapFB c f) n + (build (\cn. foldr (mapFB c f) n xs)))) + += -- Apply fold/build rule + map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n)) + += -- Beta-reduce + -- Alas we have no occurrence-analysed, so we don't know + -- that c is used exactly once + map f (build (\cn. let c1 = mapFB c f in + foldr (mapFB c1 f) n xs)) + += -- Use mapFB rule: mapFB (mapFB c f) g = mapFB c (f.g) + -- We can do this because (mapFB c n) is a PAP and hence expandable + map f (build (\cn. let c1 = mapFB c n in + foldr (mapFB c (f.f)) n x)) + +This is not too bad. But now do the same with the outer map, and +we get another use of mapFB, and t can interact with /both/ remaining +mapFB calls in the above expression. This is stupid because actually +that 'c1' binding is dead. The outer map introduces another c2. If +there is a deep stack of maps we get lots of dead bindings, and lots +of redundant work as we repeatedly simplify the result of firing rules. + +The easy thing to do is simply to occurrence analyse the result of +the rule firing. Note that this occ-anals not only the RHS of the +rule, but also the function arguments, which by now are OutExprs. +E.g. + RULE f (g x) = x+1 + +Call f (g BIG) --> (\x. x+1) BIG + +The rule binders are lambda-bound and applied to the OutExpr arguments +(here BIG) which lack all internal occurrence info. + +Is this inefficient? Not really: we are about to walk over the result +of the rule firing to simplify it, so occurrence analysis is at most +a constant factor. + +Possible improvement: occ-anal the rules when putting them in the +database; and in the simplifier just occ-anal the OutExpr arguments. +But that's more complicated and the rule RHS is usually tiny; so I'm +just doing the simple thing. + +Historical note: previously we did occ-anal the rules in Rule.hs, +but failed to occ-anal the OutExpr arguments, which led to the +nasty performance problem described above. + + +Note [Optimising tagToEnum#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an enumeration data type: + + data Foo = A | B | C + +Then we want to transform + + case tagToEnum# x of ==> case x of + A -> e1 DEFAULT -> e1 + B -> e2 1# -> e2 + C -> e3 2# -> e3 + +thereby getting rid of the tagToEnum# altogether. If there was a DEFAULT +alternative we retain it (remember it comes first). If not the case must +be exhaustive, and we reflect that in the transformed version by adding +a DEFAULT. Otherwise Lint complains that the new case is not exhaustive. +See #8317. + +Note [Rules for recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that we shouldn't apply rules for a loop breaker: +doing so might give rise to an infinite loop, because a RULE is +rather like an extra equation for the function: + RULE: f (g x) y = x+y + Eqn: f a y = a-y + +But it's too drastic to disable rules for loop breakers. +Even the foldr/build rule would be disabled, because foldr +is recursive, and hence a loop breaker: + foldr k z (build g) = g k z +So it's up to the programmer: rules can cause divergence + + +************************************************************************ +* * + Rebuilding a case expression +* * +************************************************************************ + +Note [Case elimination] +~~~~~~~~~~~~~~~~~~~~~~~ +The case-elimination transformation discards redundant case expressions. +Start with a simple situation: + + case x# of ===> let y# = x# in e + y# -> e + +(when x#, y# are of primitive type, of course). We can't (in general) +do this for algebraic cases, because we might turn bottom into +non-bottom! + +The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise +this idea to look for a case where we're scrutinising a variable, and we know +that only the default case can match. For example: + + case x of + 0# -> ... + DEFAULT -> ...(case x of + 0# -> ... + DEFAULT -> ...) ... + +Here the inner case is first trimmed to have only one alternative, the +DEFAULT, after which it's an instance of the previous case. This +really only shows up in eliminating error-checking code. + +Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs. So + + case e of ===> case e of DEFAULT -> r + True -> r + False -> r + +Now again the case may be eliminated by the CaseElim transformation. +This includes things like (==# a# b#)::Bool so that we simplify + case ==# a# b# of { True -> x; False -> x } +to just + x +This particular example shows up in default methods for +comparison operations (e.g. in (>=) for Int.Int32) + +Note [Case to let transformation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a case over a lifted type has a single alternative, and is being +used as a strict 'let' (all isDeadBinder bndrs), we may want to do +this transformation: + + case e of r ===> let r = e in ...r... + _ -> ...r... + +We treat the unlifted and lifted cases separately: + +* Unlifted case: 'e' satisfies exprOkForSpeculation + (ok-for-spec is needed to satisfy the let/app invariant). + This turns case a +# b of r -> ...r... + into let r = a +# b in ...r... + and thence .....(a +# b).... + + However, if we have + case indexArray# a i of r -> ...r... + we might like to do the same, and inline the (indexArray# a i). + But indexArray# is not okForSpeculation, so we don't build a let + in rebuildCase (lest it get floated *out*), so the inlining doesn't + happen either. Annoying. + +* Lifted case: we need to be sure that the expression is already + evaluated (exprIsHNF). If it's not already evaluated + - we risk losing exceptions, divergence or + user-specified thunk-forcing + - even if 'e' is guaranteed to converge, we don't want to + create a thunk (call by need) instead of evaluating it + right away (call by value) + + However, we can turn the case into a /strict/ let if the 'r' is + used strictly in the body. Then we won't lose divergence; and + we won't build a thunk because the let is strict. + See also Note [Case-to-let for strictly-used binders] + + NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in GHC.Core.Make. + We want to turn + case (absentError "foo") of r -> ...MkT r... + into + let r = absentError "foo" in ...MkT r... + + +Note [Case-to-let for strictly-used binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have this: + case of r { _ -> ..r.. } + +where 'r' is used strictly in (..r..), we can safely transform to + let r = in ...r... + +This is a Good Thing, because 'r' might be dead (if the body just +calls error), or might be used just once (in which case it can be +inlined); or we might be able to float the let-binding up or down. +E.g. #15631 has an example. + +Note that this can change the error behaviour. For example, we might +transform + case x of { _ -> error "bad" } + --> error "bad" +which is might be puzzling if 'x' currently lambda-bound, but later gets +let-bound to (error "good"). + +Nevertheless, the paper "A semantics for imprecise exceptions" allows +this transformation. If you want to fix the evaluation order, use +'pseq'. See #8900 for an example where the loss of this +transformation bit us in practice. + +See also Note [Empty case alternatives] in GHC.Core. + +Historical notes + +There have been various earlier versions of this patch: + +* By Sept 18 the code looked like this: + || scrut_is_demanded_var scrut + + scrut_is_demanded_var :: CoreExpr -> Bool + scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s + scrut_is_demanded_var (Var _) = isStrictDmd (idDemandInfo case_bndr) + scrut_is_demanded_var _ = False + + This only fired if the scrutinee was a /variable/, which seems + an unnecessary restriction. So in #15631 I relaxed it to allow + arbitrary scrutinees. Less code, less to explain -- but the change + had 0.00% effect on nofib. + +* Previously, in Jan 13 the code looked like this: + || case_bndr_evald_next rhs + + case_bndr_evald_next :: CoreExpr -> Bool + -- See Note [Case binder next] + case_bndr_evald_next (Var v) = v == case_bndr + case_bndr_evald_next (Cast e _) = case_bndr_evald_next e + case_bndr_evald_next (App e _) = case_bndr_evald_next e + case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e + case_bndr_evald_next _ = False + + This patch was part of fixing #7542. See also + Note [Eta reduction of an eval'd function] in GHC.Core.Utils.) + + +Further notes about case elimination +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: test :: Integer -> IO () + test = print + +Turns out that this compiles to: + Print.test + = \ eta :: Integer + eta1 :: Void# -> + case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> + case hPutStr stdout + (PrelNum.jtos eta ($w[] @ Char)) + eta1 + of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} + +Notice the strange '<' which has no effect at all. This is a funny one. +It started like this: + +f x y = if x < 0 then jtos x + else if y==0 then "" else jtos x + +At a particular call site we have (f v 1). So we inline to get + + if v < 0 then jtos x + else if 1==0 then "" else jtos x + +Now simplify the 1==0 conditional: + + if v<0 then jtos v else jtos v + +Now common-up the two branches of the case: + + case (v<0) of DEFAULT -> jtos v + +Why don't we drop the case? Because it's strict in v. It's technically +wrong to drop even unnecessary evaluations, and in practice they +may be a result of 'seq' so we *definitely* don't want to drop those. +I don't really know how to improve this situation. + + +Note [FloatBinds from constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have FloatBinds coming from the constructor wrapper +(as in Note [exprIsConApp_maybe on data constructors with wrappers]), +we cannot float past them. We'd need to float the FloatBind +together with the simplify floats, unfortunately the +simplifier doesn't have case-floats. The simplest thing we can +do is to wrap all the floats here. The next iteration of the +simplifier will take care of all these cases and lets. + +Given data T = MkT !Bool, this allows us to simplify +case $WMkT b of { MkT x -> f x } +to +case b of { b' -> f b' }. + +We could try and be more clever (like maybe wfloats only contain +let binders, so we could float them). But the need for the +extra complication is not clear. +-} + +--------------------------------------------------------- +-- Eliminate the case if possible + +rebuildCase, reallyRebuildCase + :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Alternatives (increasing order) + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-------------------------------------------------- +-- 1. Eliminate the case if there's a known constructor +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts cont + | Lit lit <- scrut -- No need for same treatment as constructors + -- because literals are inlined more vigorously + , not (litIsLifted lit) + = do { tick (KnownBranch case_bndr) + ; case findAlt (LitAlt lit) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (_, bs, rhs) -> simple_rhs env [] scrut bs rhs } + + | Just (in_scope', wfloats, con, ty_args, other_args) + <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut + -- Works when the scrutinee is a variable with a known unfolding + -- as well as when it's an explicit constructor application + , let env0 = setInScopeSet env in_scope' + = do { tick (KnownBranch case_bndr) + ; case findAlt (DataAlt con) alts of + Nothing -> missingAlt env0 case_bndr alts cont + Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con) + `mkTyApps` ty_args + `mkApps` other_args + in simple_rhs env0 wfloats con_app bs rhs + Just (_, bs, rhs) -> knownCon env0 scrut wfloats con ty_args other_args + case_bndr bs rhs cont + } + where + simple_rhs env wfloats scrut' bs rhs = + ASSERT( null bs ) + do { (floats1, env') <- simplNonRecX env case_bndr scrut' + -- scrut is a constructor application, + -- hence satisfies let/app invariant + ; (floats2, expr') <- simplExprF env' rhs cont + ; case wfloats of + [] -> return (floats1 `addFloats` floats2, expr') + _ -> return + -- See Note [FloatBinds from constructor wrappers] + ( emptyFloats env, + GHC.Core.Make.wrapFloats wfloats $ + wrapFloats (floats1 `addFloats` floats2) expr' )} + + +-------------------------------------------------- +-- 2. Eliminate the case if scrutinee is evaluated +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont + -- See if we can get rid of the case altogether + -- See Note [Case elimination] + -- mkCase made sure that if all the alternatives are equal, + -- then there is now only one (DEFAULT) rhs + + -- 2a. Dropping the case altogether, if + -- a) it binds nothing (so it's really just a 'seq') + -- b) evaluating the scrutinee has no side effects + | is_plain_seq + , exprOkForSideEffects scrut + -- The entire case is dead, so we can drop it + -- if the scrutinee converges without having imperative + -- side effects or raising a Haskell exception + -- See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps + = simplExprF env rhs cont + + -- 2b. Turn the case into a let, if + -- a) it binds only the case-binder + -- b) unlifted case: the scrutinee is ok-for-speculation + -- lifted case: the scrutinee is in HNF (or will later be demanded) + -- See Note [Case to let transformation] + | all_dead_bndrs + , doCaseToLet scrut case_bndr + = do { tick (CaseElim case_bndr) + ; (floats1, env') <- simplNonRecX env case_bndr scrut + ; (floats2, expr') <- simplExprF env' rhs cont + ; return (floats1 `addFloats` floats2, expr') } + + -- 2c. Try the seq rules if + -- a) it binds only the case binder + -- b) a rule for seq applies + -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make + | is_plain_seq + = do { mb_rule <- trySeqRules env scrut rhs cont + ; case mb_rule of + Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont' + Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + where + all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] + is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect + +rebuildCase env scrut case_bndr alts cont + = reallyRebuildCase env scrut case_bndr alts cont + + +doCaseToLet :: OutExpr -- Scrutinee + -> InId -- Case binder + -> Bool +-- The situation is case scrut of b { DEFAULT -> body } +-- Can we transform thus? let { b = scrut } in body +doCaseToLet scrut case_bndr + | isTyCoVar case_bndr -- Respect GHC.Core + = isTyCoArg scrut -- Note [Core type and coercion invariant] + + | isUnliftedType (idType case_bndr) + = exprOkForSpeculation scrut + + | otherwise -- Scrut has a lifted type + = exprIsHNF scrut + || isStrictDmd (idDemandInfo case_bndr) + -- See Note [Case-to-let for strictly-used binders] + +-------------------------------------------------- +-- 3. Catch-all case +-------------------------------------------------- + +reallyRebuildCase env scrut case_bndr alts cont + | not (sm_case_case (getMode env)) + = do { case_expr <- simplAlts env scrut case_bndr alts + (mkBoringStop (contHoleType cont)) + ; rebuild env case_expr cont } + + | otherwise + = do { (floats, cont') <- mkDupableCaseCont env alts cont + ; case_expr <- simplAlts (env `setInScopeFromF` floats) + scrut case_bndr alts cont' + ; return (floats, case_expr) } + +{- +simplCaseBinder checks whether the scrutinee is a variable, v. If so, +try to eliminate uses of v in the RHSs in favour of case_bndr; that +way, there's a chance that v will now only be used once, and hence +inlined. + +Historical note: we use to do the "case binder swap" in the Simplifier +so there were additional complications if the scrutinee was a variable. +Now the binder-swap stuff is done in the occurrence analyser; see +OccurAnal Note [Binder swap]. + +Note [knownCon occ info] +~~~~~~~~~~~~~~~~~~~~~~~~ +If the case binder is not dead, then neither are the pattern bound +variables: + case of x { (a,b) -> + case x of { (p,q) -> p } } +Here (a,b) both look dead, but come alive after the inner case is eliminated. +The point is that we bring into the envt a binding + let x = (a,b) +after the outer case, and that makes (a,b) alive. At least we do unless +the case binder is guaranteed dead. + +Note [Case alternative occ info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are simply reconstructing a case (the common case), we always +zap the occurrence info on the binders in the alternatives. Even +if the case binder is dead, the scrutinee is usually a variable, and *that* +can bring the case-alternative binders back to life. +See Note [Add unfolding for scrutinee] + +Note [Improving seq] +~~~~~~~~~~~~~~~~~~~ +Consider + type family F :: * -> * + type instance F Int = Int + +We'd like to transform + case e of (x :: F Int) { DEFAULT -> rhs } +===> + case e `cast` co of (x'::Int) + I# x# -> let x = x' `cast` sym co + in rhs + +so that 'rhs' can take advantage of the form of x'. Notice that Note +[Case of cast] (in OccurAnal) may then apply to the result. + +We'd also like to eliminate empty types (#13468). So if + + data Void + type instance F Bool = Void + +then we'd like to transform + case (x :: F Bool) of { _ -> error "urk" } +===> + case (x |> co) of (x' :: Void) of {} + +Nota Bene: we used to have a built-in rule for 'seq' that dropped +casts, so that + case (x |> co) of { _ -> blah } +dropped the cast; in order to improve the chances of trySeqRules +firing. But that works in the /opposite/ direction to Note [Improving +seq] so there's a danger of flip/flopping. Better to make trySeqRules +insensitive to the cast, which is now is. + +The need for [Improving seq] showed up in Roman's experiments. Example: + foo :: F Int -> Int -> Int + foo t n = t `seq` bar n + where + bar 0 = 0 + bar n = bar (n - case t of TI i -> i) +Here we'd like to avoid repeated evaluating t inside the loop, by +taking advantage of the `seq`. + +At one point I did transformation in LiberateCase, but it's more +robust here. (Otherwise, there's a danger that we'll simply drop the +'seq' altogether, before LiberateCase gets to see it.) +-} + +simplAlts :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Non-empty + -> SimplCont + -> SimplM OutExpr -- Returns the complete simplified case expression + +simplAlts env0 scrut case_bndr alts cont' + = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr + , text "cont':" <+> ppr cont' + , text "in_scope" <+> ppr (seInScope env0) ]) + ; (env1, case_bndr1) <- simplBinder env0 case_bndr + ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding + env2 = modifyInScope env1 case_bndr2 + -- See Note [Case binder evaluated-ness] + + ; fam_envs <- getFamEnvs + ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut + case_bndr case_bndr2 alts + + ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts + -- NB: it's possible that the returned in_alts is empty: this is handled + -- by the caller (rebuildCase) in the missingAlt function + + ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts + ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $ + + ; let alts_ty' = contResultType cont' + -- See Note [Avoiding space leaks in OutType] + ; seqType alts_ty' `seq` + mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' } + + +------------------------------------ +improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv + -> OutExpr -> InId -> OutId -> [InAlt] + -> SimplM (SimplEnv, OutExpr, OutId) +-- Note [Improving seq] +improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] + | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) + = do { case_bndr2 <- newId (fsLit "nt") ty2 + ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing + env2 = extendIdSubst env case_bndr rhs + ; return (env2, scrut `Cast` co, case_bndr2) } + +improveSeq _ env scrut _ case_bndr1 _ + = return (env, scrut, case_bndr1) + + +------------------------------------ +simplAlt :: SimplEnv + -> Maybe OutExpr -- The scrutinee + -> [AltCon] -- These constructors can't be present when + -- matching the DEFAULT alternative + -> OutId -- The case binder + -> SimplCont + -> InAlt + -> SimplM OutAlt + +simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) + = ASSERT( null bndrs ) + do { let env' = addBinderUnfolding env case_bndr' + (mkOtherCon imposs_deflt_cons) + -- Record the constructors that the case-binder *can't* be. + ; rhs' <- simplExprC env' rhs cont' + ; return (DEFAULT, [], rhs') } + +simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs) + = ASSERT( null bndrs ) + do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) + ; rhs' <- simplExprC env' rhs cont' + ; return (LitAlt lit, [], rhs') } + +simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs) + = do { -- See Note [Adding evaluatedness info to pattern-bound variables] + let vs_with_evals = addEvals scrut' con vs + ; (env', vs') <- simplLamBndrs env vs_with_evals + + -- Bind the case-binder to (con args) + ; let inst_tys' = tyConAppArgs (idType case_bndr') + con_app :: OutExpr + con_app = mkConApp2 con inst_tys' vs' + + ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app + ; rhs' <- simplExprC env'' rhs cont' + ; return (DataAlt con, vs', rhs') } + +{- Note [Adding evaluatedness info to pattern-bound variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +addEvals records the evaluated-ness of the bound variables of +a case pattern. This is *important*. Consider + + data T = T !Int !Int + + case x of { T a b -> T (a+1) b } + +We really must record that b is already evaluated so that we don't +go and re-evaluate it when constructing the result. +See Note [Data-con worker strictness] in GHC.Core.DataCon + +NB: simplLamBndrs preserves this eval info + +In addition to handling data constructor fields with !s, addEvals +also records the fact that the result of seq# is always in WHNF. +See Note [seq# magic] in GHC.Core.Opt.ConstantFold. Example (#15226): + + case seq# v s of + (# s', v' #) -> E + +we want the compiler to be aware that v' is in WHNF in E. + +Open problem: we don't record that v itself is in WHNF (and we can't +do it here). The right thing is to do some kind of binder-swap; +see #15226 for discussion. +-} + +addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id] +-- See Note [Adding evaluatedness info to pattern-bound variables] +addEvals scrut con vs + -- Deal with seq# applications + | Just scr <- scrut + , isUnboxedTupleCon con + , [s,x] <- vs + -- Use stripNArgs rather than collectArgsTicks to avoid building + -- a list of arguments only to throw it away immediately. + , Just (Var f) <- stripNArgs 4 scr + , Just SeqOp <- isPrimOpId_maybe f + , let x' = zapIdOccInfoAndSetEvald MarkedStrict x + = [s, x'] + + -- Deal with banged datacon fields +addEvals _scrut con vs = go vs the_strs + where + the_strs = dataConRepStrictness con + + go [] [] = [] + go (v:vs') strs | isTyVar v = v : go vs' strs + go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs + go _ _ = pprPanic "Simplify.addEvals" + (ppr con $$ + ppr vs $$ + ppr_with_length (map strdisp the_strs) $$ + ppr_with_length (dataConRepArgTys con) $$ + ppr_with_length (dataConRepStrictness con)) + where + ppr_with_length list + = ppr list <+> parens (text "length =" <+> ppr (length list)) + strdisp MarkedStrict = text "MarkedStrict" + strdisp NotMarkedStrict = text "NotMarkedStrict" + +zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id +zapIdOccInfoAndSetEvald str v = + setCaseBndrEvald str $ -- Add eval'dness info + zapIdOccInfo v -- And kill occ info; + -- see Note [Case alternative occ info] + +addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv +addAltUnfoldings env scrut case_bndr con_app + = do { let con_app_unf = mk_simple_unf con_app + env1 = addBinderUnfolding env case_bndr con_app_unf + + -- See Note [Add unfolding for scrutinee] + env2 = case scrut of + Just (Var v) -> addBinderUnfolding env1 v con_app_unf + Just (Cast (Var v) co) -> addBinderUnfolding env1 v $ + mk_simple_unf (Cast con_app (mkSymCo co)) + _ -> env1 + + ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) + ; return env2 } + where + mk_simple_unf = mkSimpleUnfolding (seDynFlags env) + +addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv +addBinderUnfolding env bndr unf + | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf + = WARN( not (eqType (idType bndr) (exprType tmpl)), + ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) ) + modifyInScope env (bndr `setIdUnfolding` unf) + + | otherwise + = modifyInScope env (bndr `setIdUnfolding` unf) + +zapBndrOccInfo :: Bool -> Id -> Id +-- Consider case e of b { (a,b) -> ... } +-- Then if we bind b to (a,b) in "...", and b is not dead, +-- then we must zap the deadness info on a,b +zapBndrOccInfo keep_occ_info pat_id + | keep_occ_info = pat_id + | otherwise = zapIdOccInfo pat_id + +{- Note [Case binder evaluated-ness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pin on a (OtherCon []) unfolding to the case-binder of a Case, +even though it'll be over-ridden in every case alternative with a more +informative unfolding. Why? Because suppose a later, less clever, pass +simply replaces all occurrences of the case binder with the binder itself; +then Lint may complain about the let/app invariant. Example + case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in .... + ; K -> blah } + +The let/app invariant requires that y is evaluated in the call to +reallyUnsafePtrEq#, which it is. But we still want that to be true if we +propagate binders to occurrences. + +This showed up in #13027. + +Note [Add unfolding for scrutinee] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general it's unlikely that a variable scrutinee will appear +in the case alternatives case x of { ...x unlikely to appear... } +because the binder-swap in OccAnal has got rid of all such occurrences +See Note [Binder swap] in OccAnal. + +BUT it is still VERY IMPORTANT to add a suitable unfolding for a +variable scrutinee, in simplAlt. Here's why + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +There is no occurrence of 'b' in the (...(f y)...). But y gets +the unfolding (a,b), and *that* mentions b. If f has a RULE + RULE f (p, I# q) = ... +we want that rule to match, so we must extend the in-scope env with a +suitable unfolding for 'y'. It's *essential* for rule matching; but +it's also good for case-elimination -- suppose that 'f' was inlined +and did multi-level case analysis, then we'd solve it in one +simplifier sweep instead of two. + +Exactly the same issue arises in GHC.Core.Opt.SpecConstr; +see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr + +HOWEVER, given + case x of y { Just a -> r1; Nothing -> r2 } +we do not want to add the unfolding x -> y to 'x', which might seem cool, +since 'y' itself has different unfoldings in r1 and r2. Reason: if we +did that, we'd have to zap y's deadness info and that is a very useful +piece of information. + +So instead we add the unfolding x -> Just a, and x -> Nothing in the +respective RHSs. + + +************************************************************************ +* * +\subsection{Known constructor} +* * +************************************************************************ + +We are a bit careful with occurrence info. Here's an example + + (\x* -> case x of (a*, b) -> f a) (h v, e) + +where the * means "occurs once". This effectively becomes + case (h v, e) of (a*, b) -> f a) +and then + let a* = h v; b = e in f a +and then + f (h v) + +All this should happen in one sweep. +-} + +knownCon :: SimplEnv + -> OutExpr -- The scrutinee + -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) + -> InId -> [InBndr] -> InExpr -- The alternative + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont + = do { (floats1, env1) <- bind_args env bs dc_args + ; (floats2, env2) <- bind_case_bndr env1 + ; (floats3, expr') <- simplExprF env2 rhs cont + ; case dc_floats of + [] -> + return (floats1 `addFloats` floats2 `addFloats` floats3, expr') + _ -> + return ( emptyFloats env + -- See Note [FloatBinds from constructor wrappers] + , GHC.Core.Make.wrapFloats dc_floats $ + wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') } + where + zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId + + -- Ugh! + bind_args env' [] _ = return (emptyFloats env', env') + + bind_args env' (b:bs') (Type ty : args) + = ASSERT( isTyVar b ) + bind_args (extendTvSubst env' b ty) bs' args + + bind_args env' (b:bs') (Coercion co : args) + = ASSERT( isCoVar b ) + bind_args (extendCvSubst env' b co) bs' args + + bind_args env' (b:bs') (arg : args) + = ASSERT( isId b ) + do { let b' = zap_occ b + -- Note that the binder might be "dead", because it doesn't + -- occur in the RHS; and simplNonRecX may therefore discard + -- it via postInlineUnconditionally. + -- Nevertheless we must keep it if the case-binder is alive, + -- because it may be used in the con_app. See Note [knownCon occ info] + ; (floats1, env2) <- simplNonRecX env' b' arg -- arg satisfies let/app invariant + ; (floats2, env3) <- bind_args env2 bs' args + ; return (floats1 `addFloats` floats2, env3) } + + bind_args _ _ _ = + pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ + text "scrut:" <+> ppr scrut + + -- It's useful to bind bndr to scrut, rather than to a fresh + -- binding x = Con arg1 .. argn + -- because very often the scrut is a variable, so we avoid + -- creating, and then subsequently eliminating, a let-binding + -- BUT, if scrut is a not a variable, we must be careful + -- about duplicating the arg redexes; in that case, make + -- a new con-app from the args + bind_case_bndr env + | isDeadBinder bndr = return (emptyFloats env, env) + | exprIsTrivial scrut = return (emptyFloats env + , extendIdSubst env bndr (DoneEx scrut Nothing)) + | otherwise = do { dc_args <- mapM (simplVar env) bs + -- dc_ty_args are already OutTypes, + -- but bs are InBndrs + ; let con_app = Var (dataConWorkId dc) + `mkTyApps` dc_ty_args + `mkApps` dc_args + ; simplNonRecX env bndr con_app } + +------------------- +missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont + -> SimplM (SimplFloats, OutExpr) + -- This isn't strictly an error, although it is unusual. + -- It's possible that the simplifier might "see" that + -- an inner case has no accessible alternatives before + -- it "sees" that the entire branch of an outer case is + -- inaccessible. So we simply put an error case here instead. +missingAlt env case_bndr _ cont + = WARN( True, text "missingAlt" <+> ppr case_bndr ) + -- See Note [Avoiding space leaks in OutType] + let cont_ty = contResultType cont + in seqType cont_ty `seq` + return (emptyFloats env, mkImpossibleExpr cont_ty) + +{- +************************************************************************ +* * +\subsection{Duplicating continuations} +* * +************************************************************************ + +Consider + let x* = case e of { True -> e1; False -> e2 } + in b +where x* is a strict binding. Then mkDupableCont will be given +the continuation + case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop +and will split it into + dupable: case [] of { True -> $j1; False -> $j2 } ; stop + join floats: $j1 = e1, $j2 = e2 + non_dupable: let x* = [] in b; stop + +Putting this back together would give + let x* = let { $j1 = e1; $j2 = e2 } in + case e of { True -> $j1; False -> $j2 } + in b +(Of course we only do this if 'e' wants to duplicate that continuation.) +Note how important it is that the new join points wrap around the +inner expression, and not around the whole thing. + +In contrast, any let-bindings introduced by mkDupableCont can wrap +around the entire thing. + +Note [Bottom alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have + case (case x of { A -> error .. ; B -> e; C -> error ..) + of alts +then we can just duplicate those alts because the A and C cases +will disappear immediately. This is more direct than creating +join points and inlining them away. See #4930. +-} + +-------------------- +mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont + -> SimplM (SimplFloats, SimplCont) +mkDupableCaseCont env alts cont + | altsWouldDup alts = mkDupableCont env cont + | otherwise = return (emptyFloats env, cont) + +altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative +altsWouldDup [] = False -- See Note [Bottom alternatives] +altsWouldDup [_] = False +altsWouldDup (alt:alts) + | is_bot_alt alt = altsWouldDup alts + | otherwise = not (all is_bot_alt alts) + where + is_bot_alt (_,_,rhs) = exprIsBottom rhs + +------------------------- +mkDupableCont :: SimplEnv -> SimplCont + -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with + -- extra let/join-floats and in-scope variables + , SimplCont) -- dup_cont: duplicable continuation + +mkDupableCont env cont + | contIsDupable cont + = return (emptyFloats env, cont) + +mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn + +mkDupableCont env (CastIt ty cont) + = do { (floats, cont') <- mkDupableCont env cont + ; return (floats, CastIt ty cont') } + +-- Duplicating ticks for now, not sure if this is good or not +mkDupableCont env (TickIt t cont) + = do { (floats, cont') <- mkDupableCont env cont + ; return (floats, TickIt t cont') } + +mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs + , sc_body = body, sc_env = se, sc_cont = cont}) + -- See Note [Duplicating StrictBind] + = do { let sb_env = se `setInScopeFromE` env + ; (sb_env1, bndr') <- simplBinder sb_env bndr + ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont + -- No need to use mkDupableCont before simplLam; we + -- use cont once here, and then share the result if necessary + + ; let join_body = wrapFloats floats1 join_inner + res_ty = contResultType cont + + ; (floats2, body2) + <- if exprIsDupable (targetPlatform (seDynFlags env)) join_body + then return (emptyFloats env, join_body) + else do { join_bndr <- newJoinId [bndr'] res_ty + ; let join_call = App (Var join_bndr) (Var bndr') + join_rhs = Lam (setOneShotLambda bndr') join_body + join_bind = NonRec join_bndr join_rhs + floats = emptyFloats env `extendFloats` join_bind + ; return (floats, join_call) } + ; return ( floats2 + , StrictBind { sc_bndr = bndr', sc_bndrs = [] + , sc_body = body2 + , sc_env = zapSubstEnv se `setInScopeFromF` floats2 + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_dup = OkToDup + , sc_cont = mkBoringStop res_ty } ) } + +mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci, sc_cont = cont }) + -- See Note [Duplicating StrictArg] + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + = do { (floats1, cont') <- mkDupableCont env cont + ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env)) + (ai_args info) + ; return ( foldl' addLetFloats floats1 floats_s + , StrictArg { sc_fun = info { ai_args = args' } + , sc_cci = cci + , sc_cont = cont' + , sc_dup = OkToDup} ) } + +mkDupableCont env (ApplyToTy { sc_cont = cont + , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) + = do { (floats, cont') <- mkDupableCont env cont + ; return (floats, ApplyToTy { sc_cont = cont' + , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } + +mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup + , sc_env = se, sc_cont = cont }) + = -- e.g. [...hole...] (...arg...) + -- ==> + -- let a = ...arg... + -- in [...hole...] a + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + do { (floats1, cont') <- mkDupableCont env cont + ; let env' = env `setInScopeFromF` floats1 + ; (_, se', arg') <- simplArg env' dup se arg + ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel (fsLit "karg") arg' + ; let all_floats = floats1 `addLetFloats` let_floats2 + ; return ( all_floats + , ApplyToVal { sc_arg = arg'' + , sc_env = se' `setInScopeFromF` all_floats + -- Ensure that sc_env includes the free vars of + -- arg'' in its in-scope set, even if makeTrivial + -- has turned arg'' into a fresh variable + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_dup = OkToDup, sc_cont = cont' }) } + +mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts + , sc_env = se, sc_cont = cont }) + = -- e.g. (case [...hole...] of { pi -> ei }) + -- ===> + -- let ji = \xij -> ei + -- in case [...hole...] of { pi -> ji xij } + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + do { tick (CaseOfCase case_bndr) + ; (floats, alt_cont) <- mkDupableCaseCont env alts cont + -- NB: We call mkDupableCaseCont here to make cont duplicable + -- (if necessary, depending on the number of alts) + -- And this is important: see Note [Fusing case continuations] + + ; let alt_env = se `setInScopeFromF` floats + ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr + ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) alts + -- Safe to say that there are no handled-cons for the DEFAULT case + -- NB: simplBinder does not zap deadness occ-info, so + -- a dead case_bndr' will still advertise its deadness + -- This is really important because in + -- case e of b { (# p,q #) -> ... } + -- b is always dead, and indeed we are not allowed to bind b to (# p,q #), + -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. + -- In the new alts we build, we have the new case binder, so it must retain + -- its deadness. + -- NB: we don't use alt_env further; it has the substEnv for + -- the alternatives, and we don't want that + + ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr') + emptyJoinFloats alts' + + ; let all_floats = floats `addJoinFloats` join_floats + -- Note [Duplicated env] + ; return (all_floats + , Select { sc_dup = OkToDup + , sc_bndr = case_bndr' + , sc_alts = alts'' + , sc_env = zapSubstEnv se `setInScopeFromF` all_floats + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_cont = mkBoringStop (contResultType cont) } ) } + +mkDupableAlt :: Platform -> OutId + -> JoinFloats -> OutAlt + -> SimplM (JoinFloats, OutAlt) +mkDupableAlt platform case_bndr jfloats (con, bndrs', rhs') + | exprIsDupable platform rhs' -- Note [Small alternative rhs] + = return (jfloats, (con, bndrs', rhs')) + + | otherwise + = do { let rhs_ty' = exprType rhs' + scrut_ty = idType case_bndr + case_bndr_w_unf + = case con of + DEFAULT -> case_bndr + DataAlt dc -> setIdUnfolding case_bndr unf + where + -- See Note [Case binders and join points] + unf = mkInlineUnfolding rhs + rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs' + + LitAlt {} -> WARN( True, text "mkDupableAlt" + <+> ppr case_bndr <+> ppr con ) + case_bndr + -- The case binder is alive but trivial, so why has + -- it not been substituted away? + + final_bndrs' + | isDeadBinder case_bndr = filter abstract_over bndrs' + | otherwise = bndrs' ++ [case_bndr_w_unf] + + abstract_over bndr + | isTyVar bndr = True -- Abstract over all type variables just in case + | otherwise = not (isDeadBinder bndr) + -- The deadness info on the new Ids is preserved by simplBinders + final_args = varsToCoreExprs final_bndrs' + -- Note [Join point abstraction] + + -- We make the lambdas into one-shot-lambdas. The + -- join point is sure to be applied at most once, and doing so + -- prevents the body of the join point being floated out by + -- the full laziness pass + really_final_bndrs = map one_shot final_bndrs' + one_shot v | isId v = setOneShotLambda v + | otherwise = v + join_rhs = mkLams really_final_bndrs rhs' + + ; join_bndr <- newJoinId final_bndrs' rhs_ty' + + ; let join_call = mkApps (Var join_bndr) final_args + alt' = (con, bndrs', join_call) + + ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) + , alt') } + -- See Note [Duplicated env] + +{- +Note [Fusing case continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important to fuse two successive case continuations when the +first has one alternative. That's why we call prepareCaseCont here. +Consider this, which arises from thunk splitting (see Note [Thunk +splitting] in GHC.Core.Opt.WorkWrap): + + let + x* = case (case v of {pn -> rn}) of + I# a -> I# a + in body + +The simplifier will find + (Var v) with continuation + Select (pn -> rn) ( + Select [I# a -> I# a] ( + StrictBind body Stop + +So we'll call mkDupableCont on + Select [I# a -> I# a] (StrictBind body Stop) +There is just one alternative in the first Select, so we want to +simplify the rhs (I# a) with continuation (StrictBind body Stop) +Supposing that body is big, we end up with + let $j a = + in case v of { pn -> case rn of + I# a -> $j a } +This is just what we want because the rn produces a box that +the case rn cancels with. + +See #4957 a fuller example. + +Note [Case binders and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + case (case .. ) of c { + I# c# -> ....c.... + +If we make a join point with c but not c# we get + $j = \c -> ....c.... + +But if later inlining scrutinises the c, thus + + $j = \c -> ... case c of { I# y -> ... } ... + +we won't see that 'c' has already been scrutinised. This actually +happens in the 'tabulate' function in wave4main, and makes a significant +difference to allocation. + +An alternative plan is this: + + $j = \c# -> let c = I# c# in ...c.... + +but that is bad if 'c' is *not* later scrutinised. + +So instead we do both: we pass 'c' and 'c#' , and record in c's inlining +(a stable unfolding) that it's really I# c#, thus + + $j = \c# -> \c[=I# c#] -> ...c.... + +Absence analysis may later discard 'c'. + +NB: take great care when doing strictness analysis; + see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal. + +Also note that we can still end up passing stuff that isn't used. Before +strictness analysis we have + let $j x y c{=(x,y)} = (h c, ...) + in ... +After strictness analysis we see that h is strict, we end up with + let $j x y c{=(x,y)} = ($wh x y, ...) +and c is unused. + +Note [Duplicated env] +~~~~~~~~~~~~~~~~~~~~~ +Some of the alternatives are simplified, but have not been turned into a join point +So they *must* have a zapped subst-env. So we can't use completeNonRecX to +bind the join point, because it might to do PostInlineUnconditionally, and +we'd lose that when zapping the subst-env. We could have a per-alt subst-env, +but zapping it (as we do in mkDupableCont, the Select case) is safe, and +at worst delays the join-point inlining. + +Note [Small alternative rhs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is worth checking for a small RHS because otherwise we +get extra let bindings that may cause an extra iteration of the simplifier to +inline back in place. Quite often the rhs is just a variable or constructor. +The Ord instance of Maybe in PrelMaybe.hs, for example, took several extra +iterations because the version with the let bindings looked big, and so wasn't +inlined, but after the join points had been inlined it looked smaller, and so +was inlined. + +NB: we have to check the size of rhs', not rhs. +Duplicating a small InAlt might invalidate occurrence information +However, if it *is* dupable, we return the *un* simplified alternative, +because otherwise we'd need to pair it up with an empty subst-env.... +but we only have one env shared between all the alts. +(Remember we must zap the subst-env before re-simplifying something). +Rather than do this we simply agree to re-simplify the original (small) thing later. + +Note [Funky mkLamTypes] +~~~~~~~~~~~~~~~~~~~~~~ +Notice the funky mkLamTypes. If the constructor has existentials +it's possible that the join point will be abstracted over +type variables as well as term variables. + Example: Suppose we have + data T = forall t. C [t] + Then faced with + case (case e of ...) of + C t xs::[t] -> rhs + We get the join point + let j :: forall t. [t] -> ... + j = /\t \xs::[t] -> rhs + in + case (case e of ...) of + C t xs::[t] -> j t xs + +Note [Duplicating StrictArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We make a StrictArg duplicable simply by making all its +stored-up arguments (in sc_fun) trivial, by let-binding +them. Thus: + f E [..hole..] + ==> let a = E + in f a [..hole..] +Now if the thing in the hole is a case expression (which is when +we'll call mkDupableCont), we'll push the function call into the +branches, which is what we want. Now RULES for f may fire, and +call-pattern specialisation. Here's an example from #3116 + go (n+1) (case l of + 1 -> bs' + _ -> Chunk p fpc (o+1) (l-1) bs') +If we can push the call for 'go' inside the case, we get +call-pattern specialisation for 'go', which is *crucial* for +this program. + +Here is the (&&) example: + && E (case x of { T -> F; F -> T }) + ==> let a = E in + case x of { T -> && a F; F -> && a T } +Much better! + +Notice that + * Arguments to f *after* the strict one are handled by + the ApplyToVal case of mkDupableCont. Eg + f [..hole..] E + + * We can only do the let-binding of E because the function + part of a StrictArg continuation is an explicit syntax + tree. In earlier versions we represented it as a function + (CoreExpr -> CoreEpxr) which we couldn't take apart. + +Historical aide: previously we did this (where E is a +big argument: + f E [..hole..] + ==> let $j = \a -> f E a + in $j [..hole..] + +But this is terrible! Here's an example: + && E (case x of { T -> F; F -> T }) +Now, && is strict so we end up simplifying the case with +an ArgOf continuation. If we let-bind it, we get + let $j = \v -> && E v + in simplExpr (case x of { T -> F; F -> T }) + (ArgOf (\r -> $j r) +And after simplifying more we get + let $j = \v -> && E v + in case x of { T -> $j F; F -> $j T } +Which is a Very Bad Thing + + +Note [Duplicating StrictBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We make a StrictBind duplicable in a very similar way to +that for case expressions. After all, + let x* = e in b is similar to case e of x -> b + +So we potentially make a join-point for the body, thus: + let x = [] in b ==> join j x = b + in let x = [] in j x + + +Note [Join point abstraction] Historical note +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: This note is now historical, describing how (in the past) we used +to add a void argument to nullary join points. But now that "join +point" is not a fuzzy concept but a formal syntactic construct (as +distinguished by the JoinId constructor of IdDetails), each of these +concerns is handled separately, with no need for a vestigial extra +argument. + +Join points always have at least one value argument, +for several reasons + +* If we try to lift a primitive-typed something out + for let-binding-purposes, we will *caseify* it (!), + with potentially-disastrous strictness results. So + instead we turn it into a function: \v -> e + where v::Void#. The value passed to this function is void, + which generates (almost) no code. + +* CPR. We used to say "&& isUnliftedType rhs_ty'" here, but now + we make the join point into a function whenever used_bndrs' + is empty. This makes the join-point more CPR friendly. + Consider: let j = if .. then I# 3 else I# 4 + in case .. of { A -> j; B -> j; C -> ... } + + Now CPR doesn't w/w j because it's a thunk, so + that means that the enclosing function can't w/w either, + which is a lose. Here's the example that happened in practice: + kgmod :: Int -> Int -> Int + kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 + then 78 + else 5 + +* Let-no-escape. We want a join point to turn into a let-no-escape + so that it is implemented as a jump, and one of the conditions + for LNE is that it's not updatable. In CoreToStg, see + Note [What is a non-escaping let] + +* Floating. Since a join point will be entered once, no sharing is + gained by floating out, but something might be lost by doing + so because it might be allocated. + +I have seen a case alternative like this: + True -> \v -> ... +It's a bit silly to add the realWorld dummy arg in this case, making + $j = \s v -> ... + True -> $j s +(the \v alone is enough to make CPR happy) but I think it's rare + +There's a slight infelicity here: we pass the overall +case_bndr to all the join points if it's used in *any* RHS, +because we don't know its usage in each RHS separately + + + +************************************************************************ +* * + Unfoldings +* * +************************************************************************ +-} + +simplLetUnfolding :: SimplEnv-> TopLevelFlag + -> MaybeJoinCont + -> InId + -> OutExpr -> OutType + -> Unfolding -> SimplM Unfolding +simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty unf + | isStableUnfolding unf + = simplStableUnfolding env top_lvl cont_mb id unf rhs_ty + | isExitJoinId id + = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify + | otherwise + = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs + +------------------- +mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource + -> InId -> OutExpr -> SimplM Unfolding +mkLetUnfolding dflags top_lvl src id new_rhs + = is_bottoming `seq` -- See Note [Force bottoming field] + return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs) + -- We make an unfolding *even for loop-breakers*. + -- Reason: (a) It might be useful to know that they are WHNF + -- (b) In GHC.Iface.Tidy we currently assume that, if we want to + -- expose the unfolding then indeed we *have* an unfolding + -- to expose. (We could instead use the RHS, but currently + -- we don't.) The simple thing is always to have one. + where + is_top_lvl = isTopLevel top_lvl + is_bottoming = isBottomingId id + +------------------- +simplStableUnfolding :: SimplEnv -> TopLevelFlag + -> MaybeJoinCont -- Just k => a join point with continuation k + -> InId + -> Unfolding -> OutType -> SimplM Unfolding +-- Note [Setting the new unfolding] +simplStableUnfolding env top_lvl mb_cont id unf rhs_ty + = case unf of + NoUnfolding -> return unf + BootUnfolding -> return unf + OtherCon {} -> return unf + + DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args } + -> do { (env', bndrs') <- simplBinders unf_env bndrs + ; args' <- mapM (simplExpr env') args + ; return (mkDFunUnfolding bndrs' con args') } + + CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide } + | isStableSource src + -> do { expr' <- case mb_cont of -- See Note [Rules and unfolding for join points] + Just cont -> simplJoinRhs unf_env id expr cont + Nothing -> simplExprC unf_env expr (mkBoringStop rhs_ty) + ; case guide of + UnfWhen { ug_arity = arity + , ug_unsat_ok = sat_ok + , ug_boring_ok = boring_ok + } + -- Happens for INLINE things + -> let guide' = + UnfWhen { ug_arity = arity + , ug_unsat_ok = sat_ok + , ug_boring_ok = + boring_ok || inlineBoringOk expr' + } + -- Refresh the boring-ok flag, in case expr' + -- has got small. This happens, notably in the inlinings + -- for dfuns for single-method classes; see + -- Note [Single-method classes] in GHC.Tc.TyCl.Instance. + -- A test case is #4138 + -- But retain a previous boring_ok of True; e.g. see + -- the way it is set in calcUnfoldingGuidanceWithArity + in return (mkCoreUnfolding src is_top_lvl expr' guide') + -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold + + _other -- Happens for INLINABLE things + -> mkLetUnfolding dflags top_lvl src id expr' } + -- If the guidance is UnfIfGoodArgs, this is an INLINABLE + -- unfolding, and we need to make sure the guidance is kept up + -- to date with respect to any changes in the unfolding. + + | otherwise -> return noUnfolding -- Discard unstable unfoldings + where + dflags = seDynFlags env + is_top_lvl = isTopLevel top_lvl + act = idInlineActivation id + unf_env = updMode (updModeForStableUnfoldings act) env + -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils + +{- +Note [Force bottoming field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to force bottoming, or the new unfolding holds +on to the old unfolding (which is part of the id). + +Note [Setting the new unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* If there's an INLINE pragma, we simplify the RHS gently. Maybe we + should do nothing at all, but simplifying gently might get rid of + more crap. + +* If not, we make an unfolding from the new RHS. But *only* for + non-loop-breakers. Making loop breakers not have an unfolding at all + means that we can avoid tests in exprIsConApp, for example. This is + important: if exprIsConApp says 'yes' for a recursive thing, then we + can get into an infinite loop + +If there's a stable unfolding on a loop breaker (which happens for +INLINABLE), we hang on to the inlining. It's pretty dodgy, but the +user did say 'INLINE'. May need to revisit this choice. + +************************************************************************ +* * + Rules +* * +************************************************************************ + +Note [Rules in a letrec] +~~~~~~~~~~~~~~~~~~~~~~~~ +After creating fresh binders for the binders of a letrec, we +substitute the RULES and add them back onto the binders; this is done +*before* processing any of the RHSs. This is important. Manuel found +cases where he really, really wanted a RULE for a recursive function +to apply in that function's own right-hand side. + +See Note [Forming Rec groups] in OccurAnal +-} + +addBndrRules :: SimplEnv -> InBndr -> OutBndr + -> MaybeJoinCont -- Just k for a join point binder + -- Nothing otherwise + -> SimplM (SimplEnv, OutBndr) +-- Rules are added back into the bin +addBndrRules env in_id out_id mb_cont + | null old_rules + = return (env, out_id) + | otherwise + = do { new_rules <- simplRules env (Just out_id) old_rules mb_cont + ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules + ; return (modifyInScope env final_id, final_id) } + where + old_rules = ruleInfoRules (idSpecialisation in_id) + +simplRules :: SimplEnv -> Maybe OutId -> [CoreRule] + -> MaybeJoinCont -> SimplM [CoreRule] +simplRules env mb_new_id rules mb_cont + = mapM simpl_rule rules + where + simpl_rule rule@(BuiltinRule {}) + = return rule + + simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs }) + = do { (env', bndrs') <- simplBinders env bndrs + ; let rhs_ty = substTy env' (exprType rhs) + rhs_cont = case mb_cont of -- See Note [Rules and unfolding for join points] + Nothing -> mkBoringStop rhs_ty + Just cont -> ASSERT2( join_ok, bad_join_msg ) + cont + rule_env = updMode updModeForRules env' + fn_name' = case mb_new_id of + Just id -> idName id + Nothing -> fn_name + + -- join_ok is an assertion check that the join-arity of the + -- binder matches that of the rule, so that pushing the + -- continuation into the RHS makes sense + join_ok = case mb_new_id of + Just id | Just join_arity <- isJoinId_maybe id + -> length args == join_arity + _ -> False + bad_join_msg = vcat [ ppr mb_new_id, ppr rule + , ppr (fmap isJoinId_maybe mb_new_id) ] + + ; args' <- mapM (simplExpr rule_env) args + ; rhs' <- simplExprC rule_env rhs rhs_cont + ; return (rule { ru_bndrs = bndrs' + , ru_fn = fn_name' + , ru_args = args' + , ru_rhs = rhs' }) } diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -0,0 +1,938 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.Simplify.Env ( + -- * The simplifier mode + setMode, getMode, updMode, seDynFlags, + + -- * Environments + SimplEnv(..), pprSimplEnv, -- Temp not abstract + mkSimplEnv, extendIdSubst, + extendTvSubst, extendCvSubst, + zapSubstEnv, setSubstEnv, + getInScope, setInScopeFromE, setInScopeFromF, + setInScopeSet, modifyInScope, addNewInScopeIds, + getSimplRules, + + -- * Substitution results + SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope, + + -- * Simplifying 'Id' binders + simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, + simplBinder, simplBinders, + substTy, substTyVar, getTCvSubst, + substCo, substCoVar, + + -- * Floats + SimplFloats(..), emptyFloats, mkRecFloats, + mkFloatBind, addLetFloats, addJoinFloats, addFloats, + extendFloats, wrapFloats, + doFloatFromRhs, getTopFloatBinds, + + -- * LetFloats + LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat, + addLetFlts, mapLetFloats, + + -- * JoinFloats + JoinFloat, JoinFloats, emptyJoinFloats, + wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Opt.Monad ( SimplMode(..) ) +import GHC.Core +import GHC.Core.Utils +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Data.OrdList +import GHC.Types.Id as Id +import GHC.Core.Make ( mkWildValBinder ) +import GHC.Driver.Session ( DynFlags ) +import GHC.Builtin.Types +import qualified GHC.Core.Type as Type +import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst ) +import qualified GHC.Core.Coercion as Coercion +import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) +import GHC.Types.Basic +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.Unique.FM ( pprUniqFM ) + +import Data.List (mapAccumL) + +{- +************************************************************************ +* * +\subsubsection{The @SimplEnv@ type} +* * +************************************************************************ +-} + +data SimplEnv + = SimplEnv { + ----------- Static part of the environment ----------- + -- Static in the sense of lexically scoped, + -- wrt the original expression + + seMode :: SimplMode + + -- The current substitution + , seTvSubst :: TvSubstEnv -- InTyVar |--> OutType + , seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion + , seIdSubst :: SimplIdSubst -- InId |--> OutExpr + + ----------- Dynamic part of the environment ----------- + -- Dynamic in the sense of describing the setup where + -- the expression finally ends up + + -- The current set of in-scope variables + -- They are all OutVars, and all bound in this module + , seInScope :: InScopeSet -- OutVars only + } + +data SimplFloats + = SimplFloats + { -- Ordinary let bindings + sfLetFloats :: LetFloats + -- See Note [LetFloats] + + -- Join points + , sfJoinFloats :: JoinFloats + -- Handled separately; they don't go very far + -- We consider these to be /inside/ sfLetFloats + -- because join points can refer to ordinary bindings, + -- but not vice versa + + -- Includes all variables bound by sfLetFloats and + -- sfJoinFloats, plus at least whatever is in scope where + -- these bindings land up. + , sfInScope :: InScopeSet -- All OutVars + } + +instance Outputable SimplFloats where + ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is }) + = text "SimplFloats" + <+> braces (vcat [ text "lets: " <+> ppr lf + , text "joins:" <+> ppr jf + , text "in_scope:" <+> ppr is ]) + +emptyFloats :: SimplEnv -> SimplFloats +emptyFloats env + = SimplFloats { sfLetFloats = emptyLetFloats + , sfJoinFloats = emptyJoinFloats + , sfInScope = seInScope env } + +pprSimplEnv :: SimplEnv -> SDoc +-- Used for debugging; selective +pprSimplEnv env + = vcat [text "TvSubst:" <+> ppr (seTvSubst env), + text "CvSubst:" <+> ppr (seCvSubst env), + text "IdSubst:" <+> id_subst_doc, + text "InScope:" <+> in_scope_vars_doc + ] + where + id_subst_doc = pprUniqFM ppr (seIdSubst env) + in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env)) + (vcat . map ppr_one) + ppr_one v | isId v = ppr v <+> ppr (idUnfolding v) + | otherwise = ppr v + +type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr + -- See Note [Extending the Subst] in GHC.Core.Subst + +-- | A substitution result. +data SimplSR + = DoneEx OutExpr (Maybe JoinArity) + -- If x :-> DoneEx e ja is in the SimplIdSubst + -- then replace occurrences of x by e + -- and ja = Just a <=> x is a join-point of arity a + -- See Note [Join arity in SimplIdSubst] + + + | DoneId OutId + -- If x :-> DoneId v is in the SimplIdSubst + -- then replace occurrences of x by v + -- and v is a join-point of arity a + -- <=> x is a join-point of arity a + + | ContEx TvSubstEnv -- A suspended substitution + CvSubstEnv + SimplIdSubst + InExpr + -- If x :-> ContEx tv cv id e is in the SimplISubst + -- then replace occurrences of x by (subst (tv,cv,id) e) + +instance Outputable SimplSR where + ppr (DoneId v) = text "DoneId" <+> ppr v + ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e + where + pp_mj = case mj of + Nothing -> empty + Just n -> parens (int n) + + ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, + ppr (filter_env tv), ppr (filter_env id) -}] + -- where + -- fvs = exprFreeVars e + -- filter_env env = filterVarEnv_Directly keep env + -- keep uniq _ = uniq `elemUFM_Directly` fvs + +{- +Note [SimplEnv invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +seInScope: + The in-scope part of Subst includes *all* in-scope TyVars and Ids + The elements of the set may have better IdInfo than the + occurrences of in-scope Ids, and (more important) they will + have a correctly-substituted type. So we use a lookup in this + set to replace occurrences + + The Ids in the InScopeSet are replete with their Rules, + and as we gather info about the unfolding of an Id, we replace + it in the in-scope set. + + The in-scope set is actually a mapping OutVar -> OutVar, and + in case expressions we sometimes bind + +seIdSubst: + The substitution is *apply-once* only, because InIds and OutIds + can overlap. + For example, we generally omit mappings + a77 -> a77 + from the substitution, when we decide not to clone a77, but it's quite + legitimate to put the mapping in the substitution anyway. + + Furthermore, consider + let x = case k of I# x77 -> ... in + let y = case k of I# x77 -> ... in ... + and suppose the body is strict in both x and y. Then the simplifier + will pull the first (case k) to the top; so the second (case k) will + cancel out, mapping x77 to, well, x77! But one is an in-Id and the + other is an out-Id. + + Of course, the substitution *must* applied! Things in its domain + simply aren't necessarily bound in the result. + +* substId adds a binding (DoneId new_id) to the substitution if + the Id's unique has changed + + Note, though that the substitution isn't necessarily extended + if the type of the Id changes. Why not? Because of the next point: + +* We *always, always* finish by looking up in the in-scope set + any variable that doesn't get a DoneEx or DoneVar hit in the substitution. + Reason: so that we never finish up with a "old" Id in the result. + An old Id might point to an old unfolding and so on... which gives a space + leak. + + [The DoneEx and DoneVar hits map to "new" stuff.] + +* It follows that substExpr must not do a no-op if the substitution is empty. + substType is free to do so, however. + +* When we come to a let-binding (say) we generate new IdInfo, including an + unfolding, attach it to the binder, and add this newly adorned binder to + the in-scope set. So all subsequent occurrences of the binder will get + mapped to the full-adorned binder, which is also the one put in the + binding site. + +* The in-scope "set" usually maps x->x; we use it simply for its domain. + But sometimes we have two in-scope Ids that are synomyms, and should + map to the same target: x->x, y->x. Notably: + case y of x { ... } + That's why the "set" is actually a VarEnv Var + +Note [Join arity in SimplIdSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have to remember which incoming variables are join points: the occurrences +may not be marked correctly yet, and we're in change of propagating the change if +OccurAnal makes something a join point). + +Normally the in-scope set is where we keep the latest information, but +the in-scope set tracks only OutVars; if a binding is unconditionally +inlined (via DoneEx), it never makes it into the in-scope set, and we +need to know at the occurrence site that the variable is a join point +so that we know to drop the context. Thus we remember which join +points we're substituting. -} + +mkSimplEnv :: SimplMode -> SimplEnv +mkSimplEnv mode + = SimplEnv { seMode = mode + , seInScope = init_in_scope + , seTvSubst = emptyVarEnv + , seCvSubst = emptyVarEnv + , seIdSubst = emptyVarEnv } + -- The top level "enclosing CC" is "SUBSUMED". + +init_in_scope :: InScopeSet +init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy)) + -- See Note [WildCard binders] + +{- +Note [WildCard binders] +~~~~~~~~~~~~~~~~~~~~~~~ +The program to be simplified may have wild binders + case e of wild { p -> ... } +We want to *rename* them away, so that there are no +occurrences of 'wild-id' (with wildCardKey). The easy +way to do that is to start of with a representative +Id in the in-scope set + +There can be *occurrences* of wild-id. For example, +GHC.Core.Make.mkCoreApp transforms + e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild } +This is ok provided 'wild' isn't free in 'e', and that's the delicate +thing. Generally, you want to run the simplifier to get rid of the +wild-ids before doing much else. + +It's a very dark corner of GHC. Maybe it should be cleaned up. +-} + +getMode :: SimplEnv -> SimplMode +getMode env = seMode env + +seDynFlags :: SimplEnv -> DynFlags +seDynFlags env = sm_dflags (seMode env) + +setMode :: SimplMode -> SimplEnv -> SimplEnv +setMode mode env = env { seMode = mode } + +updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv +updMode upd env = env { seMode = upd (seMode env) } + +--------------------- +extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv +extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res + = ASSERT2( isId var && not (isCoVar var), ppr var ) + env { seIdSubst = extendVarEnv subst var res } + +extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv +extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res + = ASSERT2( isTyVar var, ppr var $$ ppr res ) + env {seTvSubst = extendVarEnv tsubst var res} + +extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv +extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co + = ASSERT( isCoVar var ) + env {seCvSubst = extendVarEnv csubst var co} + +--------------------- +getInScope :: SimplEnv -> InScopeSet +getInScope env = seInScope env + +setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv +setInScopeSet env in_scope = env {seInScope = in_scope} + +setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv +-- See Note [Setting the right in-scope set] +setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env } + +setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv +setInScopeFromF env floats = env { seInScope = sfInScope floats } + +addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv + -- The new Ids are guaranteed to be freshly allocated +addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs + = env { seInScope = in_scope `extendInScopeSetList` vs, + seIdSubst = id_subst `delVarEnvList` vs } + -- Why delete? Consider + -- let x = a*b in (x, \x -> x+3) + -- We add [x |-> a*b] to the substitution, but we must + -- _delete_ it from the substitution when going inside + -- the (\x -> ...)! + +modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv +-- The variable should already be in scope, but +-- replace the existing version with this new one +-- which has more information +modifyInScope env@(SimplEnv {seInScope = in_scope}) v + = env {seInScope = extendInScopeSet in_scope v} + +{- Note [Setting the right in-scope set] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + \x. (let x = e in b) arg[x] +where the let shadows the lambda. Really this means something like + \x1. (let x2 = e in b) arg[x1] + +- When we capture the 'arg' in an ApplyToVal continuation, we capture + the environment, which says what 'x' is bound to, namely x1 + +- Then that continuation gets pushed under the let + +- Finally we simplify 'arg'. We want + - the static, lexical environment binding x :-> x1 + - the in-scopeset from "here", under the 'let' which includes + both x1 and x2 + +It's important to have the right in-scope set, else we may rename a +variable to one that is already in scope. So we must pick up the +in-scope set from "here", but otherwise use the environment we +captured along with 'arg'. This transfer of in-scope set is done by +setInScopeFromE. +-} + +--------------------- +zapSubstEnv :: SimplEnv -> SimplEnv +zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} + +setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv +setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } + +mkContEx :: SimplEnv -> InExpr -> SimplSR +mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e + +{- +************************************************************************ +* * +\subsection{LetFloats} +* * +************************************************************************ + +Note [LetFloats] +~~~~~~~~~~~~~~~~ +The LetFloats is a bunch of bindings, classified by a FloatFlag. + +* All of them satisfy the let/app invariant + +Examples + + NonRec x (y:ys) FltLifted + Rec [(x,rhs)] FltLifted + + NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted? + NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n + + NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge + +Can't happen: + NonRec x# (a /# b) -- Might fail; does not satisfy let/app + NonRec x# (f y) -- Might diverge; does not satisfy let/app +-} + +data LetFloats = LetFloats (OrdList OutBind) FloatFlag + -- See Note [LetFloats] + +type JoinFloat = OutBind +type JoinFloats = OrdList JoinFloat + +data FloatFlag + = FltLifted -- All bindings are lifted and lazy *or* + -- consist of a single primitive string literal + -- Hence ok to float to top level, or recursive + + | FltOkSpec -- All bindings are FltLifted *or* + -- strict (perhaps because unlifted, + -- perhaps because of a strict binder), + -- *and* ok-for-speculation + -- Hence ok to float out of the RHS + -- of a lazy non-recursive let binding + -- (but not to top level, or into a rec group) + + | FltCareful -- At least one binding is strict (or unlifted) + -- and not guaranteed cheap + -- Do not float these bindings out of a lazy let + +instance Outputable LetFloats where + ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds) + +instance Outputable FloatFlag where + ppr FltLifted = text "FltLifted" + ppr FltOkSpec = text "FltOkSpec" + ppr FltCareful = text "FltCareful" + +andFF :: FloatFlag -> FloatFlag -> FloatFlag +andFF FltCareful _ = FltCareful +andFF FltOkSpec FltCareful = FltCareful +andFF FltOkSpec _ = FltOkSpec +andFF FltLifted flt = flt + +doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool +-- If you change this function look also at FloatIn.noFloatFromRhs +doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs + = not (isNilOL fs) && want_to_float && can_float + where + want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs + -- See Note [Float when cheap or expandable] + can_float = case ff of + FltLifted -> True + FltOkSpec -> isNotTopLevel lvl && isNonRec rec + FltCareful -> isNotTopLevel lvl && isNonRec rec && str + +{- +Note [Float when cheap or expandable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to float a let from a let if the residual RHS is + a) cheap, such as (\x. blah) + b) expandable, such as (f b) if f is CONLIKE +But there are + - cheap things that are not expandable (eg \x. expensive) + - expandable things that are not cheap (eg (f b) where b is CONLIKE) +so we must take the 'or' of the two. +-} + +emptyLetFloats :: LetFloats +emptyLetFloats = LetFloats nilOL FltLifted + +emptyJoinFloats :: JoinFloats +emptyJoinFloats = nilOL + +unitLetFloat :: OutBind -> LetFloats +-- This key function constructs a singleton float with the right form +unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind)) + LetFloats (unitOL bind) (flag bind) + where + flag (Rec {}) = FltLifted + flag (NonRec bndr rhs) + | not (isStrictId bndr) = FltLifted + | exprIsTickedString rhs = FltLifted + -- String literals can be floated freely. + -- See Note [Core top-level string literals] in GHC.Core. + | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) + | otherwise = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr ) + FltCareful + -- Unlifted binders can only be let-bound if exprOkForSpeculation holds + +unitJoinFloat :: OutBind -> JoinFloats +unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind)) + unitOL bind + +mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv) +-- Make a singleton SimplFloats, and +-- extend the incoming SimplEnv's in-scope set with its binders +-- These binders may already be in the in-scope set, +-- but may have by now been augmented with more IdInfo +mkFloatBind env bind + = (floats, env { seInScope = in_scope' }) + where + floats + | isJoinBind bind + = SimplFloats { sfLetFloats = emptyLetFloats + , sfJoinFloats = unitJoinFloat bind + , sfInScope = in_scope' } + | otherwise + = SimplFloats { sfLetFloats = unitLetFloat bind + , sfJoinFloats = emptyJoinFloats + , sfInScope = in_scope' } + + in_scope' = seInScope env `extendInScopeSetBind` bind + +extendFloats :: SimplFloats -> OutBind -> SimplFloats +-- Add this binding to the floats, and extend the in-scope env too +extendFloats (SimplFloats { sfLetFloats = floats + , sfJoinFloats = jfloats + , sfInScope = in_scope }) + bind + | isJoinBind bind + = SimplFloats { sfInScope = in_scope' + , sfLetFloats = floats + , sfJoinFloats = jfloats' } + | otherwise + = SimplFloats { sfInScope = in_scope' + , sfLetFloats = floats' + , sfJoinFloats = jfloats } + where + in_scope' = in_scope `extendInScopeSetBind` bind + floats' = floats `addLetFlts` unitLetFloat bind + jfloats' = jfloats `addJoinFlts` unitJoinFloat bind + +addLetFloats :: SimplFloats -> LetFloats -> SimplFloats +-- Add the let-floats for env2 to env1; +-- *plus* the in-scope set for env2, which is bigger +-- than that for env1 +addLetFloats floats let_floats@(LetFloats binds _) + = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats + , sfInScope = foldlOL extendInScopeSetBind + (sfInScope floats) binds } + +addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats +addJoinFloats floats join_floats + = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats + , sfInScope = foldlOL extendInScopeSetBind + (sfInScope floats) join_floats } + +extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet +extendInScopeSetBind in_scope bind + = extendInScopeSetList in_scope (bindersOf bind) + +addFloats :: SimplFloats -> SimplFloats -> SimplFloats +-- Add both let-floats and join-floats for env2 to env1; +-- *plus* the in-scope set for env2, which is bigger +-- than that for env1 +addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 }) + (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope }) + = SimplFloats { sfLetFloats = lf1 `addLetFlts` lf2 + , sfJoinFloats = jf1 `addJoinFlts` jf2 + , sfInScope = in_scope } + +addLetFlts :: LetFloats -> LetFloats -> LetFloats +addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2) + = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2) + +letFloatBinds :: LetFloats -> [CoreBind] +letFloatBinds (LetFloats bs _) = fromOL bs + +addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats +addJoinFlts = appOL + +mkRecFloats :: SimplFloats -> SimplFloats +-- Flattens the floats from env2 into a single Rec group, +-- They must either all be lifted LetFloats or all JoinFloats +mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs ff + , sfJoinFloats = jbs + , sfInScope = in_scope }) + = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) ) + ASSERT2( isNilOL bs || isNilOL jbs, ppr floats ) + SimplFloats { sfLetFloats = floats' + , sfJoinFloats = jfloats' + , sfInScope = in_scope } + where + floats' | isNilOL bs = emptyLetFloats + | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs))) + jfloats' | isNilOL jbs = emptyJoinFloats + | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs))) + +wrapFloats :: SimplFloats -> OutExpr -> OutExpr +-- Wrap the floats around the expression; they should all +-- satisfy the let/app invariant, so mkLets should do the job just fine +wrapFloats (SimplFloats { sfLetFloats = LetFloats bs _ + , sfJoinFloats = jbs }) body + = foldrOL Let (wrapJoinFloats jbs body) bs + -- Note: Always safe to put the joins on the inside + -- since the values can't refer to them + +wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr) +-- Wrap the sfJoinFloats of the env around the expression, +-- and take them out of the SimplEnv +wrapJoinFloatsX floats body + = ( floats { sfJoinFloats = emptyJoinFloats } + , wrapJoinFloats (sfJoinFloats floats) body ) + +wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr +-- Wrap the sfJoinFloats of the env around the expression, +-- and take them out of the SimplEnv +wrapJoinFloats join_floats body + = foldrOL Let body join_floats + +getTopFloatBinds :: SimplFloats -> [CoreBind] +getTopFloatBinds (SimplFloats { sfLetFloats = lbs + , sfJoinFloats = jbs}) + = ASSERT( isNilOL jbs ) -- Can't be any top-level join bindings + letFloatBinds lbs + +mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats +mapLetFloats (LetFloats fs ff) fun + = LetFloats (mapOL app fs) ff + where + app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' + app (Rec bs) = Rec (map fun bs) + +{- +************************************************************************ +* * + Substitution of Vars +* * +************************************************************************ + +Note [Global Ids in the substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We look up even a global (eg imported) Id in the substitution. Consider + case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... } +The binder-swap in the occurrence analyser will add a binding +for a LocalId version of g (with the same unique though): + case X.g_34 of b { (a,b) -> let g_34 = b in + ... case X.g_34 of { (p,q) -> ...} ... } +So we want to look up the inner X.g_34 in the substitution, where we'll +find that it has been substituted by b. (Or conceivably cloned.) +-} + +substId :: SimplEnv -> InId -> SimplSR +-- Returns DoneEx only on a non-Var expression +substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v + = case lookupVarEnv ids v of -- Note [Global Ids in the substitution] + Nothing -> DoneId (refineFromInScope in_scope v) + Just (DoneId v) -> DoneId (refineFromInScope in_scope v) + Just res -> res -- DoneEx non-var, or ContEx + + -- Get the most up-to-date thing from the in-scope set + -- Even though it isn't in the substitution, it may be in + -- the in-scope set with better IdInfo. + -- + -- See also Note [In-scope set as a substitution] in GHC.Core.Opt.Simplify. + +refineFromInScope :: InScopeSet -> Var -> Var +refineFromInScope in_scope v + | isLocalId v = case lookupInScope in_scope v of + Just v' -> v' + Nothing -> WARN( True, ppr v ) v -- This is an error! + | otherwise = v + +lookupRecBndr :: SimplEnv -> InId -> OutId +-- Look up an Id which has been put into the envt by simplRecBndrs, +-- but where we have not yet done its RHS +lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v + = case lookupVarEnv ids v of + Just (DoneId v) -> v + Just _ -> pprPanic "lookupRecBndr" (ppr v) + Nothing -> refineFromInScope in_scope v + +{- +************************************************************************ +* * +\section{Substituting an Id binder} +* * +************************************************************************ + + +These functions are in the monad only so that they can be made strict via seq. + +Note [Return type for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + (join j :: Char -> Int -> Int) 77 + ( j x = \y. y + ord x ) + (in case v of ) + ( A -> j 'x' ) + ( B -> j 'y' ) + ( C -> ) + +The simplifier pushes the "apply to 77" continuation inwards to give + + join j :: Char -> Int + j x = (\y. y + ord x) 77 + in case v of + A -> j 'x' + B -> j 'y' + C -> 77 + +Notice that the "apply to 77" continuation went into the RHS of the +join point. And that meant that the return type of the join point +changed!! + +That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr +takes a (Just res_ty) argument so that it knows to do the type-changing +thing. +-} + +simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) +simplBinders env bndrs = mapAccumLM simplBinder env bndrs + +------------- +simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- Used for lambda and case-bound variables +-- Clone Id if necessary, substitute type +-- Return with IdInfo already substituted, but (fragile) occurrence info zapped +-- The substitution is extended only if the variable is cloned, because +-- we *don't* need to use it to track occurrence info. +simplBinder env bndr + | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr + ; seqTyVar tv `seq` return (env', tv) } + | otherwise = do { let (env', id) = substIdBndr Nothing env bndr + ; seqId id `seq` return (env', id) } + +--------------- +simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- A non-recursive let binder +simplNonRecBndr env id + = do { let (env1, id1) = substIdBndr Nothing env id + ; seqId id1 `seq` return (env1, id1) } + +--------------- +simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr + -> SimplM (SimplEnv, OutBndr) +-- A non-recursive let binder for a join point; +-- context being pushed inward may change the type +-- See Note [Return type for join points] +simplNonRecJoinBndr env res_ty id + = do { let (env1, id1) = substIdBndr (Just res_ty) env id + ; seqId id1 `seq` return (env1, id1) } + +--------------- +simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv +-- Recursive let binders +simplRecBndrs env@(SimplEnv {}) ids + = ASSERT(all (not . isJoinId) ids) + do { let (env1, ids1) = mapAccumL (substIdBndr Nothing) env ids + ; seqIds ids1 `seq` return env1 } + +--------------- +simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv +-- Recursive let binders for join points; +-- context being pushed inward may change types +-- See Note [Return type for join points] +simplRecJoinBndrs env@(SimplEnv {}) res_ty ids + = ASSERT(all isJoinId ids) + do { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids + ; seqIds ids1 `seq` return env1 } + +--------------- +substIdBndr :: Maybe OutType -> SimplEnv -> InBndr -> (SimplEnv, OutBndr) +-- Might be a coercion variable +substIdBndr new_res_ty env bndr + | isCoVar bndr = substCoVarBndr env bndr + | otherwise = substNonCoVarIdBndr new_res_ty env bndr + +--------------- +substNonCoVarIdBndr + :: Maybe OutType -- New result type, if a join binder + -- See Note [Return type for join points] + -> SimplEnv + -> InBndr -- Env and binder to transform + -> (SimplEnv, OutBndr) +-- Clone Id if necessary, substitute its type +-- Return an Id with its +-- * Type substituted +-- * UnfoldingInfo, Rules, WorkerInfo zapped +-- * Fragile OccInfo (only) zapped: Note [Robust OccInfo] +-- * Robust info, retained especially arity and demand info, +-- so that they are available to occurrences that occur in an +-- earlier binding of a letrec +-- +-- For the robust info, see Note [Arity robustness] +-- +-- Augment the substitution if the unique changed +-- Extend the in-scope set with the new Id +-- +-- Similar to GHC.Core.Subst.substIdBndr, except that +-- the type of id_subst differs +-- all fragile info is zapped +substNonCoVarIdBndr new_res_ty + env@(SimplEnv { seInScope = in_scope + , seIdSubst = id_subst }) + old_id + = ASSERT2( not (isCoVar old_id), ppr old_id ) + (env { seInScope = in_scope `extendInScopeSet` new_id, + seIdSubst = new_subst }, new_id) + where + id1 = uniqAway in_scope old_id + id2 = substIdType env id1 + + id3 | Just res_ty <- new_res_ty + = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2) + -- See Note [Return type for join points] + | otherwise + = id2 + + new_id = zapFragileIdInfo id3 -- Zaps rules, worker-info, unfolding + -- and fragile OccInfo + + -- Extend the substitution if the unique has changed, + -- or there's some useful occurrence information + -- See the notes with substTyVarBndr for the delSubstEnv + new_subst | new_id /= old_id + = extendVarEnv id_subst old_id (DoneId new_id) + | otherwise + = delVarEnv id_subst old_id + +------------------------------------ +seqTyVar :: TyVar -> () +seqTyVar b = b `seq` () + +seqId :: Id -> () +seqId id = seqType (idType id) `seq` + idInfo id `seq` + () + +seqIds :: [Id] -> () +seqIds [] = () +seqIds (id:ids) = seqId id `seq` seqIds ids + +{- +Note [Arity robustness] +~~~~~~~~~~~~~~~~~~~~~~~ +We *do* transfer the arity from from the in_id of a let binding to the +out_id. This is important, so that the arity of an Id is visible in +its own RHS. For example: + f = \x. ....g (\y. f y).... +We can eta-reduce the arg to g, because f is a value. But that +needs to be visible. + +This interacts with the 'state hack' too: + f :: Bool -> IO Int + f = \x. case x of + True -> f y + False -> \s -> ... +Can we eta-expand f? Only if we see that f has arity 1, and then we +take advantage of the 'state hack' on the result of +(f y) :: State# -> (State#, Int) to expand the arity one more. + +There is a disadvantage though. Making the arity visible in the RHS +allows us to eta-reduce + f = \x -> f x +to + f = f +which technically is not sound. This is very much a corner case, so +I'm not worried about it. Another idea is to ensure that f's arity +never decreases; its arity started as 1, and we should never eta-reduce +below that. + + +Note [Robust OccInfo] +~~~~~~~~~~~~~~~~~~~~~ +It's important that we *do* retain the loop-breaker OccInfo, because +that's what stops the Id getting inlined infinitely, in the body of +the letrec. +-} + + +{- +************************************************************************ +* * + Impedance matching to type substitution +* * +************************************************************************ +-} + +getTCvSubst :: SimplEnv -> TCvSubst +getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env + , seCvSubst = cv_env }) + = mkTCvSubst in_scope (tv_env, cv_env) + +substTy :: SimplEnv -> Type -> Type +substTy env ty = Type.substTy (getTCvSubst env) ty + +substTyVar :: SimplEnv -> TyVar -> Type +substTyVar env tv = Type.substTyVar (getTCvSubst env) tv + +substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) +substTyVarBndr env tv + = case Type.substTyVarBndr (getTCvSubst env) tv of + (TCvSubst in_scope' tv_env' cv_env', tv') + -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv') + +substCoVar :: SimplEnv -> CoVar -> Coercion +substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv + +substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) +substCoVarBndr env cv + = case Coercion.substCoVarBndr (getTCvSubst env) cv of + (TCvSubst in_scope' tv_env' cv_env', cv') + -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') + +substCo :: SimplEnv -> Coercion -> Coercion +substCo env co = Coercion.substCo (getTCvSubst env) co + +------------------ +substIdType :: SimplEnv -> Id -> Id +substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) + || noFreeVarsOfType old_ty + = id + | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty) + -- The tyCoVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself + where + old_ty = idType id diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -0,0 +1,252 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad} +-} + +{-# LANGUAGE DeriveFunctor #-} +module GHC.Core.Opt.Simplify.Monad ( + -- The monad + SimplM, + initSmpl, traceSmpl, + getSimplRules, getFamEnvs, + + -- Unique supply + MonadUnique(..), newId, newJoinId, + + -- Counting + SimplCount, tick, freeTick, checkedTick, + getSimplCount, zeroSimplCount, pprSimplCount, + plusSimplCount, isZeroSimplCount + ) where + +import GHC.Prelude + +import GHC.Types.Var ( Var, isId, mkLocalVar ) +import GHC.Types.Name ( mkSystemVarName ) +import GHC.Types.Id ( Id, mkSysLocalOrCoVar ) +import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) +import GHC.Core.Type ( Type, mkLamTypes ) +import GHC.Core.FamInstEnv ( FamInstEnv ) +import GHC.Core ( RuleEnv(..) ) +import GHC.Types.Unique.Supply +import GHC.Driver.Session +import GHC.Core.Opt.Monad +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Monad +import GHC.Utils.Error as Err +import GHC.Utils.Misc ( count ) +import GHC.Utils.Panic (throwGhcExceptionIO, GhcException (..)) +import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf ) +import Control.Monad ( ap ) + +{- +************************************************************************ +* * +\subsection{Monad plumbing} +* * +************************************************************************ + +For the simplifier monad, we want to {\em thread} a unique supply and a counter. +(Command-line switches move around through the explicitly-passed SimplEnv.) +-} + +newtype SimplM result + = SM { unSM :: SimplTopEnv -- Envt that does not change much + -> UniqSupply -- We thread the unique supply because + -- constantly splitting it is rather expensive + -> SimplCount + -> IO (result, UniqSupply, SimplCount)} + -- we only need IO here for dump output + deriving (Functor) + +data SimplTopEnv + = STE { st_flags :: DynFlags + , st_max_ticks :: IntWithInf -- Max #ticks in this simplifier run + , st_rules :: RuleEnv + , st_fams :: (FamInstEnv, FamInstEnv) } + +initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv) + -> UniqSupply -- No init count; set to 0 + -> Int -- Size of the bindings, used to limit + -- the number of ticks we allow + -> SimplM a + -> IO (a, SimplCount) + +initSmpl dflags rules fam_envs us size m + = do (result, _, count) <- unSM m env us (zeroSimplCount dflags) + return (result, count) + where + env = STE { st_flags = dflags, st_rules = rules + , st_max_ticks = computeMaxTicks dflags size + , st_fams = fam_envs } + +computeMaxTicks :: DynFlags -> Int -> IntWithInf +-- Compute the max simplifier ticks as +-- (base-size + pgm-size) * magic-multiplier * tick-factor/100 +-- where +-- magic-multiplier is a constant that gives reasonable results +-- base-size is a constant to deal with size-zero programs +computeMaxTicks dflags size + = treatZeroAsInf $ + fromInteger ((toInteger (size + base_size) + * toInteger (tick_factor * magic_multiplier)) + `div` 100) + where + tick_factor = simplTickFactor dflags + base_size = 100 + magic_multiplier = 40 + -- MAGIC NUMBER, multiplies the simplTickFactor + -- We can afford to be generous; this is really + -- just checking for loops, and shouldn't usually fire + -- A figure of 20 was too small: see #5539. + +{-# INLINE thenSmpl #-} +{-# INLINE thenSmpl_ #-} +{-# INLINE returnSmpl #-} + + +instance Applicative SimplM where + pure = returnSmpl + (<*>) = ap + (*>) = thenSmpl_ + +instance Monad SimplM where + (>>) = (*>) + (>>=) = thenSmpl + +returnSmpl :: a -> SimplM a +returnSmpl e = SM (\_st_env us sc -> return (e, us, sc)) + +thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b +thenSmpl_ :: SimplM a -> SimplM b -> SimplM b + +thenSmpl m k + = SM $ \st_env us0 sc0 -> do + (m_result, us1, sc1) <- unSM m st_env us0 sc0 + unSM (k m_result) st_env us1 sc1 + +thenSmpl_ m k + = SM $ \st_env us0 sc0 -> do + (_, us1, sc1) <- unSM m st_env us0 sc0 + unSM k st_env us1 sc1 + +-- TODO: this specializing is not allowed +-- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-} +-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-} +-- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-} + +traceSmpl :: String -> SDoc -> SimplM () +traceSmpl herald doc + = do { dflags <- getDynFlags + ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace" + FormatText + (hang (text herald) 2 doc) } + +{- +************************************************************************ +* * +\subsection{The unique supply} +* * +************************************************************************ +-} + +instance MonadUnique SimplM where + getUniqueSupplyM + = SM (\_st_env us sc -> case splitUniqSupply us of + (us1, us2) -> return (us1, us2, sc)) + + getUniqueM + = SM (\_st_env us sc -> case takeUniqFromSupply us of + (u, us') -> return (u, us', sc)) + + getUniquesM + = SM (\_st_env us sc -> case splitUniqSupply us of + (us1, us2) -> return (uniqsFromSupply us1, us2, sc)) + +instance HasDynFlags SimplM where + getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc)) + +instance MonadIO SimplM where + liftIO m = SM $ \_ us sc -> do + x <- m + return (x, us, sc) + +getSimplRules :: SimplM RuleEnv +getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc)) + +getFamEnvs :: SimplM (FamInstEnv, FamInstEnv) +getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc)) + +newId :: FastString -> Type -> SimplM Id +newId fs ty = do uniq <- getUniqueM + return (mkSysLocalOrCoVar fs uniq ty) + +newJoinId :: [Var] -> Type -> SimplM Id +newJoinId bndrs body_ty + = do { uniq <- getUniqueM + ; let name = mkSystemVarName uniq (fsLit "$j") + join_id_ty = mkLamTypes bndrs body_ty -- Note [Funky mkLamTypes] + arity = count isId bndrs + -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core + join_arity = length bndrs + details = JoinId join_arity + id_info = vanillaIdInfo `setArityInfo` arity +-- `setOccInfo` strongLoopBreaker + + ; return (mkLocalVar details name join_id_ty id_info) } + +{- +************************************************************************ +* * +\subsection{Counting up what we've done} +* * +************************************************************************ +-} + +getSimplCount :: SimplM SimplCount +getSimplCount = SM (\_st_env us sc -> return (sc, us, sc)) + +tick :: Tick -> SimplM () +tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc + in sc' `seq` return ((), us, sc')) + +checkedTick :: Tick -> SimplM () +-- Try to take a tick, but fail if too many +checkedTick t + = SM (\st_env us sc -> + if st_max_ticks st_env <= mkIntWithInf (simplCountN sc) + then throwGhcExceptionIO $ + PprProgramError "Simplifier ticks exhausted" (msg sc) + else let sc' = doSimplTick (st_flags st_env) t sc + in sc' `seq` return ((), us, sc')) + where + msg sc = vcat + [ text "When trying" <+> ppr t + , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)." + , space + , text "If you need to increase the limit substantially, please file a" + , text "bug report and indicate the factor you needed." + , space + , text "If GHC was unable to complete compilation even" + <+> text "with a very large factor" + , text "(a thousand or more), please consult the" + <+> doubleQuotes (text "Known bugs or infelicities") + , text "section in the Users Guide before filing a report. There are a" + , text "few situations unlikely to occur in practical programs for which" + , text "simplifier non-termination has been judged acceptable." + , space + , pp_details sc + , pprSimplCount sc ] + pp_details sc + | hasDetailedCounts sc = empty + | otherwise = text "To see detailed counts use -ddump-simpl-stats" + + +freeTick :: Tick -> SimplM () +-- Record a tick, but don't add to the total tick count, which is +-- used to decide when nothing further has happened +freeTick t + = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc + in sc' `seq` return ((), us, sc')) diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -0,0 +1,2336 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +The simplifier utilities +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.Simplify.Utils ( + -- Rebuilding + mkLam, mkCase, prepareAlts, tryEtaExpandRhs, + + -- Inlining, + preInlineUnconditionally, postInlineUnconditionally, + activeUnfolding, activeRule, + getUnfoldingInRuleMatch, + simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules, + + -- The continuation type + SimplCont(..), DupFlag(..), StaticEnv, + isSimplified, contIsStop, + contIsDupable, contResultType, contHoleType, + contIsTrivial, contArgs, + countArgs, + mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, + interestingCallContext, + + -- ArgInfo + ArgInfo(..), ArgSpec(..), mkArgInfo, + addValArgTo, addCastTo, addTyArgTo, + argInfoExpr, argInfoAppArgs, pushSimplifiedArgs, + + abstractFloats, + + -- Utilities + isExitJoinId + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Monad ( SimplMode(..), Tick(..) ) +import GHC.Driver.Session +import GHC.Core +import qualified GHC.Core.Subst +import GHC.Core.Ppr +import GHC.Core.TyCo.Ppr ( pprParendType ) +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Arity +import GHC.Core.Unfold +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var +import GHC.Types.Demand +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Builtin.PrimOps +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Type hiding( substTy ) +import GHC.Core.Coercion hiding( substCo ) +import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon ) +import GHC.Utils.Misc +import GHC.Data.OrdList ( isNilOL ) +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Core.Opt.ConstantFold +import GHC.Data.FastString ( fsLit ) + +import Control.Monad ( when ) +import Data.List ( sortBy ) + +{- +************************************************************************ +* * + The SimplCont and DupFlag types +* * +************************************************************************ + +A SimplCont allows the simplifier to traverse the expression in a +zipper-like fashion. The SimplCont represents the rest of the expression, +"above" the point of interest. + +You can also think of a SimplCont as an "evaluation context", using +that term in the way it is used for operational semantics. This is the +way I usually think of it, For example you'll often see a syntax for +evaluation context looking like + C ::= [] | C e | case C of alts | C `cast` co +That's the kind of thing we are doing here, and I use that syntax in +the comments. + + +Key points: + * A SimplCont describes a *strict* context (just like + evaluation contexts do). E.g. Just [] is not a SimplCont + + * A SimplCont describes a context that *does not* bind + any variables. E.g. \x. [] is not a SimplCont +-} + +data SimplCont + = Stop -- Stop[e] = e + OutType -- Type of the + CallCtxt -- Tells if there is something interesting about + -- the context, and hence the inliner + -- should be a bit keener (see interestingCallContext) + -- Specifically: + -- This is an argument of a function that has RULES + -- Inlining the call might allow the rule to fire + -- Never ValAppCxt (use ApplyToVal instead) + -- or CaseCtxt (use Select instead) + + | CastIt -- (CastIt co K)[e] = K[ e `cast` co ] + OutCoercion -- The coercion simplified + -- Invariant: never an identity coercion + SimplCont + + | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ] + { sc_dup :: DupFlag -- See Note [DupFlag invariants] + , sc_arg :: InExpr -- The argument, + , sc_env :: StaticEnv -- see Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] + { sc_arg_ty :: OutType -- Argument type + , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) + -- See Note [The hole type in ApplyToTy] + , sc_cont :: SimplCont } + + | Select -- (Select alts K)[e] = K[ case e of alts ] + { sc_dup :: DupFlag -- See Note [DupFlag invariants] + , sc_bndr :: InId -- case binder + , sc_alts :: [InAlt] -- Alternatives + , sc_env :: StaticEnv -- See Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + -- The two strict forms have no DupFlag, because we never duplicate them + | StrictBind -- (StrictBind x xs b K)[e] = let x = e in K[\xs.b] + -- or, equivalently, = K[ (\x xs.b) e ] + { sc_dup :: DupFlag -- See Note [DupFlag invariants] + , sc_bndr :: InId + , sc_bndrs :: [InBndr] + , sc_body :: InExpr + , sc_env :: StaticEnv -- See Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] + { sc_dup :: DupFlag -- Always Simplified or OkToDup + , sc_fun :: ArgInfo -- Specifies f, e1..en, Whether f has rules, etc + -- plus strictness flags for *further* args + , sc_cci :: CallCtxt -- Whether *this* argument position is interesting + , sc_cont :: SimplCont } + + | TickIt -- (TickIt t K)[e] = K[ tick t e ] + (Tickish Id) -- Tick tickish + SimplCont + +type StaticEnv = SimplEnv -- Just the static part is relevant + +data DupFlag = NoDup -- Unsimplified, might be big + | Simplified -- Simplified + | OkToDup -- Simplified and small + +isSimplified :: DupFlag -> Bool +isSimplified NoDup = False +isSimplified _ = True -- Invariant: the subst-env is empty + +perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type +perhapsSubstTy dup env ty + | isSimplified dup = ty + | otherwise = substTy env ty + +{- Note [StaticEnv invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pair up an InExpr or InAlts with a StaticEnv, which establishes the +lexical scope for that InExpr. When we simplify that InExpr/InAlts, we +use + - Its captured StaticEnv + - Overriding its InScopeSet with the larger one at the + simplification point. + +Why override the InScopeSet? Example: + (let y = ey in f) ex +By the time we simplify ex, 'y' will be in scope. + +However the InScopeSet in the StaticEnv is not irrelevant: it should +include all the free vars of applying the substitution to the InExpr. +Reason: contHoleType uses perhapsSubstTy to apply the substitution to +the expression, and that (rightly) gives ASSERT failures if the InScopeSet +isn't big enough. + +Note [DupFlag invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In both (ApplyToVal dup _ env k) + and (Select dup _ _ env k) +the following invariants hold + + (a) if dup = OkToDup, then continuation k is also ok-to-dup + (b) if dup = OkToDup or Simplified, the subst-env is empty + (and and hence no need to re-simplify) +-} + +instance Outputable DupFlag where + ppr OkToDup = text "ok" + ppr NoDup = text "nodup" + ppr Simplified = text "simpl" + +instance Outputable SimplCont where + ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty + ppr (CastIt co cont ) = (text "CastIt" <+> pprOptCo co) $$ ppr cont + ppr (TickIt t cont) = (text "TickIt" <+> ppr t) $$ ppr cont + ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) + = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont + ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont }) + = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg) + $$ ppr cont + ppr (StrictBind { sc_bndr = b, sc_cont = cont }) + = (text "StrictBind" <+> ppr b) $$ ppr cont + ppr (StrictArg { sc_fun = ai, sc_cont = cont }) + = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont + ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) + = (text "Select" <+> ppr dup <+> ppr bndr) $$ + whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont + + +{- Note [The hole type in ApplyToTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_hole_ty field of ApplyToTy records the type of the "hole" in the +continuation. It is absolutely necessary to compute contHoleType, but it is +not used for anything else (and hence may not be evaluated). + +Why is it necessary for contHoleType? Consider the continuation + ApplyToType Int (Stop Int) +corresponding to + ( @Int) :: Int +What is the type of ? It could be (forall a. Int) or (forall a. a), +and there is no way to know which, so we must record it. + +In a chain of applications (f @t1 @t2 @t3) we'll lazily compute exprType +for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably +doesn't matter because we'll never compute them all. + +************************************************************************ +* * + ArgInfo and ArgSpec +* * +************************************************************************ +-} + +data ArgInfo + = ArgInfo { + ai_fun :: OutId, -- The function + ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) + + ai_type :: OutType, -- Type of (f a1 ... an) + + ai_rules :: FunRules, -- Rules for this function + + ai_encl :: Bool, -- Flag saying whether this function + -- or an enclosing one has rules (recursively) + -- True => be keener to inline in all args + + ai_strs :: [Bool], -- Strictness of remaining arguments + -- Usually infinite, but if it is finite it guarantees + -- that the function diverges after being given + -- that number of args + ai_discs :: [Int] -- Discounts for remaining arguments; non-zero => be keener to inline + -- Always infinite + } + +data ArgSpec + = ValArg OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal + | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy + , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah) + | CastBy OutCoercion -- Cast by this; c.f. CastIt + +instance Outputable ArgSpec where + ppr (ValArg e) = text "ValArg" <+> ppr e + ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty + ppr (CastBy c) = text "CastBy" <+> ppr c + +addValArgTo :: ArgInfo -> OutExpr -> ArgInfo +addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai + , ai_type = applyTypeToArg (ai_type ai) arg + , ai_rules = decRules (ai_rules ai) } + +addTyArgTo :: ArgInfo -> OutType -> ArgInfo +addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai + , ai_type = piResultTy poly_fun_ty arg_ty + , ai_rules = decRules (ai_rules ai) } + where + poly_fun_ty = ai_type ai + arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = poly_fun_ty } + +addCastTo :: ArgInfo -> OutCoercion -> ArgInfo +addCastTo ai co = ai { ai_args = CastBy co : ai_args ai + , ai_type = coercionRKind co } + +argInfoAppArgs :: [ArgSpec] -> [OutExpr] +argInfoAppArgs [] = [] +argInfoAppArgs (CastBy {} : _) = [] -- Stop at a cast +argInfoAppArgs (ValArg e : as) = e : argInfoAppArgs as +argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as + +pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont +pushSimplifiedArgs _env [] k = k +pushSimplifiedArgs env (arg : args) k + = case arg of + TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } + -> ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest } + ValArg e -> ApplyToVal { sc_arg = e, sc_env = env, sc_dup = Simplified, sc_cont = rest } + CastBy c -> CastIt c rest + where + rest = pushSimplifiedArgs env args k + -- The env has an empty SubstEnv + +argInfoExpr :: OutId -> [ArgSpec] -> OutExpr +-- NB: the [ArgSpec] is reversed so that the first arg +-- in the list is the last one in the application +argInfoExpr fun rev_args + = go rev_args + where + go [] = Var fun + go (ValArg a : as) = go as `App` a + go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty + go (CastBy co : as) = mkCast (go as) co + + +type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function + -- Nothing => No rules + -- Just (n, rules) => some rules, requiring at least n more type/value args + +decRules :: FunRules -> FunRules +decRules (Just (n, rules)) = Just (n-1, rules) +decRules Nothing = Nothing + +mkFunRules :: [CoreRule] -> FunRules +mkFunRules [] = Nothing +mkFunRules rs = Just (n_required, rs) + where + n_required = maximum (map ruleArity rs) + +{- +************************************************************************ +* * + Functions on SimplCont +* * +************************************************************************ +-} + +mkBoringStop :: OutType -> SimplCont +mkBoringStop ty = Stop ty BoringCtxt + +mkRhsStop :: OutType -> SimplCont -- See Note [RHS of lets] in GHC.Core.Unfold +mkRhsStop ty = Stop ty RhsCtxt + +mkLazyArgStop :: OutType -> CallCtxt -> SimplCont +mkLazyArgStop ty cci = Stop ty cci + +------------------- +contIsRhsOrArg :: SimplCont -> Bool +contIsRhsOrArg (Stop {}) = True +contIsRhsOrArg (StrictBind {}) = True +contIsRhsOrArg (StrictArg {}) = True +contIsRhsOrArg _ = False + +contIsRhs :: SimplCont -> Bool +contIsRhs (Stop _ RhsCtxt) = True +contIsRhs _ = False + +------------------- +contIsStop :: SimplCont -> Bool +contIsStop (Stop {}) = True +contIsStop _ = False + +contIsDupable :: SimplCont -> Bool +contIsDupable (Stop {}) = True +contIsDupable (ApplyToTy { sc_cont = k }) = contIsDupable k +contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants] +contIsDupable (Select { sc_dup = OkToDup }) = True -- ...ditto... +contIsDupable (StrictArg { sc_dup = OkToDup }) = True -- ...ditto... +contIsDupable (CastIt _ k) = contIsDupable k +contIsDupable _ = False + +------------------- +contIsTrivial :: SimplCont -> Bool +contIsTrivial (Stop {}) = True +contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial k +contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k +contIsTrivial (CastIt _ k) = contIsTrivial k +contIsTrivial _ = False + +------------------- +contResultType :: SimplCont -> OutType +contResultType (Stop ty _) = ty +contResultType (CastIt _ k) = contResultType k +contResultType (StrictBind { sc_cont = k }) = contResultType k +contResultType (StrictArg { sc_cont = k }) = contResultType k +contResultType (Select { sc_cont = k }) = contResultType k +contResultType (ApplyToTy { sc_cont = k }) = contResultType k +contResultType (ApplyToVal { sc_cont = k }) = contResultType k +contResultType (TickIt _ k) = contResultType k + +contHoleType :: SimplCont -> OutType +contHoleType (Stop ty _) = ty +contHoleType (TickIt _ k) = contHoleType k +contHoleType (CastIt co _) = coercionLKind co +contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se }) + = perhapsSubstTy dup se (idType b) +contHoleType (StrictArg { sc_fun = ai }) = funArgTy (ai_type ai) +contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] +contHoleType (ApplyToVal { sc_arg = e, sc_env = se, sc_dup = dup, sc_cont = k }) + = mkVisFunTy (perhapsSubstTy dup se (exprType e)) + (contHoleType k) +contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) + = perhapsSubstTy d se (idType b) + +------------------- +countArgs :: SimplCont -> Int +-- Count all arguments, including types, coercions, and other values +countArgs (ApplyToTy { sc_cont = cont }) = 1 + countArgs cont +countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont +countArgs _ = 0 + +contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont) +-- Summarises value args, discards type args and coercions +-- The returned continuation of the call is only used to +-- answer questions like "are you interesting?" +contArgs cont + | lone cont = (True, [], cont) + | otherwise = go [] cont + where + lone (ApplyToTy {}) = False -- See Note [Lone variables] in GHC.Core.Unfold + lone (ApplyToVal {}) = False + lone (CastIt {}) = False + lone _ = True + + go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) + = go (is_interesting arg se : args) k + go args (ApplyToTy { sc_cont = k }) = go args k + go args (CastIt _ k) = go args k + go args k = (False, reverse args, k) + + is_interesting arg se = interestingArg se arg + -- Do *not* use short-cutting substitution here + -- because we want to get as much IdInfo as possible + + +------------------- +mkArgInfo :: SimplEnv + -> Id + -> [CoreRule] -- Rules for function + -> Int -- Number of value args + -> SimplCont -- Context of the call + -> ArgInfo + +mkArgInfo env fun rules n_val_args call_cont + | n_val_args < idArity fun -- Note [Unsaturated functions] + = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty + , ai_rules = fun_rules + , ai_encl = False + , ai_strs = vanilla_stricts + , ai_discs = vanilla_discounts } + | otherwise + = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty + , ai_rules = fun_rules + , ai_encl = interestingArgContext rules call_cont + , ai_strs = arg_stricts + , ai_discs = arg_discounts } + where + fun_ty = idType fun + + fun_rules = mkFunRules rules + + vanilla_discounts, arg_discounts :: [Int] + vanilla_discounts = repeat 0 + arg_discounts = case idUnfolding fun of + CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} + -> discounts ++ vanilla_discounts + _ -> vanilla_discounts + + vanilla_stricts, arg_stricts :: [Bool] + vanilla_stricts = repeat False + + arg_stricts + | not (sm_inline (seMode env)) + = vanilla_stricts -- See Note [Do not expose strictness if sm_inline=False] + | otherwise + = add_type_str fun_ty $ + case splitStrictSig (idStrictness fun) of + (demands, result_info) + | not (demands `lengthExceeds` n_val_args) + -> -- Enough args, use the strictness given. + -- For bottoming functions we used to pretend that the arg + -- is lazy, so that we don't treat the arg as an + -- interesting context. This avoids substituting + -- top-level bindings for (say) strings into + -- calls to error. But now we are more careful about + -- inlining lone variables, so it's ok + -- (see GHC.Core.Opt.Simplify.Utils.analyseCont) + -- See Note [Precise exceptions and strictness analysis] in Demand.hs + -- for the special case on raiseIO# + if isBotDiv result_info || isPrimOpId_maybe fun == Just RaiseIOOp then + map isStrictDmd demands -- Finite => result is bottom + else + map isStrictDmd demands ++ vanilla_stricts + | otherwise + -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun) + <+> ppr n_val_args <+> ppr demands ) + vanilla_stricts -- Not enough args, or no strictness + + add_type_str :: Type -> [Bool] -> [Bool] + -- If the function arg types are strict, record that in the 'strictness bits' + -- No need to instantiate because unboxed types (which dominate the strict + -- types) can't instantiate type variables. + -- add_type_str is done repeatedly (for each call); + -- might be better once-for-all in the function + -- But beware primops/datacons with no strictness + + add_type_str _ [] = [] + add_type_str fun_ty all_strs@(str:strs) + | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info + = (str || Just False == isLiftedType_maybe arg_ty) + : add_type_str fun_ty' strs + -- If the type is levity-polymorphic, we can't know whether it's + -- strict. isLiftedType_maybe will return Just False only when + -- we're sure the type is unlifted. + + | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty + = add_type_str fun_ty' all_strs -- Look through foralls + + | otherwise + = all_strs + +{- Note [Unsaturated functions] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (test eyeball/inline4) + x = a:as + y = f x +where f has arity 2. Then we do not want to inline 'x', because +it'll just be floated out again. Even if f has lots of discounts +on its first argument -- it must be saturated for these to kick in + +Note [Do not expose strictness if sm_inline=False] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#15163 showed a case in which we had + + {-# INLINE [1] zip #-} + zip = undefined + + {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-} + +If we expose zip's bottoming nature when simplifying the LHS of the +RULE we get + {-# RULES "foo" forall as bs. + stream (case zip of {}) = ..blah... #-} +discarding the arguments to zip. Usually this is fine, but on the +LHS of a rule it's not, because 'as' and 'bs' are now not bound on +the LHS. + +This is a pretty pathological example, so I'm not losing sleep over +it, but the simplest solution was to check sm_inline; if it is False, +which it is on the LHS of a rule (see updModeForRules), then don't +make use of the strictness info for the function. +-} + + +{- +************************************************************************ +* * + Interesting arguments +* * +************************************************************************ + +Note [Interesting call context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to avoid inlining an expression where there can't possibly be +any gain, such as in an argument position. Hence, if the continuation +is interesting (eg. a case scrutinee, application etc.) then we +inline, otherwise we don't. + +Previously some_benefit used to return True only if the variable was +applied to some value arguments. This didn't work: + + let x = _coerce_ (T Int) Int (I# 3) in + case _coerce_ Int (T Int) x of + I# y -> .... + +we want to inline x, but can't see that it's a constructor in a case +scrutinee position, and some_benefit is False. + +Another example: + +dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) + +.... case dMonadST _@_ x0 of (a,b,c) -> .... + +we'd really like to inline dMonadST here, but we *don't* want to +inline if the case expression is just + + case x of y { DEFAULT -> ... } + +since we can just eliminate this case instead (x is in WHNF). Similar +applies when x is bound to a lambda expression. Hence +contIsInteresting looks for case expressions with just a single +default case. + +Note [No case of case is boring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see + case f x of + +we'd usually treat the context as interesting, to encourage 'f' to +inline. But if case-of-case is off, it's really not so interesting +after all, because we are unlikely to be able to push the case +expression into the branches of any case in f's unfolding. So, to +reduce unnecessary code expansion, we just make the context look boring. +This made a small compile-time perf improvement in perf/compiler/T6048, +and it looks plausible to me. +-} + +interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt +-- See Note [Interesting call context] +interestingCallContext env cont + = interesting cont + where + interesting (Select {}) + | sm_case_case (getMode env) = CaseCtxt + | otherwise = BoringCtxt + -- See Note [No case of case is boring] + + interesting (ApplyToVal {}) = ValAppCtxt + -- Can happen if we have (f Int |> co) y + -- If f has an INLINE prag we need to give it some + -- motivation to inline. See Note [Cast then apply] + -- in GHC.Core.Unfold + + interesting (StrictArg { sc_cci = cci }) = cci + interesting (StrictBind {}) = BoringCtxt + interesting (Stop _ cci) = cci + interesting (TickIt _ k) = interesting k + interesting (ApplyToTy { sc_cont = k }) = interesting k + interesting (CastIt _ k) = interesting k + -- If this call is the arg of a strict function, the context + -- is a bit interesting. If we inline here, we may get useful + -- evaluation information to avoid repeated evals: e.g. + -- x + (y * z) + -- Here the contIsInteresting makes the '*' keener to inline, + -- which in turn exposes a constructor which makes the '+' inline. + -- Assuming that +,* aren't small enough to inline regardless. + -- + -- It's also very important to inline in a strict context for things + -- like + -- foldr k z (f x) + -- Here, the context of (f x) is strict, and if f's unfolding is + -- a build it's *great* to inline it here. So we must ensure that + -- the context for (f x) is not totally uninteresting. + +interestingArgContext :: [CoreRule] -> SimplCont -> Bool +-- If the argument has form (f x y), where x,y are boring, +-- and f is marked INLINE, then we don't want to inline f. +-- But if the context of the argument is +-- g (f x y) +-- where g has rules, then we *do* want to inline f, in case it +-- exposes a rule that might fire. Similarly, if the context is +-- h (g (f x x)) +-- where h has rules, then we do want to inline f; hence the +-- call_cont argument to interestingArgContext +-- +-- The ai-rules flag makes this happen; if it's +-- set, the inliner gets just enough keener to inline f +-- regardless of how boring f's arguments are, if it's marked INLINE +-- +-- The alternative would be to *always* inline an INLINE function, +-- regardless of how boring its context is; but that seems overkill +-- For example, it'd mean that wrapper functions were always inlined +-- +-- The call_cont passed to interestingArgContext is the context of +-- the call itself, e.g. g in the example above +interestingArgContext rules call_cont + = notNull rules || enclosing_fn_has_rules + where + enclosing_fn_has_rules = go call_cont + + go (Select {}) = False + go (ApplyToVal {}) = False -- Shouldn't really happen + go (ApplyToTy {}) = False -- Ditto + go (StrictArg { sc_cci = cci }) = interesting cci + go (StrictBind {}) = False -- ?? + go (CastIt _ c) = go c + go (Stop _ cci) = interesting cci + go (TickIt _ c) = go c + + interesting RuleArgCtxt = True + interesting _ = False + + +{- Note [Interesting arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An argument is interesting if it deserves a discount for unfoldings +with a discount in that argument position. The idea is to avoid +unfolding a function that is applied only to variables that have no +unfolding (i.e. they are probably lambda bound): f x y z There is +little point in inlining f here. + +Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But +we must look through lets, eg (let x = e in C a b), because the let will +float, exposing the value, if we inline. That makes it different to +exprIsHNF. + +Before 2009 we said it was interesting if the argument had *any* structure +at all; i.e. (hasSomeUnfolding v). But does too much inlining; see #3016. + +But we don't regard (f x y) as interesting, unless f is unsaturated. +If it's saturated and f hasn't inlined, then it's probably not going +to now! + +Note [Conlike is interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f d = ...((*) d x y)... + ... f (df d')... +where df is con-like. Then we'd really like to inline 'f' so that the +rule for (*) (df d) can fire. To do this + a) we give a discount for being an argument of a class-op (eg (*) d) + b) we say that a con-like argument (eg (df d)) is interesting +-} + +interestingArg :: SimplEnv -> CoreExpr -> ArgSummary +-- See Note [Interesting arguments] +interestingArg env e = go env 0 e + where + -- n is # value args to which the expression is applied + go env n (Var v) + = case substId env v of + DoneId v' -> go_var n v' + DoneEx e _ -> go (zapSubstEnv env) n e + ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e + + go _ _ (Lit {}) = ValueArg + go _ _ (Type _) = TrivArg + go _ _ (Coercion _) = TrivArg + go env n (App fn (Type _)) = go env n fn + go env n (App fn _) = go env (n+1) fn + go env n (Tick _ a) = go env n a + go env n (Cast e _) = go env n e + go env n (Lam v e) + | isTyVar v = go env n e + | n>0 = NonTrivArg -- (\x.b) e is NonTriv + | otherwise = ValueArg + go _ _ (Case {}) = NonTrivArg + go env n (Let b e) = case go env' n e of + ValueArg -> ValueArg + _ -> NonTrivArg + where + env' = env `addNewInScopeIds` bindersOf b + + go_var n v + | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that + -- data constructors here + | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding + | n > 0 = NonTrivArg -- Saturated or unknown call + | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding + -- See Note [Conlike is interesting] + | otherwise = TrivArg -- n==0, no useful unfolding + where + conlike_unfolding = isConLikeUnfolding (idUnfolding v) + +{- +************************************************************************ +* * + SimplMode +* * +************************************************************************ + +The SimplMode controls several switches; see its definition in +GHC.Core.Opt.Monad + sm_rules :: Bool -- Whether RULES are enabled + sm_inline :: Bool -- Whether inlining is enabled + sm_case_case :: Bool -- Whether case-of-case is enabled + sm_eta_expand :: Bool -- Whether eta-expansion is enabled +-} + +simplEnvForGHCi :: DynFlags -> SimplEnv +simplEnvForGHCi dflags + = mkSimplEnv $ SimplMode { sm_names = ["GHCi"] + , sm_phase = InitialPhase + , sm_dflags = dflags + , sm_rules = rules_on + , sm_inline = False + , sm_eta_expand = eta_expand_on + , sm_case_case = True } + where + rules_on = gopt Opt_EnableRewriteRules dflags + eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags + -- Do not do any inlining, in case we expose some unboxed + -- tuple stuff that confuses the bytecode interpreter + +updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode +-- See Note [Simplifying inside stable unfoldings] +updModeForStableUnfoldings inline_rule_act current_mode + = current_mode { sm_phase = phaseFromActivation inline_rule_act + , sm_inline = True + , sm_eta_expand = False } + -- sm_eta_expand: see Note [No eta expansion in stable unfoldings] + -- For sm_rules, just inherit; sm_rules might be "off" + -- because of -fno-enable-rewrite-rules + where + phaseFromActivation (ActiveAfter _ n) = Phase n + phaseFromActivation _ = InitialPhase + +updModeForRules :: SimplMode -> SimplMode +-- See Note [Simplifying rules] +updModeForRules current_mode + = current_mode { sm_phase = InitialPhase + , sm_inline = False -- See Note [Do not expose strictness if sm_inline=False] + , sm_rules = False + , sm_eta_expand = False } + +{- Note [Simplifying rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When simplifying a rule LHS, refrain from /any/ inlining or applying +of other RULES. + +Doing anything to the LHS is plain confusing, because it means that what the +rule matches is not what the user wrote. c.f. #10595, and #10528. +Moreover, inlining (or applying rules) on rule LHSs risks introducing +Ticks into the LHS, which makes matching trickier. #10665, #10745. + +Doing this to either side confounds tools like HERMIT, which seek to reason +about and apply the RULES as originally written. See #10829. + +Note [No eta expansion in stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a stable unfolding + + f :: Ord a => a -> IO () + -- Unfolding template + -- = /\a \(d:Ord a) (x:a). bla + +we do not want to eta-expand to + + f :: Ord a => a -> IO () + -- Unfolding template + -- = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co + +because not specialisation of the overloading doesn't work properly +(see Note [Specialisation shape] in GHC.Core.Opt.Specialise), #9509. + +So we disable eta-expansion in stable unfoldings. + +Note [Inlining in gentle mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Something is inlined if + (i) the sm_inline flag is on, AND + (ii) the thing has an INLINE pragma, AND + (iii) the thing is inlinable in the earliest phase. + +Example of why (iii) is important: + {-# INLINE [~1] g #-} + g = ... + + {-# INLINE f #-} + f x = g (g x) + +If we were to inline g into f's inlining, then an importing module would +never be able to do + f e --> g (g e) ---> RULE fires +because the stable unfolding for f has had g inlined into it. + +On the other hand, it is bad not to do ANY inlining into an +stable unfolding, because then recursive knots in instance declarations +don't get unravelled. + +However, *sometimes* SimplGently must do no call-site inlining at all +(hence sm_inline = False). Before full laziness we must be careful +not to inline wrappers, because doing so inhibits floating + e.g. ...(case f x of ...)... + ==> ...(case (case x of I# x# -> fw x#) of ...)... + ==> ...(case x of I# x# -> case fw x# of ...)... +and now the redex (f x) isn't floatable any more. + +The no-inlining thing is also important for Template Haskell. You might be +compiling in one-shot mode with -O2; but when TH compiles a splice before +running it, we don't want to use -O2. Indeed, we don't want to inline +anything, because the byte-code interpreter might get confused about +unboxed tuples and suchlike. + +Note [Simplifying inside stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must take care with simplification inside stable unfoldings (which come from +INLINE pragmas). + +First, consider the following example + let f = \pq -> BIG + in + let g = \y -> f y y + {-# INLINE g #-} + in ...g...g...g...g...g... +Now, if that's the ONLY occurrence of f, it might be inlined inside g, +and thence copied multiple times when g is inlined. HENCE we treat +any occurrence in a stable unfolding as a multiple occurrence, not a single +one; see OccurAnal.addRuleUsage. + +Second, we do want *do* to some modest rules/inlining stuff in stable +unfoldings, partly to eliminate senseless crap, and partly to break +the recursive knots generated by instance declarations. + +However, suppose we have + {-# INLINE f #-} + f = +meaning "inline f in phases p where activation (p) holds". +Then what inlinings/rules can we apply to the copy of captured in +f's stable unfolding? Our model is that literally is substituted for +f when it is inlined. So our conservative plan (implemented by +updModeForStableUnfoldings) is this: + + ------------------------------------------------------------- + When simplifying the RHS of a stable unfolding, set the phase + to the phase in which the stable unfolding first becomes active + ------------------------------------------------------------- + +That ensures that + + a) Rules/inlinings that *cease* being active before p will + not apply to the stable unfolding, consistent with it being + inlined in its *original* form in phase p. + + b) Rules/inlinings that only become active *after* p will + not apply to the stable unfolding, again to be consistent with + inlining the *original* rhs in phase p. + +For example, + {-# INLINE f #-} + f x = ...g... + + {-# NOINLINE [1] g #-} + g y = ... + + {-# RULE h g = ... #-} +Here we must not inline g into f's RHS, even when we get to phase 0, +because when f is later inlined into some other module we want the +rule for h to fire. + +Similarly, consider + {-# INLINE f #-} + f x = ...g... + + g y = ... +and suppose that there are auto-generated specialisations and a strictness +wrapper for g. The specialisations get activation AlwaysActive, and the +strictness wrapper get activation (ActiveAfter 0). So the strictness +wrepper fails the test and won't be inlined into f's stable unfolding. That +means f can inline, expose the specialised call to g, so the specialisation +rules can fire. + +A note about wrappers +~~~~~~~~~~~~~~~~~~~~~ +It's also important not to inline a worker back into a wrapper. +A wrapper looks like + wraper = inline_me (\x -> ...worker... ) +Normally, the inline_me prevents the worker getting inlined into +the wrapper (initially, the worker's only call site!). But, +if the wrapper is sure to be called, the strictness analyser will +mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf +continuation. +-} + +activeUnfolding :: SimplMode -> Id -> Bool +activeUnfolding mode id + | isCompulsoryUnfolding (realIdUnfolding id) + = True -- Even sm_inline can't override compulsory unfoldings + | otherwise + = isActive (sm_phase mode) (idInlineActivation id) + && sm_inline mode + -- `or` isStableUnfolding (realIdUnfolding id) + -- Inline things when + -- (a) they are active + -- (b) sm_inline says so, except that for stable unfoldings + -- (ie pragmas) we inline anyway + +getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv +-- When matching in RULE, we want to "look through" an unfolding +-- (to see a constructor) if *rules* are on, even if *inlinings* +-- are not. A notable example is DFuns, which really we want to +-- match in rules like (op dfun) in gentle mode. Another example +-- is 'otherwise' which we want exprIsConApp_maybe to be able to +-- see very early on +getUnfoldingInRuleMatch env + = (in_scope, id_unf) + where + in_scope = seInScope env + mode = getMode env + id_unf id | unf_is_active id = idUnfolding id + | otherwise = NoUnfolding + unf_is_active id + | not (sm_rules mode) = -- active_unfolding_minimal id + isStableUnfolding (realIdUnfolding id) + -- Do we even need to test this? I think this InScopeEnv + -- is only consulted if activeRule returns True, which + -- never happens if sm_rules is False + | otherwise = isActive (sm_phase mode) (idInlineActivation id) + +---------------------- +activeRule :: SimplMode -> Activation -> Bool +-- Nothing => No rules at all +activeRule mode + | not (sm_rules mode) = \_ -> False -- Rewriting is off + | otherwise = isActive (sm_phase mode) + +{- +************************************************************************ +* * + preInlineUnconditionally +* * +************************************************************************ + +preInlineUnconditionally +~~~~~~~~~~~~~~~~~~~~~~~~ +@preInlineUnconditionally@ examines a bndr to see if it is used just +once in a completely safe way, so that it is safe to discard the +binding inline its RHS at the (unique) usage site, REGARDLESS of how +big the RHS might be. If this is the case we don't simplify the RHS +first, but just inline it un-simplified. + +This is much better than first simplifying a perhaps-huge RHS and then +inlining and re-simplifying it. Indeed, it can be at least quadratically +better. Consider + + x1 = e1 + x2 = e2[x1] + x3 = e3[x2] + ...etc... + xN = eN[xN-1] + +We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc. +This can happen with cascades of functions too: + + f1 = \x1.e1 + f2 = \xs.e2[f1] + f3 = \xs.e3[f3] + ...etc... + +THE MAIN INVARIANT is this: + + ---- preInlineUnconditionally invariant ----- + IF preInlineUnconditionally chooses to inline x = + THEN doing the inlining should not change the occurrence + info for the free vars of + ---------------------------------------------- + +For example, it's tempting to look at trivial binding like + x = y +and inline it unconditionally. But suppose x is used many times, +but this is the unique occurrence of y. Then inlining x would change +y's occurrence info, which breaks the invariant. It matters: y +might have a BIG rhs, which will now be dup'd at every occurrence of x. + + +Even RHSs labelled InlineMe aren't caught here, because there might be +no benefit from inlining at the call site. + +[Sept 01] Don't unconditionally inline a top-level thing, because that +can simply make a static thing into something built dynamically. E.g. + x = (a,b) + main = \s -> h x + +[Remember that we treat \s as a one-shot lambda.] No point in +inlining x unless there is something interesting about the call site. + +But watch out: if you aren't careful, some useful foldr/build fusion +can be lost (most notably in spectral/hartel/parstof) because the +foldr didn't see the build. Doing the dynamic allocation isn't a big +deal, in fact, but losing the fusion can be. But the right thing here +seems to be to do a callSiteInline based on the fact that there is +something interesting about the call site (it's strict). Hmm. That +seems a bit fragile. + +Conclusion: inline top level things gaily until Phase 0 (the last +phase), at which point don't. + +Note [pre/postInlineUnconditionally in gentle mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even in gentle mode we want to do preInlineUnconditionally. The +reason is that too little clean-up happens if you don't inline +use-once things. Also a bit of inlining is *good* for full laziness; +it can expose constant sub-expressions. Example in +spectral/mandel/Mandel.hs, where the mandelset function gets a useful +let-float if you inline windowToViewport + +However, as usual for Gentle mode, do not inline things that are +inactive in the initial stages. See Note [Gentle mode]. + +Note [Stable unfoldings and preInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas! +Example + + {-# INLINE f #-} + f :: Eq a => a -> a + f x = ... + + fInt :: Int -> Int + fInt = f Int dEqInt + + ...fInt...fInt...fInt... + +Here f occurs just once, in the RHS of fInt. But if we inline it there +it might make fInt look big, and we'll lose the opportunity to inline f +at each of fInt's call sites. The INLINE pragma will only inline when +the application is saturated for exactly this reason; and we don't +want PreInlineUnconditionally to second-guess it. A live example is +#3736. + c.f. Note [Stable unfoldings and postInlineUnconditionally] + +NB: if the pragma is INLINEABLE, then we don't want to behave in +this special way -- an INLINEABLE pragma just says to GHC "inline this +if you like". But if there is a unique occurrence, we want to inline +the stable unfolding, not the RHS. + +Note [Top-level bottoming Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't inline top-level Ids that are bottoming, even if they are used just +once, because FloatOut has gone to some trouble to extract them out. +Inlining them won't make the program run faster! + +Note [Do not inline CoVars unconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Coercion variables appear inside coercions, and the RHS of a let-binding +is a term (not a coercion) so we can't necessarily inline the latter in +the former. +-} + +preInlineUnconditionally + :: SimplEnv -> TopLevelFlag -> InId + -> InExpr -> StaticEnv -- These two go together + -> Maybe SimplEnv -- Returned env has extended substitution +-- Precondition: rhs satisfies the let/app invariant +-- See Note [Core let/app invariant] in GHC.Core +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-ful bindings +preInlineUnconditionally env top_lvl bndr rhs rhs_env + | not pre_inline_unconditionally = Nothing + | not active = Nothing + | isTopLevel top_lvl && isBottomingId bndr = Nothing -- Note [Top-level bottoming Ids] + | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally] + | isExitJoinId bndr = Nothing -- Note [Do not inline exit join points] + -- in module Exitify + | not (one_occ (idOccInfo bndr)) = Nothing + | not (isStableUnfolding unf) = Just (extend_subst_with rhs) + + -- Note [Stable unfoldings and preInlineUnconditionally] + | isInlinablePragma inline_prag + , Just inl <- maybeUnfoldingTemplate unf = Just (extend_subst_with inl) + | otherwise = Nothing + where + unf = idUnfolding bndr + extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs) + + one_occ IAmDead = True -- Happens in ((\x.1) v) + one_occ OneOcc{ occ_one_br = InOneBranch + , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase + one_occ OneOcc{ occ_one_br = InOneBranch + , occ_in_lam = IsInsideLam + , occ_int_cxt = IsInteresting } = canInlineInLam rhs + one_occ _ = False + + pre_inline_unconditionally = gopt Opt_SimplPreInlining (seDynFlags env) + mode = getMode env + active = isActive (sm_phase mode) (inlinePragmaActivation inline_prag) + -- See Note [pre/postInlineUnconditionally in gentle mode] + inline_prag = idInlinePragma bndr + +-- Be very careful before inlining inside a lambda, because (a) we must not +-- invalidate occurrence information, and (b) we want to avoid pushing a +-- single allocation (here) into multiple allocations (inside lambda). +-- Inlining a *function* with a single *saturated* call would be ok, mind you. +-- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok) +-- where +-- is_cheap = exprIsCheap rhs +-- ok = is_cheap && int_cxt + + -- int_cxt The context isn't totally boring + -- E.g. let f = \ab.BIG in \y. map f xs + -- Don't want to substitute for f, because then we allocate + -- its closure every time the \y is called + -- But: let f = \ab.BIG in \y. map (f y) xs + -- Now we do want to substitute for f, even though it's not + -- saturated, because we're going to allocate a closure for + -- (f y) every time round the loop anyhow. + + -- canInlineInLam => free vars of rhs are (Once in_lam) or Many, + -- so substituting rhs inside a lambda doesn't change the occ info. + -- Sadly, not quite the same as exprIsHNF. + canInlineInLam (Lit _) = True + canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e + canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e + canInlineInLam _ = False + -- not ticks. Counting ticks cannot be duplicated, and non-counting + -- ticks around a Lam will disappear anyway. + + early_phase = case sm_phase mode of + Phase 0 -> False + _ -> True +-- If we don't have this early_phase test, consider +-- x = length [1,2,3] +-- The full laziness pass carefully floats all the cons cells to +-- top level, and preInlineUnconditionally floats them all back in. +-- Result is (a) static allocation replaced by dynamic allocation +-- (b) many simplifier iterations because this tickles +-- a related problem; only one inlining per pass +-- +-- On the other hand, I have seen cases where top-level fusion is +-- lost if we don't inline top level thing (e.g. string constants) +-- Hence the test for phase zero (which is the phase for all the final +-- simplifications). Until phase zero we take no special notice of +-- top level things, but then we become more leery about inlining +-- them. + +{- +************************************************************************ +* * + postInlineUnconditionally +* * +************************************************************************ + +postInlineUnconditionally +~~~~~~~~~~~~~~~~~~~~~~~~~ +@postInlineUnconditionally@ decides whether to unconditionally inline +a thing based on the form of its RHS; in particular if it has a +trivial RHS. If so, we can inline and discard the binding altogether. + +NB: a loop breaker has must_keep_binding = True and non-loop-breakers +only have *forward* references. Hence, it's safe to discard the binding + +NOTE: This isn't our last opportunity to inline. We're at the binding +site right now, and we'll get another opportunity when we get to the +occurrence(s) + +Note that we do this unconditional inlining only for trivial RHSs. +Don't inline even WHNFs inside lambdas; doing so may simply increase +allocation when the function is called. This isn't the last chance; see +NOTE above. + +NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why? +Because we don't even want to inline them into the RHS of constructor +arguments. See NOTE above + +NB: At one time even NOINLINE was ignored here: if the rhs is trivial +it's best to inline it anyway. We often get a=E; b=a from desugaring, +with both a and b marked NOINLINE. But that seems incompatible with +our new view that inlining is like a RULE, so I'm sticking to the 'active' +story for now. +-} + +postInlineUnconditionally + :: SimplEnv -> TopLevelFlag + -> OutId -- The binder (*not* a CoVar), including its unfolding + -> OccInfo -- From the InId + -> OutExpr + -> Bool +-- Precondition: rhs satisfies the let/app invariant +-- See Note [Core let/app invariant] in GHC.Core +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-ful bindings +postInlineUnconditionally env top_lvl bndr occ_info rhs + | not active = False + | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline + -- because it might be referred to "earlier" + | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally] + | isTopLevel top_lvl = False -- Note [Top level and postInlineUnconditionally] + | exprIsTrivial rhs = True + | otherwise + = case occ_info of + -- The point of examining occ_info here is that for *non-values* + -- that occur outside a lambda, the call-site inliner won't have + -- a chance (because it doesn't know that the thing + -- only occurs once). The pre-inliner won't have gotten + -- it either, if the thing occurs in more than one branch + -- So the main target is things like + -- let x = f y in + -- case v of + -- True -> case x of ... + -- False -> case x of ... + -- This is very important in practice; e.g. wheel-seive1 doubles + -- in allocation if you miss this out + OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt } + -- OneOcc => no code-duplication issue + -> smallEnoughToInline dflags unfolding -- Small enough to dup + -- ToDo: consider discount on smallEnoughToInline if int_cxt is true + -- + -- NB: Do NOT inline arbitrarily big things, even if one_br is True + -- Reason: doing so risks exponential behaviour. We simplify a big + -- expression, inline it, and simplify it again. But if the + -- very same thing happens in the big expression, we get + -- exponential cost! + -- PRINCIPLE: when we've already simplified an expression once, + -- make sure that we only inline it if it's reasonably small. + + && (in_lam == NotInsideLam || + -- Outside a lambda, we want to be reasonably aggressive + -- about inlining into multiple branches of case + -- e.g. let x = + -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... } + -- Inlining can be a big win if C3 is the hot-spot, even if + -- the uses in C1, C2 are not 'interesting' + -- An example that gets worse if you add int_cxt here is 'clausify' + + (isCheapUnfolding unfolding && int_cxt == IsInteresting)) + -- isCheap => acceptable work duplication; in_lam may be true + -- int_cxt to prevent us inlining inside a lambda without some + -- good reason. See the notes on int_cxt in preInlineUnconditionally + + IAmDead -> True -- This happens; for example, the case_bndr during case of + -- known constructor: case (a,b) of x { (p,q) -> ... } + -- Here x isn't mentioned in the RHS, so we don't want to + -- create the (dead) let-binding let x = (a,b) in ... + + _ -> False + +-- Here's an example that we don't handle well: +-- let f = if b then Left (\x.BIG) else Right (\y.BIG) +-- in \y. ....case f of {...} .... +-- Here f is used just once, and duplicating the case work is fine (exprIsCheap). +-- But +-- - We can't preInlineUnconditionally because that would invalidate +-- the occ info for b. +-- - We can't postInlineUnconditionally because the RHS is big, and +-- that risks exponential behaviour +-- - We can't call-site inline, because the rhs is big +-- Alas! + + where + unfolding = idUnfolding bndr + dflags = seDynFlags env + active = isActive (sm_phase (getMode env)) (idInlineActivation bndr) + -- See Note [pre/postInlineUnconditionally in gentle mode] + +{- +Note [Top level and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't do postInlineUnconditionally for top-level things (even for +ones that are trivial): + + * Doing so will inline top-level error expressions that have been + carefully floated out by FloatOut. More generally, it might + replace static allocation with dynamic. + + * Even for trivial expressions there's a problem. Consider + {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-} + blah xs = reverse xs + ruggle = sort + In one simplifier pass we might fire the rule, getting + blah xs = ruggle xs + but in *that* simplifier pass we must not do postInlineUnconditionally + on 'ruggle' because then we'll have an unbound occurrence of 'ruggle' + + If the rhs is trivial it'll be inlined by callSiteInline, and then + the binding will be dead and discarded by the next use of OccurAnal + + * There is less point, because the main goal is to get rid of local + bindings used in multiple case branches. + + * The inliner should inline trivial things at call sites anyway. + + * The Id might be exported. We could check for that separately, + but since we aren't going to postInlineUnconditionally /any/ + top-level bindings, we don't need to test. + +Note [Stable unfoldings and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do not do postInlineUnconditionally if the Id has a stable unfolding, +otherwise we lose the unfolding. Example + + -- f has stable unfolding with rhs (e |> co) + -- where 'e' is big + f = e |> co + +Then there's a danger we'll optimise to + + f' = e + f = f' |> co + +and now postInlineUnconditionally, losing the stable unfolding on f. Now f' +won't inline because 'e' is too big. + + c.f. Note [Stable unfoldings and preInlineUnconditionally] + + +************************************************************************ +* * + Rebuilding a lambda +* * +************************************************************************ +-} + +mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr +-- mkLam tries three things +-- a) eta reduction, if that gives a trivial expression +-- b) eta expansion [only if there are some value lambdas] + +mkLam _env [] body _cont + = return body +mkLam env bndrs body cont + = do { dflags <- getDynFlags + ; mkLam' dflags bndrs body } + where + mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr + mkLam' dflags bndrs (Cast body co) + | not (any bad bndrs) + -- Note [Casts and lambdas] + = do { lam <- mkLam' dflags bndrs body + ; return (mkCast lam (mkPiCos Representational bndrs co)) } + where + co_vars = tyCoVarsOfCo co + bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars + + mkLam' dflags bndrs body@(Lam {}) + = mkLam' dflags (bndrs ++ bndrs1) body1 + where + (bndrs1, body1) = collectBinders body + + mkLam' dflags bndrs (Tick t expr) + | tickishFloatable t + = mkTick t <$> mkLam' dflags bndrs expr + + mkLam' dflags bndrs body + | gopt Opt_DoEtaReduction dflags + , Just etad_lam <- tryEtaReduce bndrs body + = do { tick (EtaReduction (head bndrs)) + ; return etad_lam } + + | not (contIsRhs cont) -- See Note [Eta-expanding lambdas] + , sm_eta_expand (getMode env) + , any isRuntimeVar bndrs + , let body_arity = exprEtaExpandArity dflags body + , body_arity > 0 + = do { tick (EtaExpansion (head bndrs)) + ; let res = mkLams bndrs (etaExpand body_arity body) + ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body) + , text "after" <+> ppr res]) + ; return res } + + | otherwise + = return (mkLams bndrs body) + +{- +Note [Eta expanding lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we *do* want to eta-expand lambdas. Consider + f (\x -> case x of (a,b) -> \s -> blah) +where 's' is a state token, and hence can be eta expanded. This +showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather +important function! + +The eta-expansion will never happen unless we do it now. (Well, it's +possible that CorePrep will do it, but CorePrep only has a half-baked +eta-expander that can't deal with casts. So it's much better to do it +here.) + +However, when the lambda is let-bound, as the RHS of a let, we have a +better eta-expander (in the form of tryEtaExpandRhs), so we don't +bother to try expansion in mkLam in that case; hence the contIsRhs +guard. + +NB: We check the SimplEnv (sm_eta_expand), not DynFlags. + See Note [No eta expansion in stable unfoldings] + +Note [Casts and lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (\x. (\y. e) `cast` g1) `cast` g2 +There is a danger here that the two lambdas look separated, and the +full laziness pass might float an expression to between the two. + +So this equation in mkLam' floats the g1 out, thus: + (\x. e `cast` g1) --> (\x.e) `cast` (tx -> g1) +where x:tx. + +In general, this floats casts outside lambdas, where (I hope) they +might meet and cancel with some other cast: + \x. e `cast` co ===> (\x. e) `cast` (tx -> co) + /\a. e `cast` co ===> (/\a. e) `cast` (/\a. co) + /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co) + (if not (g `in` co)) + +Notice that it works regardless of 'e'. Originally it worked only +if 'e' was itself a lambda, but in some cases that resulted in +fruitless iteration in the simplifier. A good example was when +compiling Text.ParserCombinators.ReadPrec, where we had a definition +like (\x. Get `cast` g) +where Get is a constructor with nonzero arity. Then mkLam eta-expanded +the Get, and the next iteration eta-reduced it, and then eta-expanded +it again. + +Note also the side condition for the case of coercion binders. +It does not make sense to transform + /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g) +because the latter is not well-kinded. + +************************************************************************ +* * + Eta expansion +* * +************************************************************************ +-} + +tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr + -> SimplM (Arity, Bool, OutExpr) +-- See Note [Eta-expanding at let bindings] +-- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then +-- (a) rhs' has manifest arity n +-- (b) if is_bot is True then rhs' applied to n args is guaranteed bottom +tryEtaExpandRhs mode bndr rhs + | Just join_arity <- isJoinId_maybe bndr + = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs + ; return (count isId join_bndrs, exprIsBottom join_body, rhs) } + -- Note [Do not eta-expand join points] + -- But do return the correct arity and bottom-ness, because + -- these are used to set the bndr's IdInfo (#15517) + -- Note [Invariants on join points] invariant 2b, in GHC.Core + + | otherwise + = do { (new_arity, is_bot, new_rhs) <- try_expand + + ; WARN( new_arity < old_id_arity, + (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity + <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) ) + -- Note [Arity decrease] in GHC.Core.Opt.Simplify + return (new_arity, is_bot, new_rhs) } + where + try_expand + | exprIsTrivial rhs + = return (exprArity rhs, False, rhs) + + | sm_eta_expand mode -- Provided eta-expansion is on + , new_arity > old_arity -- And the current manifest arity isn't enough + = do { tick (EtaExpansion bndr) + ; return (new_arity, is_bot, etaExpand new_arity rhs) } + + | otherwise + = return (old_arity, is_bot && new_arity == old_arity, rhs) + + dflags = sm_dflags mode + old_arity = exprArity rhs -- See Note [Do not expand eta-expand PAPs] + old_id_arity = idArity bndr + + (new_arity1, is_bot) = findRhsArity dflags bndr rhs old_arity + new_arity2 = idCallArity bndr + new_arity = max new_arity1 new_arity2 + +{- +Note [Eta-expanding at let bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We now eta expand at let-bindings, which is where the payoff comes. +The most significant thing is that we can do a simple arity analysis +(in GHC.Core.Arity.findRhsArity), which we can't do for free-floating lambdas + +One useful consequence of not eta-expanding lambdas is this example: + genMap :: C a => ... + {-# INLINE genMap #-} + genMap f xs = ... + + myMap :: D a => ... + {-# INLINE myMap #-} + myMap = genMap + +Notice that 'genMap' should only inline if applied to two arguments. +In the stable unfolding for myMap we'll have the unfolding + (\d -> genMap Int (..d..)) +We do not want to eta-expand to + (\d f xs -> genMap Int (..d..) f xs) +because then 'genMap' will inline, and it really shouldn't: at least +as far as the programmer is concerned, it's not applied to two +arguments! + +Note [Do not eta-expand join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Similarly to CPR (see Note [Don't w/w join points for CPR] in +GHC.Core.Opt.WorkWrap), a join point stands well to gain from its outer binding's +eta-expansion, and eta-expanding a join point is fraught with issues like how to +deal with a cast: + + let join $j1 :: IO () + $j1 = ... + $j2 :: Int -> IO () + $j2 n = if n > 0 then $j1 + else ... + + => + + let join $j1 :: IO () + $j1 = (\eta -> ...) + `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) + ~ IO () + $j2 :: Int -> IO () + $j2 n = (\eta -> if n > 0 then $j1 + else ...) + `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) + ~ IO () + +The cast here can't be pushed inside the lambda (since it's not casting to a +function type), so the lambda has to stay, but it can't because it contains a +reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather +than try and detect this situation (and whatever other situations crop up!), we +don't bother; again, any surrounding eta-expansion will improve these join +points anyway, since an outer cast can *always* be pushed inside. By the time +CorePrep comes around, the code is very likely to look more like this: + + let join $j1 :: State# RealWorld -> (# State# RealWorld, ()) + $j1 = (...) eta + $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ()) + $j2 = if n > 0 then $j1 + else (...) eta + +Note [Do not eta-expand PAPs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have old_arity = manifestArity rhs, which meant that we +would eta-expand even PAPs. But this gives no particular advantage, +and can lead to a massive blow-up in code size, exhibited by #9020. +Suppose we have a PAP + foo :: IO () + foo = returnIO () +Then we can eta-expand do + foo = (\eta. (returnIO () |> sym g) eta) |> g +where + g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #) + +But there is really no point in doing this, and it generates masses of +coercions and whatnot that eventually disappear again. For T9020, GHC +allocated 6.6G before, and 0.8G afterwards; and residency dropped from +1.8G to 45M. + +But note that this won't eta-expand, say + f = \g -> map g +Does it matter not eta-expanding such functions? I'm not sure. Perhaps +strictness analysis will have less to bite on? + + +************************************************************************ +* * +\subsection{Floating lets out of big lambdas} +* * +************************************************************************ + +Note [Floating and type abstraction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + x = /\a. C e1 e2 +We'd like to float this to + y1 = /\a. e1 + y2 = /\a. e2 + x = /\a. C (y1 a) (y2 a) +for the usual reasons: we want to inline x rather vigorously. + +You may think that this kind of thing is rare. But in some programs it is +common. For example, if you do closure conversion you might get: + + data a :-> b = forall e. (e -> a -> b) :$ e + + f_cc :: forall a. a :-> a + f_cc = /\a. (\e. id a) :$ () + +Now we really want to inline that f_cc thing so that the +construction of the closure goes away. + +So I have elaborated simplLazyBind to understand right-hand sides that look +like + /\ a1..an. body + +and treat them specially. The real work is done in +GHC.Core.Opt.Simplify.Utils.abstractFloats, but there is quite a bit of plumbing +in simplLazyBind as well. + +The same transformation is good when there are lets in the body: + + /\abc -> let(rec) x = e in b + ==> + let(rec) x' = /\abc -> let x = x' a b c in e + in + /\abc -> let x = x' a b c in b + +This is good because it can turn things like: + + let f = /\a -> letrec g = ... g ... in g +into + letrec g' = /\a -> ... g' a ... + in + let f = /\ a -> g' a + +which is better. In effect, it means that big lambdas don't impede +let-floating. + +This optimisation is CRUCIAL in eliminating the junk introduced by +desugaring mutually recursive definitions. Don't eliminate it lightly! + +[May 1999] If we do this transformation *regardless* then we can +end up with some pretty silly stuff. For example, + + let + st = /\ s -> let { x1=r1 ; x2=r2 } in ... + in .. +becomes + let y1 = /\s -> r1 + y2 = /\s -> r2 + st = /\s -> ...[y1 s/x1, y2 s/x2] + in .. + +Unless the "..." is a WHNF there is really no point in doing this. +Indeed it can make things worse. Suppose x1 is used strictly, +and is of the form + + x1* = case f y of { (a,b) -> e } + +If we abstract this wrt the tyvar we then can't do the case inline +as we would normally do. + +That's why the whole transformation is part of the same process that +floats let-bindings and constructor arguments out of RHSs. In particular, +it is guarded by the doFloatFromRhs call in simplLazyBind. + +Note [Which type variables to abstract over] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Abstract only over the type variables free in the rhs wrt which the +new binding is abstracted. Note that + + * The naive approach of abstracting wrt the + tyvars free in the Id's /type/ fails. Consider: + /\ a b -> let t :: (a,b) = (e1, e2) + x :: a = fst t + in ... + Here, b isn't free in x's type, but we must nevertheless + abstract wrt b as well, because t's type mentions b. + Since t is floated too, we'd end up with the bogus: + poly_t = /\ a b -> (e1, e2) + poly_x = /\ a -> fst (poly_t a *b*) + + * We must do closeOverKinds. Example (#10934): + f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ... + Here we want to float 't', but we must remember to abstract over + 'k' as well, even though it is not explicitly mentioned in the RHS, + otherwise we get + t = /\ (f:k->*) (a:k). AccFailure @ (f a) + which is obviously bogus. +-} + +abstractFloats :: DynFlags -> TopLevelFlag -> [OutTyVar] -> SimplFloats + -> OutExpr -> SimplM ([OutBind], OutExpr) +abstractFloats dflags top_lvl main_tvs floats body + = ASSERT( notNull body_floats ) + ASSERT( isNilOL (sfJoinFloats floats) ) + do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats + ; return (float_binds, GHC.Core.Subst.substExpr (text "abstract_floats1") subst body) } + where + is_top_lvl = isTopLevel top_lvl + main_tv_set = mkVarSet main_tvs + body_floats = letFloatBinds (sfLetFloats floats) + empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats) + + abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind) + abstract subst (NonRec id rhs) + = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id + ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs' + subst' = GHC.Core.Subst.extendIdSubst subst id poly_app + ; return (subst', NonRec poly_id2 poly_rhs) } + where + rhs' = GHC.Core.Subst.substExpr (text "abstract_floats2") subst rhs + + -- tvs_here: see Note [Which type variables to abstract over] + tvs_here = scopedSort $ + filter (`elemVarSet` main_tv_set) $ + closeOverKindsList $ + exprSomeFreeVarsList isTyVar rhs' + + abstract subst (Rec prs) + = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids + ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps) + poly_pairs = [ mk_poly2 poly_id tvs_here rhs' + | (poly_id, rhs) <- poly_ids `zip` rhss + , let rhs' = GHC.Core.Subst.substExpr (text "abstract_floats") + subst' rhs ] + ; return (subst', Rec poly_pairs) } + where + (ids,rhss) = unzip prs + -- For a recursive group, it's a bit of a pain to work out the minimal + -- set of tyvars over which to abstract: + -- /\ a b c. let x = ...a... in + -- letrec { p = ...x...q... + -- q = .....p...b... } in + -- ... + -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted + -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'. + -- Since it's a pain, we just use the whole set, which is always safe + -- + -- If you ever want to be more selective, remember this bizarre case too: + -- x::a = x + -- Here, we must abstract 'x' over 'a'. + tvs_here = scopedSort main_tvs + + mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr) + mk_poly1 tvs_here var + = do { uniq <- getUniqueM + ; let poly_name = setNameUnique (idName var) uniq -- Keep same name + poly_ty = mkInvForAllTys tvs_here (idType var) -- But new type of course + poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id + mkLocalId poly_name poly_ty + ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } + -- In the olden days, it was crucial to copy the occInfo of the original var, + -- because we were looking at occurrence-analysed but as yet unsimplified code! + -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking + -- at already simplified code, so it doesn't matter + -- + -- It's even right to retain single-occurrence or dead-var info: + -- Suppose we started with /\a -> let x = E in B + -- where x occurs once in B. Then we transform to: + -- let x' = /\a -> E in /\a -> let x* = x' a in B + -- where x* has an INLINE prag on it. Now, once x* is inlined, + -- the occurrences of x' will be just the occurrences originally + -- pinned on x. + + mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr) + mk_poly2 poly_id tvs_here rhs + = (poly_id `setIdUnfolding` unf, poly_rhs) + where + poly_rhs = mkLams tvs_here rhs + unf = mkUnfolding dflags InlineRhs is_top_lvl False poly_rhs + + -- We want the unfolding. Consider + -- let + -- x = /\a. let y = ... in Just y + -- in body + -- Then we float the y-binding out (via abstractFloats and addPolyBind) + -- but 'x' may well then be inlined in 'body' in which case we'd like the + -- opportunity to inline 'y' too. + +{- +Note [Abstract over coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the +type variable a. Rather than sort this mess out, we simply bale out and abstract +wrt all the type variables if any of them are coercion variables. + + +Historical note: if you use let-bindings instead of a substitution, beware of this: + + -- Suppose we start with: + -- + -- x = /\ a -> let g = G in E + -- + -- Then we'll float to get + -- + -- x = let poly_g = /\ a -> G + -- in /\ a -> let g = poly_g a in E + -- + -- But now the occurrence analyser will see just one occurrence + -- of poly_g, not inside a lambda, so the simplifier will + -- PreInlineUnconditionally poly_g back into g! Badk to square 1! + -- (I used to think that the "don't inline lone occurrences" stuff + -- would stop this happening, but since it's the *only* occurrence, + -- PreInlineUnconditionally kicks in first!) + -- + -- Solution: put an INLINE note on g's RHS, so that poly_g seems + -- to appear many times. (NB: mkInlineMe eliminates + -- such notes on trivial RHSs, so do it manually.) + +************************************************************************ +* * + prepareAlts +* * +************************************************************************ + +prepareAlts tries these things: + +1. filterAlts: eliminate alternatives that cannot match, including + the DEFAULT alternative. Here "cannot match" includes knowledge + from GADTs + +2. refineDefaultAlt: if the DEFAULT alternative can match only one + possible constructor, then make that constructor explicit. + e.g. + case e of x { DEFAULT -> rhs } + ===> + case e of x { (a,b) -> rhs } + where the type is a single constructor type. This gives better code + when rhs also scrutinises x or e. + See CoreUtils Note [Refine DEFAULT case alternatives] + +3. combineIdenticalAlts: combine identical alternatives into a DEFAULT. + See CoreUtils Note [Combine identical alternatives], which also + says why we do this on InAlts not on OutAlts + +4. Returns a list of the constructors that cannot holds in the + DEFAULT alternative (if there is one) + +It's a good idea to do this stuff before simplifying the alternatives, to +avoid simplifying alternatives we know can't happen, and to come up with +the list of constructors that are handled, to put into the IdInfo of the +case binder, for use when simplifying the alternatives. + +Eliminating the default alternative in (1) isn't so obvious, but it can +happen: + +data Colour = Red | Green | Blue + +f x = case x of + Red -> .. + Green -> .. + DEFAULT -> h x + +h y = case y of + Blue -> .. + DEFAULT -> [ case y of ... ] + +If we inline h into f, the default case of the inlined h can't happen. +If we don't notice this, we may end up filtering out *all* the cases +of the inner case y, which give us nowhere to go! +-} + +prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) +-- The returned alternatives can be empty, none are possible +prepareAlts scrut case_bndr' alts + | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr') + -- Case binder is needed just for its type. Note that as an + -- OutId, it has maximum information; this is important. + -- Test simpl013 is an example + = do { us <- getUniquesM + ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts + (yes2, alts2) = refineDefaultAlt us tc tys idcs1 alts1 + (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2 + -- "idcs" stands for "impossible default data constructors" + -- i.e. the constructors that can't match the default case + ; when yes2 $ tick (FillInCaseDefault case_bndr') + ; when yes3 $ tick (AltMerge case_bndr') + ; return (idcs3, alts3) } + + | otherwise -- Not a data type, so nothing interesting happens + = return ([], alts) + where + imposs_cons = case scrut of + Var v -> otherCons (idUnfolding v) + _ -> [] + + +{- +************************************************************************ +* * + mkCase +* * +************************************************************************ + +mkCase tries these things + +* Note [Nerge nested cases] +* Note [Eliminate identity case] +* Note [Scrutinee constant folding] + +Note [Merge Nested Cases] +~~~~~~~~~~~~~~~~~~~~~~~~~ + case e of b { ==> case e of b { + p1 -> rhs1 p1 -> rhs1 + ... ... + pm -> rhsm pm -> rhsm + _ -> case b of b' { pn -> let b'=b in rhsn + pn -> rhsn ... + ... po -> let b'=b in rhso + po -> rhso _ -> let b'=b in rhsd + _ -> rhsd + } + +which merges two cases in one case when -- the default alternative of +the outer case scrutises the same variable as the outer case. This +transformation is called Case Merging. It avoids that the same +variable is scrutinised multiple times. + +Note [Eliminate Identity Case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + case e of ===> e + True -> True; + False -> False + +and similar friends. + +Note [Scrutinee Constant Folding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + case x op# k# of _ { ===> case x of _ { + a1# -> e1 (a1# inv_op# k#) -> e1 + a2# -> e2 (a2# inv_op# k#) -> e2 + ... ... + DEFAULT -> ed DEFAULT -> ed + + where (x op# k#) inv_op# k# == x + +And similarly for commuted arguments and for some unary operations. + +The purpose of this transformation is not only to avoid an arithmetic +operation at runtime but to allow other transformations to apply in cascade. + +Example with the "Merge Nested Cases" optimization (from #12877): + + main = case t of t0 + 0## -> ... + DEFAULT -> case t0 `minusWord#` 1## of t1 + 0## -> ... + DEFAULT -> case t1 `minusWord#` 1## of t2 + 0## -> ... + DEFAULT -> case t2 `minusWord#` 1## of _ + 0## -> ... + DEFAULT -> ... + + becomes: + + main = case t of _ + 0## -> ... + 1## -> ... + 2## -> ... + 3## -> ... + DEFAULT -> ... + +There are some wrinkles + +* Do not apply caseRules if there is just a single DEFAULT alternative + case e +# 3# of b { DEFAULT -> rhs } + If we applied the transformation here we would (stupidly) get + case a of b' { DEFAULT -> let b = e +# 3# in rhs } + and now the process may repeat, because that let will really + be a case. + +* The type of the scrutinee might change. E.g. + case tagToEnum (x :: Int#) of (b::Bool) + False -> e1 + True -> e2 + ==> + case x of (b'::Int#) + DEFAULT -> e1 + 1# -> e2 + +* The case binder may be used in the right hand sides, so we need + to make a local binding for it, if it is alive. e.g. + case e +# 10# of b + DEFAULT -> blah...b... + 44# -> blah2...b... + ===> + case e of b' + DEFAULT -> let b = b' +# 10# in blah...b... + 34# -> let b = 44# in blah2...b... + + Note that in the non-DEFAULT cases we know what to bind 'b' to, + whereas in the DEFAULT case we must reconstruct the original value. + But NB: we use b'; we do not duplicate 'e'. + +* In dataToTag we might need to make up some fake binders; + see Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold +-} + +mkCase, mkCase1, mkCase2, mkCase3 + :: DynFlags + -> OutExpr -> OutId + -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order + -> SimplM OutExpr + +-------------------------------------------------- +-- 1. Merge Nested Cases +-------------------------------------------------- + +mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts) + | gopt Opt_CaseMerge dflags + , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) + <- stripTicksTop tickishFloatable deflt_rhs + , inner_scrut_var == outer_bndr + = do { tick (CaseMerge outer_bndr) + + ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args ) + (con, args, wrap_rhs rhs) + -- Simplifier's no-shadowing invariant should ensure + -- that outer_bndr is not shadowed by the inner patterns + wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs + -- The let is OK even for unboxed binders, + + wrapped_alts | isDeadBinder inner_bndr = inner_alts + | otherwise = map wrap_alt inner_alts + + merged_alts = mergeAlts outer_alts wrapped_alts + -- NB: mergeAlts gives priority to the left + -- case x of + -- A -> e1 + -- DEFAULT -> case x of + -- A -> e2 + -- B -> e3 + -- When we merge, we must ensure that e1 takes + -- precedence over e2 as the value for A! + + ; fmap (mkTicks ticks) $ + mkCase1 dflags scrut outer_bndr alts_ty merged_alts + } + -- Warning: don't call mkCase recursively! + -- Firstly, there's no point, because inner alts have already had + -- mkCase applied to them, so they won't have a case in their default + -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr + -- in munge_rhs may put a case into the DEFAULT branch! + +mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts + +-------------------------------------------------- +-- 2. Eliminate Identity Case +-------------------------------------------------- + +mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case + | all identity_alt alts + = do { tick (CaseIdentity case_bndr) + ; return (mkTicks ticks $ re_cast scrut rhs1) } + where + ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts) + identity_alt (con, args, rhs) = check_eq rhs con args + + check_eq (Cast rhs co) con args -- See Note [RHS casts] + = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args + check_eq (Tick t e) alt args + = tickishFloatable t && check_eq e alt args + + check_eq (Lit lit) (LitAlt lit') _ = lit == lit' + check_eq (Var v) _ _ | v == case_bndr = True + check_eq (Var v) (DataAlt con) args + | null arg_tys, null args = v == dataConWorkId con + -- Optimisation only + check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $ + mkConApp2 con arg_tys args + check_eq _ _ _ = False + + arg_tys = tyConAppArgs (idType case_bndr) + + -- Note [RHS casts] + -- ~~~~~~~~~~~~~~~~ + -- We've seen this: + -- case e of x { _ -> x `cast` c } + -- And we definitely want to eliminate this case, to give + -- e `cast` c + -- So we throw away the cast from the RHS, and reconstruct + -- it at the other end. All the RHS casts must be the same + -- if (all identity_alt alts) holds. + -- + -- Don't worry about nested casts, because the simplifier combines them + + re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co + re_cast scrut _ = scrut + +mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts + +-------------------------------------------------- +-- 2. Scrutinee Constant Folding +-------------------------------------------------- + +mkCase2 dflags scrut bndr alts_ty alts + | -- See Note [Scrutinee Constant Folding] + case alts of -- Not if there is just a DEFAULT alternative + [(DEFAULT,_,_)] -> False + _ -> True + , gopt Opt_CaseFolding dflags + , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut + = do { bndr' <- newId (fsLit "lwild") (exprType scrut') + + ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts + -- mapMaybeM: discard unreachable alternatives + -- See Note [Unreachable caseRules alternatives] + -- in GHC.Core.Opt.ConstantFold + + ; mkCase3 dflags scrut' bndr' alts_ty $ + add_default (re_sort alts') + } + + | otherwise + = mkCase3 dflags scrut bndr alts_ty alts + where + -- We need to keep the correct association between the scrutinee and its + -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with + -- "let bndr = ... in": + -- + -- case v + 10 of y =====> case v of y + -- 20 -> e1 10 -> let y = 20 in e1 + -- DEFAULT -> e2 DEFAULT -> let y = v + 10 in e2 + -- + -- Other transformations give: =====> case v of y' + -- 10 -> let y = 20 in e1 + -- DEFAULT -> let y = y' + 10 in e2 + -- + -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules, + -- to construct an expression equivalent to the original one, for use + -- in the DEFAULT case + + tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id + -> CoreAlt -> SimplM (Maybe CoreAlt) + tx_alt tx_con mk_orig new_bndr (con, bs, rhs) + = case tx_con con of + Nothing -> return Nothing + Just con' -> do { bs' <- mk_new_bndrs new_bndr con' + ; return (Just (con', bs', rhs')) } + where + rhs' | isDeadBinder bndr = rhs + | otherwise = bindNonRec bndr orig_val rhs + + orig_val = case con of + DEFAULT -> mk_orig new_bndr + LitAlt l -> Lit l + DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs + + mk_new_bndrs new_bndr (DataAlt dc) + | not (isNullaryRepDataCon dc) + = -- For non-nullary data cons we must invent some fake binders + -- See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold + do { us <- getUniquesM + ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc + (tyConAppArgs (idType new_bndr)) + ; return (ex_tvs ++ arg_ids) } + mk_new_bndrs _ _ = return [] + + re_sort :: [CoreAlt] -> [CoreAlt] + -- Sort the alternatives to re-establish + -- GHC.Core Note [Case expression invariants] + re_sort alts = sortBy cmpAlt alts + + add_default :: [CoreAlt] -> [CoreAlt] + -- See Note [Literal cases] + add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts + add_default alts = alts + +{- Note [Literal cases] +~~~~~~~~~~~~~~~~~~~~~~~ +If we have + case tagToEnum (a ># b) of + False -> e1 + True -> e2 + +then caseRules for TagToEnum will turn it into + case tagToEnum (a ># b) of + 0# -> e1 + 1# -> e2 + +Since the case is exhaustive (all cases are) we can convert it to + case tagToEnum (a ># b) of + DEFAULT -> e1 + 1# -> e2 + +This may generate sligthtly better code (although it should not, since +all cases are exhaustive) and/or optimise better. I'm not certain that +it's necessary, but currently we do make this change. We do it here, +NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum] +in GHC.Core.Opt.ConstantFold) +-} + +-------------------------------------------------- +-- Catch-all +-------------------------------------------------- +mkCase3 _dflags scrut bndr alts_ty alts + = return (Case scrut bndr alts_ty alts) + +-- See Note [Exitification] and Note [Do not inline exit join points] in +-- GHC.Core.Opt.Exitify +-- This lives here (and not in Id) because occurrence info is only valid on +-- InIds, so it's crucial that isExitJoinId is only called on freshly +-- occ-analysed code. It's not a generic function you can call anywhere. +isExitJoinId :: Var -> Bool +isExitJoinId id + = isJoinId id + && isOneOcc (idOccInfo id) + && occ_in_lam (idOccInfo id) == IsInsideLam + +{- +Note [Dead binders] +~~~~~~~~~~~~~~~~~~~~ +Note that dead-ness is maintained by the simplifier, so that it is +accurate after simplification as well as before. + + +Note [Cascading case merge] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case merging should cascade in one sweep, because it +happens bottom-up + + case e of a { + DEFAULT -> case a of b + DEFAULT -> case b of c { + DEFAULT -> e + A -> ea + B -> eb + C -> ec +==> + case e of a { + DEFAULT -> case a of b + DEFAULT -> let c = b in e + A -> let c = b in ea + B -> eb + C -> ec +==> + case e of a { + DEFAULT -> let b = a in let c = b in e + A -> let b = a in let c = b in ea + B -> let b = a in eb + C -> ec + + +However here's a tricky case that we still don't catch, and I don't +see how to catch it in one pass: + + case x of c1 { I# a1 -> + case a1 of c2 -> + 0 -> ... + DEFAULT -> case x of c3 { I# a2 -> + case a2 of ... + +After occurrence analysis (and its binder-swap) we get this + + case x of c1 { I# a1 -> + let x = c1 in -- Binder-swap addition + case a1 of c2 -> + 0 -> ... + DEFAULT -> case x of c3 { I# a2 -> + case a2 of ... + +When we simplify the inner case x, we'll see that +x=c1=I# a1. So we'll bind a2 to a1, and get + + case x of c1 { I# a1 -> + case a1 of c2 -> + 0 -> ... + DEFAULT -> case a1 of ... + +This is correct, but we can't do a case merge in this sweep +because c2 /= a1. Reason: the binding c1=I# a1 went inwards +without getting changed to c1=I# c2. + +I don't think this is worth fixing, even if I knew how. It'll +all come out in the next pass anyway. +-} diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -0,0 +1,2362 @@ +{- +ToDo [Oct 2013] +~~~~~~~~~~~~~~~ +1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim) +2. Nuke NoSpecConstr + + +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[SpecConstr]{Specialise over constructors} +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Core.Opt.SpecConstr( + specConstrProgram, + SpecConstrAnnotation(..) + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Subst +import GHC.Core.Utils +import GHC.Core.Unfold ( couldBeSmallEnoughToInline ) +import GHC.Core.FVs ( exprsFreeVarsList ) +import GHC.Core.Opt.Monad +import GHC.Types.Literal ( litIsLifted ) +import GHC.Driver.Types ( ModGuts(..) ) +import GHC.Core.Opt.WorkWrap.Utils ( isWorkerSmallEnough, mkWorkerArgs ) +import GHC.Core.DataCon +import GHC.Core.Coercion hiding( substCo ) +import GHC.Core.Rules +import GHC.Core.Type hiding ( substTy ) +import GHC.Core.TyCon ( tyConName ) +import GHC.Types.Id +import GHC.Core.Ppr ( pprParendExpr ) +import GHC.Core.Make ( mkImpossibleExpr ) +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) + , gopt, hasPprDebug ) +import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing ) +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Serialized ( deserializeWithData ) +import GHC.Utils.Misc +import GHC.Data.Pair +import GHC.Types.Unique.Supply +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Unique.FM +import GHC.Utils.Monad +import Control.Monad ( zipWithM ) +import Data.List +import GHC.Builtin.Names ( specTyConName ) +import GHC.Unit.Module +import GHC.Core.TyCon ( TyCon ) +import GHC.Exts( SpecConstrAnnotation(..) ) +import Data.Ord( comparing ) + +{- +----------------------------------------------------- + Game plan +----------------------------------------------------- + +Consider + drop n [] = [] + drop 0 xs = [] + drop n (x:xs) = drop (n-1) xs + +After the first time round, we could pass n unboxed. This happens in +numerical code too. Here's what it looks like in Core: + + drop n xs = case xs of + [] -> [] + (y:ys) -> case n of + I# n# -> case n# of + 0 -> [] + _ -> drop (I# (n# -# 1#)) xs + +Notice that the recursive call has an explicit constructor as argument. +Noticing this, we can make a specialised version of drop + + RULE: drop (I# n#) xs ==> drop' n# xs + + drop' n# xs = let n = I# n# in ...orig RHS... + +Now the simplifier will apply the specialisation in the rhs of drop', giving + + drop' n# xs = case xs of + [] -> [] + (y:ys) -> case n# of + 0 -> [] + _ -> drop' (n# -# 1#) xs + +Much better! + +We'd also like to catch cases where a parameter is carried along unchanged, +but evaluated each time round the loop: + + f i n = if i>0 || i>n then i else f (i*2) n + +Here f isn't strict in n, but we'd like to avoid evaluating it each iteration. +In Core, by the time we've w/wd (f is strict in i) we get + + f i# n = case i# ># 0 of + False -> I# i# + True -> case n of { I# n# -> + case i# ># n# of + False -> I# i# + True -> f (i# *# 2#) n + +At the call to f, we see that the argument, n is known to be (I# n#), +and n is evaluated elsewhere in the body of f, so we can play the same +trick as above. + + +Note [Reboxing] +~~~~~~~~~~~~~~~ +We must be careful not to allocate the same constructor twice. Consider + f p = (...(case p of (a,b) -> e)...p..., + ...let t = (r,s) in ...t...(f t)...) +At the recursive call to f, we can see that t is a pair. But we do NOT want +to make a specialised copy: + f' a b = let p = (a,b) in (..., ...) +because now t is allocated by the caller, then r and s are passed to the +recursive call, which allocates the (r,s) pair again. + +This happens if + (a) the argument p is used in other than a case-scrutinisation way. + (b) the argument to the call is not a 'fresh' tuple; you have to + look into its unfolding to see that it's a tuple + +Hence the "OR" part of Note [Good arguments] below. + +ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves +allocation, but does perhaps save evals. In the RULE we'd have +something like + + f (I# x#) = f' (I# x#) x# + +If at the call site the (I# x) was an unfolding, then we'd have to +rely on CSE to eliminate the duplicate allocation.... This alternative +doesn't look attractive enough to pursue. + +ALTERNATIVE 3: ignore the reboxing problem. The trouble is that +the conservative reboxing story prevents many useful functions from being +specialised. Example: + foo :: Maybe Int -> Int -> Int + foo (Just m) 0 = 0 + foo x@(Just m) n = foo x (n-m) +Here the use of 'x' will clearly not require boxing in the specialised function. + +The strictness analyser has the same problem, in fact. Example: + f p@(a,b) = ... +If we pass just 'a' and 'b' to the worker, it might need to rebox the +pair to create (a,b). A more sophisticated analysis might figure out +precisely the cases in which this could happen, but the strictness +analyser does no such analysis; it just passes 'a' and 'b', and hopes +for the best. + +So my current choice is to make SpecConstr similarly aggressive, and +ignore the bad potential of reboxing. + + +Note [Good arguments] +~~~~~~~~~~~~~~~~~~~~~ +So we look for + +* A self-recursive function. Ignore mutual recursion for now, + because it's less common, and the code is simpler for self-recursion. + +* EITHER + + a) At a recursive call, one or more parameters is an explicit + constructor application + AND + That same parameter is scrutinised by a case somewhere in + the RHS of the function + + OR + + b) At a recursive call, one or more parameters has an unfolding + that is an explicit constructor application + AND + That same parameter is scrutinised by a case somewhere in + the RHS of the function + AND + Those are the only uses of the parameter (see Note [Reboxing]) + + +What to abstract over +~~~~~~~~~~~~~~~~~~~~~ +There's a bit of a complication with type arguments. If the call +site looks like + + f p = ...f ((:) [a] x xs)... + +then our specialised function look like + + f_spec x xs = let p = (:) [a] x xs in ....as before.... + +This only makes sense if either + a) the type variable 'a' is in scope at the top of f, or + b) the type variable 'a' is an argument to f (and hence fs) + +Actually, (a) may hold for value arguments too, in which case +we may not want to pass them. Suppose 'x' is in scope at f's +defn, but xs is not. Then we'd like + + f_spec xs = let p = (:) [a] x xs in ....as before.... + +Similarly (b) may hold too. If x is already an argument at the +call, no need to pass it again. + +Finally, if 'a' is not in scope at the call site, we could abstract +it as we do the term variables: + + f_spec a x xs = let p = (:) [a] x xs in ...as before... + +So the grand plan is: + + * abstract the call site to a constructor-only pattern + e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3) + + * Find the free variables of the abstracted pattern + + * Pass these variables, less any that are in scope at + the fn defn. But see Note [Shadowing] below. + + +NOTICE that we only abstract over variables that are not in scope, +so we're in no danger of shadowing variables used in "higher up" +in f_spec's RHS. + + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +In this pass we gather up usage information that may mention variables +that are bound between the usage site and the definition site; or (more +seriously) may be bound to something different at the definition site. +For example: + + f x = letrec g y v = let x = ... + in ...(g (a,b) x)... + +Since 'x' is in scope at the call site, we may make a rewrite rule that +looks like + RULE forall a,b. g (a,b) x = ... +But this rule will never match, because it's really a different 'x' at +the call site -- and that difference will be manifest by the time the +simplifier gets to it. [A worry: the simplifier doesn't *guarantee* +no-shadowing, so perhaps it may not be distinct?] + +Anyway, the rule isn't actually wrong, it's just not useful. One possibility +is to run deShadowBinds before running SpecConstr, but instead we run the +simplifier. That gives the simplest possible program for SpecConstr to +chew on; and it virtually guarantees no shadowing. + +Note [Specialising for constant parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This one is about specialising on a *constant* (but not necessarily +constructor) argument + + foo :: Int -> (Int -> Int) -> Int + foo 0 f = 0 + foo m f = foo (f m) (+1) + +It produces + + lvl_rmV :: GHC.Base.Int -> GHC.Base.Int + lvl_rmV = + \ (ds_dlk :: GHC.Base.Int) -> + case ds_dlk of wild_alH { GHC.Base.I# x_alG -> + GHC.Base.I# (GHC.Prim.+# x_alG 1) + + T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) -> + GHC.Prim.Int# + T.$wfoo = + \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) -> + case ww_sme of ds_Xlw { + __DEFAULT -> + case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz -> + T.$wfoo ww1_Xmz lvl_rmV + }; + 0 -> 0 + } + +The recursive call has lvl_rmV as its argument, so we could create a specialised copy +with that argument baked in; that is, not passed at all. Now it can perhaps be inlined. + +When is this worth it? Call the constant 'lvl' +- If 'lvl' has an unfolding that is a constructor, see if the corresponding + parameter is scrutinised anywhere in the body. + +- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding + parameter is applied (...to enough arguments...?) + + Also do this is if the function has RULES? + +Also + +Note [Specialising for lambda parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + foo :: Int -> (Int -> Int) -> Int + foo 0 f = 0 + foo m f = foo (f m) (\n -> n-m) + +This is subtly different from the previous one in that we get an +explicit lambda as the argument: + + T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) -> + GHC.Prim.Int# + T.$wfoo = + \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) -> + case ww_sm8 of ds_Xlr { + __DEFAULT -> + case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq -> + T.$wfoo + ww1_Xmq + (\ (n_ad3 :: GHC.Base.Int) -> + case n_ad3 of wild_alB { GHC.Base.I# x_alA -> + GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr) + }) + }; + 0 -> 0 + } + +I wonder if SpecConstr couldn't be extended to handle this? After all, +lambda is a sort of constructor for functions and perhaps it already +has most of the necessary machinery? + +Furthermore, there's an immediate win, because you don't need to allocate the lambda +at the call site; and if perchance it's called in the recursive call, then you +may avoid allocating it altogether. Just like for constructors. + +Looks cool, but probably rare...but it might be easy to implement. + + +Note [SpecConstr for casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a :: * + data instance T Int = T Int + + foo n = ... + where + go (T 0) = 0 + go (T n) = go (T (n-1)) + +The recursive call ends up looking like + go (T (I# ...) `cast` g) +So we want to spot the constructor application inside the cast. +That's why we have the Cast case in argToPat + +Note [Local recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a *local* recursive group, we can see all the calls to the +function, so we seed the specialisation loop from the calls in the +body, not from the calls in the RHS. Consider: + + bar m n = foo n (n,n) (n,n) (n,n) (n,n) + where + foo n p q r s + | n == 0 = m + | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s } + | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s } + | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s } + | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) } + +If we start with the RHSs of 'foo', we get lots and lots of specialisations, +most of which are not needed. But if we start with the (single) call +in the rhs of 'bar' we get exactly one fully-specialised copy, and all +the recursive calls go to this fully-specialised copy. Indeed, the original +function is later collected as dead code. This is very important in +specialising the loops arising from stream fusion, for example in NDP where +we were getting literally hundreds of (mostly unused) specialisations of +a local function. + +In a case like the above we end up never calling the original un-specialised +function. (Although we still leave its code around just in case.) + +However, if we find any boring calls in the body, including *unsaturated* +ones, such as + letrec foo x y = ....foo... + in map foo xs +then we will end up calling the un-specialised function, so then we *should* +use the calls in the un-specialised RHS as seeds. We call these +"boring call patterns", and callsToPats reports if it finds any of these. + +Note [Seeding top-level recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This seeding is done in the binding for seed_calls in specRec. + +1. If all the bindings in a top-level recursive group are local (not + exported), then all the calls are in the rest of the top-level + bindings. This means we can specialise with those call patterns + ONLY, and NOT with the RHSs of the recursive group (exactly like + Note [Local recursive groups]) + +2. But if any of the bindings are exported, the function may be called + with any old arguments, so (for lack of anything better) we specialise + based on + (a) the call patterns in the RHS + (b) the call patterns in the rest of the top-level bindings + NB: before Apr 15 we used (a) only, but Dimitrios had an example + where (b) was crucial, so I added that. + Adding (b) also improved nofib allocation results: + multiplier: 4% better + minimax: 2.8% better + +Actually in case (2), instead of using the calls from the RHS, it +would be better to specialise in the importing module. We'd need to +add an INLINABLE pragma to the function, and then it can be +specialised in the importing scope, just as is done for type classes +in GHC.Core.Opt.Specialise.specImports. This remains to be done (#10346). + +Note [Top-level recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To get the call usage information from "the rest of the top level +bindings" (c.f. Note [Seeding top-level recursive groups]), we work +backwards through the top-level bindings so we see the usage before we +get to the binding of the function. Before we can collect the usage +though, we go through all the bindings and add them to the +environment. This is necessary because usage is only tracked for +functions in the environment. These two passes are called + 'go' and 'goEnv' +in specConstrProgram. (Looks a bit revolting to me.) + +Note [Do not specialise diverging functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Specialising a function that just diverges is a waste of code. +Furthermore, it broke GHC (simpl014) thus: + {-# STR Sb #-} + f = \x. case x of (a,b) -> f x +If we specialise f we get + f = \x. case x of (a,b) -> fspec a b +But fspec doesn't have decent strictness info. As it happened, +(f x) :: IO t, so the state hack applied and we eta expanded fspec, +and hence f. But now f's strictness is less than its arity, which +breaks an invariant. + + +Note [Forcing specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With stream fusion and in other similar cases, we want to fully +specialise some (but not necessarily all!) loops regardless of their +size and the number of specialisations. + +We allow a library to do this, in one of two ways (one which is +deprecated): + + 1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body. + + 2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts, + and then add *that* type as a parameter to the loop body + +The reason #2 is deprecated is because it requires GHCi, which isn't +available for things like a cross compiler using stage1. + +Here's a (simplified) example from the `vector` package. You may bring +the special 'force specialization' type into scope by saying: + + import GHC.Types (SPEC(..)) + +or by defining your own type (again, deprecated): + + data SPEC = SPEC | SPEC2 + {-# ANN type SPEC ForceSpecConstr #-} + +(Note this is the exact same definition of GHC.Types.SPEC, just +without the annotation.) + +After that, you say: + + foldl :: (a -> b -> a) -> a -> Stream b -> a + {-# INLINE foldl #-} + foldl f z (Stream step s _) = foldl_loop SPEC z s + where + foldl_loop !sPEC z s = case step s of + Yield x s' -> foldl_loop sPEC (f z x) s' + Skip -> foldl_loop sPEC z s' + Done -> z + +SpecConstr will spot the SPEC parameter and always fully specialise +foldl_loop. Note that + + * We have to prevent the SPEC argument from being removed by + w/w which is why (a) SPEC is a sum type, and (b) we have to seq on + the SPEC argument. + + * And lastly, the SPEC argument is ultimately eliminated by + SpecConstr itself so there is no runtime overhead. + +This is all quite ugly; we ought to come up with a better design. + +ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set +sc_force to True when calling specLoop. This flag does four things: + + * Ignore specConstrThreshold, to specialise functions of arbitrary size + (see scTopBind) + * Ignore specConstrCount, to make arbitrary numbers of specialisations + (see specialise) + * Specialise even for arguments that are not scrutinised in the loop + (see argToPat; #4448) + * Only specialise on recursive types a finite number of times + (see is_too_recursive; #5550; Note [Limit recursive specialisation]) + +The flag holds only for specialising a single binding group, and NOT +for nested bindings. (So really it should be passed around explicitly +and not stored in ScEnv.) #14379 turned out to be caused by + f SPEC x = let g1 x = ... + in ... +We force-specialise f (because of the SPEC), but that generates a specialised +copy of g1 (as well as the original). Alas g1 has a nested binding g2; and +in each copy of g1 we get an unspecialised and specialised copy of g2; and so +on. Result, exponential. So the force-spec flag now only applies to one +level of bindings at a time. + +Mechanism for this one-level-only thing: + + - Switch it on at the call to specRec, in scExpr and scTopBinds + - Switch it off when doing the RHSs; + this can be done very conveniently in decreaseSpecCount + +What alternatives did I consider? + +* Annotating the loop itself doesn't work because (a) it is local and + (b) it will be w/w'ed and having w/w propagating annotations somehow + doesn't seem like a good idea. The types of the loop arguments + really seem to be the most persistent thing. + +* Annotating the types that make up the loop state doesn't work, + either, because (a) it would prevent us from using types like Either + or tuples here, (b) we don't want to restrict the set of types that + can be used in Stream states and (c) some types are fixed by the + user (e.g., the accumulator here) but we still want to specialise as + much as possible. + +Alternatives to ForceSpecConstr +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instead of giving the loop an extra argument of type SPEC, we +also considered *wrapping* arguments in SPEC, thus + data SPEC a = SPEC a | SPEC2 + + loop = \arg -> case arg of + SPEC state -> + case state of (x,y) -> ... loop (SPEC (x',y')) ... + S2 -> error ... +The idea is that a SPEC argument says "specialise this argument +regardless of whether the function case-analyses it". But this +doesn't work well: + * SPEC must still be a sum type, else the strictness analyser + eliminates it + * But that means that 'loop' won't be strict in its real payload +This loss of strictness in turn screws up specialisation, because +we may end up with calls like + loop (SPEC (case z of (p,q) -> (q,p))) +Without the SPEC, if 'loop' were strict, the case would move out +and we'd see loop applied to a pair. But if 'loop' isn't strict +this doesn't look like a specialisable call. + +Note [Limit recursive specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible for ForceSpecConstr to cause an infinite loop of specialisation. +Because there is no limit on the number of specialisations, a recursive call with +a recursive constructor as an argument (for example, list cons) will generate +a specialisation for that constructor. If the resulting specialisation also +contains a recursive call with the constructor, this could proceed indefinitely. + +For example, if ForceSpecConstr is on: + loop :: [Int] -> [Int] -> [Int] + loop z [] = z + loop z (x:xs) = loop (x:z) xs +this example will create a specialisation for the pattern + loop (a:b) c = loop' a b c + + loop' a b [] = (a:b) + loop' a b (x:xs) = loop (x:(a:b)) xs +and a new pattern is found: + loop (a:(b:c)) d = loop'' a b c d +which can continue indefinitely. + +Roman's suggestion to fix this was to stop after a couple of times on recursive types, +but still specialising on non-recursive types as much as possible. + +To implement this, we count the number of times we have gone round the +"specialise recursively" loop ('go' in 'specRec'). Once have gone round +more than N times (controlled by -fspec-constr-recursive=N) we check + + - If sc_force is off, and sc_count is (Just max) then we don't + need to do anything: trim_pats will limit the number of specs + + - Otherwise check if any function has now got more than (sc_count env) + specialisations. If sc_count is "no limit" then we arbitrarily + choose 10 as the limit (ugh). + +See #5550. Also #13623, where this test had become over-aggressive, +and we lost a wonderful specialisation that we really wanted! + +Note [NoSpecConstr] +~~~~~~~~~~~~~~~~~~~ +The ignoreDataCon stuff allows you to say + {-# ANN type T NoSpecConstr #-} +to mean "don't specialise on arguments of this type". It was added +before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised +regardless of size; and then we needed a way to turn that *off*. Now +that we have ForceSpecConstr, this NoSpecConstr is probably redundant. +(Used only for PArray, TODO: remove?) + +----------------------------------------------------- + Stuff not yet handled +----------------------------------------------------- + +Here are notes arising from Roman's work that I don't want to lose. + +Example 1 +~~~~~~~~~ + data T a = T !a + + foo :: Int -> T Int -> Int + foo 0 t = 0 + foo x t | even x = case t of { T n -> foo (x-n) t } + | otherwise = foo (x-1) t + +SpecConstr does no specialisation, because the second recursive call +looks like a boxed use of the argument. A pity. + + $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# + $wfoo_sFw = + \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) -> + case ww_sFo of ds_Xw6 [Just L] { + __DEFAULT -> + case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] { + __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq; + 0 -> + case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] -> + case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] -> + $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy + } } }; + 0 -> 0 + +Example 2 +~~~~~~~~~ + data a :*: b = !a :*: !b + data T a = T !a + + foo :: (Int :*: T Int) -> Int + foo (0 :*: t) = 0 + foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) } + | otherwise = foo ((x-1) :*: t) + +Very similar to the previous one, except that the parameters are now in +a strict tuple. Before SpecConstr, we have + + $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# + $wfoo_sG3 = + \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T + GHC.Base.Int) -> + case ww_sFU of ds_Xws [Just L] { + __DEFAULT -> + case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] { + __DEFAULT -> + case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] -> + $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1 + }; + 0 -> + case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] -> + case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] -> + $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2 + } } }; + 0 -> 0 } + +We get two specialisations: +"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#} + Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB) + = Foo.$s$wfoo1 a_sFB sc_sGC ; +"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#} + Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp)) + = Foo.$s$wfoo y_aFp sc_sGC ; + +But perhaps the first one isn't good. After all, we know that tpl_B2 is +a T (I# x) really, because T is strict and Int has one constructor. (We can't +unbox the strict fields, because T is polymorphic!) + +************************************************************************ +* * +\subsection{Top level wrapper stuff} +* * +************************************************************************ +-} + +specConstrProgram :: ModGuts -> CoreM ModGuts +specConstrProgram guts + = do + dflags <- getDynFlags + us <- getUniqueSupplyM + (_, annos) <- getFirstAnnotations deserializeWithData guts + this_mod <- getModule + let binds' = reverse $ fst $ initUs us $ do + -- Note [Top-level recursive groups] + (env, binds) <- goEnv (initScEnv dflags this_mod annos) + (mg_binds guts) + -- binds is identical to (mg_binds guts), except that the + -- binders on the LHS have been replaced by extendBndr + -- (SPJ this seems like overkill; I don't think the binders + -- will change at all; and we don't substitute in the RHSs anyway!!) + go env nullUsage (reverse binds) + + return (guts { mg_binds = binds' }) + where + -- See Note [Top-level recursive groups] + goEnv env [] = return (env, []) + goEnv env (bind:binds) = do (env', bind') <- scTopBindEnv env bind + (env'', binds') <- goEnv env' binds + return (env'', bind' : binds') + + -- Arg list of bindings is in reverse order + go _ _ [] = return [] + go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind + binds' <- go env usg' binds + return (bind' : binds') + +{- +************************************************************************ +* * +\subsection{Environment: goes downwards} +* * +************************************************************************ + +Note [Work-free values only in environment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_vals field keeps track of in-scope value bindings, so +that if we come across (case x of Just y ->...) we can reduce the +case from knowing that x is bound to a pair. + +But only *work-free* values are ok here. For example if the envt had + x -> Just (expensive v) +then we do NOT want to expand to + let y = expensive v in ... +because the x-binding still exists and we've now duplicated (expensive v). + +This seldom happens because let-bound constructor applications are +ANF-ised, but it can happen as a result of on-the-fly transformations in +SpecConstr itself. Here is #7865: + + let { + a'_shr = + case xs_af8 of _ { + [] -> acc_af6; + : ds_dgt [Dmd=] ds_dgu [Dmd=] -> + (expensive x_af7, x_af7 + } } in + let { + ds_sht = + case a'_shr of _ { (p'_afd, q'_afe) -> + TSpecConstr_DoubleInline.recursive + (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd) + } } in + +When processed knowing that xs_af8 was bound to a cons, we simplify to + a'_shr = (expensive x_af7, x_af7) +and we do NOT want to inline that at the occurrence of a'_shr in ds_sht. +(There are other occurrences of a'_shr.) No no no. + +It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned +into a work-free value again, thus + a1 = expensive x_af7 + a'_shr = (a1, x_af7) +but that's more work, so until its shown to be important I'm going to +leave it for now. + +Note [Making SpecConstr keener] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this, in (perf/should_run/T9339) + last (filter odd [1..1000]) + +After optimisation, including SpecConstr, we get: + f :: Int# -> Int -> Int + f x y = case case remInt# x 2# of + __DEFAULT -> case x of + __DEFAULT -> f (+# wild_Xp 1#) (I# x) + 1000000# -> ... + 0# -> case x of + __DEFAULT -> f (+# wild_Xp 1#) y + 1000000# -> y + +Not good! We build an (I# x) box every time around the loop. +SpecConstr (as described in the paper) does not specialise f, despite +the call (f ... (I# x)) because 'y' is not scrutinised in the body. +But it is much better to specialise f for the case where the argument +is of form (I# x); then we build the box only when returning y, which +is on the cold path. + +Another example: + + f x = ...(g x).... + +Here 'x' is not scrutinised in f's body; but if we did specialise 'f' +then the call (g x) might allow 'g' to be specialised in turn. + +So sc_keen controls whether or not we take account of whether argument is +scrutinised in the body. True <=> ignore that, and specialise whenever +the function is applied to a data constructor. +-} + +data ScEnv = SCE { sc_dflags :: DynFlags, + sc_module :: !Module, + sc_size :: Maybe Int, -- Size threshold + -- Nothing => no limit + + sc_count :: Maybe Int, -- Max # of specialisations for any one fn + -- Nothing => no limit + -- See Note [Avoiding exponential blowup] + + sc_recursive :: Int, -- Max # of specialisations over recursive type. + -- Stops ForceSpecConstr from diverging. + + sc_keen :: Bool, -- Specialise on arguments that are known + -- constructors, even if they are not + -- scrutinised in the body. See + -- Note [Making SpecConstr keener] + + sc_force :: Bool, -- Force specialisation? + -- See Note [Forcing specialisation] + + sc_subst :: Subst, -- Current substitution + -- Maps InIds to OutExprs + + sc_how_bound :: HowBoundEnv, + -- Binds interesting non-top-level variables + -- Domain is OutVars (*after* applying the substitution) + + sc_vals :: ValueEnv, + -- Domain is OutIds (*after* applying the substitution) + -- Used even for top-level bindings (but not imported ones) + -- The range of the ValueEnv is *work-free* values + -- such as (\x. blah), or (Just v) + -- but NOT (Just (expensive v)) + -- See Note [Work-free values only in environment] + + sc_annotations :: UniqFM SpecConstrAnnotation + } + +--------------------- +type HowBoundEnv = VarEnv HowBound -- Domain is OutVars + +--------------------- +type ValueEnv = IdEnv Value -- Domain is OutIds +data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors + -- The AltCon is never DEFAULT + | LambdaVal -- Inlinable lambdas or PAPs + +instance Outputable Value where + ppr (ConVal con args) = ppr con <+> interpp'SP args + ppr LambdaVal = text "" + +--------------------- +initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv +initScEnv dflags this_mod anns + = SCE { sc_dflags = dflags, + sc_module = this_mod, + sc_size = specConstrThreshold dflags, + sc_count = specConstrCount dflags, + sc_recursive = specConstrRecursive dflags, + sc_keen = gopt Opt_SpecConstrKeen dflags, + sc_force = False, + sc_subst = emptySubst, + sc_how_bound = emptyVarEnv, + sc_vals = emptyVarEnv, + sc_annotations = anns } + +data HowBound = RecFun -- These are the recursive functions for which + -- we seek interesting call patterns + + | RecArg -- These are those functions' arguments, or their sub-components; + -- we gather occurrence information for these + +instance Outputable HowBound where + ppr RecFun = text "RecFun" + ppr RecArg = text "RecArg" + +scForce :: ScEnv -> Bool -> ScEnv +scForce env b = env { sc_force = b } + +lookupHowBound :: ScEnv -> Id -> Maybe HowBound +lookupHowBound env id = lookupVarEnv (sc_how_bound env) id + +scSubstId :: ScEnv -> Id -> CoreExpr +scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v + +scSubstTy :: ScEnv -> Type -> Type +scSubstTy env ty = substTy (sc_subst env) ty + +scSubstCo :: ScEnv -> Coercion -> Coercion +scSubstCo env co = substCo (sc_subst env) co + +zapScSubst :: ScEnv -> ScEnv +zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) } + +extendScInScope :: ScEnv -> [Var] -> ScEnv + -- Bring the quantified variables into scope +extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars } + + -- Extend the substitution +extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv +extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr } + +extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv +extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs } + +extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv +extendHowBound env bndrs how_bound + = env { sc_how_bound = extendVarEnvList (sc_how_bound env) + [(bndr,how_bound) | bndr <- bndrs] } + +extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var]) +extendBndrsWith how_bound env bndrs + = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs') + where + (subst', bndrs') = substBndrs (sc_subst env) bndrs + hb_env' = sc_how_bound env `extendVarEnvList` + [(bndr,how_bound) | bndr <- bndrs'] + +extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var) +extendBndrWith how_bound env bndr + = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr') + where + (subst', bndr') = substBndr (sc_subst env) bndr + hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound + +extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var]) +extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs') + where + (subst', bndrs') = substRecBndrs (sc_subst env) bndrs + +extendBndr :: ScEnv -> Var -> (ScEnv, Var) +extendBndr env bndr = (env { sc_subst = subst' }, bndr') + where + (subst', bndr') = substBndr (sc_subst env) bndr + +extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv +extendValEnv env _ Nothing = env +extendValEnv env id (Just cv) + | valueIsWorkFree cv -- Don't duplicate work!! #7865 + = env { sc_vals = extendVarEnv (sc_vals env) id cv } +extendValEnv env _ _ = env + +extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var]) +-- When we encounter +-- case scrut of b +-- C x y -> ... +-- we want to bind b, to (C x y) +-- NB1: Extends only the sc_vals part of the envt +-- NB2: Kill the dead-ness info on the pattern binders x,y, since +-- they are potentially made alive by the [b -> C x y] binding +extendCaseBndrs env scrut case_bndr con alt_bndrs + = (env2, alt_bndrs') + where + live_case_bndr = not (isDeadBinder case_bndr) + env1 | Var v <- stripTicksTopE (const True) scrut + = extendValEnv env v cval + | otherwise = env -- See Note [Add scrutinee to ValueEnv too] + env2 | live_case_bndr = extendValEnv env1 case_bndr cval + | otherwise = env1 + + alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr } + = map zap alt_bndrs + | otherwise + = alt_bndrs + + cval = case con of + DEFAULT -> Nothing + LitAlt {} -> Just (ConVal con []) + DataAlt {} -> Just (ConVal con vanilla_args) + where + vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ + varsToCoreExprs alt_bndrs + + zap v | isTyVar v = v -- See NB2 above + | otherwise = zapIdOccInfo v + + +decreaseSpecCount :: ScEnv -> Int -> ScEnv +-- See Note [Avoiding exponential blowup] +decreaseSpecCount env n_specs + = env { sc_force = False -- See Note [Forcing specialisation] + , sc_count = case sc_count env of + Nothing -> Nothing + Just n -> Just (n `div` (n_specs + 1)) } + -- The "+1" takes account of the original function; + -- See Note [Avoiding exponential blowup] + +--------------------------------------------------- +-- See Note [Forcing specialisation] +ignoreType :: ScEnv -> Type -> Bool +ignoreDataCon :: ScEnv -> DataCon -> Bool +forceSpecBndr :: ScEnv -> Var -> Bool + +ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc) + +ignoreType env ty + = case tyConAppTyCon_maybe ty of + Just tycon -> ignoreTyCon env tycon + _ -> False + +ignoreTyCon :: ScEnv -> TyCon -> Bool +ignoreTyCon env tycon + = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr + +forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var + +forceSpecFunTy :: ScEnv -> Type -> Bool +forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys + +forceSpecArgTy :: ScEnv -> Type -> Bool +forceSpecArgTy env ty + | Just ty' <- coreView ty = forceSpecArgTy env ty' + +forceSpecArgTy env ty + | Just (tycon, tys) <- splitTyConApp_maybe ty + , tycon /= funTyCon + = tyConName tycon == specTyConName + || lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr + || any (forceSpecArgTy env) tys + +forceSpecArgTy _ _ = False + +{- +Note [Add scrutinee to ValueEnv too] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +By the time we get to the call (f y), the ValueEnv +will have a binding for y, and for c + y -> (a,b) + c -> I# v +BUT that's not enough! Looking at the call (f y) we +see that y is pair (a,b), but we also need to know what 'b' is. +So in extendCaseBndrs we must *also* add the binding + b -> I# v +else we lose a useful specialisation for f. This is necessary even +though the simplifier has systematically replaced uses of 'x' with 'y' +and 'b' with 'c' in the code. The use of 'b' in the ValueEnv came +from outside the case. See #4908 for the live example. + +Note [Avoiding exponential blowup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_count field of the ScEnv says how many times we are prepared to +duplicate a single function. But we must take care with recursive +specialisations. Consider + + let $j1 = let $j2 = let $j3 = ... + in + ...$j3... + in + ...$j2... + in + ...$j1... + +If we specialise $j1 then in each specialisation (as well as the original) +we can specialise $j2, and similarly $j3. Even if we make just *one* +specialisation of each, because we also have the original we'll get 2^n +copies of $j3, which is not good. + +So when recursively specialising we divide the sc_count by the number of +copies we are making at this level, including the original. + + +************************************************************************ +* * +\subsection{Usage information: flows upwards} +* * +************************************************************************ +-} + +data ScUsage + = SCU { + scu_calls :: CallEnv, -- Calls + -- The functions are a subset of the + -- RecFuns in the ScEnv + + scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences + } -- The domain is OutIds + +type CallEnv = IdEnv [Call] +data Call = Call Id [CoreArg] ValueEnv + -- The arguments of the call, together with the + -- env giving the constructor bindings at the call site + -- We keep the function mainly for debug output + +instance Outputable ScUsage where + ppr (SCU { scu_calls = calls, scu_occs = occs }) + = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls + , text "occs =" <+> ppr occs ]) + +instance Outputable Call where + ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args) + +nullUsage :: ScUsage +nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv } + +combineCalls :: CallEnv -> CallEnv -> CallEnv +combineCalls = plusVarEnv_C (++) + where +-- plus cs ds | length res > 1 +-- = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs +-- , text "ds:" <+> ppr ds]) +-- res +-- | otherwise = res +-- where +-- res = cs ++ ds + +combineUsage :: ScUsage -> ScUsage -> ScUsage +combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2), + scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) } + +combineUsages :: [ScUsage] -> ScUsage +combineUsages [] = nullUsage +combineUsages us = foldr1 combineUsage us + +lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc]) +lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs + = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs}, + [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs]) + +data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument + | UnkOcc -- Used in some unknown way + + | ScrutOcc -- See Note [ScrutOcc] + (DataConEnv [ArgOcc]) -- How the sub-components are used + +type DataConEnv a = UniqFM a -- Keyed by DataCon + +{- Note [ScrutOcc] +~~~~~~~~~~~~~~~~~~~ +An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, +is *only* taken apart or applied. + + Functions, literal: ScrutOcc emptyUFM + Data constructors: ScrutOcc subs, + +where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components, +The domain of the UniqFM is the Unique of the data constructor + +The [ArgOcc] is the occurrences of the *pattern-bound* components +of the data structure. E.g. + data T a = forall b. MkT a b (b->a) +A pattern binds b, x::a, y::b, z::b->a, but not 'a'! + +-} + +instance Outputable ArgOcc where + ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs + ppr UnkOcc = text "unk-occ" + ppr NoOcc = text "no-occ" + +evalScrutOcc :: ArgOcc +evalScrutOcc = ScrutOcc emptyUFM + +-- Experimentally, this version of combineOcc makes ScrutOcc "win", so +-- that if the thing is scrutinised anywhere then we get to see that +-- in the overall result, even if it's also used in a boxed way +-- This might be too aggressive; see Note [Reboxing] Alternative 3 +combineOcc :: ArgOcc -> ArgOcc -> ArgOcc +combineOcc NoOcc occ = occ +combineOcc occ NoOcc = occ +combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys) +combineOcc UnkOcc (ScrutOcc ys) = ScrutOcc ys +combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs +combineOcc UnkOcc UnkOcc = UnkOcc + +combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc] +combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys + +setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage +-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee +-- is a variable, and an interesting variable +setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ +setScrutOcc env usg (Tick _ e) occ = setScrutOcc env usg e occ +setScrutOcc env usg (Var v) occ + | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ } + | otherwise = usg +setScrutOcc _env usg _other _occ -- Catch-all + = usg + +{- +************************************************************************ +* * +\subsection{The main recursive function} +* * +************************************************************************ + +The main recursive function gathers up usage information, and +creates specialised versions of functions. +-} + +scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr) + -- The unique supply is needed when we invent + -- a new name for the specialised function and its args + +scExpr env e = scExpr' env e + +scExpr' env (Var v) = case scSubstId env v of + Var v' -> return (mkVarUsage env v' [], Var v') + e' -> scExpr (zapScSubst env) e' + +scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t)) +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') +scExpr' env (Cast e co) = do (usg, e') <- scExpr env e + return (usg, mkCast e' (scSubstCo env co)) + -- Important to use mkCast here + -- See Note [SpecConstr call patterns] +scExpr' env e@(App _ _) = scApp env (collectArgs e) +scExpr' env (Lam b e) = do let (env', b') = extendBndr env b + (usg, e') <- scExpr env' e + return (usg, Lam b' e') + +scExpr' env (Case scrut b ty alts) + = do { (scrut_usg, scrut') <- scExpr env scrut + ; case isValue (sc_vals env) scrut' of + Just (ConVal con args) -> sc_con_app con args scrut' + _other -> sc_vanilla scrut_usg scrut' + } + where + sc_con_app con args scrut' -- Known constructor; simplify + = do { let (_, bs, rhs) = findAlt con alts + `orElse` (DEFAULT, [], mkImpossibleExpr ty) + alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) + ; scExpr alt_env' rhs } + + sc_vanilla scrut_usg scrut' -- Normal case + = do { let (alt_env,b') = extendBndrWith RecArg env b + -- Record RecArg for the components + + ; (alt_usgs, alt_occs, alts') + <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts + + ; let scrut_occ = foldr combineOcc NoOcc alt_occs + scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ + -- The combined usage of the scrutinee is given + -- by scrut_occ, which is passed to scScrut, which + -- in turn treats a bare-variable scrutinee specially + + ; return (foldr combineUsage scrut_usg' alt_usgs, + Case scrut' b' (scSubstTy env ty) alts') } + + sc_alt env scrut' b' (con,bs,rhs) + = do { let (env1, bs1) = extendBndrsWith RecArg env bs + (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 + ; (usg, rhs') <- scExpr env2 rhs + ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2) + scrut_occ = case con of + DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) + _ -> ScrutOcc emptyUFM + ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) } + +scExpr' env (Let (NonRec bndr rhs) body) + | isTyVar bndr -- Type-lets may be created by doBeta + = scExpr' (extendScSubst env bndr rhs) body + + | otherwise + = do { let (body_env, bndr') = extendBndr env bndr + ; rhs_info <- scRecRhs env (bndr',rhs) + + ; let body_env2 = extendHowBound body_env [bndr'] RecFun + -- Note [Local let bindings] + rhs' = ri_new_rhs rhs_info + body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') + + ; (body_usg, body') <- scExpr body_env3 body + + -- NB: For non-recursive bindings we inherit sc_force flag from + -- the parent function (see Note [Forcing specialisation]) + ; (spec_usg, specs) <- specNonRec env body_usg rhs_info + + ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } + `combineUsage` spec_usg, -- Note [spec_usg includes rhs_usg] + mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body') + } + + +-- A *local* recursive group: see Note [Local recursive groups] +scExpr' env (Let (Rec prs) body) + = do { let (bndrs,rhss) = unzip prs + (rhs_env1,bndrs') = extendRecBndrs env bndrs + rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun + force_spec = any (forceSpecBndr env) bndrs' + -- Note [Forcing specialisation] + + ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss) + ; (body_usg, body') <- scExpr rhs_env2 body + + -- NB: start specLoop from body_usg + ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec) + body_usg rhs_infos + -- Do not unconditionally generate specialisations from rhs_usgs + -- Instead use them only if we find an unspecialised call + -- See Note [Local recursive groups] + + ; let all_usg = spec_usg `combineUsage` body_usg -- Note [spec_usg includes rhs_usg] + bind' = Rec (concat (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs)) + -- zipWithEqual: length of returned [SpecInfo] + -- should be the same as incoming [RhsInfo] + + ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' }, + Let bind' body') } + +{- +Note [Local let bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~ +It is not uncommon to find this + + let $j = \x. in ...$j True...$j True... + +Here $j is an arbitrary let-bound function, but it often comes up for +join points. We might like to specialise $j for its call patterns. +Notice the difference from a letrec, where we look for call patterns +in the *RHS* of the function. Here we look for call patterns in the +*body* of the let. + +At one point I predicated this on the RHS mentioning the outer +recursive function, but that's not essential and might even be +harmful. I'm not sure. +-} + +scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr) + +scApp env (Var fn, args) -- Function is a variable + = ASSERT( not (null args) ) + do { args_w_usgs <- mapM (scExpr env) args + ; let (arg_usgs, args') = unzip args_w_usgs + arg_usg = combineUsages arg_usgs + ; case scSubstId env fn of + fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args') + -- Do beta-reduction and try again + + Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args', + mkApps (Var fn') args') + + other_fn' -> return (arg_usg, mkApps other_fn' args') } + -- NB: doing this ignores any usage info from the substituted + -- function, but I don't think that matters. If it does + -- we can fix it. + where + doBeta :: OutExpr -> [OutExpr] -> OutExpr + -- ToDo: adjust for System IF + doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args) + doBeta fn args = mkApps fn args + +-- The function is almost always a variable, but not always. +-- In particular, if this pass follows float-in, +-- which it may, we can get +-- (let f = ...f... in f) arg1 arg2 +scApp env (other_fn, args) + = do { (fn_usg, fn') <- scExpr env other_fn + ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args + ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') } + +---------------------- +mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage +mkVarUsage env fn args + = case lookupHowBound env fn of + Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)] + , scu_occs = emptyVarEnv } + Just RecArg -> SCU { scu_calls = emptyVarEnv + , scu_occs = unitVarEnv fn arg_occ } + Nothing -> nullUsage + where + -- I rather think we could use UnkOcc all the time + arg_occ | null args = UnkOcc + | otherwise = evalScrutOcc + +---------------------- +scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) +scTopBindEnv env (Rec prs) + = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs + rhs_env2 = extendHowBound rhs_env1 bndrs RecFun + + prs' = zip bndrs' rhss + ; return (rhs_env2, Rec prs') } + where + (bndrs,rhss) = unzip prs + +scTopBindEnv env (NonRec bndr rhs) + = do { let (env1, bndr') = extendBndr env bndr + env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs) + ; return (env2, NonRec bndr' rhs) } + +---------------------- +scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind) + +{- +scTopBind _ usage _ + | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False + = error "false" +-} + +scTopBind env body_usage (Rec prs) + | Just threshold <- sc_size env + , not force_spec + , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss) + -- No specialisation + = -- pprTrace "scTopBind: nospec" (ppr bndrs) $ + do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss + ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) } + + | otherwise -- Do specialisation + = do { rhs_infos <- mapM (scRecRhs env) prs + + ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec) + body_usage rhs_infos + + ; return (body_usage `combineUsage` spec_usage, + Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) } + where + (bndrs,rhss) = unzip prs + force_spec = any (forceSpecBndr env) bndrs + -- Note [Forcing specialisation] + +scTopBind env usage (NonRec bndr rhs) -- Oddly, we don't seem to specialise top-level non-rec functions + = do { (rhs_usg', rhs') <- scExpr env rhs + ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') } + +---------------------- +scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo +scRecRhs env (bndr,rhs) + = do { let (arg_bndrs,body) = collectBinders rhs + (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs + ; (body_usg, body') <- scExpr body_env body + ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs' + ; return (RI { ri_rhs_usg = rhs_usg + , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body' + , ri_lam_bndrs = arg_bndrs, ri_lam_body = body + , ri_arg_occs = arg_occs }) } + -- The arg_occs says how the visible, + -- lambda-bound binders of the RHS are used + -- (including the TyVar binders) + -- Two pats are the same if they match both ways + +---------------------- +ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)] +ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs }) + (SI { si_specs = specs }) + = [(id,rhs) | OS { os_id = id, os_rhs = rhs } <- specs] ++ + -- First the specialised bindings + + [(fn `addIdSpecialisations` rules, new_rhs)] + -- And now the original binding + where + rules = [r | OS { os_rule = r } <- specs] + +{- +************************************************************************ +* * + The specialiser itself +* * +************************************************************************ +-} + +data RhsInfo + = RI { ri_fn :: OutId -- The binder + , ri_new_rhs :: OutExpr -- The specialised RHS (in current envt) + , ri_rhs_usg :: ScUsage -- Usage info from specialising RHS + + , ri_lam_bndrs :: [InVar] -- The *original* RHS (\xs.body) + , ri_lam_body :: InExpr -- Note [Specialise original body] + , ri_arg_occs :: [ArgOcc] -- Info on how the xs occur in body + } + +data SpecInfo -- Info about specialisations for a particular Id + = SI { si_specs :: [OneSpec] -- The specialisations we have generated + + , si_n_specs :: Int -- Length of si_specs; used for numbering them + + , si_mb_unspec :: Maybe ScUsage -- Just cs => we have not yet used calls in the + } -- from calls in the *original* RHS as + -- seeds for new specialisations; + -- if you decide to do so, here is the + -- RHS usage (which has not yet been + -- unleashed) + -- Nothing => we have + -- See Note [Local recursive groups] + -- See Note [spec_usg includes rhs_usg] + + -- One specialisation: Rule plus definition +data OneSpec = + OS { os_pat :: CallPat -- Call pattern that generated this specialisation + , os_rule :: CoreRule -- Rule connecting original id with the specialisation + , os_id :: OutId -- Spec id + , os_rhs :: OutExpr } -- Spec rhs + +noSpecInfo :: SpecInfo +noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing } + +---------------------- +specNonRec :: ScEnv + -> ScUsage -- Body usage + -> RhsInfo -- Structure info usage info for un-specialised RHS + -> UniqSM (ScUsage, SpecInfo) -- Usage from RHSs (specialised and not) + -- plus details of specialisations + +specNonRec env body_usg rhs_info + = specialise env (scu_calls body_usg) rhs_info + (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) }) + +---------------------- +specRec :: TopLevelFlag -> ScEnv + -> ScUsage -- Body usage + -> [RhsInfo] -- Structure info and usage info for un-specialised RHSs + -> UniqSM (ScUsage, [SpecInfo]) -- Usage from all RHSs (specialised and not) + -- plus details of specialisations + +specRec top_lvl env body_usg rhs_infos + = go 1 seed_calls nullUsage init_spec_infos + where + (seed_calls, init_spec_infos) -- Note [Seeding top-level recursive groups] + | isTopLevel top_lvl + , any (isExportedId . ri_fn) rhs_infos -- Seed from body and RHSs + = (all_calls, [noSpecInfo | _ <- rhs_infos]) + | otherwise -- Seed from body only + = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) } + | ri <- rhs_infos]) + + calls_in_body = scu_calls body_usg + calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos + all_calls = calls_in_rhss `combineCalls` calls_in_body + + -- Loop, specialising, until you get no new specialisations + go :: Int -- Which iteration of the "until no new specialisations" + -- loop we are on; first iteration is 1 + -> CallEnv -- Seed calls + -- Two accumulating parameters: + -> ScUsage -- Usage from earlier specialisations + -> [SpecInfo] -- Details of specialisations so far + -> UniqSM (ScUsage, [SpecInfo]) + go n_iter seed_calls usg_so_far spec_infos + | isEmptyVarEnv seed_calls + = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos) + -- , ppr seed_calls + -- , ppr body_usg ]) $ + return (usg_so_far, spec_infos) + + -- Limit recursive specialisation + -- See Note [Limit recursive specialisation] + | n_iter > sc_recursive env -- Too many iterations of the 'go' loop + , sc_force env || isNothing (sc_count env) + -- If both of these are false, the sc_count + -- threshold will prevent non-termination + , any ((> the_limit) . si_n_specs) spec_infos + = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $ + return (usg_so_far, spec_infos) + + | otherwise + = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos) + -- , text "iteration" <+> int n_iter + -- , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos) + -- ]) $ + do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos + ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg + extra_usg = combineUsages extra_usg_s + all_usg = usg_so_far `combineUsage` extra_usg + ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos } + + -- See Note [Limit recursive specialisation] + the_limit = case sc_count env of + Nothing -> 10 -- Ugh! + Just max -> max + + +---------------------- +specialise + :: ScEnv + -> CallEnv -- Info on newly-discovered calls to this function + -> RhsInfo + -> SpecInfo -- Original RHS plus patterns dealt with + -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage + +-- See Note [spec_usg includes rhs_usg] + +-- Note: this only generates *specialised* bindings +-- The original binding is added by ruleInfoBinds +-- +-- Note: the rhs here is the optimised version of the original rhs +-- So when we make a specialised copy of the RHS, we're starting +-- from an RHS whose nested functions have been optimised already. + +specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs + , ri_lam_body = body, ri_arg_occs = arg_occs }) + spec_info@(SI { si_specs = specs, si_n_specs = spec_count + , si_mb_unspec = mb_unspec }) + | isBottomingId fn -- Note [Do not specialise diverging functions] + -- and do not generate specialisation seeds from its RHS + = -- pprTrace "specialise bot" (ppr fn) $ + return (nullUsage, spec_info) + + | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation] + || null arg_bndrs -- Only specialise functions + = -- pprTrace "specialise inactive" (ppr fn) $ + case mb_unspec of -- Behave as if there was a single, boring call + Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing }) + -- See Note [spec_usg includes rhs_usg] + Nothing -> return (nullUsage, spec_info) + + | Just all_calls <- lookupVarEnv bind_calls fn + = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $ + do { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls + + ; let n_pats = length new_pats +-- ; if (not (null new_pats) || isJust mb_unspec) then +-- pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns" +-- , text "mb_unspec" <+> ppr (isJust mb_unspec) +-- , text "arg_occs" <+> ppr arg_occs +-- , text "good pats" <+> ppr new_pats]) $ +-- return () +-- else return () + + ; let spec_env = decreaseSpecCount env n_pats + ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body) + (new_pats `zip` [spec_count..]) + -- See Note [Specialise original body] + + ; let spec_usg = combineUsages spec_usgs + + -- If there were any boring calls among the seeds (= all_calls), then those + -- calls will call the un-specialised function. So we should use the seeds + -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning + -- then in new_usg. + (new_usg, mb_unspec') + = case mb_unspec of + Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing) + _ -> (spec_usg, mb_unspec) + +-- ; pprTrace "specialise return }" +-- (vcat [ ppr fn +-- , text "boring_call:" <+> ppr boring_call +-- , text "new calls:" <+> ppr (scu_calls new_usg)]) $ +-- return () + + ; return (new_usg, SI { si_specs = new_specs ++ specs + , si_n_specs = spec_count + n_pats + , si_mb_unspec = mb_unspec' }) } + + | otherwise -- No new seeds, so return nullUsage + = return (nullUsage, spec_info) + + + + +--------------------- +spec_one :: ScEnv + -> OutId -- Function + -> [InVar] -- Lambda-binders of RHS; should match patterns + -> InExpr -- Body of the original function + -> (CallPat, Int) + -> UniqSM (ScUsage, OneSpec) -- Rule and binding + +-- spec_one creates a specialised copy of the function, together +-- with a rule for using it. I'm very proud of how short this +-- function is, considering what it does :-). + +{- + Example + + In-scope: a, x::a + f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))... + [c::*, v::(b,c) are presumably bound by the (...) part] + ==> + f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] -> + (...entire body of f...) [b -> (b,c), + y -> ((:) (a,(b,c)) (x,v) hw)] + + RULE: forall b::* c::*, -- Note, *not* forall a, x + v::(b,c), + hw::[(a,(b,c))] . + + f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw +-} + +spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) + = do { spec_uniq <- getUniqueM + ; let spec_env = extendScSubstList (extendScInScope env qvars) + (arg_bndrs `zip` pats) + fn_name = idName fn + fn_loc = nameSrcSpan fn_name + fn_occ = nameOccName fn_name + spec_occ = mkSpecOcc fn_occ + -- We use fn_occ rather than fn in the rule_name string + -- as we don't want the uniq to end up in the rule, and + -- hence in the ABI, as that can cause spurious ABI + -- changes (#4012). + rule_name = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number) + spec_name = mkInternalName spec_uniq spec_occ fn_loc +-- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn +-- <+> ppr pats <+> text "-->" <+> ppr spec_name) $ +-- return () + + -- Specialise the body + ; (spec_usg, spec_body) <- scExpr spec_env body + +-- ; pprTrace "done spec_one}" (ppr fn) $ +-- return () + + -- And build the results + ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env) + qvars body_ty + -- Usual w/w hack to avoid generating + -- a spec_rhs of unlifted type and no args + + spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args + -- Annotate the variables with the strictness information from + -- the function (see Note [Strictness information in worker binders]) + + spec_join_arity | isJoinId fn = Just (length spec_lam_args) + | otherwise = Nothing + spec_id = mkLocalId spec_name + (mkLamTypes spec_lam_args body_ty) + -- See Note [Transfer strictness] + `setIdStrictness` spec_str + `setIdCprInfo` topCprSig + `setIdArity` count isId spec_lam_args + `asJoinId_maybe` spec_join_arity + spec_str = calcSpecStrictness fn spec_lam_args pats + + + -- Conditionally use result of new worker-wrapper transform + spec_rhs = mkLams spec_lam_args_str spec_body + body_ty = exprType spec_body + rule_rhs = mkVarApps (Var spec_id) spec_call_args + inline_act = idInlineActivation fn + this_mod = sc_module spec_env + rule = mkRule this_mod True {- Auto -} True {- Local -} + rule_name inline_act fn_name qvars pats rule_rhs + -- See Note [Transfer activation] + ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule + , os_id = spec_id + , os_rhs = spec_rhs }) } + + +-- See Note [Strictness information in worker binders] +handOutStrictnessInformation :: [Demand] -> [Var] -> [Var] +handOutStrictnessInformation = go + where + go _ [] = [] + go [] vs = vs + go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs + go dmds (v:vs) = v : go dmds vs + +calcSpecStrictness :: Id -- The original function + -> [Var] -> [CoreExpr] -- Call pattern + -> StrictSig -- Strictness of specialised thing +-- See Note [Transfer strictness] +calcSpecStrictness fn qvars pats + = mkClosedStrictSig spec_dmds topDiv + where + spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] + StrictSig (DmdType _ dmds _) = idStrictness fn + + dmd_env = go emptyVarEnv dmds pats + + go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv + go env ds (Type {} : pats) = go env ds pats + go env ds (Coercion {} : pats) = go env ds pats + go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats + go env _ _ = env + + go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv + go_one env d (Var v) = extendVarEnv_C bothDmd env v d + go_one env d e + | Just ds <- splitProdDmd_maybe d -- NB: d does not have to be strict + , (Var _, args) <- collectArgs e = go env ds args + go_one env _ _ = env + +{- +Note [spec_usg includes rhs_usg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In calls to 'specialise', the returned ScUsage must include the rhs_usg in +the passed-in SpecInfo, unless there are no calls at all to the function. + +The caller can, indeed must, assume this. He should not combine in rhs_usg +himself, or he'll get rhs_usg twice -- and that can lead to an exponential +blowup of duplicates in the CallEnv. This is what gave rise to the massive +performance loss in #8852. + +Note [Specialise original body] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RhsInfo for a binding keeps the *original* body of the binding. We +must specialise that, *not* the result of applying specExpr to the RHS +(which is also kept in RhsInfo). Otherwise we end up specialising a +specialised RHS, and that can lead directly to exponential behaviour. + +Note [Transfer activation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + This note is for SpecConstr, but exactly the same thing + happens in the overloading specialiser; see + Note [Auto-specialisation and RULES] in GHC.Core.Opt.Specialise. + +In which phase should the specialise-constructor rules be active? +Originally I made them always-active, but Manuel found that this +defeated some clever user-written rules. Then I made them active only +in Phase 0; after all, currently, the specConstr transformation is +only run after the simplifier has reached Phase 0, but that meant +that specialisations didn't fire inside wrappers; see test +simplCore/should_compile/spec-inline. + +So now I just use the inline-activation of the parent Id, as the +activation for the specialisation RULE, just like the main specialiser; + +This in turn means there is no point in specialising NOINLINE things, +so we test for that. + +Note [Transfer strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must transfer strictness information from the original function to +the specialised one. Suppose, for example + + f has strictness SS + and a RULE f (a:as) b = f_spec a as b + +Now we want f_spec to have strictness LLS, otherwise we'll use call-by-need +when calling f_spec instead of call-by-value. And that can result in +unbounded worsening in space (cf the classic foldl vs foldl') + +See #3437 for a good example. + +The function calcSpecStrictness performs the calculation. + +Note [Strictness information in worker binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +After having calculated the strictness annotation for the worker (see Note +[Transfer strictness] above), we also want to have this information attached to +the worker’s arguments, for the benefit of later passes. The function +handOutStrictnessInformation decomposes the strictness annotation calculated by +calcSpecStrictness and attaches them to the variables. + +************************************************************************ +* * +\subsection{Argument analysis} +* * +************************************************************************ + +This code deals with analysing call-site arguments to see whether +they are constructor applications. + +Note [Free type variables of the qvar types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a call (f @a x True), that we want to specialise, what variables should +we quantify over. Clearly over 'a' and 'x', but what about any type variables +free in x's type? In fact we don't need to worry about them because (f @a) +can only be a well-typed application if its type is compatible with x, so any +variables free in x's type must be free in (f @a), and hence either be gathered +via 'a' itself, or be in scope at f's defn. Hence we just take + (exprsFreeVars pats). + +BUT phantom type synonyms can mess this reasoning up, + eg x::T b with type T b = Int +So we apply expandTypeSynonyms to the bound Ids. +See # 5458. Yuk. + +Note [SpecConstr call patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "call patterns" that we collect is going to become the LHS of a RULE. +It's important that it doesn't have + e |> Refl +or + e |> g1 |> g2 +because both of these will be optimised by Simplify.simplRule. In the +former case such optimisation benign, because the rule will match more +terms; but in the latter we may lose a binding of 'g1' or 'g2', and +end up with a rule LHS that doesn't bind the template variables +(#10602). + +The simplifier eliminates such things, but SpecConstr itself constructs +new terms by substituting. So the 'mkCast' in the Cast case of scExpr +is very important! + +Note [Choosing patterns] +~~~~~~~~~~~~~~~~~~~~~~~~ +If we get lots of patterns we may not want to make a specialisation +for each of them (code bloat), so we choose as follows, implemented +by trim_pats. + +* The flag -fspec-constr-count-N sets the sc_count field + of the ScEnv to (Just n). This limits the total number + of specialisations for a given function to N. + +* -fno-spec-constr-count sets the sc_count field to Nothing, + which switches of the limit. + +* The ghastly ForceSpecConstr trick also switches of the limit + for a particular function + +* Otherwise we sort the patterns to choose the most general + ones first; more general => more widely applicable. + +Note [SpecConstr and casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14270) a call like + + let f = e + in ... f (K @(a |> co)) ... + +where 'co' is a coercion variable not in scope at f's definition site. +If we aren't caereful we'll get + + let $sf a co = e (K @(a |> co)) + RULE "SC:f" forall a co. f (K @(a |> co)) = $sf a co + f = e + in ... + +But alas, when we match the call we won't bind 'co', because type-matching +(for good reasons) discards casts). + +I don't know how to solve this, so for now I'm just discarding any +call patterns that + * Mentions a coercion variable in a type argument + * That is not in scope at the binding of the function + +I think this is very rare. + +It is important (e.g. #14936) that this /only/ applies to +coercions mentioned in casts. We don't want to be discombobulated +by casts in terms! For example, consider + f ((e1,e2) |> sym co) +where, say, + f :: Foo -> blah + co :: Foo ~R (Int,Int) + +Here we definitely do want to specialise for that pair! We do not +match on the structure of the coercion; instead we just match on a +coercion variable, so the RULE looks like + + forall (x::Int, y::Int, co :: (Int,Int) ~R Foo) + f ((x,y) |> co) = $sf x y co + +Often the body of f looks like + f arg = ...(case arg |> co' of + (x,y) -> blah)... + +so that the specialised f will turn into + $sf x y co = let arg = (x,y) |> co + in ...(case arg>| co' of + (x,y) -> blah).... + +which will simplify to not use 'co' at all. But we can't guarantee +that co will end up unused, so we still pass it. Absence analysis +may remove it later. + +Note that this /also/ discards the call pattern if we have a cast in a +/term/, although in fact Rules.match does make a very flaky and +fragile attempt to match coercions. e.g. a call like + f (Maybe Age) (Nothing |> co) blah + where co :: Maybe Int ~ Maybe Age +will be discarded. It's extremely fragile to match on the form of a +coercion, so I think it's better just not to try. A more complicated +alternative would be to discard calls that mention coercion variables +only in kind-casts, but I'm doing the simple thing for now. +-} + +type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments + -- See Note [SpecConstr call patterns] + +callsToNewPats :: ScEnv -> Id + -> SpecInfo + -> [ArgOcc] -> [Call] + -> UniqSM (Bool, [CallPat]) + -- Result has no duplicate patterns, + -- nor ones mentioned in done_pats + -- Bool indicates that there was at least one boring pattern +callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls + = do { mb_pats <- mapM (callToPats env bndr_occs) calls + + ; let have_boring_call = any isNothing mb_pats + + good_pats :: [CallPat] + good_pats = catMaybes mb_pats + + -- Remove patterns we have already done + new_pats = filterOut is_done good_pats + is_done p = any (samePat p . os_pat) done_specs + + -- Remove duplicates + non_dups = nubBy samePat new_pats + + -- Remove ones that have too many worker variables + small_pats = filterOut too_big non_dups + too_big (vars,_) = not (isWorkerSmallEnough (sc_dflags env) vars) + -- We are about to construct w/w pair in 'spec_one'. + -- Omit specialisation leading to high arity workers. + -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils + + -- Discard specialisations if there are too many of them + trimmed_pats = trim_pats env fn spec_info small_pats + +-- ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls +-- , text "done_specs:" <+> ppr (map os_pat done_specs) +-- , text "good_pats:" <+> ppr good_pats ]) $ +-- return () + + ; return (have_boring_call, trimmed_pats) } + + +trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat] +-- See Note [Choosing patterns] +trim_pats env fn (SI { si_n_specs = done_spec_count }) pats + | sc_force env + || isNothing mb_scc + || n_remaining >= n_pats + = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats) + pats -- No need to trim + + | otherwise + = emit_trace $ -- Need to trim, so keep the best ones + take n_remaining sorted_pats + + where + n_pats = length pats + spec_count' = n_pats + done_spec_count + n_remaining = max_specs - done_spec_count + mb_scc = sc_count env + Just max_specs = mb_scc + + sorted_pats = map fst $ + sortBy (comparing snd) $ + [(pat, pat_cons pat) | pat <- pats] + -- Sort in order of increasing number of constructors + -- (i.e. decreasing generality) and pick the initial + -- segment of this list + + pat_cons :: CallPat -> Int + -- How many data constructors of literals are in + -- the pattern. More data-cons => less general + pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps + where + q_set = mkVarSet qs + n_cons (Var v) | v `elemVarSet` q_set = 0 + | otherwise = 1 + n_cons (Cast e _) = n_cons e + n_cons (App e1 e2) = n_cons e1 + n_cons e2 + n_cons (Lit {}) = 1 + n_cons _ = 0 + + emit_trace result + | debugIsOn || hasPprDebug (sc_dflags env) + -- Suppress this scary message for ordinary users! #5125 + = pprTrace "SpecConstr" msg result + | otherwise + = result + msg = vcat [ sep [ text "Function" <+> quotes (ppr fn) + , nest 2 (text "has" <+> + speakNOf spec_count' (text "call pattern") <> comma <+> + text "but the limit is" <+> int max_specs) ] + , text "Use -fspec-constr-count=n to set the bound" + , text "done_spec_count =" <+> int done_spec_count + , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats + , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ] + + +callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) + -- The [Var] is the variables to quantify over in the rule + -- Type variables come first, since they may scope + -- over the following term variables + -- The [CoreExpr] are the argument patterns for the rule +callToPats env bndr_occs call@(Call _ args con_env) + | args `ltLength` bndr_occs -- Check saturated + = return Nothing + | otherwise + = do { let in_scope = substInScope (sc_subst env) + ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs + ; let pat_fvs = exprsFreeVarsList pats + -- To get determinism we need the list of free variables in + -- deterministic order. Otherwise we end up creating + -- lambdas with different argument orders. See + -- determinism/simplCore/should_compile/spec-inline-determ.hs + -- for an example. For explanation of determinism + -- considerations See Note [Unique Determinism] in GHC.Types.Unique. + + in_scope_vars = getInScopeVars in_scope + is_in_scope v = v `elemVarSet` in_scope_vars + qvars = filterOut is_in_scope pat_fvs + -- Quantify over variables that are not in scope + -- at the call site + -- See Note [Free type variables of the qvar types] + -- See Note [Shadowing] at the top + + (ktvs, ids) = partition isTyVar qvars + qvars' = scopedSort ktvs ++ map sanitise ids + -- Order into kind variables, type variables, term variables + -- The kind of a type variable may mention a kind variable + -- and the type of a term variable may mention a type variable + + sanitise id = id `setIdType` expandTypeSynonyms (idType id) + -- See Note [Free type variables of the qvar types] + + -- Bad coercion variables: see Note [SpecConstr and casts] + bad_covars :: CoVarSet + bad_covars = mapUnionVarSet get_bad_covars pats + get_bad_covars :: CoreArg -> CoVarSet + get_bad_covars (Type ty) + = filterVarSet (\v -> isId v && not (is_in_scope v)) $ + tyCoVarsOfType ty + get_bad_covars _ + = emptyVarSet + + ; -- pprTrace "callToPats" (ppr args $$ ppr bndr_occs) $ + WARN( not (isEmptyVarSet bad_covars) + , text "SpecConstr: bad covars:" <+> ppr bad_covars + $$ ppr call ) + if interesting && isEmptyVarSet bad_covars + then return (Just (qvars', pats)) + else return Nothing } + + -- argToPat takes an actual argument, and returns an abstracted + -- version, consisting of just the "constructor skeleton" of the + -- argument, with non-constructor sub-expression replaced by new + -- placeholder variables. For example: + -- C a (D (f x) (g y)) ==> C p1 (D p2 p3) + +argToPat :: ScEnv + -> InScopeSet -- What's in scope at the fn defn site + -> ValueEnv -- ValueEnv at the call site + -> CoreArg -- A call arg (or component thereof) + -> ArgOcc + -> UniqSM (Bool, CoreArg) + +-- Returns (interesting, pat), +-- where pat is the pattern derived from the argument +-- interesting=True if the pattern is non-trivial (not a variable or type) +-- E.g. x:xs --> (True, x:xs) +-- f xs --> (False, w) where w is a fresh wildcard +-- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard +-- \x. x+y --> (True, \x. x+y) +-- lvl7 --> (True, lvl7) if lvl7 is bound +-- somewhere further out + +argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ + = return (False, arg) + +argToPat env in_scope val_env (Tick _ arg) arg_occ + = argToPat env in_scope val_env arg arg_occ + -- Note [Notes in call patterns] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Ignore Notes. In particular, we want to ignore any InlineMe notes + -- Perhaps we should not ignore profiling notes, but I'm going to + -- ride roughshod over them all for now. + --- See Note [Notes in RULE matching] in GHC.Core.Rules + +argToPat env in_scope val_env (Let _ arg) arg_occ + = argToPat env in_scope val_env arg arg_occ + -- See Note [Matching lets] in Rule.hs + -- Look through let expressions + -- e.g. f (let v = rhs in (v,w)) + -- Here we can specialise for f (v,w) + -- because the rule-matcher will look through the let. + +{- Disabled; see Note [Matching cases] in Rule.hs +argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ + | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs + = argToPat env in_scope val_env rhs arg_occ +-} + +argToPat env in_scope val_env (Cast arg co) arg_occ + | not (ignoreType env ty2) + = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ + ; if not interesting then + wildCardPat ty2 + else do + { -- Make a wild-card pattern for the coercion + uniq <- getUniqueM + ; let co_name = mkSysTvName uniq (fsLit "sg") + co_var = mkCoVar co_name (mkCoercionType Representational ty1 ty2) + ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } + where + Pair ty1 ty2 = coercionKind co + + + +{- Disabling lambda specialisation for now + It's fragile, and the spec_loop can be infinite +argToPat in_scope val_env arg arg_occ + | is_value_lam arg + = return (True, arg) + where + is_value_lam (Lam v e) -- Spot a value lambda, even if + | isId v = True -- it is inside a type lambda + | otherwise = is_value_lam e + is_value_lam other = False +-} + + -- Check for a constructor application + -- NB: this *precedes* the Var case, so that we catch nullary constrs +argToPat env in_scope val_env arg arg_occ + | Just (ConVal (DataAlt dc) args) <- isValue val_env arg + , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] + , Just arg_occs <- mb_scrut dc + = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args + ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs + ; return (True, + mkConApp dc (ty_args ++ args')) } + where + mb_scrut dc = case arg_occ of + ScrutOcc bs | Just occs <- lookupUFM bs dc + -> Just (occs) -- See Note [Reboxing] + _other | sc_force env || sc_keen env + -> Just (repeat UnkOcc) + | otherwise + -> Nothing + + -- Check if the argument is a variable that + -- (a) is used in an interesting way in the function body + -- (b) we know what its value is + -- In that case it counts as "interesting" +argToPat env in_scope val_env (Var v) arg_occ + | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) + is_value, -- (b) + -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing] + -- So sc_keen focused just on f (I# x), where we have freshly-allocated + -- box that we can eliminate in the caller + not (ignoreType env (varType v)) + = return (True, Var v) + where + is_value + | isLocalId v = v `elemInScopeSet` in_scope + && isJust (lookupVarEnv val_env v) + -- Local variables have values in val_env + | otherwise = isValueUnfolding (idUnfolding v) + -- Imports have unfoldings + +-- I'm really not sure what this comment means +-- And by not wild-carding we tend to get forall'd +-- variables that are in scope, which in turn can +-- expose the weakness in let-matching +-- See Note [Matching lets] in GHC.Core.Rules + + -- Check for a variable bound inside the function. + -- Don't make a wild-card, because we may usefully share + -- e.g. f a = let x = ... in f (x,x) + -- NB: this case follows the lambda and con-app cases!! +-- argToPat _in_scope _val_env (Var v) _arg_occ +-- = return (False, Var v) + -- SLPJ : disabling this to avoid proliferation of versions + -- also works badly when thinking about seeding the loop + -- from the body of the let + -- f x y = letrec g z = ... in g (x,y) + -- We don't want to specialise for that *particular* x,y + + -- The default case: make a wild-card + -- We use this for coercions too +argToPat _env _in_scope _val_env arg _arg_occ + = wildCardPat (exprType arg) + +wildCardPat :: Type -> UniqSM (Bool, CoreArg) +wildCardPat ty + = do { uniq <- getUniqueM + ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq ty + ; return (False, varToCoreExpr id) } + +argsToPats :: ScEnv -> InScopeSet -> ValueEnv + -> [CoreArg] -> [ArgOcc] -- Should be same length + -> UniqSM (Bool, [CoreArg]) +argsToPats env in_scope val_env args occs + = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs + ; let (interesting_s, args') = unzip stuff + ; return (or interesting_s, args') } + +isValue :: ValueEnv -> CoreExpr -> Maybe Value +isValue _env (Lit lit) + | litIsLifted lit = Nothing + | otherwise = Just (ConVal (LitAlt lit) []) + +isValue env (Var v) + | Just cval <- lookupVarEnv env v + = Just cval -- You might think we could look in the idUnfolding here + -- but that doesn't take account of which branch of a + -- case we are in, which is the whole point + + | not (isLocalId v) && isCheapUnfolding unf + = isValue env (unfoldingTemplate unf) + where + unf = idUnfolding v + -- However we do want to consult the unfolding + -- as well, for let-bound constructors! + +isValue env (Lam b e) + | isTyVar b = case isValue env e of + Just _ -> Just LambdaVal + Nothing -> Nothing + | otherwise = Just LambdaVal + +isValue env (Tick t e) + | not (tickishIsCode t) + = isValue env e + +isValue _env expr -- Maybe it's a constructor application + | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr + = case isDataConWorkId_maybe fun of + + Just con | args `lengthAtLeast` dataConRepArity con + -- Check saturated; might be > because the + -- arity excludes type args + -> Just (ConVal (DataAlt con) args) + + _other | valArgCount args < idArity fun + -- Under-applied function + -> Just LambdaVal -- Partial application + + _other -> Nothing + +isValue _env _expr = Nothing + +valueIsWorkFree :: Value -> Bool +valueIsWorkFree LambdaVal = True +valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args + +samePat :: CallPat -> CallPat -> Bool +samePat (vs1, as1) (vs2, as2) + = all2 same as1 as2 + where + same (Var v1) (Var v2) + | v1 `elem` vs1 = v2 `elem` vs2 + | v2 `elem` vs2 = False + | otherwise = v1 == v2 + + same (Lit l1) (Lit l2) = l1==l2 + same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2 + + same (Type {}) (Type {}) = True -- Note [Ignore type differences] + same (Coercion {}) (Coercion {}) = True + same (Tick _ e1) e2 = same e1 e2 -- Ignore casts and notes + same (Cast e1 _) e2 = same e1 e2 + same e1 (Tick _ e2) = same e1 e2 + same e1 (Cast e2 _) = same e1 e2 + + same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2) + False -- Let, lambda, case should not occur + bad (Case {}) = True + bad (Let {}) = True + bad (Lam {}) = True + bad _other = False + +{- +Note [Ignore type differences] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not want to generate specialisations where the call patterns +differ only in their type arguments! Not only is it utterly useless, +but it also means that (with polymorphic recursion) we can generate +an infinite number of specialisations. Example is Data.Sequence.adjustTree, +I think. +-} diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -0,0 +1,2949 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[Specialise]{Stamping out overloading, and (optionally) polymorphism} +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Id +import GHC.Tc.Utils.TcType hiding( substTy ) +import GHC.Core.Type hiding( substTy, extendTvSubstList ) +import GHC.Core.Predicate +import GHC.Unit.Module( Module, HasModule(..) ) +import GHC.Core.Coercion( Coercion ) +import GHC.Core.Opt.Monad +import qualified GHC.Core.Subst as Core +import GHC.Core.Unfold +import GHC.Types.Var ( isLocalVar ) +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Core +import GHC.Core.Rules +import GHC.Core.SimpleOpt ( collectBindersPushingCo ) +import GHC.Core.Utils ( exprIsTrivial, getIdFromTrivialExpr_maybe + , mkCast, exprType ) +import GHC.Core.FVs +import GHC.Core.Arity ( etaExpandToJoinPointRule ) +import GHC.Types.Unique.Supply +import GHC.Types.Name +import GHC.Types.Id.Make ( voidArgId, voidPrimId ) +import GHC.Builtin.Types.Prim ( voidPrimTy ) +import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust ) +import GHC.Utils.Monad ( foldlM ) +import GHC.Types.Basic +import GHC.Driver.Types +import GHC.Data.Bag +import GHC.Driver.Session +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Monad.State +import GHC.Types.Unique.DFM +import GHC.Core.TyCo.Rep (TyCoBinder (..)) + +import Control.Monad + +{- +************************************************************************ +* * +\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]} +* * +************************************************************************ + +These notes describe how we implement specialisation to eliminate +overloading. + +The specialisation pass works on Core +syntax, complete with all the explicit dictionary application, +abstraction and construction as added by the type checker. The +existing type checker remains largely as it is. + +One important thought: the {\em types} passed to an overloaded +function, and the {\em dictionaries} passed are mutually redundant. +If the same function is applied to the same type(s) then it is sure to +be applied to the same dictionary(s)---or rather to the same {\em +values}. (The arguments might look different but they will evaluate +to the same value.) + +Second important thought: we know that we can make progress by +treating dictionary arguments as static and worth specialising on. So +we can do without binding-time analysis, and instead specialise on +dictionary arguments and no others. + +The basic idea +~~~~~~~~~~~~~~ +Suppose we have + + let f = + in + +and suppose f is overloaded. + +STEP 1: CALL-INSTANCE COLLECTION + +We traverse , accumulating all applications of f to types and +dictionaries. + +(Might there be partial applications, to just some of its types and +dictionaries? In principle yes, but in practice the type checker only +builds applications of f to all its types and dictionaries, so partial +applications could only arise as a result of transformation, and even +then I think it's unlikely. In any case, we simply don't accumulate such +partial applications.) + + +STEP 2: EQUIVALENCES + +So now we have a collection of calls to f: + f t1 t2 d1 d2 + f t3 t4 d3 d4 + ... +Notice that f may take several type arguments. To avoid ambiguity, we +say that f is called at type t1/t2 and t3/t4. + +We take equivalence classes using equality of the *types* (ignoring +the dictionary args, which as mentioned previously are redundant). + +STEP 3: SPECIALISATION + +For each equivalence class, choose a representative (f t1 t2 d1 d2), +and create a local instance of f, defined thus: + + f@t1/t2 = t1 t2 d1 d2 + +f_rhs presumably has some big lambdas and dictionary lambdas, so lots +of simplification will now result. However we don't actually *do* that +simplification. Rather, we leave it for the simplifier to do. If we +*did* do it, though, we'd get more call instances from the specialised +RHS. We can work out what they are by instantiating the call-instance +set from f's RHS with the types t1, t2. + +Add this new id to f's IdInfo, to record that f has a specialised version. + +Before doing any of this, check that f's IdInfo doesn't already +tell us about an existing instance of f at the required type/s. +(This might happen if specialisation was applied more than once, or +it might arise from user SPECIALIZE pragmas.) + +Recursion +~~~~~~~~~ +Wait a minute! What if f is recursive? Then we can't just plug in +its right-hand side, can we? + +But it's ok. The type checker *always* creates non-recursive definitions +for overloaded recursive functions. For example: + + f x = f (x+x) -- Yes I know its silly + +becomes + + f a (d::Num a) = let p = +.sel a d + in + letrec fl (y::a) = fl (p y y) + in + fl + +We still have recursion for non-overloaded functions which we +specialise, but the recursive call should get specialised to the +same recursive version. + + +Polymorphism 1 +~~~~~~~~~~~~~~ + +All this is crystal clear when the function is applied to *constant +types*; that is, types which have no type variables inside. But what if +it is applied to non-constant types? Suppose we find a call of f at type +t1/t2. There are two possibilities: + +(a) The free type variables of t1, t2 are in scope at the definition point +of f. In this case there's no problem, we proceed just as before. A common +example is as follows. Here's the Haskell: + + g y = let f x = x+x + in f y + f y + +After typechecking we have + + g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x + in +.sel a d (f a d y) (f a d y) + +Notice that the call to f is at type type "a"; a non-constant type. +Both calls to f are at the same type, so we can specialise to give: + + g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x + in +.sel a d (f@a y) (f@a y) + + +(b) The other case is when the type variables in the instance types +are *not* in scope at the definition point of f. The example we are +working with above is a good case. There are two instances of (+.sel a d), +but "a" is not in scope at the definition of +.sel. Can we do anything? +Yes, we can "common them up", a sort of limited common sub-expression deal. +This would give: + + g a (d::Num a) (y::a) = let +.sel@a = +.sel a d + f@a (x::a) = +.sel@a x x + in +.sel@a (f@a y) (f@a y) + +This can save work, and can't be spotted by the type checker, because +the two instances of +.sel weren't originally at the same type. + +Further notes on (b) + +* There are quite a few variations here. For example, the defn of + +.sel could be floated outside the \y, to attempt to gain laziness. + It certainly mustn't be floated outside the \d because the d has to + be in scope too. + +* We don't want to inline f_rhs in this case, because +that will duplicate code. Just commoning up the call is the point. + +* Nothing gets added to +.sel's IdInfo. + +* Don't bother unless the equivalence class has more than one item! + +Not clear whether this is all worth it. It is of course OK to +simply discard call-instances when passing a big lambda. + +Polymorphism 2 -- Overloading +~~~~~~~~~~~~~~ +Consider a function whose most general type is + + f :: forall a b. Ord a => [a] -> b -> b + +There is really no point in making a version of g at Int/Int and another +at Int/Bool, because it's only instantiating the type variable "a" which +buys us any efficiency. Since g is completely polymorphic in b there +ain't much point in making separate versions of g for the different +b types. + +That suggests that we should identify which of g's type variables +are constrained (like "a") and which are unconstrained (like "b"). +Then when taking equivalence classes in STEP 2, we ignore the type args +corresponding to unconstrained type variable. In STEP 3 we make +polymorphic versions. Thus: + + f@t1/ = /\b -> t1 b d1 d2 + +We do this. + + +Dictionary floating +~~~~~~~~~~~~~~~~~~~ +Consider this + + f a (d::Num a) = let g = ... + in + ...(let d1::Ord a = Num.Ord.sel a d in g a d1)... + +Here, g is only called at one type, but the dictionary isn't in scope at the +definition point for g. Usually the type checker would build a +definition for d1 which enclosed g, but the transformation system +might have moved d1's defn inward. Solution: float dictionary bindings +outwards along with call instances. + +Consider + + f x = let g p q = p==q + h r s = (r+s, g r s) + in + h x x + + +Before specialisation, leaving out type abstractions we have + + f df x = let g :: Eq a => a -> a -> Bool + g dg p q = == dg p q + h :: Num a => a -> a -> (a, Bool) + h dh r s = let deq = eqFromNum dh + in (+ dh r s, g deq r s) + in + h df x x + +After specialising h we get a specialised version of h, like this: + + h' r s = let deq = eqFromNum df + in (+ df r s, g deq r s) + +But we can't naively make an instance for g from this, because deq is not in scope +at the defn of g. Instead, we have to float out the (new) defn of deq +to widen its scope. Notice that this floating can't be done in advance -- it only +shows up when specialisation is done. + +User SPECIALIZE pragmas +~~~~~~~~~~~~~~~~~~~~~~~ +Specialisation pragmas can be digested by the type checker, and implemented +by adding extra definitions along with that of f, in the same way as before + + f@t1/t2 = t1 t2 d1 d2 + +Indeed the pragmas *have* to be dealt with by the type checker, because +only it knows how to build the dictionaries d1 and d2! For example + + g :: Ord a => [a] -> [a] + {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-} + +Here, the specialised version of g is an application of g's rhs to the +Ord dictionary for (Tree Int), which only the type checker can conjure +up. There might not even *be* one, if (Tree Int) is not an instance of +Ord! (All the other specialision has suitable dictionaries to hand +from actual calls.) + +Problem. The type checker doesn't have to hand a convenient , because +it is buried in a complex (as-yet-un-desugared) binding group. +Maybe we should say + + f@t1/t2 = f* t1 t2 d1 d2 + +where f* is the Id f with an IdInfo which says "inline me regardless!". +Indeed all the specialisation could be done in this way. +That in turn means that the simplifier has to be prepared to inline absolutely +any in-scope let-bound thing. + + +Again, the pragma should permit polymorphism in unconstrained variables: + + h :: Ord a => [a] -> b -> b + {-# SPECIALIZE h :: [Int] -> b -> b #-} + +We *insist* that all overloaded type variables are specialised to ground types, +(and hence there can be no context inside a SPECIALIZE pragma). +We *permit* unconstrained type variables to be specialised to + - a ground type + - or left as a polymorphic type variable +but nothing in between. So + + {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-} + +is *illegal*. (It can be handled, but it adds complication, and gains the +programmer nothing.) + + +SPECIALISING INSTANCE DECLARATIONS +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + instance Foo a => Foo [a] where + ... + {-# SPECIALIZE instance Foo [Int] #-} + +The original instance decl creates a dictionary-function +definition: + + dfun.Foo.List :: forall a. Foo a -> Foo [a] + +The SPECIALIZE pragma just makes a specialised copy, just as for +ordinary function definitions: + + dfun.Foo.List@Int :: Foo [Int] + dfun.Foo.List@Int = dfun.Foo.List Int dFooInt + +The information about what instance of the dfun exist gets added to +the dfun's IdInfo in the same way as a user-defined function too. + + +Automatic instance decl specialisation? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can instance decls be specialised automatically? It's tricky. +We could collect call-instance information for each dfun, but +then when we specialised their bodies we'd get new call-instances +for ordinary functions; and when we specialised their bodies, we might get +new call-instances of the dfuns, and so on. This all arises because of +the unrestricted mutual recursion between instance decls and value decls. + +Still, there's no actual problem; it just means that we may not do all +the specialisation we could theoretically do. + +Furthermore, instance decls are usually exported and used non-locally, +so we'll want to compile enough to get those specialisations done. + +Lastly, there's no such thing as a local instance decl, so we can +survive solely by spitting out *usage* information, and then reading that +back in as a pragma when next compiling the file. So for now, +we only specialise instance decls in response to pragmas. + + +SPITTING OUT USAGE INFORMATION +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To spit out usage information we need to traverse the code collecting +call-instance information for all imported (non-prelude?) functions +and data types. Then we equivalence-class it and spit it out. + +This is done at the top-level when all the call instances which escape +must be for imported functions and data types. + +*** Not currently done *** + + +Partial specialisation by pragmas +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What about partial specialisation: + + k :: (Ord a, Eq b) => [a] -> b -> b -> [a] + {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-} + +or even + + {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-} + +Seems quite reasonable. Similar things could be done with instance decls: + + instance (Foo a, Foo b) => Foo (a,b) where + ... + {-# SPECIALIZE instance Foo a => Foo (a,Int) #-} + {-# SPECIALIZE instance Foo b => Foo (Int,b) #-} + +Ho hum. Things are complex enough without this. I pass. + + +Requirements for the simplifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The simplifier has to be able to take advantage of the specialisation. + +* When the simplifier finds an application of a polymorphic f, it looks in +f's IdInfo in case there is a suitable instance to call instead. This converts + + f t1 t2 d1 d2 ===> f_t1_t2 + +Note that the dictionaries get eaten up too! + +* Dictionary selection operations on constant dictionaries must be + short-circuited: + + +.sel Int d ===> +Int + +The obvious way to do this is in the same way as other specialised +calls: +.sel has inside it some IdInfo which tells that if it's applied +to the type Int then it should eat a dictionary and transform to +Int. + +In short, dictionary selectors need IdInfo inside them for constant +methods. + +* Exactly the same applies if a superclass dictionary is being + extracted: + + Eq.sel Int d ===> dEqInt + +* Something similar applies to dictionary construction too. Suppose +dfun.Eq.List is the function taking a dictionary for (Eq a) to +one for (Eq [a]). Then we want + + dfun.Eq.List Int d ===> dEq.List_Int + +Where does the Eq [Int] dictionary come from? It is built in +response to a SPECIALIZE pragma on the Eq [a] instance decl. + +In short, dfun Ids need IdInfo with a specialisation for each +constant instance of their instance declaration. + +All this uses a single mechanism: the SpecEnv inside an Id + + +What does the specialisation IdInfo look like? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The SpecEnv of an Id maps a list of types (the template) to an expression + + [Type] |-> Expr + +For example, if f has this RuleInfo: + + [Int, a] -> \d:Ord Int. f' a + +it means that we can replace the call + + f Int t ===> (\d. f' t) + +This chucks one dictionary away and proceeds with the +specialised version of f, namely f'. + + +What can't be done this way? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no way, post-typechecker, to get a dictionary for (say) +Eq a from a dictionary for Eq [a]. So if we find + + ==.sel [t] d + +we can't transform to + + eqList (==.sel t d') + +where + eqList :: (a->a->Bool) -> [a] -> [a] -> Bool + +Of course, we currently have no way to automatically derive +eqList, nor to connect it to the Eq [a] instance decl, but you +can imagine that it might somehow be possible. Taking advantage +of this is permanently ruled out. + +Still, this is no great hardship, because we intend to eliminate +overloading altogether anyway! + +A note about non-tyvar dictionaries +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some Ids have types like + + forall a,b,c. Eq a -> Ord [a] -> tau + +This seems curious at first, because we usually only have dictionary +args whose types are of the form (C a) where a is a type variable. +But this doesn't hold for the functions arising from instance decls, +which sometimes get arguments with types of form (C (T a)) for some +type constructor T. + +Should we specialise wrt this compound-type dictionary? We used to say +"no", saying: + "This is a heuristic judgement, as indeed is the fact that we + specialise wrt only dictionaries. We choose *not* to specialise + wrt compound dictionaries because at the moment the only place + they show up is in instance decls, where they are simply plugged + into a returned dictionary. So nothing is gained by specialising + wrt them." + +But it is simpler and more uniform to specialise wrt these dicts too; +and in future GHC is likely to support full fledged type signatures +like + f :: Eq [(a,b)] => ... + + +************************************************************************ +* * +\subsubsection{The new specialiser} +* * +************************************************************************ + +Our basic game plan is this. For let(rec) bound function + f :: (C a, D c) => (a,b,c,d) -> Bool + +* Find any specialised calls of f, (f ts ds), where + ts are the type arguments t1 .. t4, and + ds are the dictionary arguments d1 .. d2. + +* Add a new definition for f1 (say): + + f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2 + + Note that we abstract over the unconstrained type arguments. + +* Add the mapping + + [t1,b,t3,d] |-> \d1 d2 -> f1 b d + + to the specialisations of f. This will be used by the + simplifier to replace calls + (f t1 t2 t3 t4) da db + by + (\d1 d1 -> f1 t2 t4) da db + + All the stuff about how many dictionaries to discard, and what types + to apply the specialised function to, are handled by the fact that the + SpecEnv contains a template for the result of the specialisation. + +We don't build *partial* specialisations for f. For example: + + f :: Eq a => a -> a -> Bool + {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-} + +Here, little is gained by making a specialised copy of f. +There's a distinct danger that the specialised version would +first build a dictionary for (Eq b, Eq c), and then select the (==) +method from it! Even if it didn't, not a great deal is saved. + +We do, however, generate polymorphic, but not overloaded, specialisations: + + f :: Eq a => [a] -> b -> b -> b + ... SPECIALISE f :: [Int] -> b -> b -> b ... + +Hence, the invariant is this: + + *** no specialised version is overloaded *** + + +************************************************************************ +* * +\subsubsection{The exported function} +* * +************************************************************************ +-} + +-- | Specialise calls to type-class overloaded functions occurring in a program. +specProgram :: ModGuts -> CoreM ModGuts +specProgram guts@(ModGuts { mg_module = this_mod + , mg_rules = local_rules + , mg_binds = binds }) + = do { dflags <- getDynFlags + + -- Specialise the bindings of this module + ; (binds', uds) <- runSpecM dflags this_mod (go binds) + + ; (spec_rules, spec_binds) <- specImports dflags this_mod top_env + local_rules uds + + ; return (guts { mg_binds = spec_binds ++ binds' + , mg_rules = spec_rules ++ local_rules }) } + where + -- We need to start with a Subst that knows all the things + -- that are in scope, so that the substitution engine doesn't + -- accidentally re-use a unique that's already in use + -- Easiest thing is to do it all at once, as if all the top-level + -- decls were mutually recursive + top_env = SE { se_subst = Core.mkEmptySubst $ mkInScopeSet $ mkVarSet $ + bindersOfBinds binds + , se_interesting = emptyVarSet } + + go [] = return ([], emptyUDs) + go (bind:binds) = do (binds', uds) <- go binds + (bind', uds') <- specBind top_env bind uds + return (bind' ++ binds', uds') + +{- +Note [Wrap bindings returned by specImports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'specImports' returns a set of specialized bindings. However, these are lacking +necessary floated dictionary bindings, which are returned by +UsageDetails(ud_binds). These dictionaries need to be brought into scope with +'wrapDictBinds' before the bindings returned by 'specImports' can be used. See, +for instance, the 'specImports' call in 'specProgram'. + + +Note [Disabling cross-module specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since GHC 7.10 we have performed specialisation of INLINABLE bindings living +in modules outside of the current module. This can sometimes uncover user code +which explodes in size when aggressively optimized. The +-fno-cross-module-specialise option was introduced to allow users to being +bitten by such instances to revert to the pre-7.10 behavior. + +See #10491 +-} + + +{- ********************************************************************* +* * + Specialising imported functions +* * +********************************************************************* -} + +specImports :: DynFlags -> Module -> SpecEnv + -> [CoreRule] + -> UsageDetails + -> CoreM ([CoreRule], [CoreBind]) +specImports dflags this_mod top_env local_rules + (MkUD { ud_binds = dict_binds, ud_calls = calls }) + | not $ gopt Opt_CrossModuleSpecialise dflags + -- See Note [Disabling cross-module specialisation] + = return ([], wrapDictBinds dict_binds []) + + | otherwise + = do { hpt_rules <- getRuleBase + ; let rule_base = extendRuleBaseList hpt_rules local_rules + + ; (spec_rules, spec_binds) <- spec_imports dflags this_mod top_env + [] rule_base + dict_binds calls + + -- Don't forget to wrap the specialized bindings with + -- bindings for the needed dictionaries. + -- See Note [Wrap bindings returned by specImports] + -- and Note [Glom the bindings if imported functions are specialised] + ; let final_binds + | null spec_binds = wrapDictBinds dict_binds [] + | otherwise = [Rec $ flattenBinds $ + wrapDictBinds dict_binds spec_binds] + + ; return (spec_rules, final_binds) + } + +-- | Specialise a set of calls to imported bindings +spec_imports :: DynFlags + -> Module + -> SpecEnv -- Passed in so that all top-level Ids are in scope + -> [Id] -- Stack of imported functions being specialised + -- See Note [specImport call stack] + -> RuleBase -- Rules from this module and the home package + -- (but not external packages, which can change) + -> Bag DictBind -- Dict bindings, used /only/ for filterCalls + -- See Note [Avoiding loops in specImports] + -> CallDetails -- Calls for imported things + -> CoreM ( [CoreRule] -- New rules + , [CoreBind] ) -- Specialised bindings +spec_imports dflags this_mod top_env + callers rule_base dict_binds calls + = do { let import_calls = dVarEnvElts calls + -- ; debugTraceMsg (text "specImports {" <+> + -- vcat [ text "calls:" <+> ppr import_calls + -- , text "dict_binds:" <+> ppr dict_binds ]) + ; (rules, spec_binds) <- go rule_base import_calls + -- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls) + + ; return (rules, spec_binds) } + where + go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind]) + go _ [] = return ([], []) + go rb (cis : other_calls) + = do { -- debugTraceMsg (text "specImport {" <+> ppr cis) + ; (rules1, spec_binds1) <- spec_import dflags this_mod top_env + callers rb dict_binds cis + -- ; debugTraceMsg (text "specImport }" <+> ppr cis) + + ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls + ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) } + +spec_import :: DynFlags + -> Module + -> SpecEnv -- Passed in so that all top-level Ids are in scope + -> [Id] -- Stack of imported functions being specialised + -- See Note [specImport call stack] + -> RuleBase -- Rules from this module + -> Bag DictBind -- Dict bindings, used /only/ for filterCalls + -- See Note [Avoiding loops in specImports] + -> CallInfoSet -- Imported function and calls for it + -> CoreM ( [CoreRule] -- New rules + , [CoreBind] ) -- Specialised bindings +spec_import dflags this_mod top_env callers + rb dict_binds cis@(CIS fn _) + | isIn "specImport" fn callers + = return ([], []) -- No warning. This actually happens all the time + -- when specialising a recursive function, because + -- the RHS of the specialised function contains a recursive + -- call to the original function + + | null good_calls + = do { -- debugTraceMsg (text "specImport:no valid calls") + ; return ([], []) } + + | wantSpecImport dflags unfolding + , Just rhs <- maybeUnfoldingTemplate unfolding + = do { -- Get rules from the external package state + -- We keep doing this in case we "page-fault in" + -- more rules as we go along + ; hsc_env <- getHscEnv + ; eps <- liftIO $ hscEPS hsc_env + ; vis_orphs <- getVisibleOrphanMods + ; let full_rb = unionRuleBase rb (eps_rule_base eps) + rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn + + ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls }) + <- do { -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) + ; runSpecM dflags this_mod $ + specCalls (Just this_mod) top_env rules_for_fn good_calls fn rhs } + ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] + -- After the rules kick in we may get recursion, but + -- we rely on a global GlomBinds to sort that out later + -- See Note [Glom the bindings if imported functions are specialised] + + -- Now specialise any cascaded calls + -- ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1)) + ; (rules2, spec_binds2) <- spec_imports dflags this_mod top_env + (fn:callers) + (extendRuleBaseList rb rules1) + (dict_binds `unionBags` dict_binds1) + new_calls + + ; let final_binds = wrapDictBinds dict_binds1 $ + spec_binds2 ++ spec_binds1 + + ; return (rules2 ++ rules1, final_binds) } + + | otherwise + = do { tryWarnMissingSpecs dflags callers fn good_calls + ; return ([], [])} + + where + unfolding = realIdUnfolding fn -- We want to see the unfolding even for loop breakers + good_calls = filterCalls cis dict_binds + -- SUPER IMPORTANT! Drop calls that (directly or indirectly) refer to fn + -- See Note [Avoiding loops in specImports] + +-- | Returns whether or not to show a missed-spec warning. +-- If -Wall-missed-specializations is on, show the warning. +-- Otherwise, if -Wmissed-specializations is on, only show a warning +-- if there is at least one imported function being specialized, +-- and if all imported functions are marked with an inline pragma +-- Use the most specific warning as the reason. +tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () +-- See Note [Warning about missed specialisations] +tryWarnMissingSpecs dflags callers fn calls_for_fn + | wopt Opt_WarnMissedSpecs dflags + && not (null callers) + && allCallersInlined = doWarn $ Reason Opt_WarnMissedSpecs + | wopt Opt_WarnAllMissedSpecs dflags = doWarn $ Reason Opt_WarnAllMissedSpecs + | otherwise = return () + where + allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers + doWarn reason = + warnMsg reason + (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) + 2 (vcat [ text "when specialising" <+> quotes (ppr caller) + | caller <- callers]) + , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) + , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) + +wantSpecImport :: DynFlags -> Unfolding -> Bool +-- See Note [Specialise imported INLINABLE things] +wantSpecImport dflags unf + = case unf of + NoUnfolding -> False + BootUnfolding -> False + OtherCon {} -> False + DFunUnfolding {} -> True + CoreUnfolding { uf_src = src, uf_guidance = _guidance } + | gopt Opt_SpecialiseAggressively dflags -> True + | isStableSource src -> True + -- Specialise even INLINE things; it hasn't inlined yet, + -- so perhaps it never will. Moreover it may have calls + -- inside it that we want to specialise + | otherwise -> False -- Stable, not INLINE, hence INLINABLE + +{- Note [Avoiding loops in specImports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must take great care when specialising instance declarations +(functions like $fOrdList) lest we accidentally build a recursive +dictionary. See Note [Avoiding loops]. + +The basic strategy of Note [Avoiding loops] is to use filterCalls +to discard loopy specialisations. But to do that we must ensure +that the in-scope dict-binds (passed to filterCalls) contains +all the needed dictionary bindings. In particular, in the recursive +call to spec_imorpts in spec_import, we must include the dict-binds +from the parent. Lacking this caused #17151, a really nasty bug. + +Here is what happened. +* Class struture: + Source is a superclass of Mut + Index is a superclass of Source + +* We started with these dict binds + dSource = $fSourcePix @Int $fIndexInt + dIndex = sc_sel dSource + dMut = $fMutPix @Int dIndex + and these calls to specialise + $fMutPix @Int dIndex + $fSourcePix @Int $fIndexInt + +* We specialised the call ($fMutPix @Int dIndex) + ==> new call ($fSourcePix @Int dIndex) + (because Source is a superclass of Mut) + +* We specialised ($fSourcePix @Int dIndex) + ==> produces specialised dict $s$fSourcePix, + a record with dIndex as a field + plus RULE forall d. ($fSourcePix @Int d) = $s$fSourcePix + *** This is the bogus step *** + +* Now we decide not to specialise the call + $fSourcePix @Int $fIndexInt + because we alredy have a RULE that matches it + +* Finally the simplifer rewrites + dSource = $fSourcePix @Int $fIndexInt + ==> dSource = $s$fSourcePix + +Disaster. Now we have + +Rewrite dSource's RHS to $s$fSourcePix Disaster + dSource = $s$fSourcePix + dIndex = sc_sel dSource + $s$fSourcePix = MkSource dIndex ... + +Solution: filterCalls should have stopped the bogus step, +by seeing that dIndex transitively uses $fSourcePix. But +it can only do that if it sees all the dict_binds. Wow. + +-------------- +Here's another example (#13429). Suppose we have + class Monoid v => C v a where ... + +We start with a call + f @ [Integer] @ Integer $fC[]Integer + +Specialising call to 'f' gives dict bindings + $dMonoid_1 :: Monoid [Integer] + $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer + + $dC_1 :: C [Integer] (Node [Integer] Integer) + $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 + +...plus a recursive call to + f @ [Integer] @ (Node [Integer] Integer) $dC_1 + +Specialising that call gives + $dMonoid_2 :: Monoid [Integer] + $dMonoid_2 = M.$p1C @ [Integer] $dC_1 + + $dC_2 :: C [Integer] (Node [Integer] Integer) + $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2 + +Now we have two calls to the imported function + M.$fCvNode :: Monoid v => C v a + M.$fCvNode @v @a m = C m some_fun + +But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2) +for specialisation, else we get: + + $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 + $dMonoid_2 = M.$p1C @ [Integer] $dC_1 + $s$fCvNode = C $dMonoid_2 ... + RULE M.$fCvNode [Integer] _ _ = $s$fCvNode + +Now use the rule to rewrite the call in the RHS of $dC_1 +and we get a loop! + + +Note [specImport call stack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When specialising an imports function 'f', we may get new calls +of an imported fuction 'g', which we want to specialise in turn, +and similarly specialising 'g' might expose a new call to 'h'. + +We track the stack of enclosing functions. So when specialising 'h' we +haev a specImport call stack of [g,f]. We do this for two reasons: +* Note [Warning about missed specialisations] +* Note [Avoiding recursive specialisation] + +Note [Warning about missed specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose + * In module Lib, you carefully mark a function 'foo' INLINABLE + * Import Lib(foo) into another module M + * Call 'foo' at some specialised type in M +Then you jolly well expect it to be specialised in M. But what if +'foo' calls another function 'Lib.bar'. Then you'd like 'bar' to be +specialised too. But if 'bar' is not marked INLINABLE it may well +not be specialised. The warning Opt_WarnMissedSpecs warns about this. + +It's more noisy to warning about a missed specialisation opportunity +for /every/ overloaded imported function, but sometimes useful. That +is what Opt_WarnAllMissedSpecs does. + +ToDo: warn about missed opportunities for local functions. + +Note [Avoiding recursive specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise 'f' we may find new overloaded calls to 'g', 'h' in +'f's RHS. So we want to specialise g,h. But we don't want to +specialise f any more! It's possible that f's RHS might have a +recursive yet-more-specialised call, so we'd diverge in that case. +And if the call is to the same type, one specialisation is enough. +Avoiding this recursive specialisation loop is one reason for the +'callers' stack passed to specImports and specImport. + +Note [Specialise imported INLINABLE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What imported functions do we specialise? The basic set is + * DFuns and things with INLINABLE pragmas. +but with -fspecialise-aggressively we add + * Anything with an unfolding template + +#8874 has a good example of why we want to auto-specialise DFuns. + +We have the -fspecialise-aggressively flag (usually off), because we +risk lots of orphan modules from over-vigorous specialisation. +However it's not a big deal: anything non-recursive with an +unfolding-template will probably have been inlined already. + +Note [Glom the bindings if imported functions are specialised] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have an imported, *recursive*, INLINABLE function + f :: Eq a => a -> a + f = /\a \d x. ...(f a d)... +In the module being compiled we have + g x = f (x::Int) +Now we'll make a specialised function + f_spec :: Int -> Int + f_spec = \x -> ...(f Int dInt)... + {-# RULE f Int _ = f_spec #-} + g = \x. f Int dInt x +Note that f_spec doesn't look recursive +After rewriting with the RULE, we get + f_spec = \x -> ...(f_spec)... +BUT since f_spec was non-recursive before it'll *stay* non-recursive. +The occurrence analyser never turns a NonRec into a Rec. So we must +make sure that f_spec is recursive. Easiest thing is to make all +the specialisations for imported bindings recursive. + + + +************************************************************************ +* * +\subsubsection{@specExpr@: the main function} +* * +************************************************************************ +-} + +data SpecEnv + = SE { se_subst :: Core.Subst + -- We carry a substitution down: + -- a) we must clone any binding that might float outwards, + -- to avoid name clashes + -- b) we carry a type substitution to use when analysing + -- the RHS of specialised bindings (no type-let!) + + + , se_interesting :: VarSet + -- Dict Ids that we know something about + -- and hence may be worth specialising against + -- See Note [Interesting dictionary arguments] + } + +instance Outputable SpecEnv where + ppr (SE { se_subst = subst, se_interesting = interesting }) + = text "SE" <+> braces (sep $ punctuate comma + [ text "subst =" <+> ppr subst + , text "interesting =" <+> ppr interesting ]) + +specVar :: SpecEnv -> Id -> CoreExpr +specVar env v = Core.lookupIdSubst (text "specVar") (se_subst env) v + +specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails) + +---------------- First the easy cases -------------------- +specExpr env (Type ty) = return (Type (substTy env ty), emptyUDs) +specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs) +specExpr env (Var v) = return (specVar env v, emptyUDs) +specExpr _ (Lit lit) = return (Lit lit, emptyUDs) +specExpr env (Cast e co) + = do { (e', uds) <- specExpr env e + ; return ((mkCast e' (substCo env co)), uds) } +specExpr env (Tick tickish body) + = do { (body', uds) <- specExpr env body + ; return (Tick (specTickish env tickish) body', uds) } + +---------------- Applications might generate a call instance -------------------- +specExpr env expr@(App {}) + = go expr [] + where + go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg + (fun', uds_app) <- go fun (arg':args) + return (App fun' arg', uds_arg `plusUDs` uds_app) + + go (Var f) args = case specVar env f of + Var f' -> return (Var f', mkCallUDs env f' args) + e' -> return (e', emptyUDs) -- I don't expect this! + go other _ = specExpr env other + +---------------- Lambda/case require dumping of usage details -------------------- +specExpr env e@(Lam {}) + = specLam env' bndrs' body + where + (bndrs, body) = collectBinders e + (env', bndrs') = substBndrs env bndrs + -- More efficient to collect a group of binders together all at once + -- and we don't want to split a lambda group with dumped bindings + +specExpr env (Case scrut case_bndr ty alts) + = do { (scrut', scrut_uds) <- specExpr env scrut + ; (scrut'', case_bndr', alts', alts_uds) + <- specCase env scrut' case_bndr alts + ; return (Case scrut'' case_bndr' (substTy env ty) alts' + , scrut_uds `plusUDs` alts_uds) } + +---------------- Finally, let is the interesting case -------------------- +specExpr env (Let bind body) + = do { -- Clone binders + (rhs_env, body_env, bind') <- cloneBindSM env bind + + -- Deal with the body + ; (body', body_uds) <- specExpr body_env body + + -- Deal with the bindings + ; (binds', uds) <- specBind rhs_env bind' body_uds + + -- All done + ; return (foldr Let body' binds', uds) } + +-------------- +specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails) +-- The binders have been substituted, but the body has not +specLam env bndrs body + | null bndrs + = specExpr env body + | otherwise + = do { (body', uds) <- specExpr env body + ; let (free_uds, dumped_dbs) = dumpUDs bndrs uds + ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) } + +-------------- +specTickish :: SpecEnv -> Tickish Id -> Tickish Id +specTickish env (Breakpoint ix ids) + = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]] + -- drop vars from the list if they have a non-variable substitution. + -- should never happen, but it's harmless to drop them anyway. +specTickish _ other_tickish = other_tickish + +-------------- +specCase :: SpecEnv + -> CoreExpr -- Scrutinee, already done + -> Id -> [CoreAlt] + -> SpecM ( CoreExpr -- New scrutinee + , Id + , [CoreAlt] + , UsageDetails) +specCase env scrut' case_bndr [(con, args, rhs)] + | isDictId case_bndr -- See Note [Floating dictionaries out of cases] + , interestingDict env scrut' + , not (isDeadBinder case_bndr && null sc_args') + = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') + + ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg') + [(con, args', Var sc_arg')] + | sc_arg' <- sc_args' ] + + -- Extend the substitution for RHS to map the *original* binders + -- to their floated versions. + mb_sc_flts :: [Maybe DictId] + mb_sc_flts = map (lookupVarEnv clone_env) args' + clone_env = zipVarEnv sc_args' sc_args_flt + subst_prs = (case_bndr, Var case_bndr_flt) + : [ (arg, Var sc_flt) + | (arg, Just sc_flt) <- args `zip` mb_sc_flts ] + env_rhs' = env_rhs { se_subst = Core.extendIdSubstList (se_subst env_rhs) subst_prs + , se_interesting = se_interesting env_rhs `extendVarSetList` + (case_bndr_flt : sc_args_flt) } + + ; (rhs', rhs_uds) <- specExpr env_rhs' rhs + ; let scrut_bind = mkDB (NonRec case_bndr_flt scrut') + case_bndr_set = unitVarSet case_bndr_flt + sc_binds = [ DB { db_bind = NonRec sc_arg_flt sc_rhs + , db_fvs = case_bndr_set } + | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ] + flt_binds = scrut_bind : sc_binds + (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds + all_uds = flt_binds `addDictBinds` free_uds + alt' = (con, args', wrapDictBindsE dumped_dbs rhs') + ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } + where + (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args) + sc_args' = filter is_flt_sc_arg args' + + clone_me bndr = do { uniq <- getUniqueM + ; return (mkUserLocalOrCoVar occ uniq ty loc) } + where + name = idName bndr + ty = idType bndr + occ = nameOccName name + loc = getSrcSpan name + + arg_set = mkVarSet args' + is_flt_sc_arg var = isId var + && not (isDeadBinder var) + && isDictTy var_ty + && not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set) + where + var_ty = idType var + + +specCase env scrut case_bndr alts + = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts + ; return (scrut, case_bndr', alts', uds_alts) } + where + (env_alt, case_bndr') = substBndr env case_bndr + spec_alt (con, args, rhs) = do + (rhs', uds) <- specExpr env_rhs rhs + let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds + return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds) + where + (env_rhs, args') = substBndrs env_alt args + +{- +Note [Floating dictionaries out of cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + g = \d. case d of { MkD sc ... -> ...(f sc)... } +Naively we can't float d2's binding out of the case expression, +because 'sc' is bound by the case, and that in turn means we can't +specialise f, which seems a pity. + +So we invert the case, by floating out a binding +for 'sc_flt' thus: + sc_flt = case d of { MkD sc ... -> sc } +Now we can float the call instance for 'f'. Indeed this is just +what'll happen if 'sc' was originally bound with a let binding, +but case is more efficient, and necessary with equalities. So it's +good to work with both. + +You might think that this won't make any difference, because the +call instance will only get nuked by the \d. BUT if 'g' itself is +specialised, then transitively we should be able to specialise f. + +In general, given + case e of cb { MkD sc ... -> ...(f sc)... } +we transform to + let cb_flt = e + sc_flt = case cb_flt of { MkD sc ... -> sc } + in + case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... } + +The "_flt" things are the floated binds; we use the current substitution +to substitute sc -> sc_flt in the RHS + +************************************************************************ +* * + Dealing with a binding +* * +************************************************************************ +-} + +specBind :: SpecEnv -- Use this for RHSs + -> CoreBind -- Binders are already cloned by cloneBindSM, + -- but RHSs are un-processed + -> UsageDetails -- Info on how the scope of the binding + -> SpecM ([CoreBind], -- New bindings + UsageDetails) -- And info to pass upstream + +-- Returned UsageDetails: +-- No calls for binders of this bind +specBind rhs_env (NonRec fn rhs) body_uds + = do { (rhs', rhs_uds) <- specExpr rhs_env rhs + + ; let zapped_fn = zapIdDemandInfo fn + -- We zap the demand info because the binding may float, + -- which would invaidate the demand info (see #17810 for example). + -- Destroying demand info is not terrible; specialisation is + -- always followed soon by demand analysis. + ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds zapped_fn rhs + + ; let pairs = spec_defns ++ [(fn', rhs')] + -- fn' mentions the spec_defns in its rules, + -- so put the latter first + + combined_uds = body_uds1 `plusUDs` rhs_uds + + (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds + + final_binds :: [DictBind] + -- See Note [From non-recursive to recursive] + final_binds + | not (isEmptyBag dump_dbs) + , not (null spec_defns) + = [recWithDumpedDicts pairs dump_dbs] + | otherwise + = [mkDB $ NonRec b r | (b,r) <- pairs] + ++ bagToList dump_dbs + + ; if float_all then + -- Rather than discard the calls mentioning the bound variables + -- we float this (dictionary) binding along with the others + return ([], free_uds `snocDictBinds` final_binds) + else + -- No call in final_uds mentions bound variables, + -- so we can just leave the binding here + return (map db_bind final_binds, free_uds) } + + +specBind rhs_env (Rec pairs) body_uds + -- Note [Specialising a recursive group] + = do { let (bndrs,rhss) = unzip pairs + ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss + ; let scope_uds = body_uds `plusUDs` rhs_uds + -- Includes binds and calls arising from rhss + + ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs + + ; (bndrs3, spec_defns3, uds3) + <- if null spec_defns1 -- Common case: no specialisation + then return (bndrs1, [], uds1) + else do { -- Specialisation occurred; do it again + (bndrs2, spec_defns2, uds2) + <- specDefns rhs_env uds1 (bndrs1 `zip` rhss) + ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) } + + ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3 + final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss') + dumped_dbs + + ; if float_all then + return ([], final_uds `snocDictBind` final_bind) + else + return ([db_bind final_bind], final_uds) } + + +--------------------------- +specDefns :: SpecEnv + -> UsageDetails -- Info on how it is used in its scope + -> [(OutId,InExpr)] -- The things being bound and their un-processed RHS + -> SpecM ([OutId], -- Original Ids with RULES added + [(OutId,OutExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions + +-- Specialise a list of bindings (the contents of a Rec), but flowing usages +-- upwards binding by binding. Example: { f = ...g ...; g = ...f .... } +-- Then if the input CallDetails has a specialised call for 'g', whose specialisation +-- in turn generates a specialised call for 'f', we catch that in this one sweep. +-- But not vice versa (it's a fixpoint problem). + +specDefns _env uds [] + = return ([], [], uds) +specDefns env uds ((bndr,rhs):pairs) + = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs + ; (bndr1, spec_defns2, uds2) <- specDefn env uds1 bndr rhs + ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) } + +--------------------------- +specDefn :: SpecEnv + -> UsageDetails -- Info on how it is used in its scope + -> OutId -> InExpr -- The thing being bound and its un-processed RHS + -> SpecM (Id, -- Original Id with added RULES + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions + +specDefn env body_uds fn rhs + = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds + rules_for_me = idCoreRules fn + ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me + calls_for_me fn rhs + ; return ( fn `addIdSpecialisations` rules + , spec_defns + , body_uds_without_me `plusUDs` spec_uds) } + -- It's important that the `plusUDs` is this way + -- round, because body_uds_without_me may bind + -- dictionaries that are used in calls_for_me passed + -- to specDefn. So the dictionary bindings in + -- spec_uds may mention dictionaries bound in + -- body_uds_without_me + +--------------------------- +specCalls :: Maybe Module -- Just this_mod => specialising imported fn + -- Nothing => specialising local fn + -> SpecEnv + -> [CoreRule] -- Existing RULES for the fn + -> [CallInfo] + -> OutId -> InExpr + -> SpecM SpecInfo -- New rules, specialised bindings, and usage details + +-- This function checks existing rules, and does not create +-- duplicate ones. So the caller does not need to do this filtering. +-- See 'already_covered' + +type SpecInfo = ( [CoreRule] -- Specialisation rules + , [(Id,CoreExpr)] -- Specialised definition + , UsageDetails ) -- Usage details from specialised RHSs + +specCalls mb_mod env existing_rules calls_for_me fn rhs + -- The first case is the interesting one + | notNull calls_for_me -- And there are some calls to specialise + && not (isNeverActive (idInlineActivation fn)) + -- Don't specialise NOINLINE things + -- See Note [Auto-specialisation and RULES] + +-- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small +-- See Note [Inline specialisation] for why we do not +-- switch off specialisation for inline functions + + = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $ + foldlM spec_call ([], [], emptyUDs) calls_for_me + + | otherwise -- No calls or RHS doesn't fit our preconceptions + = WARN( not (exprIsTrivial rhs) && notNull calls_for_me, + text "Missed specialisation opportunity for" + <+> ppr fn $$ _trace_doc ) + -- Note [Specialisation shape] + -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ + return ([], [], emptyUDs) + where + _trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ] + + fn_type = idType fn + fn_arity = idArity fn + fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here + inl_prag = idInlinePragma fn + inl_act = inlinePragmaActivation inl_prag + is_local = isLocalId fn + + -- Figure out whether the function has an INLINE pragma + -- See Note [Inline specialisations] + + (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs + -- See Note [Account for casts in binding] + + in_scope = Core.substInScope (se_subst env) + + already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool + already_covered dflags new_rules args -- Note [Specialisations already covered] + = isJust (lookupRule dflags (in_scope, realIdUnfolding) + (const True) fn args + (new_rules ++ existing_rules)) + -- NB: we look both in the new_rules (generated by this invocation + -- of specCalls), and in existing_rules (passed in to specCalls) + + ---------------------------------------------------------- + -- Specialise to one particular call pattern + spec_call :: SpecInfo -- Accumulating parameter + -> CallInfo -- Call instance + -> SpecM SpecInfo + spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) (CI { ci_key = call_args }) + = -- See Note [Specialising Calls] + do { ( useful, rhs_env2, leftover_bndrs + , rule_bndrs, rule_lhs_args + , spec_bndrs, dx_binds, spec_args) <- specHeader env rhs_bndrs call_args + + ; dflags <- getDynFlags + ; if not useful -- No useful specialisation + || already_covered dflags rules_acc rule_lhs_args + then return spec_acc + else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids + -- , text "rhs_env2" <+> ppr (se_subst rhs_env2) + -- , ppr dx_binds ]) $ + do { -- Run the specialiser on the specialised RHS + -- The "1" suffix is before we maybe add the void arg + ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs ++ leftover_bndrs) rhs_body + ; let spec_fn_ty1 = exprType spec_rhs1 + + -- Maybe add a void arg to the specialised function, + -- to avoid unlifted bindings + -- See Note [Specialisations Must Be Lifted] + -- C.f. GHC.Core.Opt.WorkWrap.Utils.mkWorkerArgs + add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn) + (spec_rhs, spec_fn_ty, rule_rhs_args) + | add_void_arg = ( Lam voidArgId spec_rhs1 + , mkVisFunTy voidPrimTy spec_fn_ty1 + , voidPrimId : spec_bndrs) + | otherwise = (spec_rhs1, spec_fn_ty1, spec_bndrs) + + arity_decr = count isValArg rule_lhs_args - count isId rule_rhs_args + join_arity_decr = length rule_lhs_args - length rule_rhs_args + spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn + = Just (orig_join_arity - join_arity_decr) + | otherwise + = Nothing + + ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity + ; this_mod <- getModule + ; let + -- The rule to put in the function's specialisation is: + -- forall x @b d1' d2'. + -- f x @T1 @b @T2 d1' d2' = f1 x @b + -- See Note [Specialising Calls] + herald = case mb_mod of + Nothing -- Specialising local fn + -> text "SPEC" + Just this_mod -- Specialising imported fn + -> text "SPEC/" <> ppr this_mod + + rule_name = mkFastString $ showSDoc dflags $ + herald <+> ftext (occNameFS (getOccName fn)) + <+> hsep (mapMaybe ppr_call_key_ty call_args) + -- This name ends up in interface files, so use occNameString. + -- Otherwise uniques end up there, making builds + -- less deterministic (See #4012 comment:61 ff) + + rule_wout_eta = mkRule + this_mod + True {- Auto generated -} + is_local + rule_name + inl_act -- Note [Auto-specialisation and RULES] + (idName fn) + rule_bndrs + rule_lhs_args + (mkVarApps (Var spec_fn) rule_rhs_args) + + spec_rule + = case isJoinId_maybe fn of + Just join_arity -> etaExpandToJoinPointRule join_arity rule_wout_eta + Nothing -> rule_wout_eta + + -- Add the { d1' = dx1; d2' = dx2 } usage stuff + -- See Note [Specialising Calls] + spec_uds = foldr consDictBind rhs_uds dx_binds + + -------------------------------------- + -- Add a suitable unfolding if the spec_inl_prag says so + -- See Note [Inline specialisations] + (spec_inl_prag, spec_unf) + | not is_local && isStrongLoopBreaker (idOccInfo fn) + = (neverInlinePragma, noUnfolding) + -- See Note [Specialising imported functions] in OccurAnal + + | InlinePragma { inl_inline = Inlinable } <- inl_prag + = (inl_prag { inl_inline = NoUserInline }, noUnfolding) + + | otherwise + = (inl_prag, specUnfolding dflags fn spec_bndrs spec_app arity_decr fn_unf) + + spec_app e = e `mkApps` spec_args + + -------------------------------------- + -- Adding arity information just propagates it a bit faster + -- See Note [Arity decrease] in GHC.Core.Opt.Simplify + -- Copy InlinePragma information from the parent Id. + -- So if f has INLINE[1] so does spec_fn + spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr) + `setInlinePragma` spec_inl_prag + `setIdUnfolding` spec_unf + `asJoinId_maybe` spec_join_arity + + _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type + , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty + , ppr rhs_bndrs, ppr call_args + , ppr spec_rule + ] + + ; -- pprTrace "spec_call: rule" _rule_trace_doc + return ( spec_rule : rules_acc + , (spec_f_w_arity, spec_rhs) : pairs_acc + , spec_uds `plusUDs` uds_acc + ) } } + +{- Note [Specialisation Must Preserve Sharing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a function: + + f :: forall a. Eq a => a -> blah + f = + if expensive + then f1 + else f2 + +As written, all calls to 'f' will share 'expensive'. But if we specialise 'f' +at 'Int', eg: + + $sfInt = SUBST[a->Int,dict->dEqInt] (if expensive then f1 else f2) + + RULE "SPEC f" + forall (d :: Eq Int). + f Int _ = $sfIntf + +We've now lost sharing between 'f' and '$sfInt' for 'expensive'. Yikes! + +To avoid this, we only generate specialisations for functions whose arity is +enough to bind all of the arguments we need to specialise. This ensures our +specialised functions don't do any work before receiving all of their dicts, +and thus avoids the 'f' case above. + +Note [Specialisations Must Be Lifted] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a function 'f': + + f = forall a. Eq a => Array# a + +used like + + case x of + True -> ...f @Int dEqInt... + False -> 0 + +Naively, we might generate an (expensive) specialisation + + $sfInt :: Array# Int + +even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to +the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to +preserve laziness. + +Note [Specialising Calls] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a function with a complicated type: + + f :: forall a b c. Int -> Eq a => Show b => c -> Blah + f @a @b @c i dEqA dShowA x = blah + +and suppose it is called at: + + f 7 @T1 @T2 @T3 dEqT1 ($dfShow dShowT2) t3 + +This call is described as a 'CallInfo' whose 'ci_key' is: + + [ SpecType T1, SpecType T2, UnspecType, UnspecArg, SpecDict dEqT1 + , SpecDict ($dfShow dShowT2), UnspecArg ] + +Why are 'a' and 'b' identified as 'SpecType', while 'c' is 'UnspecType'? +Because we must specialise the function on type variables that appear +free in its *dictionary* arguments; but not on type variables that do not +appear in any dictionaries, i.e. are fully polymorphic. + +Because this call has dictionaries applied, we'd like to specialise +the call on any type argument that appears free in those dictionaries. +In this case, those are [a :-> T1, b :-> T2]. + +We also need to substitute the dictionary binders with their +specialised dictionaries. The simplest substitution would be +[dEqA :-> dEqT1, dShowA :-> $dfShow dShowT2], but this duplicates +work, since `$dfShow dShowT2` is a function application. Therefore, we +also want to *float the dictionary out* (via bindAuxiliaryDict), +creating a new dict binding + + dShow1 = $dfShow dShowT2 + +and the substitution [dEqA :-> dEqT1, dShowA :-> dShow1]. + +With the substitutions in hand, we can generate a specialised function: + + $sf :: forall c. Int -> c -> Blah + $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah) + +Note that the substitution is applied to the whole thing. This is +convenient, but just slightly fragile. Notably: + * There had better be no name clashes in a/b/c + +We must construct a rewrite rule: + + RULE "SPEC f @T1 @T2 _" + forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2). + f @T1 @T2 @c i d1 d2 = $sf @c i + +In the rule, d1 and d2 are just wildcards, not used in the RHS. Note +additionally that 'x' isn't captured by this rule --- we bind only +enough etas in order to capture all of the *specialised* arguments. + +Note [Drop dead args from specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When specialising a function, it’s possible some of the arguments may +actually be dead. For example, consider: + + f :: forall a. () -> Show a => a -> String + f x y = show y ++ "!" + +We might generate the following CallInfo for `f @Int`: + + [SpecType Int, UnspecArg, SpecDict $dShowInt, UnspecArg] + +Normally we’d include both the x and y arguments in the +specialisation, since we’re not specialising on either of them. But +that’s silly, since x is actually unused! So we might as well drop it +in the specialisation: + + $sf :: Int -> String + $sf y = show y ++ "!" + + {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-} + +This doesn’t save us much, since the arg would be removed later by +worker/wrapper, anyway, but it’s easy to do. Note, however, that we +only drop dead arguments if: + + 1. We don’t specialise on them. + 2. They come before an argument we do specialise on. + +Doing the latter would require eta-expanding the RULE, which could +make it match less often, so it’s not worth it. Doing the former could +be more useful --- it would stop us from generating pointless +specialisations --- but it’s more involved to implement and unclear if +it actually provides much benefit in practice. + +Note [Zap occ info in rule binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we generate a specialisation RULE, we need to drop occurrence +info on the binders. If we don’t, things go wrong when we specialise a +function like + + f :: forall a. () -> Show a => a -> String + f x y = show y ++ "!" + +since we’ll generate a RULE like + + RULE "SPEC f @Int" forall x [Occ=Dead]. + f @Int x $dShow = $sf + +and Core Lint complains, even though x only appears on the LHS (due to +Note [Drop dead args from specialisations]). + +Why is that a Lint error? Because the arguments on the LHS of a rule +are syntactically expressions, not patterns, so Lint treats the +appearance of x as a use rather than a binding. Fortunately, the +solution is simple: we just make sure to zap the occ info before +using ids as wildcard binders in a rule. + +Note [Account for casts in binding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: Eq a => a -> IO () + {-# INLINABLE f + StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g + #-} + f = ... + +In f's stable unfolding we have done some modest simplification which +has pushed the cast to the outside. (I wonder if this is the Right +Thing, but it's what happens now; see GHC.Core.Opt.Simplify.Utils Note [Casts and +lambdas].) Now that stable unfolding must be specialised, so we want +to push the cast back inside. It would be terrible if the cast +defeated specialisation! Hence the use of collectBindersPushingCo. + +Note [Evidence foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose (#12212) that we are specialising + f :: forall a b. (Num a, F a ~ F b) => blah +with a=b=Int. Then the RULE will be something like + RULE forall (d:Num Int) (g :: F Int ~ F Int). + f Int Int d g = f_spec +But both varToCoreExpr (when constructing the LHS args), and the +simplifier (when simplifying the LHS args), will transform to + RULE forall (d:Num Int) (g :: F Int ~ F Int). + f Int Int d = f_spec +by replacing g with Refl. So now 'g' is unbound, which results in a later +crash. So we use Refl right off the bat, and do not forall-quantify 'g': + * varToCoreExpr generates a Refl + * exprsFreeIdsList returns the Ids bound by the args, + which won't include g + +You might wonder if this will match as often, but the simplifier replaces +complicated Refl coercions with Refl pretty aggressively. + +Note [Orphans and auto-generated rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise an INLINABLE function, or when we have +-fspecialise-aggressively, we auto-generate RULES that are orphans. +We don't want to warn about these, or we'd generate a lot of warnings. +Thus, we only warn about user-specified orphan rules. + +Indeed, we don't even treat the module as an orphan module if it has +auto-generated *rule* orphans. Orphan modules are read every time we +compile, so they are pretty obtrusive and slow down every compilation, +even non-optimised ones. (Reason: for type class instances it's a +type correctness issue.) But specialisation rules are strictly for +*optimisation* only so it's fine not to read the interface. + +What this means is that a SPEC rules from auto-specialisation in +module M will be used in other modules only if M.hi has been read for +some other reason, which is actually pretty likely. + +Note [From non-recursive to recursive] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even in the non-recursive case, if any dict-binds depend on 'fn' we might +have built a recursive knot + + f a d x = + MkUD { ud_binds = NonRec d7 (MkD ..f..) + , ud_calls = ...(f T d7)... } + +The we generate + + Rec { fs x = [T/a, d7/d] + f a d x = + RULE f T _ = fs + d7 = ...f... } + +Here the recursion is only through the RULE. + +However we definitely should /not/ make the Rec in this wildly common +case: + d = ... + MkUD { ud_binds = NonRec d7 (...d...) + , ud_calls = ...(f T d7)... } + +Here we want simply to add d to the floats, giving + MkUD { ud_binds = NonRec d (...) + NonRec d7 (...d...) + , ud_calls = ...(f T d7)... } + +In general, we need only make this Rec if + - there are some specialisations (spec_binds non-empty) + - there are some dict_binds that depend on f (dump_dbs non-empty) + +Note [Avoiding loops] +~~~~~~~~~~~~~~~~~~~~~ +When specialising /dictionary functions/ we must be very careful to +avoid building loops. Here is an example that bit us badly, on +several distinct occasions. + +Here is one: #3591 + class Eq a => C a + instance Eq [a] => C [a] + +This translates to + dfun :: Eq [a] -> C [a] + dfun a d = MkD a d (meth d) + + d4 :: Eq [T] = + d2 :: C [T] = dfun T d4 + d1 :: Eq [T] = $p1 d2 + d3 :: C [T] = dfun T d1 + +None of these definitions is recursive. What happened was that we +generated a specialisation: + RULE forall d. dfun T d = dT :: C [T] + dT = (MkD a d (meth d)) [T/a, d1/d] + = MkD T d1 (meth d1) + +But now we use the RULE on the RHS of d2, to get + d2 = dT = MkD d1 (meth d1) + d1 = $p1 d2 + +and now d1 is bottom! The problem is that when specialising 'dfun' we +should first dump "below" the binding all floated dictionary bindings +that mention 'dfun' itself. So d2 and d3 (and hence d1) must be +placed below 'dfun', and thus unavailable to it when specialising +'dfun'. That in turn means that the call (dfun T d1) must be +discarded. On the other hand, the call (dfun T d4) is fine, assuming +d4 doesn't mention dfun. + +Solution: + Discard all calls that mention dictionaries that depend + (directly or indirectly) on the dfun we are specialising. + This is done by 'filterCalls' + +-------------- +Here's yet another example + + class C a where { foo,bar :: [a] -> [a] } + + instance C Int where + foo x = r_bar x + bar xs = reverse xs + + r_bar :: C a => [a] -> [a] + r_bar xs = bar (xs ++ xs) + +That translates to: + + r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) + + Rec { $fCInt :: C Int = MkC foo_help reverse + foo_help (xs::[Int]) = r_bar Int $fCInt xs } + +The call (r_bar $fCInt) mentions $fCInt, + which mentions foo_help, + which mentions r_bar +But we DO want to specialise r_bar at Int: + + Rec { $fCInt :: C Int = MkC foo_help reverse + foo_help (xs::[Int]) = r_bar Int $fCInt xs + + r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) + RULE r_bar Int _ = r_bar_Int + + r_bar_Int xs = bar Int $fCInt (xs ++ xs) + } + +Note that, because of its RULE, r_bar joins the recursive +group. (In this case it'll unravel a short moment later.) + + +Note [Specialising a recursive group] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let rec { f x = ...g x'... + ; g y = ...f y'.... } + in f 'a' +Here we specialise 'f' at Char; but that is very likely to lead to +a specialisation of 'g' at Char. We must do the latter, else the +whole point of specialisation is lost. + +But we do not want to keep iterating to a fixpoint, because in the +presence of polymorphic recursion we might generate an infinite number +of specialisations. + +So we use the following heuristic: + * Arrange the rec block in dependency order, so far as possible + (the occurrence analyser already does this) + + * Specialise it much like a sequence of lets + + * Then go through the block a second time, feeding call-info from + the RHSs back in the bottom, as it were + +In effect, the ordering maxmimises the effectiveness of each sweep, +and we do just two sweeps. This should catch almost every case of +monomorphic recursion -- the exception could be a very knotted-up +recursion with multiple cycles tied up together. + +This plan is implemented in the Rec case of specBindItself. + +Note [Specialisations already covered] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We obviously don't want to generate two specialisations for the same +argument pattern. There are two wrinkles + +1. We do the already-covered test in specDefn, not when we generate +the CallInfo in mkCallUDs. We used to test in the latter place, but +we now iterate the specialiser somewhat, and the Id at the call site +might therefore not have all the RULES that we can see in specDefn + +2. What about two specialisations where the second is an *instance* +of the first? If the more specific one shows up first, we'll generate +specialisations for both. If the *less* specific one shows up first, +we *don't* currently generate a specialisation for the more specific +one. (See the call to lookupRule in already_covered.) Reasons: + (a) lookupRule doesn't say which matches are exact (bad reason) + (b) if the earlier specialisation is user-provided, it's + far from clear that we should auto-specialise further + +Note [Auto-specialisation and RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + g :: Num a => a -> a + g = ... + + f :: (Int -> Int) -> Int + f w = ... + {-# RULE f g = 0 #-} + +Suppose that auto-specialisation makes a specialised version of +g::Int->Int That version won't appear in the LHS of the RULE for f. +So if the specialisation rule fires too early, the rule for f may +never fire. + +It might be possible to add new rules, to "complete" the rewrite system. +Thus when adding + RULE forall d. g Int d = g_spec +also add + RULE f g_spec = 0 + +But that's a bit complicated. For now we ask the programmer's help, +by *copying the INLINE activation pragma* to the auto-specialised +rule. So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule +will also not be active until phase 2. And that's what programmers +should jolly well do anyway, even aside from specialisation, to ensure +that g doesn't inline too early. + +This in turn means that the RULE would never fire for a NOINLINE +thing so not much point in generating a specialisation at all. + +Note [Specialisation shape] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only specialise a function if it has visible top-level lambdas +corresponding to its overloading. E.g. if + f :: forall a. Eq a => .... +then its body must look like + f = /\a. \d. ... + +Reason: when specialising the body for a call (f ty dexp), we want to +substitute dexp for d, and pick up specialised calls in the body of f. + +This doesn't always work. One example I came across was this: + newtype Gen a = MkGen{ unGen :: Int -> a } + + choose :: Eq a => a -> Gen a + choose n = MkGen (\r -> n) + + oneof = choose (1::Int) + +It's a silly example, but we get + choose = /\a. g `cast` co +where choose doesn't have any dict arguments. Thus far I have not +tried to fix this (wait till there's a real example). + +Mind you, then 'choose' will be inlined (since RHS is trivial) so +it doesn't matter. This comes up with single-method classes + + class C a where { op :: a -> a } + instance C a => C [a] where .... +==> + $fCList :: C a => C [a] + $fCList = $copList |> (...coercion>...) + ....(uses of $fCList at particular types)... + +So we suppress the WARN if the rhs is trivial. + +Note [Inline specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is what we do with the InlinePragma of the original function + * Activation/RuleMatchInfo: both transferred to the + specialised function + * InlineSpec: + (a) An INLINE pragma is transferred + (b) An INLINABLE pragma is *not* transferred + +Why (a): transfer INLINE pragmas? The point of INLINE was precisely to +specialise the function at its call site, and arguably that's not so +important for the specialised copies. BUT *pragma-directed* +specialisation now takes place in the typechecker/desugarer, with +manually specified INLINEs. The specialisation here is automatic. +It'd be very odd if a function marked INLINE was specialised (because +of some local use), and then forever after (including importing +modules) the specialised version wasn't INLINEd. After all, the +programmer said INLINE! + +You might wonder why we specialise INLINE functions at all. After +all they should be inlined, right? Two reasons: + + * Even INLINE functions are sometimes not inlined, when they aren't + applied to interesting arguments. But perhaps the type arguments + alone are enough to specialise (even though the args are too boring + to trigger inlining), and it's certainly better to call the + specialised version. + + * The RHS of an INLINE function might call another overloaded function, + and we'd like to generate a specialised version of that function too. + This actually happens a lot. Consider + replicateM_ :: (Monad m) => Int -> m a -> m () + {-# INLINABLE replicateM_ #-} + replicateM_ d x ma = ... + The strictness analyser may transform to + replicateM_ :: (Monad m) => Int -> m a -> m () + {-# INLINE replicateM_ #-} + replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma + + $wreplicateM_ :: (Monad m) => Int# -> m a -> m () + {-# INLINABLE $wreplicateM_ #-} + $wreplicateM_ = ... + Now an importing module has a specialised call to replicateM_, say + (replicateM_ dMonadIO). We certainly want to specialise $wreplicateM_! + This particular example had a huge effect on the call to replicateM_ + in nofib/shootout/n-body. + +Why (b): discard INLINABLE pragmas? See #4874 for persuasive examples. +Suppose we have + {-# INLINABLE f #-} + f :: Ord a => [a] -> Int + f xs = letrec f' = ...f'... in f' +Then, when f is specialised and optimised we might get + wgo :: [Int] -> Int# + wgo = ...wgo... + f_spec :: [Int] -> Int + f_spec xs = case wgo xs of { r -> I# r } +and we clearly want to inline f_spec at call sites. But if we still +have the big, un-optimised of f (albeit specialised) captured in an +INLINABLE pragma for f_spec, we won't get that optimisation. + +So we simply drop INLINABLE pragmas when specialising. It's not really +a complete solution; ignoring specialisation for now, INLINABLE functions +don't get properly strictness analysed, for example. But it works well +for examples involving specialisation, which is the dominant use of +INLINABLE. See #4874. +-} + +{- ********************************************************************* +* * + SpecArg, and specHeader +* * +********************************************************************* -} + +-- | An argument that we might want to specialise. +-- See Note [Specialising Calls] for the nitty gritty details. +data SpecArg + = + -- | Type arguments that should be specialised, due to appearing + -- free in the type of a 'SpecDict'. + SpecType Type + + -- | Type arguments that should remain polymorphic. + | UnspecType + + -- | Dictionaries that should be specialised. mkCallUDs ensures + -- that only "interesting" dictionary arguments get a SpecDict; + -- see Note [Interesting dictionary arguments] + | SpecDict DictExpr + + -- | Value arguments that should not be specialised. + | UnspecArg + +instance Outputable SpecArg where + ppr (SpecType t) = text "SpecType" <+> ppr t + ppr UnspecType = text "UnspecType" + ppr (SpecDict d) = text "SpecDict" <+> ppr d + ppr UnspecArg = text "UnspecArg" + +specArgFreeVars :: SpecArg -> VarSet +specArgFreeVars (SpecType ty) = tyCoVarsOfType ty +specArgFreeVars (SpecDict dx) = exprFreeVars dx +specArgFreeVars UnspecType = emptyVarSet +specArgFreeVars UnspecArg = emptyVarSet + +isSpecDict :: SpecArg -> Bool +isSpecDict (SpecDict {}) = True +isSpecDict _ = False + +-- | Given binders from an original function 'f', and the 'SpecArg's +-- corresponding to its usage, compute everything necessary to build +-- a specialisation. +-- +-- We will use the running example from Note [Specialising Calls]: +-- +-- f :: forall a b c. Int -> Eq a => Show b => c -> Blah +-- f @a @b @c i dEqA dShowA x = blah +-- +-- Suppose we decide to specialise it at the following pattern: +-- +-- [ SpecType T1, SpecType T2, UnspecType, UnspecArg +-- , SpecDict dEqT1, SpecDict ($dfShow dShowT2), UnspecArg ] +-- +-- We'd eventually like to build the RULE +-- +-- RULE "SPEC f @T1 @T2 _" +-- forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2). +-- f @T1 @T2 @c i d1 d2 = $sf @c i +-- +-- and the specialisation '$sf' +-- +-- $sf :: forall c. Int -> c -> Blah +-- $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah) +-- +-- where dShow1 is a floated binding created by bindAuxiliaryDict. +-- +-- The cases for 'specHeader' below are presented in the same order as this +-- running example. The result of 'specHeader' for this example is as follows: +-- +-- ( -- Returned arguments +-- env + [a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] +-- , [x] +-- +-- -- RULE helpers +-- , [c, i, d1, d2] +-- , [T1, T2, c, i, d1, d2] +-- +-- -- Specialised function helpers +-- , [c, i, x] +-- , [dShow1 = $dfShow dShowT2] +-- , [T1, T2, dEqT1, dShow1] +-- ) +specHeader + :: SpecEnv + -> [InBndr] -- The binders from the original function 'f' + -> [SpecArg] -- From the CallInfo + -> SpecM ( Bool -- True <=> some useful specialisation happened + -- Not the same as any (isSpecDict args) because + -- the args might be longer than bndrs + + -- Returned arguments + , SpecEnv -- Substitution to apply to the body of 'f' + , [OutBndr] -- Leftover binders from the original function 'f' + -- that don’t have a corresponding SpecArg + + -- RULE helpers + , [OutBndr] -- Binders for the RULE + , [CoreArg] -- Args for the LHS of the rule + + -- Specialised function helpers + , [OutBndr] -- Binders for $sf + , [DictBind] -- Auxiliary dictionary bindings + , [OutExpr] -- Specialised arguments for unfolding + ) + +-- We want to specialise on type 'T1', and so we must construct a substitution +-- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding +-- details. +specHeader env (bndr : bndrs) (SpecType t : args) + = do { let env' = extendTvSubstList env [(bndr, t)] + ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) + <- specHeader env' bndrs args + ; pure ( useful + , env'' + , leftover_bndrs + , rule_bs + , Type t : rule_es + , bs' + , dx + , Type t : spec_args + ) + } + +-- Next we have a type that we don't want to specialise. We need to perform +-- a substitution on it (in case the type refers to 'a'). Additionally, we need +-- to produce a binder, LHS argument and RHS argument for the resulting rule, +-- /and/ a binder for the specialised body. +specHeader env (bndr : bndrs) (UnspecType : args) + = do { let (env', bndr') = substBndr env bndr + ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) + <- specHeader env' bndrs args + ; pure ( useful + , env'' + , leftover_bndrs + , bndr' : rule_bs + , varToCoreExpr bndr' : rule_es + , bndr' : bs' + , dx + , varToCoreExpr bndr' : spec_args + ) + } + +-- Next we want to specialise the 'Eq a' dict away. We need to construct +-- a wildcard binder to match the dictionary (See Note [Specialising Calls] for +-- the nitty-gritty), as a LHS rule and unfolding details. +specHeader env (bndr : bndrs) (SpecDict d : args) + = do { bndr' <- newDictBndr env bndr -- See Note [Zap occ info in rule binders] + ; let (env', dx_bind, spec_dict) = bindAuxiliaryDict env bndr bndr' d + ; (_, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) + <- specHeader env' bndrs args + ; pure ( True -- Ha! A useful specialisation! + , env'' + , leftover_bndrs + -- See Note [Evidence foralls] + , exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs + , varToCoreExpr bndr' : rule_es + , bs' + , maybeToList dx_bind ++ dx + , spec_dict : spec_args + ) + } + +-- Finally, we have the unspecialised argument 'i'. We need to produce +-- a binder, LHS and RHS argument for the RULE, and a binder for the +-- specialised body. +-- +-- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is +-- why 'i' doesn't appear in our RULE above. But we have no guarantee that +-- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so +-- this case must be here. +specHeader env (bndr : bndrs) (UnspecArg : args) + = do { -- see Note [Zap occ info in rule binders] + let (env', bndr') = substBndr env (zapIdOccInfo bndr) + ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) + <- specHeader env' bndrs args + ; pure ( useful + , env'' + , leftover_bndrs + , bndr' : rule_bs + , varToCoreExpr bndr' : rule_es + , if isDeadBinder bndr + then bs' -- see Note [Drop dead args from specialisations] + else bndr' : bs' + , dx + , varToCoreExpr bndr' : spec_args + ) + } + +-- If we run out of binders, stop immediately +-- See Note [Specialisation Must Preserve Sharing] +specHeader env [] _ = pure (False, env, [], [], [], [], [], []) + +-- Return all remaining binders from the original function. These have the +-- invariant that they should all correspond to unspecialised arguments, so +-- it's safe to stop processing at this point. +specHeader env bndrs [] + = pure (False, env', bndrs', [], [], [], [], []) + where + (env', bndrs') = substBndrs env bndrs + + +-- | Binds a dictionary argument to a fresh name, to preserve sharing +bindAuxiliaryDict + :: SpecEnv + -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression + -> ( SpecEnv -- Substitute for orig_dict_id + , Maybe DictBind -- Auxiliary dict binding, if any + , OutExpr) -- Witnessing expression (always trivial) +bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting }) + orig_dict_id fresh_dict_id dict_expr + + -- If the dictionary argument is trivial, + -- don’t bother creating a new dict binding; just substitute + | Just dict_id <- getIdFromTrivialExpr_maybe dict_expr + = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr + `Core.extendInScope` dict_id + -- See Note [Keep the old dictionaries interesting] + , se_interesting = interesting `extendVarSet` dict_id } + in (env', Nothing, dict_expr) + + | otherwise -- Non-trivial dictionary arg; make an auxiliary binding + = let dict_bind = mkDB (NonRec fresh_dict_id dict_expr) + env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id) + `Core.extendInScope` fresh_dict_id + -- See Note [Make the new dictionaries interesting] + , se_interesting = interesting `extendVarSet` fresh_dict_id } + in (env', Just dict_bind, Var fresh_dict_id) + +{- +Note [Make the new dictionaries interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Important! We're going to substitute dx_id1 for d +and we want it to look "interesting", else we won't gather *any* +consequential calls. E.g. + f d = ...g d.... +If we specialise f for a call (f (dfun dNumInt)), we'll get +a consequent call (g d') with an auxiliary definition + d' = df dNumInt +We want that consequent call to look interesting + +Note [Keep the old dictionaries interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In bindAuxiliaryDict, we don’t bother creating a new dict binding if +the dict expression is trivial. For example, if we have + + f = \ @m1 (d1 :: Monad m1) -> ... + +and we specialize it at the pattern + + [SpecType IO, SpecArg $dMonadIO] + +it would be silly to create a new binding for $dMonadIO; it’s already +a binding! So we just extend the substitution directly: + + m1 :-> IO + d1 :-> $dMonadIO + +But this creates a new subtlety: the dict expression might be a dict +binding we floated out while specializing another function. For +example, we might have + + d2 = $p1Monad $dMonadIO -- floated out by bindAuxiliaryDict + $sg = h @IO d2 + h = \ @m2 (d2 :: Applicative m2) -> ... + +and end up specializing h at the following pattern: + + [SpecType IO, SpecArg d2] + +When we created the d2 binding in the first place, we locally marked +it as interesting while specializing g as described above by +Note [Make the new dictionaries interesting]. But when we go to +specialize h, it isn’t in the SpecEnv anymore, so we’ve lost the +knowledge that we should specialize on it. + +To fix this, we have to explicitly add d2 *back* to the interesting +set. That way, it will still be considered interesting while +specializing the body of h. See !2913. +-} + + +{- ********************************************************************* +* * + UsageDetails and suchlike +* * +********************************************************************* -} + +data UsageDetails + = MkUD { + ud_binds :: !(Bag DictBind), + -- See Note [Floated dictionary bindings] + -- The order is important; + -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1 + -- (Remember, Bags preserve order in GHC.) + + ud_calls :: !CallDetails + + -- INVARIANT: suppose bs = bindersOf ud_binds + -- Then 'calls' may *mention* 'bs', + -- but there should be no calls *for* bs + } + +-- | A 'DictBind' is a binding along with a cached set containing its free +-- variables (both type variables and dictionaries) +data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet } + +{- Note [Floated dictionary bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We float out dictionary bindings for the reasons described under +"Dictionary floating" above. But not /just/ dictionary bindings. +Consider + + f :: Eq a => blah + f a d = rhs + + $c== :: T -> T -> Bool + $c== x y = ... + + $df :: Eq T + $df = Eq $c== ... + + gurgle = ...(f @T $df)... + +We gather the call info for (f @T $df), and we don't want to drop it +when we come across the binding for $df. So we add $df to the floats +and continue. But then we have to add $c== to the floats, and so on. +These all float above the binding for 'f', and now we can +successfully specialise 'f'. + +So the DictBinds in (ud_binds :: Bag DictBind) may contain +non-dictionary bindings too. +-} + +instance Outputable DictBind where + ppr (DB { db_bind = bind, db_fvs = fvs }) + = text "DB" <+> braces (sep [ text "bind:" <+> ppr bind + , text "fvs: " <+> ppr fvs ]) + +instance Outputable UsageDetails where + ppr (MkUD { ud_binds = dbs, ud_calls = calls }) + = text "MkUD" <+> braces (sep (punctuate comma + [text "binds" <+> equals <+> ppr dbs, + text "calls" <+> equals <+> ppr calls])) + +emptyUDs :: UsageDetails +emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv } + +------------------------------------------------------------ +type CallDetails = DIdEnv CallInfoSet + -- The order of specialized binds and rules depends on how we linearize + -- CallDetails, so to get determinism we must use a deterministic set here. + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM + +data CallInfoSet = CIS Id (Bag CallInfo) + -- The list of types and dictionaries is guaranteed to + -- match the type of f + -- The Bag may contain duplicate calls (i.e. f @T and another f @T) + -- These dups are eliminated by already_covered in specCalls + +data CallInfo + = CI { ci_key :: [SpecArg] -- All arguments + , ci_fvs :: VarSet -- Free vars of the ci_key + -- call (including tyvars) + -- [*not* include the main id itself, of course] + } + +type DictExpr = CoreExpr + +ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet +ciSetFilter p (CIS id a) = CIS id (filterBag p a) + +instance Outputable CallInfoSet where + ppr (CIS fn map) = hang (text "CIS" <+> ppr fn) + 2 (ppr map) + +pprCallInfo :: Id -> CallInfo -> SDoc +pprCallInfo fn (CI { ci_key = key }) + = ppr fn <+> ppr key + +ppr_call_key_ty :: SpecArg -> Maybe SDoc +ppr_call_key_ty (SpecType ty) = Just $ char '@' <> pprParendType ty +ppr_call_key_ty UnspecType = Just $ char '_' +ppr_call_key_ty (SpecDict _) = Nothing +ppr_call_key_ty UnspecArg = Nothing + +instance Outputable CallInfo where + ppr (CI { ci_key = key, ci_fvs = _fvs }) + = text "CI" <> braces (sep (map ppr key)) + +unionCalls :: CallDetails -> CallDetails -> CallDetails +unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2 + +unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet +unionCallInfoSet (CIS f calls1) (CIS _ calls2) = + CIS f (calls1 `unionBags` calls2) + +callDetailsFVs :: CallDetails -> VarSet +callDetailsFVs calls = + nonDetFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls + -- It's OK to use nonDetFoldUDFM here because we forget the ordering + -- immediately by converting to a nondeterministic set. + +callInfoFVs :: CallInfoSet -> VarSet +callInfoFVs (CIS _ call_info) = + foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info + +getTheta :: [TyCoBinder] -> [PredType] +getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedBinder) + + +------------------------------------------------------------ +singleCall :: Id -> [SpecArg] -> UsageDetails +singleCall id args + = MkUD {ud_binds = emptyBag, + ud_calls = unitDVarEnv id $ CIS id $ + unitBag (CI { ci_key = args -- used to be tys + , ci_fvs = call_fvs }) } + where + call_fvs = foldr (unionVarSet . specArgFreeVars) emptyVarSet args + -- The type args (tys) are guaranteed to be part of the dictionary + -- types, because they are just the constrained types, + -- and the dictionary is therefore sure to be bound + -- inside the binding for any type variables free in the type; + -- hence it's safe to neglect tyvars free in tys when making + -- the free-var set for this call + -- BUT I don't trust this reasoning; play safe and include tys_fvs + -- + -- We don't include the 'id' itself. + +mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails +mkCallUDs env f args + = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ]) + res + where + res = mkCallUDs' env f args + +mkCallUDs' env f args + | not (want_calls_for f) -- Imported from elsewhere + || null ci_key -- No useful specialisation + -- See also Note [Specialisations already covered] + = -- pprTrace "mkCallUDs: discarding" _trace_doc + emptyUDs + + | otherwise + = -- pprTrace "mkCallUDs: keeping" _trace_doc + singleCall f ci_key + where + _trace_doc = vcat [ppr f, ppr args, ppr ci_key] + pis = fst $ splitPiTys $ idType f + constrained_tyvars = tyCoVarsOfTypes $ getTheta pis + + ci_key :: [SpecArg] + ci_key = dropWhileEndLE (not . isSpecDict) $ + zipWith mk_spec_arg args pis + -- Drop trailing args until we get to a SpecDict + -- In this way the RULE has as few args as possible, + -- which broadens its applicability, since rules only + -- fire when saturated + + mk_spec_arg :: CoreExpr -> TyCoBinder -> SpecArg + mk_spec_arg arg (Named bndr) + | binderVar bndr `elemVarSet` constrained_tyvars + = case arg of + Type ty -> SpecType ty + _ -> pprPanic "ci_key" $ ppr arg + | otherwise = UnspecType + + -- For "InvisArg", which are the type-class dictionaries, + -- we decide on a case by case basis if we want to specialise + -- on this argument; if so, SpecDict, if not UnspecArg + mk_spec_arg arg (Anon InvisArg pred) + | type_determines_value pred + , interestingDict env arg -- Note [Interesting dictionary arguments] + = SpecDict arg + | otherwise = UnspecArg + + mk_spec_arg _ (Anon VisArg _) + = UnspecArg + + want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f)) + -- For imported things, we gather call instances if + -- there is an unfolding that we could in principle specialise + -- We might still decide not to use it (consulting dflags) + -- in specImports + -- Use 'realIdUnfolding' to ignore the loop-breaker flag! + + type_determines_value pred -- See Note [Type determines value] + = case classifyPredType pred of + ClassPred cls _ -> not (isIPClass cls) -- Superclasses can't be IPs + EqPred {} -> True + IrredPred {} -> True -- Things like (D []) where D is a + -- Constraint-ranged family; #7785 + ForAllPred {} -> True + +{- +Note [Type determines value] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only specialise on non-IP *class* params, because these are the ones +whose *type* determines their *value*. In particular, with implicit +params, the type args *don't* say what the value of the implicit param +is! See #7101. + +So we treat implicit params just like ordinary arguments for the +purposes of specialisation. Note that we still want to specialise +functions with implicit params if they have *other* dicts which are +class params; see #17930. + +One apparent additional complexity involves type families. For +example, consider + type family D (v::*->*) :: Constraint + type instance D [] = () + f :: D v => v Char -> Int +If we see a call (f "foo"), we'll pass a "dictionary" + () |> (g :: () ~ D []) +and it's good to specialise f at this dictionary. + +So the question is: can an implicit parameter "hide inside" a +type-family constraint like (D a). Well, no. We don't allow + type instance D Maybe = ?x:Int +Hence the IrredPred case in type_determines_value. See #7785. + +Note [Interesting dictionary arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + \a.\d:Eq a. let f = ... in ...(f d)... +There really is not much point in specialising f wrt the dictionary d, +because the code for the specialised f is not improved at all, because +d is lambda-bound. We simply get junk specialisations. + +What is "interesting"? Just that it has *some* structure. But what about +variables? + + * A variable might be imported, in which case its unfolding + will tell us whether it has useful structure + + * Local variables are cloned on the way down (to avoid clashes when + we float dictionaries), and cloning drops the unfolding + (cloneIdBndr). Moreover, we make up some new bindings, and it's a + nuisance to give them unfoldings. So we keep track of the + "interesting" dictionaries as a VarSet in SpecEnv. + We have to take care to put any new interesting dictionary + bindings in the set. + +We accidentally lost accurate tracking of local variables for a long +time, because cloned variables don't have unfoldings. But makes a +massive difference in a few cases, eg #5113. For nofib as a +whole it's only a small win: 2.2% improvement in allocation for ansi, +1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. +-} + +interestingDict :: SpecEnv -> CoreExpr -> Bool +-- A dictionary argument is interesting if it has *some* structure +-- NB: "dictionary" arguments include constraints of all sorts, +-- including equality constraints; hence the Coercion case +interestingDict env (Var v) = hasSomeUnfolding (idUnfolding v) + || isDataConWorkId v + || v `elemVarSet` se_interesting env +interestingDict _ (Type _) = False +interestingDict _ (Coercion _) = False +interestingDict env (App fn (Type _)) = interestingDict env fn +interestingDict env (App fn (Coercion _)) = interestingDict env fn +interestingDict env (Tick _ a) = interestingDict env a +interestingDict env (Cast e _) = interestingDict env e +interestingDict _ _ = True + +plusUDs :: UsageDetails -> UsageDetails -> UsageDetails +plusUDs (MkUD {ud_binds = db1, ud_calls = calls1}) + (MkUD {ud_binds = db2, ud_calls = calls2}) + = MkUD { ud_binds = db1 `unionBags` db2 + , ud_calls = calls1 `unionCalls` calls2 } + +----------------------------- +_dictBindBndrs :: Bag DictBind -> [Id] +_dictBindBndrs dbs = foldr ((++) . bindersOf . db_bind) [] dbs + +-- | Construct a 'DictBind' from a 'CoreBind' +mkDB :: CoreBind -> DictBind +mkDB bind = DB { db_bind = bind, db_fvs = bind_fvs bind } + +-- | Identify the free variables of a 'CoreBind' +bind_fvs :: CoreBind -> VarSet +bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs) +bind_fvs (Rec prs) = foldl' delVarSet rhs_fvs bndrs + where + bndrs = map fst prs + rhs_fvs = unionVarSets (map pair_fvs prs) + +pair_fvs :: (Id, CoreExpr) -> VarSet +pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs + `unionVarSet` idFreeVars bndr + -- idFreeVars: don't forget variables mentioned in + -- the rules of the bndr. C.f. OccAnal.addRuleUsage + -- Also tyvars mentioned in its type; they may not appear + -- in the RHS + -- type T a = Int + -- x :: T a = 3 + where + interesting :: InterestingVarFun + interesting v = isLocalVar v || (isId v && isDFunId v) + -- Very important: include DFunIds /even/ if it is imported + -- Reason: See Note [Avoiding loops], the second example + -- involving an imported dfun. We must know whether + -- a dictionary binding depends on an imported dfun, + -- in case we try to specialise that imported dfun + -- #13429 illustrates + +-- | Flatten a set of "dumped" 'DictBind's, and some other binding +-- pairs, into a single recursive binding. +recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind -> DictBind +recWithDumpedDicts pairs dbs + = DB { db_bind = Rec bindings, db_fvs = fvs } + where + (bindings, fvs) = foldr add ([], emptyVarSet) + (dbs `snocBag` mkDB (Rec pairs)) + add (DB { db_bind = bind, db_fvs = fvs }) (prs_acc, fvs_acc) + = case bind of + NonRec b r -> ((b,r) : prs_acc, fvs') + Rec prs1 -> (prs1 ++ prs_acc, fvs') + where + fvs' = fvs_acc `unionVarSet` fvs + +snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails +-- Add ud_binds to the tail end of the bindings in uds +snocDictBinds uds dbs + = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs } + +consDictBind :: DictBind -> UsageDetails -> UsageDetails +consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds } + +addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails +addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds } + +snocDictBind :: UsageDetails -> DictBind -> UsageDetails +snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind } + +wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind] +wrapDictBinds dbs binds + = foldr add binds dbs + where + add (DB { db_bind = bind }) binds = bind : binds + +wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr +wrapDictBindsE dbs expr + = foldr add expr dbs + where + add (DB { db_bind = bind }) expr = Let bind expr + +---------------------- +dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind) +-- Used at a lambda or case binder; just dump anything mentioning the binder +dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) + | null bndrs = (uds, emptyBag) -- Common in case alternatives + | otherwise = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ + (free_uds, dump_dbs) + where + free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } + bndr_set = mkVarSet bndrs + (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set + free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor + deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be + -- no calls for any of the dicts in dump_dbs + +dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool) +-- Used at a let(rec) binding. +-- We return a boolean indicating whether the binding itself is mentioned, +-- directly or indirectly, by any of the ud_calls; in that case we want to +-- float the binding itself; +-- See Note [Floated dictionary bindings] +dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) + = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ + (free_uds, dump_dbs, float_all) + where + free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } + bndr_set = mkVarSet bndrs + (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set + free_calls = deleteCallsFor bndrs orig_calls + float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls + +callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo]) +callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) + = -- pprTrace ("callsForMe") + -- (vcat [ppr fn, + -- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs), + -- text "Orig calls =" <+> ppr orig_calls, + -- text "Dep set =" <+> ppr dep_set, + -- text "Calls for me =" <+> ppr calls_for_me]) $ + (uds_without_me, calls_for_me) + where + uds_without_me = MkUD { ud_binds = orig_dbs + , ud_calls = delDVarEnv orig_calls fn } + calls_for_me = case lookupDVarEnv orig_calls fn of + Nothing -> [] + Just cis -> filterCalls cis orig_dbs + -- filterCalls: drop calls that (directly or indirectly) + -- refer to fn. See Note [Avoiding loops] + +---------------------- +filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo] +-- See Note [Avoiding loops] +filterCalls (CIS fn call_bag) dbs + = filter ok_call (bagToList call_bag) + where + dump_set = foldl' go (unitVarSet fn) dbs + -- This dump-set could also be computed by splitDictBinds + -- (_,_,dump_set) = splitDictBinds dbs {fn} + -- But this variant is shorter + + go so_far (DB { db_bind = bind, db_fvs = fvs }) + | fvs `intersectsVarSet` so_far + = extendVarSetList so_far (bindersOf bind) + | otherwise = so_far + + ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set) + +---------------------- +splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet) +-- splitDictBinds dbs bndrs returns +-- (free_dbs, dump_dbs, dump_set) +-- where +-- * dump_dbs depends, transitively on bndrs +-- * free_dbs does not depend on bndrs +-- * dump_set = bndrs `union` bndrs(dump_dbs) +splitDictBinds dbs bndr_set + = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs + -- Important that it's foldl' not foldr; + -- we're accumulating the set of dumped ids in dump_set + where + split_db (free_dbs, dump_dbs, dump_idset) db + | DB { db_bind = bind, db_fvs = fvs } <- db + , dump_idset `intersectsVarSet` fvs -- Dump it + = (free_dbs, dump_dbs `snocBag` db, + extendVarSetList dump_idset (bindersOf bind)) + + | otherwise -- Don't dump it + = (free_dbs `snocBag` db, dump_dbs, dump_idset) + + +---------------------- +deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails +-- Remove calls *mentioning* bs in any way +deleteCallsMentioning bs calls + = mapDVarEnv (ciSetFilter keep_call) calls + where + keep_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` bs) + +deleteCallsFor :: [Id] -> CallDetails -> CallDetails +-- Remove calls *for* bs +deleteCallsFor bs calls = delDVarEnvList calls bs + +{- +************************************************************************ +* * +\subsubsection{Boring helper functions} +* * +************************************************************************ +-} + +newtype SpecM a = SpecM (State SpecState a) deriving (Functor) + +data SpecState = SpecState { + spec_uniq_supply :: UniqSupply, + spec_module :: Module, + spec_dflags :: DynFlags + } + +instance Applicative SpecM where + pure x = SpecM $ return x + (<*>) = ap + +instance Monad SpecM where + SpecM x >>= f = SpecM $ do y <- x + case f y of + SpecM z -> + z + +instance MonadFail SpecM where + fail str = SpecM $ error str + +instance MonadUnique SpecM where + getUniqueSupplyM + = SpecM $ do st <- get + let (us1, us2) = splitUniqSupply $ spec_uniq_supply st + put $ st { spec_uniq_supply = us2 } + return us1 + + getUniqueM + = SpecM $ do st <- get + let (u,us') = takeUniqFromSupply $ spec_uniq_supply st + put $ st { spec_uniq_supply = us' } + return u + +instance HasDynFlags SpecM where + getDynFlags = SpecM $ liftM spec_dflags get + +instance HasModule SpecM where + getModule = SpecM $ liftM spec_module get + +runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a +runSpecM dflags this_mod (SpecM spec) + = do us <- getUniqueSupplyM + let initialState = SpecState { + spec_uniq_supply = us, + spec_module = this_mod, + spec_dflags = dflags + } + return $ evalState spec initialState + +mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails) +mapAndCombineSM _ [] = return ([], emptyUDs) +mapAndCombineSM f (x:xs) = do (y, uds1) <- f x + (ys, uds2) <- mapAndCombineSM f xs + return (y:ys, uds1 `plusUDs` uds2) + +extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv +extendTvSubstList env tv_binds + = env { se_subst = Core.extendTvSubstList (se_subst env) tv_binds } + +substTy :: SpecEnv -> Type -> Type +substTy env ty = Core.substTy (se_subst env) ty + +substCo :: SpecEnv -> Coercion -> Coercion +substCo env co = Core.substCo (se_subst env) co + +substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr) +substBndr env bs = case Core.substBndr (se_subst env) bs of + (subst', bs') -> (env { se_subst = subst' }, bs') + +substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr]) +substBndrs env bs = case Core.substBndrs (se_subst env) bs of + (subst', bs') -> (env { se_subst = subst' }, bs') + +cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind) +-- Clone the binders of the bind; return new bind with the cloned binders +-- Return the substitution to use for RHSs, and the one to use for the body +cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs) + = do { us <- getUniqueSupplyM + ; let (subst', bndr') = Core.cloneIdBndr subst us bndr + interesting' | interestingDict env rhs + = interesting `extendVarSet` bndr' + | otherwise = interesting + ; return (env, env { se_subst = subst', se_interesting = interesting' } + , NonRec bndr' rhs) } + +cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs) + = do { us <- getUniqueSupplyM + ; let (subst', bndrs') = Core.cloneRecIdBndrs subst us (map fst pairs) + env' = env { se_subst = subst' + , se_interesting = interesting `extendVarSetList` + [ v | (v,r) <- pairs, interestingDict env r ] } + ; return (env', env', Rec (bndrs' `zip` map snd pairs)) } + +newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr +-- Make up completely fresh binders for the dictionaries +-- Their bindings are going to float outwards +newDictBndr env b = do { uniq <- getUniqueM + ; let n = idName b + ty' = substTy env (idType b) + ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) } + +newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id + -- Give the new Id a similar occurrence name to the old one +newSpecIdSM old_id new_ty join_arity_maybe + = do { uniq <- getUniqueM + ; let name = idName old_id + new_occ = mkSpecOcc (nameOccName name) + new_id = mkUserLocal new_occ uniq new_ty (getSrcSpan name) + `asJoinId_maybe` join_arity_maybe + ; return new_id } + +{- + Old (but interesting) stuff about unboxed bindings + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +What should we do when a value is specialised to a *strict* unboxed value? + + map_*_* f (x:xs) = let h = f x + t = map f xs + in h:t + +Could convert let to case: + + map_*_Int# f (x:xs) = case f x of h# -> + let t = map f xs + in h#:t + +This may be undesirable since it forces evaluation here, but the value +may not be used in all branches of the body. In the general case this +transformation is impossible since the mutual recursion in a letrec +cannot be expressed as a case. + +There is also a problem with top-level unboxed values, since our +implementation cannot handle unboxed values at the top level. + +Solution: Lift the binding of the unboxed value and extract it when it +is used: + + map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h# + t = map f xs + in case h of + _Lift h# -> h#:t + +Now give it to the simplifier and the _Lifting will be optimised away. + +The benefit is that we have given the specialised "unboxed" values a +very simple lifted semantics and then leave it up to the simplifier to +optimise it --- knowing that the overheads will be removed in nearly +all cases. + +In particular, the value will only be evaluated in the branches of the +program which use it, rather than being forced at the point where the +value is bound. For example: + + filtermap_*_* p f (x:xs) + = let h = f x + t = ... + in case p x of + True -> h:t + False -> t + ==> + filtermap_*_Int# p f (x:xs) + = let h = case (f x) of h# -> _Lift h# + t = ... + in case p x of + True -> case h of _Lift h# + -> h#:t + False -> t + +The binding for h can still be inlined in the one branch and the +_Lifting eliminated. + + +Question: When won't the _Lifting be eliminated? + +Answer: When they at the top-level (where it is necessary) or when +inlining would duplicate work (or possibly code depending on +options). However, the _Lifting will still be eliminated if the +strictness analyser deems the lifted binding strict. +-} diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/StaticArgs.hs @@ -0,0 +1,433 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +************************************************************************ + + Static Argument Transformation pass + +************************************************************************ + +May be seen as removing invariants from loops: +Arguments of recursive functions that do not change in recursive +calls are removed from the recursion, which is done locally +and only passes the arguments which effectively change. + +Example: +map = /\ ab -> \f -> \xs -> case xs of + [] -> [] + (a:b) -> f a : map f b + +as map is recursively called with the same argument f (unmodified) +we transform it to + +map = /\ ab -> \f -> \xs -> let map' ys = case ys of + [] -> [] + (a:b) -> f a : map' b + in map' xs + +Notice that for a compiler that uses lambda lifting this is +useless as map' will be transformed back to what map was. + +We could possibly do the same for big lambdas, but we don't as +they will eventually be removed in later stages of the compiler, +therefore there is no penalty in keeping them. + +We only apply the SAT when the number of static args is > 2. This +produces few bad cases. See + should_transform +in saTransform. + +Here are the headline nofib results: + Size Allocs Runtime +Min +0.0% -13.7% -21.4% +Max +0.1% +0.0% +5.4% +Geometric Mean +0.0% -0.2% -6.9% + +The previous patch, to fix polymorphic floatout demand signatures, is +essential to make this work well! +-} + +{-# LANGUAGE CPP #-} +module GHC.Core.Opt.StaticArgs ( doStaticArgs ) where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Var.Env +import GHC.Types.Unique.Supply +import GHC.Utils.Misc +import GHC.Types.Unique.FM +import GHC.Types.Var.Set +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Utils.Outputable + +import Data.List (mapAccumL) +import GHC.Data.FastString + +#include "HsVersions.h" + +doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram +doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds + where + sat_bind_threaded_us us bind = + let (us1, us2) = splitUniqSupply us + in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet)) + +-- We don't bother to SAT recursive groups since it can lead +-- to massive code expansion: see Andre Santos' thesis for details. +-- This means we only apply the actual SAT to Rec groups of one element, +-- but we want to recurse into the others anyway to discover other binds +satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo) +satBind (NonRec binder expr) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (NonRec binder expr', finalizeApp expr_app sat_info_expr) +satBind (Rec [(binder, rhs)]) interesting_ids = do + let interesting_ids' = interesting_ids `addOneToUniqSet` binder + (rhs_binders, rhs_body) = collectBinders rhs + (rhs_body', sat_info_rhs_body) <- satTopLevelExpr rhs_body interesting_ids' + let sat_info_rhs_from_args = unitVarEnv binder (bindersToSATInfo rhs_binders) + sat_info_rhs' = mergeIdSATInfo sat_info_rhs_from_args sat_info_rhs_body + + shadowing = binder `elementOfUniqSet` interesting_ids + sat_info_rhs'' = if shadowing + then sat_info_rhs' `delFromUFM` binder -- For safety + else sat_info_rhs' + + bind' <- saTransformMaybe binder (lookupUFM sat_info_rhs' binder) + rhs_binders rhs_body' + return (bind', sat_info_rhs'') +satBind (Rec pairs) interesting_ids = do + let (binders, rhss) = unzip pairs + rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss + let (rhss', sat_info_rhss') = unzip rhss_SATed + return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss') + +data App = VarApp Id | TypeApp Type | CoApp Coercion +data Staticness a = Static a | NotStatic + +type IdAppInfo = (Id, SATInfo) + +type SATInfo = [Staticness App] +type IdSATInfo = IdEnv SATInfo +emptyIdSATInfo :: IdSATInfo +emptyIdSATInfo = emptyUFM + +{- +pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info)) + where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info) +-} + +pprSATInfo :: SATInfo -> SDoc +pprSATInfo staticness = hcat $ map pprStaticness staticness + +pprStaticness :: Staticness App -> SDoc +pprStaticness (Static (VarApp _)) = text "SV" +pprStaticness (Static (TypeApp _)) = text "ST" +pprStaticness (Static (CoApp _)) = text "SC" +pprStaticness NotStatic = text "NS" + + +mergeSATInfo :: SATInfo -> SATInfo -> SATInfo +mergeSATInfo l r = zipWith mergeSA l r + where + mergeSA NotStatic _ = NotStatic + mergeSA _ NotStatic = NotStatic + mergeSA (Static (VarApp v)) (Static (VarApp v')) + | v == v' = Static (VarApp v) + | otherwise = NotStatic + mergeSA (Static (TypeApp t)) (Static (TypeApp t')) + | t `eqType` t' = Static (TypeApp t) + | otherwise = NotStatic + mergeSA (Static (CoApp c)) (Static (CoApp c')) + | c `eqCoercion` c' = Static (CoApp c) + | otherwise = NotStatic + mergeSA _ _ = pprPanic "mergeSATInfo" $ + text "Left:" + <> pprSATInfo l <> text ", " + <> text "Right:" + <> pprSATInfo r + +mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo +mergeIdSATInfo = plusUFM_C mergeSATInfo + +mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo +mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo + +bindersToSATInfo :: [Id] -> SATInfo +bindersToSATInfo vs = map (Static . binderToApp) vs + where binderToApp v | isId v = VarApp v + | isTyVar v = TypeApp $ mkTyVarTy v + | otherwise = CoApp $ mkCoVarCo v + +finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo +finalizeApp Nothing id_sat_info = id_sat_info +finalizeApp (Just (v, sat_info')) id_sat_info = + let sat_info'' = case lookupUFM id_sat_info v of + Nothing -> sat_info' + Just sat_info -> mergeSATInfo sat_info sat_info' + in extendVarEnv id_sat_info v sat_info'' + +satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo) +satTopLevelExpr expr interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (expr', finalizeApp expr_app sat_info_expr) + +satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) +satExpr var@(Var v) interesting_ids = do + let app_info = if v `elementOfUniqSet` interesting_ids + then Just (v, []) + else Nothing + return (var, emptyIdSATInfo, app_info) + +satExpr lit@(Lit _) _ = do + return (lit, emptyIdSATInfo, Nothing) + +satExpr (Lam binders body) interesting_ids = do + (body', sat_info, this_app) <- satExpr body interesting_ids + return (Lam binders body', finalizeApp this_app sat_info, Nothing) + +satExpr (App fn arg) interesting_ids = do + (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids + let satRemainder = boring fn' sat_info_fn + case fn_app of + Nothing -> satRemainder Nothing + Just (fn_id, fn_app_info) -> + -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface) + let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness]) + in case arg of + Type t -> satRemainderWithStaticness $ Static (TypeApp t) + Coercion c -> satRemainderWithStaticness $ Static (CoApp c) + Var v -> satRemainderWithStaticness $ Static (VarApp v) + _ -> satRemainderWithStaticness $ NotStatic + where + boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) + boring fn' sat_info_fn app_info = + do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids + let sat_info_arg' = finalizeApp arg_app sat_info_arg + sat_info = mergeIdSATInfo sat_info_fn sat_info_arg' + return (App fn' arg', sat_info, app_info) + +satExpr (Case expr bndr ty alts) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + let sat_info_expr' = finalizeApp expr_app sat_info_expr + + zipped_alts' <- mapM satAlt alts + let (alts', sat_infos_alts) = unzip zipped_alts' + return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing) + where + satAlt (con, bndrs, expr) = do + (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids + return ((con, bndrs, expr'), sat_info_expr) + +satExpr (Let bind body) interesting_ids = do + (body', sat_info_body, body_app) <- satExpr body interesting_ids + (bind', sat_info_bind) <- satBind bind interesting_ids + return (Let bind' body', mergeIdSATInfo sat_info_body sat_info_bind, body_app) + +satExpr (Tick tickish expr) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (Tick tickish expr', sat_info_expr, expr_app) + +satExpr ty@(Type _) _ = do + return (ty, emptyIdSATInfo, Nothing) + +satExpr co@(Coercion _) _ = do + return (co, emptyIdSATInfo, Nothing) + +satExpr (Cast expr coercion) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (Cast expr' coercion, sat_info_expr, expr_app) + +{- +************************************************************************ + + Static Argument Transformation Monad + +************************************************************************ +-} + +type SatM result = UniqSM result + +runSAT :: UniqSupply -> SatM a -> a +runSAT = initUs_ + +newUnique :: SatM Unique +newUnique = getUniqueM + +{- +************************************************************************ + + Static Argument Transformation Monad + +************************************************************************ + +To do the transformation, the game plan is to: + +1. Create a small nonrecursive RHS that takes the + original arguments to the function but discards + the ones that are static and makes a call to the + SATed version with the remainder. We intend that + this will be inlined later, removing the overhead + +2. Bind this nonrecursive RHS over the original body + WITH THE SAME UNIQUE as the original body so that + any recursive calls to the original now go via + the small wrapper + +3. Rebind the original function to a new one which contains + our SATed function and just makes a call to it: + we call the thing making this call the local body + +Example: transform this + + map :: forall a b. (a->b) -> [a] -> [b] + map = /\ab. \(f:a->b) (as:[a]) -> body[map] +to + map :: forall a b. (a->b) -> [a] -> [b] + map = /\ab. \(f:a->b) (as:[a]) -> + letrec map' :: [a] -> [b] + -- The "worker function + map' = \(as:[a]) -> + let map :: forall a' b'. (a -> b) -> [a] -> [b] + -- The "shadow function + map = /\a'b'. \(f':(a->b) (as:[a]). + map' as + in body[map] + in map' as + +Note [Shadow binding] +~~~~~~~~~~~~~~~~~~~~~ +The calls to the inner map inside body[map] should get inlined +by the local re-binding of 'map'. We call this the "shadow binding". + +But we can't use the original binder 'map' unchanged, because +it might be exported, in which case the shadow binding won't be +discarded as dead code after it is inlined. + +So we use a hack: we make a new SysLocal binder with the *same* unique +as binder. (Another alternative would be to reset the export flag.) + +Note [Binder type capture] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that in the inner map (the "shadow function"), the static arguments +are discarded -- it's as if they were underscores. Instead, mentions +of these arguments (notably in the types of dynamic arguments) are bound +by the *outer* lambdas of the main function. So we must make up fresh +names for the static arguments so that they do not capture variables +mentioned in the types of dynamic args. + +In the map example, the shadow function must clone the static type +argument a,b, giving a',b', to ensure that in the \(as:[a]), the 'a' +is bound by the outer forall. We clone f' too for consistency, but +that doesn't matter either way because static Id arguments aren't +mentioned in the shadow binding at all. + +If we don't we get something like this: + +[Exported] +[Arity 3] +GHC.Base.until = + \ (@ a_aiK) + (p_a6T :: a_aiK -> GHC.Types.Bool) + (f_a6V :: a_aiK -> a_aiK) + (x_a6X :: a_aiK) -> + letrec { + sat_worker_s1aU :: a_aiK -> a_aiK + [] + sat_worker_s1aU = + \ (x_a6X :: a_aiK) -> + let { + sat_shadow_r17 :: forall a_a3O. + (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O + [] + sat_shadow_r17 = + \ (@ a_aiK) + (p_a6T :: a_aiK -> GHC.Types.Bool) + (f_a6V :: a_aiK -> a_aiK) + (x_a6X :: a_aiK) -> + sat_worker_s1aU x_a6X } in + case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] { + GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X); + GHC.Types.True -> x_a6X + }; } in + sat_worker_s1aU x_a6X + +Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK +type argument. This is bad because it means the application sat_worker_s1aU x_a6X +is not well typed. +-} + +saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind +saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body + | Just arg_staticness <- maybe_arg_staticness + , should_transform arg_staticness + = saTransform binder arg_staticness rhs_binders rhs_body + | otherwise + = return (Rec [(binder, mkLams rhs_binders rhs_body)]) + where + should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT + where + n_static_args = count isStaticValue staticness + +saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind +saTransform binder arg_staticness rhs_binders rhs_body + = do { shadow_lam_bndrs <- mapM clone binders_w_staticness + ; uniq <- newUnique + ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) } + where + -- Running example: foldr + -- foldr \alpha \beta c n xs = e, for some e + -- arg_staticness = [Static TypeApp, Static TypeApp, Static VarApp, Static VarApp, NonStatic] + -- rhs_binders = [\alpha, \beta, c, n, xs] + -- rhs_body = e + + binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic) + -- Any extra args are assumed NotStatic + + non_static_args :: [Var] + -- non_static_args = [xs] + -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs] + non_static_args = [v | (v, NotStatic) <- binders_w_staticness] + + clone (bndr, NotStatic) = return bndr + clone (bndr, _ ) = do { uniq <- newUnique + ; return (setVarUnique bndr uniq) } + + -- new_rhs = \alpha beta c n xs -> + -- let sat_worker = \xs -> let sat_shadow = \alpha' beta' c n xs -> + -- sat_worker xs + -- in e + -- in sat_worker xs + mk_new_rhs uniq shadow_lam_bndrs + = mkLams rhs_binders $ + Let (Rec [(rec_body_bndr, rec_body)]) + local_body + where + local_body = mkVarApps (Var rec_body_bndr) non_static_args + + rec_body = mkLams non_static_args $ + Let (NonRec shadow_bndr shadow_rhs) rhs_body + + -- See Note [Binder type capture] + shadow_rhs = mkLams shadow_lam_bndrs local_body + -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs + + rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq (exprType rec_body) + -- rec_body_bndr = sat_worker + + -- See Note [Shadow binding]; make a SysLocal + shadow_bndr = mkSysLocal (occNameFS (getOccName binder)) + (idUnique binder) + (exprType shadow_rhs) + +isStaticValue :: Staticness App -> Bool +isStaticValue (Static (VarApp _)) = True +isStaticValue _ = False diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -0,0 +1,776 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} +-} + +{-# LANGUAGE CPP #-} +module GHC.Core.Opt.WorkWrap ( wwTopBinds ) where + +import GHC.Prelude + +import GHC.Core.Arity ( manifestArity ) +import GHC.Core +import GHC.Core.Unfold ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding ) +import GHC.Core.Utils ( exprType, exprIsHNF ) +import GHC.Core.FVs ( exprFreeVars ) +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.Type +import GHC.Types.Unique.Supply +import GHC.Types.Basic +import GHC.Driver.Session +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core.Opt.WorkWrap.Utils +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Core.FamInstEnv +import GHC.Utils.Monad + +#include "HsVersions.h" + +{- +We take Core bindings whose binders have: + +\begin{enumerate} + +\item Strictness attached (by the front-end of the strictness +analyser), and / or + +\item Constructed Product Result information attached by the CPR +analysis pass. + +\end{enumerate} + +and we return some ``plain'' bindings which have been +worker/wrapper-ified, meaning: + +\begin{enumerate} + +\item Functions have been split into workers and wrappers where +appropriate. If a function has both strictness and CPR properties +then only one worker/wrapper doing both transformations is produced; + +\item Binders' @IdInfos@ have been updated to reflect the existence of +these workers/wrappers (this is where we get STRICTNESS and CPR pragma +info for exported values). +\end{enumerate} +-} + +wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram + +wwTopBinds dflags fam_envs us top_binds + = initUs_ us $ do + top_binds' <- mapM (wwBind dflags fam_envs) top_binds + return (concat top_binds') + +{- +************************************************************************ +* * +\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@} +* * +************************************************************************ + +@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in +turn. Non-recursive case first, then recursive... +-} + +wwBind :: DynFlags + -> FamInstEnvs + -> CoreBind + -> UniqSM [CoreBind] -- returns a WwBinding intermediate form; + -- the caller will convert to Expr/Binding, + -- as appropriate. + +wwBind dflags fam_envs (NonRec binder rhs) = do + new_rhs <- wwExpr dflags fam_envs rhs + new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs + return [NonRec b e | (b,e) <- new_pairs] + -- Generated bindings must be non-recursive + -- because the original binding was. + +wwBind dflags fam_envs (Rec pairs) + = return . Rec <$> concatMapM do_one pairs + where + do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs + tryWW dflags fam_envs Recursive binder new_rhs + +{- +@wwExpr@ basically just walks the tree, looking for appropriate +annotations that can be used. Remember it is @wwBind@ that does the +matching by looking for strict arguments of the correct type. +@wwExpr@ is a version that just returns the ``Plain'' Tree. +-} + +wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr + +wwExpr _ _ e@(Type {}) = return e +wwExpr _ _ e@(Coercion {}) = return e +wwExpr _ _ e@(Lit {}) = return e +wwExpr _ _ e@(Var {}) = return e + +wwExpr dflags fam_envs (Lam binder expr) + = Lam new_binder <$> wwExpr dflags fam_envs expr + where new_binder | isId binder = zapIdUsedOnceInfo binder + | otherwise = binder + -- See Note [Zapping Used Once info in WorkWrap] + +wwExpr dflags fam_envs (App f a) + = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a + +wwExpr dflags fam_envs (Tick note expr) + = Tick note <$> wwExpr dflags fam_envs expr + +wwExpr dflags fam_envs (Cast expr co) = do + new_expr <- wwExpr dflags fam_envs expr + return (Cast new_expr co) + +wwExpr dflags fam_envs (Let bind expr) + = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr + +wwExpr dflags fam_envs (Case expr binder ty alts) = do + new_expr <- wwExpr dflags fam_envs expr + new_alts <- mapM ww_alt alts + let new_binder = zapIdUsedOnceInfo binder + -- See Note [Zapping Used Once info in WorkWrap] + return (Case new_expr new_binder ty new_alts) + where + ww_alt (con, binders, rhs) = do + new_rhs <- wwExpr dflags fam_envs rhs + let new_binders = [ if isId b then zapIdUsedOnceInfo b else b + | b <- binders ] + -- See Note [Zapping Used Once info in WorkWrap] + return (con, new_binders, new_rhs) + +{- +************************************************************************ +* * +\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair} +* * +************************************************************************ + +@tryWW@ just accumulates arguments, converts strictness info from the +front-end into the proper form, then calls @mkWwBodies@ to do +the business. + +The only reason this is monadised is for the unique supply. + +Note [Don't w/w INLINE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very important to refrain from w/w-ing an INLINE function (ie one +with a stable unfolding) because the wrapper will then overwrite the +old stable unfolding with the wrapper code. + +Furthermore, if the programmer has marked something as INLINE, +we may lose by w/w'ing it. + +If the strictness analyser is run twice, this test also prevents +wrappers (which are INLINEd) from being re-done. (You can end up with +several liked-named Ids bouncing around at the same time---absolute +mischief.) + +Notice that we refrain from w/w'ing an INLINE function even if it is +in a recursive group. It might not be the loop breaker. (We could +test for loop-breaker-hood, but I'm not sure that ever matters.) + +Note [Worker-wrapper for INLINABLE functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + {-# INLINABLE f #-} + f :: Ord a => [a] -> Int -> a + f x y = ....f.... + +where f is strict in y, we might get a more efficient loop by w/w'ing +f. But that would make a new unfolding which would overwrite the old +one! So the function would no longer be INLNABLE, and in particular +will not be specialised at call sites in other modules. + +This comes in practice (#6056). + +Solution: do the w/w for strictness analysis, but transfer the Stable +unfolding to the *worker*. So we will get something like this: + + {-# INLINE[0] f #-} + f :: Ord a => [a] -> Int -> a + f d x y = case y of I# y' -> fw d x y' + + {-# INLINABLE[0] fw #-} + fw :: Ord a => [a] -> Int# -> a + fw d x y' = let y = I# y' in ...f... + +How do we "transfer the unfolding"? Easy: by using the old one, wrapped +in work_fn! See GHC.Core.Unfold.mkWorkerUnfolding. + +Note [Worker-wrapper for NOINLINE functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to disable worker/wrapper for NOINLINE things, but it turns out +this can cause unnecessary reboxing of values. Consider + + {-# NOINLINE f #-} + f :: Int -> a + f x = error (show x) + + g :: Bool -> Bool -> Int -> Int + g True True p = f p + g False True p = p + 1 + g b False p = g b True p + +the strictness analysis will discover f and g are strict, but because f +has no wrapper, the worker for g will rebox p. So we get + + $wg x y p# = + let p = I# p# in -- Yikes! Reboxing! + case x of + False -> + case y of + False -> $wg False True p# + True -> +# p# 1# + True -> + case y of + False -> $wg True True p# + True -> case f p of { } + + g x y p = case p of (I# p#) -> $wg x y p# + +Now, in this case the reboxing will float into the True branch, and so +the allocation will only happen on the error path. But it won't float +inwards if there are multiple branches that call (f p), so the reboxing +will happen on every call of g. Disaster. + +Solution: do worker/wrapper even on NOINLINE things; but move the +NOINLINE pragma to the worker. + +(See #13143 for a real-world example.) + +It is crucial that we do this for *all* NOINLINE functions. #10069 +demonstrates what happens when we promise to w/w a (NOINLINE) leaf function, but +fail to deliver: + + data C = C Int# Int# + + {-# NOINLINE c1 #-} + c1 :: C -> Int# + c1 (C _ n) = n + + {-# NOINLINE fc #-} + fc :: C -> Int# + fc c = 2 *# c1 c + +Failing to w/w `c1`, but still w/wing `fc` leads to the following code: + + c1 :: C -> Int# + c1 (C _ n) = n + + $wfc :: Int# -> Int# + $wfc n = let c = C 0# n in 2 #* c1 c + + fc :: C -> Int# + fc (C _ n) = $wfc n + +Yikes! The reboxed `C` in `$wfc` can't cancel out, so we are in a bad place. +This generalises to any function that derives its strictness signature from +its callees, so we have to make sure that when a function announces particular +strictness properties, we have to w/w them accordingly, even if it means +splitting a NOINLINE function. + +Note [Worker activation] +~~~~~~~~~~~~~~~~~~~~~~~~ +Follows on from Note [Worker-wrapper for INLINABLE functions] + +It is *vital* that if the worker gets an INLINABLE pragma (from the +original function), then the worker has the same phase activation as +the wrapper (or later). That is necessary to allow the wrapper to +inline into the worker's unfolding: see GHC.Core.Opt.Simplify.Utils +Note [Simplifying inside stable unfoldings]. + +If the original is NOINLINE, it's important that the work inherit the +original activation. Consider + + {-# NOINLINE expensive #-} + expensive x = x + 1 + + f y = let z = expensive y in ... + +If expensive's worker inherits the wrapper's activation, +we'll get this (because of the compromise in point (2) of +Note [Wrapper activation]) + + {-# NOINLINE[0] $wexpensive #-} + $wexpensive x = x + 1 + {-# INLINE[0] expensive #-} + expensive x = $wexpensive x + + f y = let z = expensive y in ... + +and $wexpensive will be immediately inlined into expensive, followed by +expensive into f. This effectively removes the original NOINLINE! + +Otherwise, nothing is lost by giving the worker the same activation as the +wrapper, because the worker won't have any chance of inlining until the +wrapper does; there's no point in giving it an earlier activation. + +Note [Don't w/w inline small non-loop-breaker things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, we refrain from w/w-ing *small* functions, which are not +loop breakers, because they'll inline anyway. But we must take care: +it may look small now, but get to be big later after other inlining +has happened. So we take the precaution of adding an INLINE pragma to +any such functions. + +I made this change when I observed a big function at the end of +compilation with a useful strictness signature but no w-w. (It was +small during demand analysis, we refrained from w/w, and then got big +when something was inlined in its rhs.) When I measured it on nofib, +it didn't make much difference; just a few percent improved allocation +on one benchmark (bspt/Euclid.space). But nothing got worse. + +There is an infelicity though. We may get something like + f = g val +==> + g x = case gw x of r -> I# r + + f {- InlineStable, Template = g val -} + f = case gw x of r -> I# r + +The code for f duplicates that for g, without any real benefit. It +won't really be executed, because calls to f will go via the inlining. + +Note [Don't w/w join points for CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's no point in exploiting CPR info on a join point. If the whole function +is getting CPR'd, then the case expression around the worker function will get +pushed into the join point by the simplifier, which will have the same effect +that w/w'ing for CPR would have - the result will be returned in an unboxed +tuple. + + f z = let join j x y = (x+1, y+1) + in case z of A -> j 1 2 + B -> j 2 3 + + => + + f z = case $wf z of (# a, b #) -> (a, b) + $wf z = case (let join j x y = (x+1, y+1) + in case z of A -> j 1 2 + B -> j 2 3) of (a, b) -> (# a, b #) + + => + + f z = case $wf z of (# a, b #) -> (a, b) + $wf z = let join j x y = (# x+1, y+1 #) + in case z of A -> j 1 2 + B -> j 2 3 + +Note that we still want to give @j@ the CPR property, so that @f@ has it. So +CPR *analyse* join points as regular functions, but don't *transform* them. + +Doing W/W for returned products on a join point would be tricky anyway, as the +worker could not be a join point because it would not be tail-called. However, +doing the *argument* part of W/W still works for join points, since the wrapper +body will make a tail call: + + f z = let join j x y = x + y + in ... + + => + + f z = let join $wj x# y# = x# +# y# + j x y = case x of I# x# -> + case y of I# y# -> + $wj x# y# + in ... + +Note [Wrapper activation] +~~~~~~~~~~~~~~~~~~~~~~~~~ +When should the wrapper inlining be active? + +1. It must not be active earlier than the current Activation of the + Id + +2. It should be active at some point, despite (1) because of + Note [Worker-wrapper for NOINLINE functions] + +3. For ordinary functions with no pragmas we want to inline the + wrapper as early as possible (#15056). Suppose another module + defines f x = g x x + and suppose there is some RULE for (g True True). Then if we have + a call (f True), we'd expect to inline 'f' and the RULE will fire. + But if f is w/w'd (which it might be), we want the inlining to + occur just as if it hadn't been. + + (This only matters if f's RHS is big enough to w/w, but small + enough to inline given the call site, but that can happen.) + +4. We do not want to inline the wrapper before specialisation. + module Foo where + f :: Num a => a -> Int -> a + f n 0 = n -- Strict in the Int, hence wrapper + f n x = f (n+n) (x-1) + + g :: Int -> Int + g x = f x x -- Provokes a specialisation for f + + module Bar where + import Foo + + h :: Int -> Int + h x = f 3 x + + In module Bar we want to give specialisations a chance to fire + before inlining f's wrapper. + +Reminder: Note [Don't w/w INLINE things], so we don't need to worry + about INLINE things here. + +Conclusion: + - If the user said NOINLINE[n], respect that + - If the user said NOINLINE, inline the wrapper as late as + poss (phase 0). This is a compromise driven by (2) above + - Otherwise inline wrapper in phase 2. That allows the + 'gentle' simplification pass to apply specialisation rules + +Historical note: At one stage I tried making the wrapper inlining +always-active, and that had a very bad effect on nofib/imaginary/x2n1; +a wrapper was inlined before the specialisation fired. + +Note [Wrapper NoUserInline] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The use an inl_inline of NoUserInline on the wrapper distinguishes +this pragma from one that was given by the user. In particular, CSE +will not happen if there is a user-specified pragma, but should happen +for w/w’ed things (#14186). +-} + +tryWW :: DynFlags + -> FamInstEnvs + -> RecFlag + -> Id -- The fn binder + -> CoreExpr -- The bound rhs; its innards + -- are already ww'd + -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs; + -- if one, then no worker (only + -- the orig "wrapper" lives on); + -- if two, then a worker and a + -- wrapper. +tryWW dflags fam_envs is_rec fn_id rhs + -- See Note [Worker-wrapper for NOINLINE functions] + + | Just stable_unf <- certainlyWillInline dflags fn_info + = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ] + -- See Note [Don't w/w INLINE things] + -- See Note [Don't w/w inline small non-loop-breaker things] + + | is_fun && is_eta_exp + = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs + + | is_thunk -- See Note [Thunk splitting] + = splitThunk dflags fam_envs is_rec new_fn_id rhs + + | otherwise + = return [ (new_fn_id, rhs) ] + + where + fn_info = idInfo fn_id + (wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info) + + cpr_ty = getCprSig (cprInfo fn_info) + -- Arity of the CPR sig should match idArity when it's not a join point. + -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal + cpr = ASSERT2( isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info + , ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) + ct_cpr cpr_ty + + new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id) + -- See Note [Zapping DmdEnv after Demand Analyzer] and + -- See Note [Zapping Used Once info WorkWrap] + + is_fun = notNull wrap_dmds || isJoinId fn_id + -- See Note [Don't eta expand in w/w] + is_eta_exp = length wrap_dmds == manifestArity rhs + is_thunk = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id) + && not (isUnliftedType (idType fn_id)) + +{- +Note [Zapping DmdEnv after Demand Analyzer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the worker-wrapper pass we zap the DmdEnv. Why? + (a) it is never used again + (b) it wastes space + (c) it becomes incorrect as things are cloned, because + we don't push the substitution into it + +Why here? + * Because we don’t want to do it in the Demand Analyzer, as we never know + there when we are doing the last pass. + * We want them to be still there at the end of DmdAnal, so that + -ddump-str-anal contains them. + * We don’t want a second pass just for that. + * WorkWrap looks at all bindings anyway. + +We also need to do it in TidyCore.tidyLetBndr to clean up after the +final, worker/wrapper-less run of the demand analyser (see +Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal). + +Note [Zapping Used Once info in WorkWrap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the worker-wrapper pass we zap the used once info in demands and in +strictness signatures. + +Why? + * The simplifier may happen to transform code in a way that invalidates the + data (see #11731 for an example). + * It is not used in later passes, up to code generation. + +So as the data is useless and possibly wrong, we want to remove it. The most +convenient place to do that is the worker wrapper phase, as it runs after every +run of the demand analyser besides the very last one (which is the one where we +want to _keep_ the info for the code generator). + +We do not do it in the demand analyser for the same reasons outlined in +Note [Zapping DmdEnv after Demand Analyzer] above. + +Note [Don't eta expand in w/w] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A binding where the manifestArity of the RHS is less than idArity of the binder +means GHC.Core.Arity didn't eta expand that binding. When this happens, it does so +for a reason (see Note [exprArity invariant] in GHC.Core.Arity) and we probably have +a PAP, cast or trivial expression as RHS. + +Performing the worker/wrapper split will implicitly eta-expand the binding to +idArity, overriding GHC.Core.Arity's decision. Other than playing fast and loose with +divergence, it's also broken for newtypes: + + f = (\xy.blah) |> co + where + co :: (Int -> Int -> Char) ~ T + +Then idArity is 2 (despite the type T), and it can have a StrictSig based on a +threshold of 2. But we can't w/w it without a type error. + +The situation is less grave for PAPs, but the implicit eta expansion caused a +compiler allocation regression in T15164, where huge recursive instance method +groups, mostly consisting of PAPs, got w/w'd. This caused great churn in the +simplifier, when simply waiting for the PAPs to inline arrived at the same +output program. + +Note there is the worry here that such PAPs and trivial RHSs might not *always* +be inlined. That would lead to reboxing, because the analysis tacitly assumes +that we W/W'd for idArity and will propagate analysis information under that +assumption. So far, this doesn't seem to matter in practice. +See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064. +-} + + +--------------------- +splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> CprResult -> CoreExpr + -> UniqSM [(Id, CoreExpr)] +splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs + = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) ) do + -- The arity should match the signature + stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info + case stuff of + Just (work_demands, join_arity, wrap_fn, work_fn) -> do + work_uniq <- getUniqueM + let work_rhs = work_fn rhs + work_act = case fn_inline_spec of -- See Note [Worker activation] + NoInline -> fn_act + _ -> wrap_act + + work_prag = InlinePragma { inl_src = SourceText "{-# INLINE" + , inl_inline = fn_inline_spec + , inl_sat = Nothing + , inl_act = work_act + , inl_rule = FunLike } + -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions] + -- inl_act: see Note [Worker activation] + -- inl_rule: it does not make sense for workers to be constructorlike. + + work_join_arity | isJoinId fn_id = Just join_arity + | otherwise = Nothing + -- worker is join point iff wrapper is join point + -- (see Note [Don't w/w join points for CPR]) + + work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) + `setIdOccInfo` occInfo fn_info + -- Copy over occurrence info from parent + -- Notably whether it's a loop breaker + -- Doesn't matter much, since we will simplify next, but + -- seems right-er to do so + + `setInlinePragma` work_prag + + `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding + -- See Note [Worker-wrapper for INLINABLE functions] + + `setIdStrictness` mkClosedStrictSig work_demands div + -- Even though we may not be at top level, + -- it's ok to give it an empty DmdEnv + + `setIdCprInfo` mkCprSig work_arity work_cpr_info + + `setIdDemandInfo` worker_demand + + `setIdArity` work_arity + -- Set the arity so that the Core Lint check that the + -- arity is consistent with the demand type goes + -- through + `asJoinId_maybe` work_join_arity + + work_arity = length work_demands + + -- See Note [Demand on the Worker] + single_call = saturatedByOneShots arity (demandInfo fn_info) + worker_demand | single_call = mkWorkerDemand work_arity + | otherwise = topDmd + + wrap_rhs = wrap_fn work_id + wrap_act = case fn_act of -- See Note [Wrapper activation] + ActiveAfter {} -> fn_act + NeverActive -> activeDuringFinal + _ -> activeAfterInitial + wrap_prag = InlinePragma { inl_src = SourceText "{-# INLINE" + , inl_inline = NoUserInline + , inl_sat = Nothing + , inl_act = wrap_act + , inl_rule = rule_match_info } + -- inl_act: see Note [Wrapper activation] + -- inl_inline: see Note [Wrapper NoUserInline] + -- inl_rule: RuleMatchInfo is (and must be) unaffected + + wrap_id = fn_id `setIdUnfolding` mkWwInlineRule dflags wrap_rhs arity + `setInlinePragma` wrap_prag + `setIdOccInfo` noOccInfo + -- Zap any loop-breaker-ness, to avoid bleating from Lint + -- about a loop breaker with an INLINE rule + + + + return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)] + -- Worker first, because wrapper mentions it + + Nothing -> return [(fn_id, rhs)] + where + rhs_fvs = exprFreeVars rhs + fn_inl_prag = inlinePragInfo fn_info + fn_inline_spec = inl_inline fn_inl_prag + fn_act = inl_act fn_inl_prag + rule_match_info = inlinePragmaRuleMatchInfo fn_inl_prag + fn_unfolding = unfoldingInfo fn_info + arity = arityInfo fn_info + -- The arity is set by the simplifier using exprEtaExpandArity + -- So it may be more than the number of top-level-visible lambdas + + -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points, + -- see Note [Don't w/w join points for CPR]. + use_cpr_info | isJoinId fn_id = topCpr + | otherwise = cpr + -- Even if we don't w/w join points for CPR, we might still do so for + -- strictness. In which case a join point worker keeps its original CPR + -- property; see Note [Don't w/w join points for CPR]. Otherwise, the worker + -- doesn't have the CPR property anymore. + work_cpr_info | isJoinId fn_id = cpr + | otherwise = topCpr + + +{- +Note [Demand on the worker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If the original function is called once, according to its demand info, then +so is the worker. This is important so that the occurrence analyser can +attach OneShot annotations to the worker’s lambda binders. + + +Example: + + -- Original function + f [Demand=] :: (a,a) -> a + f = \p -> ... + + -- Wrapper + f [Demand=] :: a -> a -> a + f = \p -> case p of (a,b) -> $wf a b + + -- Worker + $wf [Demand=] :: Int -> Int + $wf = \a b -> ... + +We need to check whether the original function is called once, with +sufficiently many arguments. This is done using saturatedByOneShots, which +takes the arity of the original function (resp. the wrapper) and the demand on +the original function. + +The demand on the worker is then calculated using mkWorkerDemand, and always of +the form [Demand=] + + +Note [Do not split void functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this rather common form of binding: + $j = \x:Void# -> ...no use of x... + +Since x is not used it'll be marked as absent. But there is no point +in w/w-ing because we'll simply add (\y:Void#), see GHC.Core.Opt.WorkWrap.Utils.mkWorerArgs. + +If x has a more interesting type (eg Int, or Int#), there *is* a point +in w/w so that we don't pass the argument at all. + +Note [Thunk splitting] +~~~~~~~~~~~~~~~~~~~~~~ +Suppose x is used strictly (never mind whether it has the CPR +property). + + let + x* = x-rhs + in body + +splitThunk transforms like this: + + let + x* = case x-rhs of { I# a -> I# a } + in body + +Now simplifier will transform to + + case x-rhs of + I# a -> let x* = I# a + in body + +which is what we want. Now suppose x-rhs is itself a case: + + x-rhs = case e of { T -> I# a; F -> I# b } + +The join point will abstract over a, rather than over (which is +what would have happened before) which is fine. + +Notice that x certainly has the CPR property now! + +In fact, splitThunk uses the function argument w/w splitting +function, so that if x's demand is deeper (say U(U(L,L),L)) +then the splitting will go deeper too. +-} + +-- See Note [Thunk splitting] +-- splitThunk converts the *non-recursive* binding +-- x = e +-- into +-- x = let x = e +-- in case x of +-- I# y -> let x = I# y in x } +-- See comments above. Is it not beautifully short? +-- Moreover, it works just as well when there are +-- several binders, and if the binders are lifted +-- E.g. x = e +-- --> x = let x = e in +-- case x of (a,b) -> let x = (a,b) in x + +splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)] +splitThunk dflags fam_envs is_rec fn_id rhs + = ASSERT(not (isJoinId fn_id)) + do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [fn_id] + ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] + ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive + return res + else return [(fn_id, rhs)] } diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -0,0 +1,1246 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +A library for the ``worker\/wrapper'' back-end to the strictness analyser +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.WorkWrap.Utils + ( mkWwBodies, mkWWstr, mkWorkerArgs + , DataConAppContext(..), deepSplitProductType_maybe, wantToUnbox + , findTypeShape + , isWorkerSmallEnough + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase ) +import GHC.Types.Id +import GHC.Types.Id.Info ( JoinArity ) +import GHC.Core.DataCon +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup + , mkCoreApp, mkCoreLet ) +import GHC.Types.Id.Make ( voidArgId, voidPrimId ) +import GHC.Builtin.Types ( tupleDataCon ) +import GHC.Builtin.Types.Prim ( voidPrimTy ) +import GHC.Types.Literal ( absentLiteralOf, rubbishLit ) +import GHC.Types.Var.Env ( mkInScopeSet ) +import GHC.Types.Var.Set ( VarSet ) +import GHC.Core.Type +import GHC.Core.Predicate ( isClassPred ) +import GHC.Types.RepType ( isVoidTy, typePrimRep ) +import GHC.Core.Coercion +import GHC.Core.FamInstEnv +import GHC.Types.Basic ( Boxity(..) ) +import GHC.Core.TyCon +import GHC.Types.Unique.Supply +import GHC.Types.Unique +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Data.List.SetOps + +{- +************************************************************************ +* * +\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@} +* * +************************************************************************ + +Here's an example. The original function is: + +\begin{verbatim} +g :: forall a . Int -> [a] -> a + +g = \/\ a -> \ x ys -> + case x of + 0 -> head ys + _ -> head (tail ys) +\end{verbatim} + +From this, we want to produce: +\begin{verbatim} +-- wrapper (an unfolding) +g :: forall a . Int -> [a] -> a + +g = \/\ a -> \ x ys -> + case x of + I# x# -> $wg a x# ys + -- call the worker; don't forget the type args! + +-- worker +$wg :: forall a . Int# -> [a] -> a + +$wg = \/\ a -> \ x# ys -> + let + x = I# x# + in + case x of -- note: body of g moved intact + 0 -> head ys + _ -> head (tail ys) +\end{verbatim} + +Something we have to be careful about: Here's an example: + +\begin{verbatim} +-- "f" strictness: U(P)U(P) +f (I# a) (I# b) = a +# b + +g = f -- "g" strictness same as "f" +\end{verbatim} + +\tr{f} will get a worker all nice and friendly-like; that's good. +{\em But we don't want a worker for \tr{g}}, even though it has the +same strictness as \tr{f}. Doing so could break laziness, at best. + +Consequently, we insist that the number of strictness-info items is +exactly the same as the number of lambda-bound arguments. (This is +probably slightly paranoid, but OK in practice.) If it isn't the +same, we ``revise'' the strictness info, so that we won't propagate +the unusable strictness-info into the interfaces. + + +************************************************************************ +* * +\subsection{The worker wrapper core} +* * +************************************************************************ + +@mkWwBodies@ is called when doing the worker\/wrapper split inside a module. +-} + +type WwResult + = ([Demand], -- Demands for worker (value) args + JoinArity, -- Number of worker (type OR value) args + Id -> CoreExpr, -- Wrapper body, lacking only the worker Id + CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs + +mkWwBodies :: DynFlags + -> FamInstEnvs + -> VarSet -- Free vars of RHS + -- See Note [Freshen WW arguments] + -> Id -- The original function + -> [Demand] -- Strictness of original function + -> CprResult -- Info about function result + -> UniqSM (Maybe WwResult) + +-- wrap_fn_args E = \x y -> E +-- work_fn_args E = E x y + +-- wrap_fn_str E = case x of { (a,b) -> +-- case a of { (a1,a2) -> +-- E a1 a2 b y }} +-- work_fn_str E = \a1 a2 b y -> +-- let a = (a1,a2) in +-- let x = (a,b) in +-- E + +mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info + = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs) + -- See Note [Freshen WW arguments] + + ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) + <- mkWWargs empty_subst fun_ty demands + ; (useful1, work_args, wrap_fn_str, work_fn_str) + <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args + + -- Do CPR w/w. See Note [Always do CPR w/w] + ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) + <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty cpr_info + + ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty + worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v] + wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var + worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args + + ; if isWorkerSmallEnough dflags work_args + && not (too_many_args_for_join_point wrap_args) + && ((useful1 && not only_one_void_argument) || useful2) + then return (Just (worker_args_dmds, length work_call_args, + wrapper_body, worker_body)) + else return Nothing + } + -- We use an INLINE unconditionally, even if the wrapper turns out to be + -- something trivial like + -- fw = ... + -- f = __inline__ (coerce T fw) + -- The point is to propagate the coerce to f's call sites, so even though + -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent + -- fw from being inlined into f's RHS + where + fun_ty = idType fun_id + mb_join_arity = isJoinId_maybe fun_id + has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id) + -- See Note [Do not unpack class dictionaries] + + -- Note [Do not split void functions] + only_one_void_argument + | [d] <- demands + , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty + , isAbsDmd d && isVoidTy arg_ty1 + = True + | otherwise + = False + + -- Note [Join points returning functions] + too_many_args_for_join_point wrap_args + | Just join_arity <- mb_join_arity + , wrap_args `lengthExceeds` join_arity + = WARN(True, text "Unable to worker/wrapper join point with arity " <+> + int join_arity <+> text "but" <+> + int (length wrap_args) <+> text "args") + True + | otherwise + = False + +-- See Note [Limit w/w arity] +isWorkerSmallEnough :: DynFlags -> [Var] -> Bool +isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags + -- We count only Free variables (isId) to skip Type, Kind + -- variables which have no runtime representation. + +{- +Note [Always do CPR w/w] +~~~~~~~~~~~~~~~~~~~~~~~~ +At one time we refrained from doing CPR w/w for thunks, on the grounds that +we might duplicate work. But that is already handled by the demand analyser, +which doesn't give the CPR property if w/w might waste work: see +Note [CPR for thunks] in GHC.Core.Opt.DmdAnal. + +And if something *has* been given the CPR property and we don't w/w, it's +a disaster, because then the enclosing function might say it has the CPR +property, but now doesn't and there a cascade of disaster. A good example +is #5920. + +Note [Limit w/w arity] +~~~~~~~~~~~~~~~~~~~~~~~~ +Guard against high worker arity as it generates a lot of stack traffic. +A simplified example is #11565#comment:6 + +Current strategy is very simple: don't perform w/w transformation at all +if the result produces a wrapper with arity higher than -fmax-worker-args=. + +It is a bit all or nothing, consider + + f (x,y) (a,b,c,d,e ... , z) = rhs + +Currently we will remove all w/w ness entirely. But actually we could +w/w on the (x,y) pair... it's the huge product that is the problem. + +Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd +solve f. But we can get a lot of args from deeply-nested products: + + g (a, (b, (c, (d, ...)))) = rhs + +This is harder to spot on an arg-by-arg basis. Previously mkWwStr was +given some "fuel" saying how many arguments it could add; when we ran +out of fuel it would stop w/wing. +Still not very clever because it had a left-right bias. + +************************************************************************ +* * +\subsection{Making wrapper args} +* * +************************************************************************ + +During worker-wrapper stuff we may end up with an unlifted thing +which we want to let-bind without losing laziness. So we +add a void argument. E.g. + + f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z +==> + fw = /\ a -> \void -> E + f = /\ a -> \x y z -> fw realworld + +We use the state-token type which generates no code. +-} + +mkWorkerArgs :: DynFlags -> [Var] + -> Type -- Type of body + -> ([Var], -- Lambda bound args + [Var]) -- Args at call site +mkWorkerArgs dflags args res_ty + | any isId args || not needsAValueLambda + = (args, args) + | otherwise + = (args ++ [voidArgId], args ++ [voidPrimId]) + where + -- See "Making wrapper args" section above + needsAValueLambda = + lifted + -- We may encounter a levity-polymorphic result, in which case we + -- conservatively assume that we have laziness that needs preservation. + -- See #15186. + || not (gopt Opt_FunToThunk dflags) + -- see Note [Protecting the last value argument] + + -- Might the result be lifted? + lifted = + case isLiftedType_maybe res_ty of + Just lifted -> lifted + Nothing -> True + +{- +Note [Protecting the last value argument] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the user writes (\_ -> E), they might be intentionally disallowing +the sharing of E. Since absence analysis and worker-wrapper are keen +to remove such unused arguments, we add in a void argument to prevent +the function from becoming a thunk. + +The user can avoid adding the void argument with the -ffun-to-thunk +flag. However, this can create sharing, which may be bad in two ways. 1) It can +create a space leak. 2) It can prevent inlining *under a lambda*. If w/w +removes the last argument from a function f, then f now looks like a thunk, and +so f can't be inlined *under a lambda*. + +Note [Join points and beta-redexes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Originally, the worker would invoke the original function by calling it with +arguments, thus producing a beta-redex for the simplifier to munch away: + + \x y z -> e => (\x y z -> e) wx wy wz + +Now that we have special rules about join points, however, this is Not Good if +the original function is itself a join point, as then it may contain invocations +of other join points: + + join j1 x = ... + join j2 y = if y == 0 then 0 else j1 y + + => + + join j1 x = ... + join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy + join j2 y = case y of I# y# -> jump $wj2 y# + +There can't be an intervening lambda between a join point's declaration and its +occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix: + + ... + let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y + ... + +Hence we simply do the beta-reduction here. (This would be harder if we had to +worry about hygiene, but luckily wy is freshly generated.) + +Note [Join points returning functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is crucial that the arity of a join point depends on its *callers,* not its +own syntax. What this means is that a join point can have "extra lambdas": + +f :: Int -> Int -> (Int, Int) -> Int +f x y = join j (z, w) = \(u, v) -> ... + in jump j (x, y) + +Typically this happens with functions that are seen as computing functions, +rather than being curried. (The real-life example was GHC.Data.Graph.Ops.addConflicts.) + +When we create the wrapper, it *must* be in "eta-contracted" form so that the +jump has the right number of arguments: + +f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ... + j (z, w) = jump $wj z w + +(See Note [Join points and beta-redexes] for where the lets come from.) If j +were a function, we would instead say + +f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ... + j (z, w) (u, v) = $wj z w u v + +Notice that the worker ends up with the same lambdas; it's only the wrapper we +have to be concerned about. + +FIXME Currently the functionality to produce "eta-contracted" wrappers is +unimplemented; we simply give up. + +************************************************************************ +* * +\subsection{Coercion stuff} +* * +************************************************************************ + +We really want to "look through" coerces. +Reason: I've seen this situation: + + let f = coerce T (\s -> E) + in \x -> case x of + p -> coerce T' f + q -> \s -> E2 + r -> coerce T' f + +If only we w/w'd f, we'd get + let f = coerce T (\s -> fw s) + fw = \s -> E + in ... + +Now we'll inline f to get + + let fw = \s -> E + in \x -> case x of + p -> fw + q -> \s -> E2 + r -> fw + +Now we'll see that fw has arity 1, and will arity expand +the \x to get what we want. +-} + +-- mkWWargs just does eta expansion +-- is driven off the function type and arity. +-- It chomps bites off foralls, arrows, newtypes +-- and keeps repeating that until it's satisfied the supplied arity + +mkWWargs :: TCvSubst -- Freshening substitution to apply to the type + -- See Note [Freshen WW arguments] + -> Type -- The type of the function + -> [Demand] -- Demands and one-shot info for value arguments + -> UniqSM ([Var], -- Wrapper args + CoreExpr -> CoreExpr, -- Wrapper fn + CoreExpr -> CoreExpr, -- Worker fn + Type) -- Type of wrapper body + +mkWWargs subst fun_ty demands + | null demands + = return ([], id, id, substTy subst fun_ty) + + | (dmd:demands') <- demands + , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty + = do { uniq <- getUniqueM + ; let arg_ty' = substTy subst arg_ty + id = mk_wrap_arg uniq arg_ty' dmd + ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) + <- mkWWargs subst fun_ty' demands' + ; return (id : wrap_args, + Lam id . wrap_fn_args, + apply_or_bind_then work_fn_args (varToCoreExpr id), + res_ty) } + + | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty + = do { uniq <- getUniqueM + ; let (subst', tv') = cloneTyVarBndr subst tv uniq + -- See Note [Freshen WW arguments] + ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) + <- mkWWargs subst' fun_ty' demands + ; return (tv' : wrap_args, + Lam tv' . wrap_fn_args, + apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')), + res_ty) } + + | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty + -- The newtype case is for when the function has + -- a newtype after the arrow (rare) + -- + -- It's also important when we have a function returning (say) a pair + -- wrapped in a newtype, at least if CPR analysis can look + -- through such newtypes, which it probably can since they are + -- simply coerces. + + = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty) + <- mkWWargs subst rep_ty demands + ; let co' = substCo subst co + ; return (wrap_args, + \e -> Cast (wrap_fn_args e) (mkSymCo co'), + \e -> work_fn_args (Cast e co'), + res_ty) } + + | otherwise + = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand + return ([], id, id, substTy subst fun_ty) -- then there should be a function arrow + where + -- See Note [Join points and beta-redexes] + apply_or_bind_then k arg (Lam bndr body) + = mkCoreLet (NonRec bndr arg) (k body) -- Important that arg is fresh! + apply_or_bind_then k arg fun + = k $ mkCoreApp (text "mkWWargs") fun arg +applyToVars :: [Var] -> CoreExpr -> CoreExpr +applyToVars vars fn = mkVarApps fn vars + +mk_wrap_arg :: Unique -> Type -> Demand -> Id +mk_wrap_arg uniq ty dmd + = mkSysLocalOrCoVar (fsLit "w") uniq ty + `setIdDemandInfo` dmd + +{- Note [Freshen WW arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Wen we do a worker/wrapper split, we must not in-scope names as the arguments +of the worker, else we'll get name capture. E.g. + + -- y1 is in scope from further out + f x = ..y1.. + +If we accidentally choose y1 as a worker argument disaster results: + + fww y1 y2 = let x = (y1,y2) in ...y1... + +To avoid this: + + * We use a fresh unique for both type-variable and term-variable binders + Originally we lacked this freshness for type variables, and that led + to the very obscure #12562. (A type variable in the worker shadowed + an outer term-variable binding.) + + * Because of this cloning we have to substitute in the type/kind of the + new binders. That's why we carry the TCvSubst through mkWWargs. + + So we need a decent in-scope set, just in case that type/kind + itself has foralls. We get this from the free vars of the RHS of the + function since those are the only variables that might be captured. + It's a lazy thunk, which will only be poked if the type/kind has a forall. + + Another tricky case was when f :: forall a. a -> forall a. a->a + (i.e. with shadowing), and then the worker used the same 'a' twice. + +************************************************************************ +* * +\subsection{Strictness stuff} +* * +************************************************************************ +-} + +mkWWstr :: DynFlags + -> FamInstEnvs + -> Bool -- True <=> INLINEABLE pragma on this function defn + -- See Note [Do not unpack class dictionaries] + -> [Var] -- Wrapper args; have their demand info on them + -- *Includes type variables* + -> UniqSM (Bool, -- Is this useful + [Var], -- Worker args + CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call + -- and without its lambdas + -- This fn adds the unboxing + + CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function, + -- and lacking its lambdas. + -- This fn does the reboxing +mkWWstr dflags fam_envs has_inlineable_prag args + = go args + where + go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg + + go [] = return (False, [], nop_fn, nop_fn) + go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg + ; (useful2, args2, wrap_fn2, work_fn2) <- go args + ; return ( useful1 || useful2 + , args1 ++ args2 + , wrap_fn1 . wrap_fn2 + , work_fn1 . work_fn2) } + +{- +Note [Unpacking arguments with product and polymorphic demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The argument is unpacked in a case if it has a product type and has a +strict *and* used demand put on it. I.e., arguments, with demands such +as the following ones: + + + + +will be unpacked, but + + or + +will not, because the pieces aren't used. This is quite important otherwise +we end up unpacking massive tuples passed to the bottoming function. Example: + + f :: ((Int,Int) -> String) -> (Int,Int) -> a + f g pr = error (g pr) + + main = print (f fst (1, error "no")) + +Does 'main' print "error 1" or "error no"? We don't really want 'f' +to unbox its second argument. This actually happened in GHC's onwn +source code, in Packages.applyPackageFlag, which ended up un-boxing +the enormous DynFlags tuple, and being strict in the +as-yet-un-filled-in pkgState files. +-} + +---------------------- +-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn) +-- * wrap_fn assumes wrap_arg is in scope, +-- brings into scope work_args (via cases) +-- * work_fn assumes work_args are in scope, a +-- brings into scope wrap_arg (via lets) +-- See Note [How to do the worker/wrapper split] +mkWWstr_one :: DynFlags -> FamInstEnvs + -> Bool -- True <=> INLINEABLE pragma on this function defn + -- See Note [Do not unpack class dictionaries] + -> Var + -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) +mkWWstr_one dflags fam_envs has_inlineable_prag arg + | isTyVar arg + = return (False, [arg], nop_fn, nop_fn) + + | isAbsDmd dmd + , Just work_fn <- mk_absent_let dflags fam_envs arg + -- Absent case. We can't always handle absence for arbitrary + -- unlifted types, so we need to choose just the cases we can + -- (that's what mk_absent_let does) + = return (True, [], nop_fn, work_fn) + + | Just (cs, acdc) <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd + = unbox_one dflags fam_envs arg cs acdc + + | otherwise -- Other cases + = return (False, [arg], nop_fn, nop_fn) + + where + arg_ty = idType arg + dmd = idDemandInfo arg + +wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConAppContext) +wantToUnbox fam_envs has_inlineable_prag ty dmd = + case deepSplitProductType_maybe fam_envs ty of + Just dcac@DataConAppContext{ dcac_arg_tys = con_arg_tys } + | isStrictDmd dmd + -- See Note [Unpacking arguments with product and polymorphic demands] + , Just cs <- split_prod_dmd_arity dmd (length con_arg_tys) + -- See Note [Do not unpack class dictionaries] + , not (has_inlineable_prag && isClassPred ty) + -- See Note [mkWWstr and unsafeCoerce] + , cs `equalLength` con_arg_tys + -> Just (cs, dcac) + _ -> Nothing + where + split_prod_dmd_arity dmd arty + -- For seqDmd, splitProdDmd_maybe will return Nothing (because how would + -- it know the arity?), but it should behave like , for some + -- suitable arity + | isSeqDmd dmd = Just (replicate arty absDmd) + -- Otherwise splitProdDmd_maybe does the job + | otherwise = splitProdDmd_maybe dmd + +unbox_one :: DynFlags -> FamInstEnvs -> Var + -> [Demand] + -> DataConAppContext + -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) +unbox_one dflags fam_envs arg cs + DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys + , dcac_arg_tys = inst_con_arg_tys + , dcac_co = co } + = do { (uniq1:uniqs) <- getUniquesM + ; let -- See Note [Add demands for strict constructors] + cs' = addDataConStrictness data_con cs + unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs' + unbox_fn = mkUnpackCase (Var arg) co uniq1 + data_con unpk_args + arg_no_unf = zapStableUnfolding arg + -- See Note [Zap unfolding when beta-reducing] + -- in GHC.Core.Opt.Simplify; and see #13890 + rebox_fn = Let (NonRec arg_no_unf con_app) + con_app = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co + ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args + ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) } + -- Don't pass the arg, rebox instead + where + mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd + +---------------------- +nop_fn :: CoreExpr -> CoreExpr +nop_fn body = body + +addDataConStrictness :: DataCon -> [Demand] -> [Demand] +-- See Note [Add demands for strict constructors] +addDataConStrictness con ds + = zipWithEqual "addDataConStrictness" add ds strs + where + strs = dataConRepStrictness con + add dmd str | isMarkedStrict str = strictifyDmd dmd + | otherwise = dmd + +{- Note [How to do the worker/wrapper split] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The worker-wrapper transformation, mkWWstr_one, takes into account +several possibilities to decide if the function is worthy for +splitting: + +1. If an argument is absent, it would be silly to pass it to + the worker. Hence the isAbsDmd case. This case must come + first because a demand like or is possible. + E.g. comes from a function like + f x = error "urk" + and can come from Note [Add demands for strict constructors] + +2. If the argument is evaluated strictly, and we can split the + product demand (splitProdDmd_maybe), then unbox it and w/w its + pieces. For example + + f :: (Int, Int) -> Int + f p = (case p of (a,b) -> a) + 1 + is split to + f :: (Int, Int) -> Int + f p = case p of (a,b) -> $wf a + + $wf :: Int -> Int + $wf a = a + 1 + + and + g :: Bool -> (Int, Int) -> Int + g c p = case p of (a,b) -> + if c then a else b + is split to + g c p = case p of (a,b) -> $gw c a b + $gw c a b = if c then a else b + +2a But do /not/ split if the components are not used; that is, the + usage is just 'Used' rather than 'UProd'. In this case + splitProdDmd_maybe returns Nothing. Otherwise we risk decomposing + a massive tuple which is barely used. Example: + + f :: ((Int,Int) -> String) -> (Int,Int) -> a + f g pr = error (g pr) + + main = print (f fst (1, error "no")) + + Here, f does not take 'pr' apart, and it's stupid to do so. + Imagine that it had millions of fields. This actually happened + in GHC itself where the tuple was DynFlags + +3. A plain 'seqDmd', which is head-strict with usage UHead, can't + be split by splitProdDmd_maybe. But we want it to behave just + like U(AAAA) for suitable number of absent demands. So we have + a special case for it, with arity coming from the data constructor. + +Note [Worker-wrapper for bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used not to split if the result is bottom. +[Justification: there's no efficiency to be gained.] + +But it's sometimes bad not to make a wrapper. Consider + fw = \x# -> let x = I# x# in case e of + p1 -> error_fn x + p2 -> error_fn x + p3 -> the real stuff +The re-boxing code won't go away unless error_fn gets a wrapper too. +[We don't do reboxing now, but in general it's better to pass an +unboxed thing to f, and have it reboxed in the error cases....] + +Note [Add demands for strict constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this program (due to Roman): + + data X a = X !a + + foo :: X Int -> Int -> Int + foo (X a) n = go 0 + where + go i | i < n = a + go (i+1) + | otherwise = 0 + +We want the worker for 'foo' too look like this: + + $wfoo :: Int# -> Int# -> Int# + +with the first argument unboxed, so that it is not eval'd each time +around the 'go' loop (which would otherwise happen, since 'foo' is not +strict in 'a'). It is sound for the wrapper to pass an unboxed arg +because X is strict, so its argument must be evaluated. And if we +*don't* pass an unboxed argument, we can't even repair it by adding a +`seq` thus: + + foo (X a) n = a `seq` go 0 + +because the seq is discarded (very early) since X is strict! + +So here's what we do + +* We leave the demand-analysis alone. The demand on 'a' in the + definition of 'foo' is ; the strictness info is Lazy + because foo's body may or may not evaluate 'a'; but the usage info + says that 'a' is unpacked and its content is used. + +* During worker/wrapper, if we unpack a strict constructor (as we do + for 'foo'), we use 'addDataConStrictness' to bump up the strictness on + the strict arguments of the data constructor. + +* That in turn means that, if the usage info supports doing so + (i.e. splitProdDmd_maybe returns Just), we will unpack that argument + -- even though the original demand (e.g. on 'a') was lazy. + +* What does "bump up the strictness" mean? Just add a head-strict + demand to the strictness! Even for a demand like we can + safely turn it into ; remember case (1) of + Note [How to do the worker/wrapper split]. + +The net effect is that the w/w transformation is more aggressive about +unpacking the strict arguments of a data constructor, when that +eagerness is supported by the usage info. + +There is the usual danger of reboxing, which as usual we ignore. But +if X is monomorphic, and has an UNPACK pragma, then this optimisation +is even more important. We don't want the wrapper to rebox an unboxed +argument, and pass an Int to $wfoo! + +This works in nested situations like + + data family Bar a + data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) + newtype instance Bar Int = Bar Int + + foo :: Bar ((Int, Int), Int) -> Int -> Int + foo f k = case f of BarPair x y -> + case burble of + True -> case x of + BarPair p q -> ... + False -> ... + +The extra eagerness lets us produce a worker of type: + $wfoo :: Int# -> Int# -> Int# -> Int -> Int + $wfoo p# q# y# = ... + +even though the `case x` is only lazily evaluated. + +--------- Historical note ------------ +We used to add data-con strictness demands when demand analysing case +expression. However, it was noticed in #15696 that this misses some cases. For +instance, consider the program (from T10482) + + data family Bar a + data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) + newtype instance Bar Int = Bar Int + + foo :: Bar ((Int, Int), Int) -> Int -> Int + foo f k = + case f of + BarPair x y -> case burble of + True -> case x of + BarPair p q -> ... + False -> ... + +We really should be able to assume that `p` is already evaluated since it came +from a strict field of BarPair. This strictness would allow us to produce a +worker of type: + + $wfoo :: Int# -> Int# -> Int# -> Int -> Int + $wfoo p# q# y# = ... + +even though the `case x` is only lazily evaluated + +Indeed before we fixed #15696 this would happen since we would float the inner +`case x` through the `case burble` to get: + + foo f k = + case f of + BarPair x y -> case x of + BarPair p q -> case burble of + True -> ... + False -> ... + +However, after fixing #15696 this could no longer happen (for the reasons +discussed in ticket:15696#comment:76). This means that the demand placed on `f` +would then be significantly weaker (since the False branch of the case on +`burble` is not strict in `p` or `q`). + +Consequently, we now instead account for data-con strictness in mkWWstr_one, +applying the strictness demands to the final result of DmdAnal. The result is +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 [mkWWstr and unsafeCoerce] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +By using unsafeCoerce, it is possible to make the number of demands fail to +match the number of constructor arguments; this happened in #8037. +If so, the worker/wrapper split doesn't work right and we get a Core Lint +bug. The fix here is simply to decline to do w/w if that happens. + +Note [Record evaluated-ness in worker/wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + data T = MkT !Int Int + + f :: T -> T + f x = e + +and f's is strict, and has the CPR property. The we are going to generate +this w/w split + + f x = case x of + MkT x1 x2 -> case $wf x1 x2 of + (# r1, r2 #) -> MkT r1 r2 + + $wfw x1 x2 = let x = MkT x1 x2 in + case e of + MkT r1 r2 -> (# r1, r2 #) + +Note that + +* In the worker $wf, inside 'e' we can be sure that x1 will be + evaluated (it came from unpacking the argument MkT. But that's no + immediately apparent in $wf + +* In the wrapper 'f', which we'll inline at call sites, we can be sure + that 'r1' has been evaluated (because it came from unpacking the result + MkT. But that is not immediately apparent from the wrapper code. + +Missing these facts isn't unsound, but it loses possible future +opportunities for optimisation. + +Solution: use setCaseBndrEvald when creating + (A) The arg binders x1,x2 in mkWstr_one + See #13077, test T13077 + (B) The result binders r1,r2 in mkWWcpr_help + See Trace #13077, test T13077a + And #13027 comment:20, item (4) +to record that the relevant binder is evaluated. + + +************************************************************************ +* * + Type scrutiny that is specific to demand analysis +* * +************************************************************************ + +Note [Do not unpack class dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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. + +But in any other situation a dictionary is just an ordinary value, +and can be unpacked. So we track the INLINABLE pragma, and switch +off the unpacking in mkWWstr_one (see the isClassPred test). + +Historical note: #14955 describes how I got this fix wrong +the first time. +-} + +-- | Context for a 'DataCon' application with a hole for every field, including +-- surrounding coercions. +-- The result of 'deepSplitProductType_maybe' and 'deepSplitCprType_maybe'. +-- +-- Example: +-- +-- > DataConAppContext Just [Int] [(Lazy, Int)] (co :: Maybe Int ~ First Int) +-- +-- represents +-- +-- > Just @Int (_1 :: Int) |> co :: First Int +-- +-- where _1 is a hole for the first argument. The number of arguments is +-- determined by the length of @arg_tys@. +data DataConAppContext + = DataConAppContext + { dcac_dc :: !DataCon + , dcac_tys :: ![Type] + , dcac_arg_tys :: ![(Type, StrictnessMark)] + , dcac_co :: !Coercion + } + +deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe DataConAppContext +-- If deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co) +-- then dc @ tys (args::arg_tys) :: rep_ty +-- co :: ty ~ rep_ty +-- Why do we return the strictness of the data-con arguments? +-- Answer: see Note [Record evaluated-ness in worker/wrapper] +deepSplitProductType_maybe fam_envs ty + | let (co, ty1) = topNormaliseType_maybe fam_envs ty + `orElse` (mkRepReflCo ty, ty) + , Just (tc, tc_args) <- splitTyConApp_maybe ty1 + , Just con <- isDataProductTyCon_maybe tc + , let arg_tys = dataConInstArgTys con tc_args + strict_marks = dataConRepStrictness con + = Just DataConAppContext { dcac_dc = con + , dcac_tys = tc_args + , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks + , dcac_co = co } +deepSplitProductType_maybe _ _ = Nothing + +deepSplitCprType_maybe + :: FamInstEnvs -> ConTag -> Type -> Maybe DataConAppContext +-- If deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co) +-- then dc @ tys (args::arg_tys) :: rep_ty +-- co :: ty ~ rep_ty +-- Why do we return the strictness of the data-con arguments? +-- Answer: see Note [Record evaluated-ness in worker/wrapper] +deepSplitCprType_maybe fam_envs con_tag ty + | let (co, ty1) = topNormaliseType_maybe fam_envs ty + `orElse` (mkRepReflCo ty, ty) + , Just (tc, tc_args) <- splitTyConApp_maybe ty1 + , isDataTyCon tc + , let cons = tyConDataCons tc + , cons `lengthAtLeast` con_tag -- This might not be true if we import the + -- type constructor via a .hs-bool file (#8743) + , let con = cons `getNth` (con_tag - fIRST_TAG) + arg_tys = dataConInstArgTys con tc_args + strict_marks = dataConRepStrictness con + = Just DataConAppContext { dcac_dc = con + , dcac_tys = tc_args + , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks + , dcac_co = co } +deepSplitCprType_maybe _ _ _ = Nothing + +findTypeShape :: FamInstEnvs -> Type -> TypeShape +-- Uncover the arrow and product shape of a type +-- The data type TypeShape is defined in GHC.Types.Demand +-- See Note [Trimming a demand to a type] in GHC.Types.Demand +findTypeShape fam_envs ty + | Just (tc, tc_args) <- splitTyConApp_maybe ty + , Just con <- isDataProductTyCon_maybe tc + = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args) + + | Just (_, res) <- splitFunTy_maybe ty + = TsFun (findTypeShape fam_envs res) + + | Just (_, ty') <- splitForAllTy_maybe ty + = findTypeShape fam_envs ty' + + | Just (_, ty') <- topNormaliseType_maybe fam_envs ty + = findTypeShape fam_envs ty' + + | otherwise + = TsUnk + +{- +************************************************************************ +* * +\subsection{CPR stuff} +* * +************************************************************************ + + +@mkWWcpr@ takes the worker/wrapper pair produced from the strictness +info and adds in the CPR transformation. The worker returns an +unboxed tuple containing non-CPR components. The wrapper takes this +tuple and re-produces the correct structured output. + +The non-CPR results appear ordered in the unboxed tuple as if by a +left-to-right traversal of the result structure. +-} + +mkWWcpr :: Bool + -> FamInstEnvs + -> Type -- function body type + -> CprResult -- CPR analysis results + -> UniqSM (Bool, -- Is w/w'ing useful? + CoreExpr -> CoreExpr, -- New wrapper + CoreExpr -> CoreExpr, -- New worker + Type) -- Type of worker's body + +mkWWcpr opt_CprAnal fam_envs body_ty cpr + -- CPR explicitly turned off (or in -O0) + | not opt_CprAnal = return (False, id, id, body_ty) + -- CPR is turned on by default for -O and O2 + | otherwise + = case asConCpr cpr of + Nothing -> return (False, id, id, body_ty) -- No CPR info + Just con_tag | Just dcac <- deepSplitCprType_maybe fam_envs con_tag body_ty + -> mkWWcpr_help dcac + | otherwise + -- See Note [non-algebraic or open body type warning] + -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty ) + return (False, id, id, body_ty) + +mkWWcpr_help :: DataConAppContext + -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type) + +mkWWcpr_help (DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys + , dcac_arg_tys = arg_tys, dcac_co = co }) + | [arg1@(arg_ty1, _)] <- arg_tys + , isUnliftedType arg_ty1 + -- Special case when there is a single result of unlifted type + -- + -- Wrapper: case (..call worker..) of x -> C x + -- Worker: case ( ..body.. ) of C x -> x + = do { (work_uniq : arg_uniq : _) <- getUniquesM + ; let arg = mk_ww_local arg_uniq arg1 + con_app = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co + + ; return ( True + , \ wkr_call -> mkDefaultCase wkr_call arg con_app + , \ body -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg) + -- varToCoreExpr important here: arg can be a coercion + -- Lacking this caused #10658 + , arg_ty1 ) } + + | otherwise -- The general case + -- Wrapper: case (..call worker..) of (# a, b #) -> C a b + -- Worker: case ( ...body... ) of C a b -> (# a, b #) + = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM + ; let wrap_wild = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict) + args = zipWith mk_ww_local uniqs arg_tys + ubx_tup_ty = exprType ubx_tup_app + ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args) + con_app = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co + tup_con = tupleDataCon Unboxed (length arg_tys) + + ; return (True + , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild + (DataAlt tup_con) args con_app + , \ body -> mkUnpackCase body co work_uniq data_con args ubx_tup_app + , ubx_tup_ty ) } + +mkUnpackCase :: CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr +-- (mkUnpackCase e co uniq Con args body) +-- returns +-- case e |> co of bndr { Con args -> body } + +mkUnpackCase (Tick tickish e) co uniq con args body -- See Note [Profiling and unpacking] + = Tick tickish (mkUnpackCase e co uniq con args body) +mkUnpackCase scrut co uniq boxing_con unpk_args body + = mkSingleAltCase casted_scrut bndr + (DataAlt boxing_con) unpk_args body + where + casted_scrut = scrut `mkCast` co + bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict) + +{- +Note [non-algebraic or open body type warning] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a few cases where the W/W transformation is told that something +returns a constructor, but the type at hand doesn't really match this. One +real-world example involves unsafeCoerce: + foo = IO a + foo = unsafeCoerce c_exit + foreign import ccall "c_exit" c_exit :: IO () +Here CPR will tell you that `foo` returns a () constructor for sure, but trying +to create a worker/wrapper for type `a` obviously fails. +(This was a real example until ee8e792 in libraries/base.) + +It does not seem feasible to avoid all such cases already in the analyser (and +after all, the analysis is not really wrong), so we simply do nothing here in +mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch +other cases where something went avoidably wrong. + +This warning also triggers for the stream fusion library within `text`. +We can'easily W/W constructed results like `Stream` because we have no simple +way to express existential types in the worker's type signature. + +Note [Profiling and unpacking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the original function looked like + f = \ x -> {-# SCC "foo" #-} E + +then we want the CPR'd worker to look like + \ x -> {-# SCC "foo" #-} (case E of I# x -> x) +and definitely not + \ x -> case ({-# SCC "foo" #-} E) of I# x -> x) + +This transform doesn't move work or allocation +from one cost centre to another. + +Later [SDM]: presumably this is because we want the simplifier to +eliminate the case, and the scc would get in the way? I'm ok with +including the case itself in the cost centre, since it is morally +part of the function (post transformation) anyway. + + +************************************************************************ +* * +\subsection{Utilities} +* * +************************************************************************ + +Note [Absent errors] +~~~~~~~~~~~~~~~~~~~~ +We make a new binding for Ids that are marked absent, thus + let x = absentError "x :: Int" +The idea is that this binding will never be used; but if it +buggily is used we'll get a runtime error message. + +Coping with absence for *unlifted* types is important; see, for +example, #4306 and #15627. In the UnliftedRep case, we can +use LitRubbish, which we need to apply to the required type. +For the unlifted types of singleton kind like Float#, Addr#, etc. we +also find a suitable literal, using Literal.absentLiteralOf. We don't +have literals for every primitive type, so the function is partial. + +Note: I did try the experiment of using an error thunk for unlifted +things too, relying on the simplifier to drop it as dead code. +But this is fragile + + - It fails when profiling is on, which disables various optimisations + + - It fails when reboxing happens. E.g. + data T = MkT Int Int# + f p@(MkT a _) = ...g p.... + where g is /lazy/ in 'p', but only uses the first component. Then + 'f' is /strict/ in 'p', and only uses the first component. So we only + pass that component to the worker for 'f', which reconstructs 'p' to + pass it to 'g'. Alas we can't say + ...f (MkT a (absentError Int# "blah"))... + bacause `MkT` is strict in its Int# argument, so we get an absentError + exception when we shouldn't. Very annoying! + +So absentError is only used for lifted types. +-} + +-- | Tries to find a suitable dummy RHS to bind the given absent identifier to. +-- +-- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding +-- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be +-- found (currently only happens for bindings of 'VecRep' representation). +mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Maybe (CoreExpr -> CoreExpr) +mk_absent_let dflags fam_envs arg + -- The lifted case: Bind 'absentError' + -- See Note [Absent errors] + | not (isUnliftedType arg_ty) + = Just (Let (NonRec lifted_arg abs_rhs)) + -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@ + -- See Note [Absent errors] + | [UnliftedRep] <- typePrimRep arg_ty + = Just (Let (NonRec arg unlifted_rhs)) + -- The monomorphic unlifted cases: Bind to some literal, if possible + -- See Note [Absent errors] + | Just tc <- tyConAppTyCon_maybe nty + , Just lit <- absentLiteralOf tc + = Just (Let (NonRec arg (Lit lit `mkCast` mkSymCo co))) + | nty `eqType` voidPrimTy + = Just (Let (NonRec arg (Var voidPrimId `mkCast` mkSymCo co))) + | otherwise + = WARN( True, text "No absent value for" <+> ppr arg_ty ) + Nothing -- Can happen for 'State#' and things of 'VecRep' + where + lifted_arg = arg `setIdStrictness` botSig `setIdCprInfo` mkCprSig 0 botCpr + -- Note in strictness signature that this is bottoming + -- (for the sake of the "empty case scrutinee not known to + -- diverge for sure lint" warning) + arg_ty = idType arg + + -- Normalise the type to have best chance of finding an absent literal + -- e.g. (#17852) data unlifted N = MkN Int# + -- f :: N -> a -> a + -- f _ x = x + (co, nty) = topNormaliseType_maybe fam_envs arg_ty + `orElse` (mkRepReflCo arg_ty, arg_ty) + + abs_rhs = mkAbsentErrorApp arg_ty msg + msg = showSDoc (gopt_set dflags Opt_SuppressUniques) + (ppr arg <+> ppr (idType arg)) + -- We need to suppress uniques here because otherwise they'd + -- end up in the generated code as strings. This is bad for + -- determinism, because with different uniques the strings + -- will have different lengths and hence different costs for + -- the inliner leading to different inlining. + -- See also Note [Unique Determinism] in GHC.Types.Unique + unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty] + +mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id +-- The StrictnessMark comes form the data constructor and says +-- whether this field is strict +-- See Note [Record evaluated-ness in worker/wrapper] +mk_ww_local uniq (ty,str) + = setCaseBndrEvald str $ + mkSysLocalOrCoVar (fsLit "ww") uniq ty diff --git a/compiler/GHC/Core/Ppr/TyThing.hs b/compiler/GHC/Core/Ppr/TyThing.hs --- a/compiler/GHC/Core/Ppr/TyThing.hs +++ b/compiler/GHC/Core/Ppr/TyThing.hs @@ -19,7 +19,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core.Type ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType ) import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..) @@ -31,7 +31,7 @@ import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType ) import GHC.Types.Name import GHC.Types.Var.Env( emptyTidyEnv ) -import Outputable +import GHC.Utils.Outputable -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Rules.hs @@ -0,0 +1,1257 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[CoreRules]{Transformation rules} +-} + +{-# LANGUAGE CPP #-} + +-- | Functions for collecting together and applying rewrite rules to a module. +-- The 'CoreRule' datatype itself is declared elsewhere. +module GHC.Core.Rules ( + -- ** Constructing + emptyRuleBase, mkRuleBase, extendRuleBaseList, + unionRuleBase, pprRuleBase, + + -- ** Checking rule applications + ruleCheckProgram, + + -- ** Manipulating 'RuleInfo' rules + extendRuleInfo, addRuleInfo, + addIdSpecialisations, + + -- * Misc. CoreRule helpers + rulesOfBinds, getRules, pprRulesForUser, + + lookupRule, mkRule, roughTopNames + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core -- All of it +import GHC.Unit.Module ( Module ) +import GHC.Unit.Module.Env +import GHC.Core.Subst +import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) +import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars + , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList ) +import GHC.Core.Utils ( exprType, eqExpr, mkTick, mkTicks + , stripTicksTopT, stripTicksTopE + , isJoinBind ) +import GHC.Core.Ppr ( pprRules ) +import GHC.Core.Type as Type + ( Type, TCvSubst, extendTvSubst, extendCvSubst + , mkEmptyTCvSubst, substTy ) +import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) +import GHC.Builtin.Types ( anyTypeOfKind ) +import GHC.Core.Coercion as Coercion +import GHC.Core.Tidy ( tidyRules ) +import GHC.Types.Id +import GHC.Types.Id.Info ( RuleInfo( RuleInfo ) ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom ) +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Unique.FM +import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) +import GHC.Types.Basic +import GHC.Driver.Session ( DynFlags, gopt, targetPlatform ) +import GHC.Driver.Flags +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.Bag +import GHC.Utils.Misc +import Data.List +import Data.Ord +import Control.Monad ( guard ) + +{- +Note [Overall plumbing for rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* After the desugarer: + - The ModGuts initially contains mg_rules :: [CoreRule] of + locally-declared rules for imported Ids. + - Locally-declared rules for locally-declared Ids are attached to + the IdInfo for that Id. See Note [Attach rules to local ids] in + GHC.HsToCore.Binds + +* GHC.Iface.Tidy strips off all the rules from local Ids and adds them to + mg_rules, so that the ModGuts has *all* the locally-declared rules. + +* The HomePackageTable contains a ModDetails for each home package + module. Each contains md_rules :: [CoreRule] of rules declared in + that module. The HomePackageTable grows as ghc --make does its + up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules + are treated by the "external" route, discussed next, regardless of + which package they come from. + +* The ExternalPackageState has a single eps_rule_base :: RuleBase for + Ids in other packages. This RuleBase simply grow monotonically, as + ghc --make compiles one module after another. + + During simplification, interface files may get demand-loaded, + as the simplifier explores the unfoldings for Ids it has in + its hand. (Via an unsafePerformIO; the EPS is really a cache.) + That in turn may make the EPS rule-base grow. In contrast, the + HPT never grows in this way. + +* The result of all this is that during Core-to-Core optimisation + there are four sources of rules: + + (a) Rules in the IdInfo of the Id they are a rule for. These are + easy: fast to look up, and if you apply a substitution then + it'll be applied to the IdInfo as a matter of course. + + (b) Rules declared in this module for imported Ids, kept in the + ModGuts. If you do a substitution, you'd better apply the + substitution to these. There are seldom many of these. + + (c) Rules declared in the HomePackageTable. These never change. + + (d) Rules in the ExternalPackageTable. These can grow in response + to lazy demand-loading of interfaces. + +* At the moment (c) is carried in a reader-monad way by the GHC.Core.Opt.Monad. + The HomePackageTable doesn't have a single RuleBase because technically + we should only be able to "see" rules "below" this module; so we + generate a RuleBase for (c) by combing rules from all the modules + "below" us. That's why we can't just select the home-package RuleBase + from HscEnv. + + [NB: we are inconsistent here. We should do the same for external + packages, but we don't. Same for type-class instances.] + +* So in the outer simplifier loop, we combine (b-d) into a single + RuleBase, reading + (b) from the ModGuts, + (c) from the GHC.Core.Opt.Monad, and + (d) from its mutable variable + [Of course this means that we won't see new EPS rules that come in + during a single simplifier iteration, but that probably does not + matter.] + + +************************************************************************ +* * +\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} +* * +************************************************************************ + +A @CoreRule@ holds details of one rule for an @Id@, which +includes its specialisations. + +For example, if a rule for @f@ contains the mapping: +\begin{verbatim} + forall a b d. [Type (List a), Type b, Var d] ===> f' a b +\end{verbatim} +then when we find an application of f to matching types, we simply replace +it by the matching RHS: +\begin{verbatim} + f (List Int) Bool dict ===> f' Int Bool +\end{verbatim} +All the stuff about how many dictionaries to discard, and what types +to apply the specialised function to, are handled by the fact that the +Rule contains a template for the result of the specialisation. + +There is one more exciting case, which is dealt with in exactly the same +way. If the specialised value is unboxed then it is lifted at its +definition site and unlifted at its uses. For example: + + pi :: forall a. Num a => a + +might have a specialisation + + [Int#] ===> (case pi' of Lift pi# -> pi#) + +where pi' :: Lift Int# is the specialised version of pi. +-} + +mkRule :: Module -> Bool -> Bool -> RuleName -> Activation + -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule +-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being +-- compiled. See also 'GHC.Core.CoreRule' +mkRule this_mod is_auto is_local name act fn bndrs args rhs + = Rule { ru_name = name, ru_fn = fn, ru_act = act, + ru_bndrs = bndrs, ru_args = args, + ru_rhs = rhs, + ru_rough = roughTopNames args, + ru_origin = this_mod, + ru_orphan = orph, + ru_auto = is_auto, ru_local = is_local } + where + -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv + -- A rule is an orphan only if none of the variables + -- mentioned on its left-hand side are locally defined + lhs_names = extendNameSet (exprsOrphNames args) fn + + -- Since rules get eventually attached to one of the free names + -- from the definition when compiling the ABI hash, we should make + -- it deterministic. This chooses the one with minimal OccName + -- as opposed to uniq value. + local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names + orph = chooseOrphanAnchor local_lhs_names + +-------------- +roughTopNames :: [CoreExpr] -> [Maybe Name] +-- ^ Find the \"top\" free names of several expressions. +-- Such names are either: +-- +-- 1. The function finally being applied to in an application chain +-- (if that name is a GlobalId: see "Var#globalvslocal"), or +-- +-- 2. The 'TyCon' if the expression is a 'Type' +-- +-- This is used for the fast-match-check for rules; +-- if the top names don't match, the rest can't +roughTopNames args = map roughTopName args + +roughTopName :: CoreExpr -> Maybe Name +roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of + Just (tc,_) -> Just (getName tc) + Nothing -> Nothing +roughTopName (Coercion _) = Nothing +roughTopName (App f _) = roughTopName f +roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] + , isDataConWorkId f || idArity f > 0 + = Just (idName f) +roughTopName (Tick t e) | tickishFloatable t + = roughTopName e +roughTopName _ = Nothing + +ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ +-- definitely can't match @tpl@ by instantiating @tpl@. +-- It's only a one-way match; unlike instance matching we +-- don't consider unification. +-- +-- Notice that [_$_] +-- @ruleCantMatch [Nothing] [Just n2] = False@ +-- Reason: a template variable can be instantiated by a constant +-- Also: +-- @ruleCantMatch [Just n1] [Nothing] = False@ +-- Reason: a local variable @v@ in the actuals might [_$_] + +ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as +ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as +ruleCantMatch _ _ = False + +{- +Note [Care with roughTopName] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + module M where { x = a:b } + module N where { ...f x... + RULE f (p:q) = ... } +You'd expect the rule to match, because the matcher can +look through the unfolding of 'x'. So we must avoid roughTopName +returning 'M.x' for the call (f x), or else it'll say "can't match" +and we won't even try!! + +However, suppose we have + RULE g (M.h x) = ... + foo = ...(g (M.k v)).... +where k is a *function* exported by M. We never really match +functions (lambdas) except by name, so in this case it seems like +a good idea to treat 'M.k' as a roughTopName of the call. +-} + +pprRulesForUser :: DynFlags -> [CoreRule] -> SDoc +-- (a) tidy the rules +-- (b) sort them into order based on the rule name +-- (c) suppress uniques (unless -dppr-debug is on) +-- This combination makes the output stable so we can use in testing +-- It's here rather than in GHC.Core.Ppr because it calls tidyRules +pprRulesForUser dflags rules + = withPprStyle (defaultUserStyle dflags) $ + pprRules $ + sortBy (comparing ruleName) $ + tidyRules emptyTidyEnv rules + +{- +************************************************************************ +* * + RuleInfo: the rules in an IdInfo +* * +************************************************************************ +-} + +extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo +extendRuleInfo (RuleInfo rs1 fvs1) rs2 + = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1) + +addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo +addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2) + = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2) + +addIdSpecialisations :: Id -> [CoreRule] -> Id +addIdSpecialisations id rules + | null rules + = id + | otherwise + = setIdSpecialisation id $ + extendRuleInfo (idSpecialisation id) rules + +-- | Gather all the rules for locally bound identifiers from the supplied bindings +rulesOfBinds :: [CoreBind] -> [CoreRule] +rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds + +getRules :: RuleEnv -> Id -> [CoreRule] +-- See Note [Where rules are found] +getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn + = idCoreRules fn ++ filter (ruleIsVisible orphs) imp_rules + where + imp_rules = lookupNameEnv rule_base (idName fn) `orElse` [] + +ruleIsVisible :: ModuleSet -> CoreRule -> Bool +ruleIsVisible _ BuiltinRule{} = True +ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin } + = notOrphan orph || origin `elemModuleSet` vis_orphs + +{- Note [Where rules are found] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rules for an Id come from two places: + (a) the ones it is born with, stored inside the Id itself (idCoreRules fn), + (b) rules added in other modules, stored in the global RuleBase (imp_rules) + +It's tempting to think that + - LocalIds have only (a) + - non-LocalIds have only (b) + +but that isn't quite right: + + - PrimOps and ClassOps are born with a bunch of rules inside the Id, + even when they are imported + + - The rules in GHC.Core.Opt.ConstantFold.builtinRules should be active even + in the module defining the Id (when it's a LocalId), but + the rules are kept in the global RuleBase + + +************************************************************************ +* * + RuleBase +* * +************************************************************************ +-} + +-- RuleBase itself is defined in GHC.Core, along with CoreRule + +emptyRuleBase :: RuleBase +emptyRuleBase = emptyNameEnv + +mkRuleBase :: [CoreRule] -> RuleBase +mkRuleBase rules = extendRuleBaseList emptyRuleBase rules + +extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase +extendRuleBaseList rule_base new_guys + = foldl' extendRuleBase rule_base new_guys + +unionRuleBase :: RuleBase -> RuleBase -> RuleBase +unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2 + +extendRuleBase :: RuleBase -> CoreRule -> RuleBase +extendRuleBase rule_base rule + = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule + +pprRuleBase :: RuleBase -> SDoc +pprRuleBase rules = pprUFM rules $ \rss -> + vcat [ pprRules (tidyRules emptyTidyEnv rs) + | rs <- rss ] + +{- +************************************************************************ +* * + Matching +* * +************************************************************************ +-} + +-- | The main rule matching function. Attempts to apply all (active) +-- supplied rules to this instance of an application in a given +-- context, returning the rule applied and the resulting expression if +-- successful. +lookupRule :: DynFlags -> InScopeEnv + -> (Activation -> Bool) -- When rule is active + -> Id -> [CoreExpr] + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) + +-- See Note [Extra args in rule matching] +-- See comments on matchRule +lookupRule dflags in_scope is_active fn args rules + = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ + case go [] rules of + [] -> Nothing + (m:ms) -> Just (findBest (fn,args') m ms) + where + rough_args = map roughTopName args + + -- Strip ticks from arguments, see note [Tick annotations in RULE + -- matching]. We only collect ticks if a rule actually matches - + -- this matters for performance tests. + args' = map (stripTicksTopE tickishFloatable) args + ticks = concatMap (stripTicksTopT tickishFloatable) args + + go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] + go ms [] = ms + go ms (r:rs) + | Just e <- matchRule dflags in_scope is_active fn args' rough_args r + = go ((r,mkTicks ticks e):ms) rs + | otherwise + = -- pprTrace "match failed" (ppr r $$ ppr args $$ + -- ppr [ (arg_id, unfoldingTemplate unf) + -- | Var arg_id <- args + -- , let unf = idUnfolding arg_id + -- , isCheapUnfolding unf] ) + go ms rs + +findBest :: (Id, [CoreExpr]) + -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) +-- All these pairs matched the expression +-- Return the pair the most specific rule +-- The (fn,args) is just for overlap reporting + +findBest _ (rule,ans) [] = (rule,ans) +findBest target (rule1,ans1) ((rule2,ans2):prs) + | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs + | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs + | debugIsOn = let pp_rule rule + = ifPprDebug (ppr rule) + (doubleQuotes (ftext (ruleName rule))) + in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" + (vcat [ whenPprDebug $ + text "Expression to match:" <+> ppr fn + <+> sep (map ppr args) + , text "Rule 1:" <+> pp_rule rule1 + , text "Rule 2:" <+> pp_rule rule2]) $ + findBest target (rule1,ans1) prs + | otherwise = findBest target (rule1,ans1) prs + where + (fn,args) = target + +isMoreSpecific :: CoreRule -> CoreRule -> Bool +-- This tests if one rule is more specific than another +-- We take the view that a BuiltinRule is less specific than +-- anything else, because we want user-define rules to "win" +-- In particular, class ops have a built-in rule, but we +-- any user-specific rules to win +-- eg (#4397) +-- truncate :: (RealFrac a, Integral b) => a -> b +-- {-# RULES "truncate/Double->Int" truncate = double2Int #-} +-- double2Int :: Double -> Int +-- We want the specific RULE to beat the built-in class-op rule +isMoreSpecific (BuiltinRule {}) _ = False +isMoreSpecific (Rule {}) (BuiltinRule {}) = True +isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) + (Rule { ru_bndrs = bndrs2, ru_args = args2 + , ru_name = rule_name2, ru_rhs = rhs }) + = isJust (matchN (in_scope, id_unfolding_fun) rule_name2 bndrs2 args2 args1 rhs) + where + id_unfolding_fun _ = NoUnfolding -- Don't expand in templates + in_scope = mkInScopeSet (mkVarSet bndrs1) + -- Actually we should probably include the free vars + -- of rule1's args, but I can't be bothered + +noBlackList :: Activation -> Bool +noBlackList _ = False -- Nothing is black listed + +{- +Note [Extra args in rule matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find a matching rule, we return (Just (rule, rhs)), +but the rule firing has only consumed as many of the input args +as the ruleArity says. It's up to the caller to keep track +of any left-over args. E.g. if you call + lookupRule ... f [e1, e2, e3] +and it returns Just (r, rhs), where r has ruleArity 2 +then the real rewrite is + f e1 e2 e3 ==> rhs e3 + +You might think it'd be cleaner for lookupRule to deal with the +leftover arguments, by applying 'rhs' to them, but the main call +in the Simplifier works better as it is. Reason: the 'args' passed +to lookupRule are the result of a lazy substitution +-} + +------------------------------------ +matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool) + -> Id -> [CoreExpr] -> [Maybe Name] + -> CoreRule -> Maybe CoreExpr + +-- If (matchRule rule args) returns Just (name,rhs) +-- then (f args) matches the rule, and the corresponding +-- rewritten RHS is rhs +-- +-- The returned expression is occurrence-analysed +-- +-- Example +-- +-- The rule +-- forall f g x. map f (map g x) ==> map (f . g) x +-- is stored +-- CoreRule "map/map" +-- [f,g,x] -- tpl_vars +-- [f,map g x] -- tpl_args +-- map (f.g) x) -- rhs +-- +-- Then the call: matchRule the_rule [e1,map e2 e3] +-- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) +-- +-- Any 'surplus' arguments in the input are simply put on the end +-- of the output. + +matchRule dflags rule_env _is_active fn args _rough_args + (BuiltinRule { ru_try = match_fn }) +-- Built-in rules can't be switched off, it seems + = let env = RuleOpts + { roPlatform = targetPlatform dflags + , roNumConstantFolding = gopt Opt_NumConstantFolding dflags + , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags + } + in case match_fn env rule_env fn args of + Nothing -> Nothing + Just expr -> Just expr + +matchRule _ in_scope is_active _ args rough_args + (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops + , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) + | not (is_active act) = Nothing + | ruleCantMatch tpl_tops rough_args = Nothing + | otherwise = matchN in_scope rule_name tpl_vars tpl_args args rhs + +--------------------------------------- +matchN :: InScopeEnv + -> RuleName -> [Var] -> [CoreExpr] + -> [CoreExpr] -> CoreExpr -- ^ Target; can have more elements than the template + -> Maybe CoreExpr +-- For a given match template and context, find bindings to wrap around +-- the entire result and what should be substituted for each template variable. +-- Fail if there are two few actual arguments from the target to match the template + +matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs + = do { rule_subst <- go init_menv emptyRuleSubst tmpl_es target_es + ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) + (mkEmptyTCvSubst in_scope) $ + tmpl_vars `zip` tmpl_vars1 + bind_wrapper = rs_binds rule_subst + -- Floated bindings; see Note [Matching lets] + ; return (bind_wrapper $ + mkLams tmpl_vars rhs `mkApps` matched_es) } + where + (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars + -- See Note [Cloning the template binders] + + init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1 + , rv_lcl = init_rn_env + , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) + , rv_unf = id_unf } + + go _ subst [] _ = Just subst + go _ _ _ [] = Nothing -- Fail if too few actual args + go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e + ; go menv subst1 ts es } + + lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr) + -- Need to return a RuleSubst solely for the benefit of mk_fake_ty + lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) + tcv_subst (tmpl_var, tmpl_var1) + | isId tmpl_var1 + = case lookupVarEnv id_subst tmpl_var1 of + Just e | Coercion co <- e + -> (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) + | otherwise + -> (tcv_subst, e) + Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1 + , let co = Coercion.substCo tcv_subst refl_co + -> -- See Note [Unbound RULE binders] + (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) + | otherwise + -> unbound tmpl_var + + | otherwise + = (Type.extendTvSubst tcv_subst tmpl_var1 ty', Type ty') + where + ty' = case lookupVarEnv tv_subst tmpl_var1 of + Just ty -> ty + Nothing -> fake_ty -- See Note [Unbound RULE binders] + fake_ty = anyTypeOfKind (Type.substTy tcv_subst (tyVarKind tmpl_var1)) + -- This substitution is the sole reason we accumulate + -- TCvSubst in lookup_tmpl + + unbound tmpl_var + = pprPanic "Template variable unbound in rewrite rule" $ + vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var) + , text "Rule" <+> pprRuleName rule_name + , text "Rule bndrs:" <+> ppr tmpl_vars + , text "LHS args:" <+> ppr tmpl_es + , text "Actual args:" <+> ppr target_es ] + + +{- Note [Unbound RULE binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be the case that the binder in a rule is not actually +bound on the LHS: + +* Type variables. Type synonyms with phantom args can give rise to + unbound template type variables. Consider this (#10689, + simplCore/should_compile/T10689): + + type Foo a b = b + + f :: Eq a => a -> Bool + f x = x==x + + {-# RULES "foo" forall (x :: Foo a Char). f x = True #-} + finkle = f 'c' + + The rule looks like + forall (a::*) (d::Eq Char) (x :: Foo a Char). + f (Foo a Char) d x = True + + Matching the rule won't bind 'a', and legitimately so. We fudge by + pretending that 'a' is bound to (Any :: *). + +* Coercion variables. On the LHS of a RULE for a local binder + we might have + RULE forall (c :: a~b). f (x |> c) = e + Now, if that binding is inlined, so that a=b=Int, we'd get + RULE forall (c :: Int~Int). f (x |> c) = e + and now when we simplify the LHS (Simplify.simplRule) we + optCoercion (look at the CoVarCo case) will turn that 'c' into Refl: + RULE forall (c :: Int~Int). f (x |> ) = e + and then perhaps drop it altogether. Now 'c' is unbound. + + It's tricky to be sure this never happens, so instead I + say it's OK to have an unbound coercion binder in a RULE + provided its type is (c :: t~t). Then, when the RULE + fires we can substitute for c. + + This actually happened (in a RULE for a local function) + in #13410, and also in test T10602. + +Note [Cloning the template binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following match (example 1): + Template: forall x. f x + Target: f (x+1) +This should succeed, because the template variable 'x' has nothing to +do with the 'x' in the target. + +Likewise this one (example 2): + Template: forall x. f (\x.x) + Target: f (\y.y) + +We achieve this simply by using rnBndrL to clone the template +binders if they are already in scope. + +------ Historical note ------- +At one point I tried simply adding the template binders to the +in-scope set /without/ cloning them, but that failed in a horribly +obscure way in #14777. Problem was that during matching we look +up target-term variables in the in-scope set (see Note [Lookup +in-scope]). If a target-term variable happens to name-clash with a +template variable, that lookup will find the template variable, which +is /utterly/ bogus. In #14777, this transformed a term variable +into a type variable, and then crashed when we wanted its idInfo. +------ End of historical note ------- + + +************************************************************************ +* * + The main matcher +* * +********************************************************************* -} + +-- * The domain of the TvSubstEnv and IdSubstEnv are the template +-- variables passed into the match. +-- +-- * The BindWrapper in a RuleSubst are the bindings floated out +-- from nested matches; see the Let case of match, below +-- +data RuleMatchEnv + = RV { rv_lcl :: RnEnv2 -- Renamings for *local bindings* + -- (lambda/case) + , rv_tmpls :: VarSet -- Template variables + -- (after applying envL of rv_lcl) + , rv_fltR :: Subst -- Renamings for floated let-bindings + -- (domain disjoint from envR of rv_lcl) + -- See Note [Matching lets] + , rv_unf :: IdUnfoldingFun + } + +rvInScopeEnv :: RuleMatchEnv -> InScopeEnv +rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) + +data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the + , rs_id_subst :: IdSubstEnv -- template variables + , rs_binds :: BindWrapper -- Floated bindings + , rs_bndrs :: VarSet -- Variables bound by floated lets + } + +type BindWrapper = CoreExpr -> CoreExpr + -- See Notes [Matching lets] and [Matching cases] + -- we represent the floated bindings as a core-to-core function + +emptyRuleSubst :: RuleSubst +emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv + , rs_binds = \e -> e, rs_bndrs = emptyVarSet } + +-- At one stage I tried to match even if there are more +-- template args than real args. + +-- I now think this is probably a bad idea. +-- Should the template (map f xs) match (map g)? I think not. +-- For a start, in general eta expansion wastes work. +-- SLPJ July 99 + +match :: RuleMatchEnv + -> RuleSubst + -> CoreExpr -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst + +-- We look through certain ticks. See note [Tick annotations in RULE matching] +match renv subst e1 (Tick t e2) + | tickishFloatable t + = match renv subst' e1 e2 + where subst' = subst { rs_binds = rs_binds subst . mkTick t } +match _ _ e@Tick{} _ + = pprPanic "Tick in rule" (ppr e) + +-- See the notes with Unify.match, which matches types +-- Everything is very similar for terms + +-- Interesting examples: +-- Consider matching +-- \x->f against \f->f +-- When we meet the lambdas we must remember to rename f to f' in the +-- second expression. The RnEnv2 does that. +-- +-- Consider matching +-- forall a. \b->b against \a->3 +-- We must rename the \a. Otherwise when we meet the lambdas we +-- might substitute [a/b] in the template, and then erroneously +-- succeed in matching what looks like the template variable 'a' against 3. + +-- The Var case follows closely what happens in GHC.Core.Unify.match +match renv subst (Var v1) e2 + = match_var renv subst v1 e2 + +match renv subst e1 (Var v2) -- Note [Expanding variables] + | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] + , Just e2' <- expandUnfolding_maybe (rv_unf renv v2') + = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2' + where + v2' = lookupRnInScope rn_env v2 + rn_env = rv_lcl renv + -- Notice that we look up v2 in the in-scope set + -- See Note [Lookup in-scope] + -- No need to apply any renaming first (hence no rnOccR) + -- because of the not-inRnEnvR + +match renv subst e1 (Let bind e2) + | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $ + not (isJoinBind bind) -- can't float join point out of argument position + , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] + = match (renv { rv_fltR = flt_subst' }) + (subst { rs_binds = rs_binds subst . Let bind' + , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs }) + e1 e2 + where + flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst) + (flt_subst', bind') = substBind flt_subst bind + new_bndrs = bindersOf bind' + +{- Disabled: see Note [Matching cases] below +match renv (tv_subst, id_subst, binds) e1 + (Case scrut case_bndr ty [(con, alt_bndrs, rhs)]) + | exprOkForSpeculation scrut -- See Note [Matching cases] + , okToFloat rn_env bndrs (exprFreeVars scrut) + = match (renv { me_env = rn_env' }) + (tv_subst, id_subst, binds . case_wrap) + e1 rhs + where + rn_env = me_env renv + rn_env' = extendRnInScopeList rn_env bndrs + bndrs = case_bndr : alt_bndrs + case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')] +-} + +match _ subst (Lit lit1) (Lit lit2) + | lit1 == lit2 + = Just subst + +match renv subst (App f1 a1) (App f2 a2) + = do { subst' <- match renv subst f1 f2 + ; match renv subst' a1 a2 } + +match renv subst (Lam x1 e1) e2 + | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2 + = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 + , rv_fltR = delBndr (rv_fltR renv) x2 } + subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } + in match renv' subst' e1 e2 + +match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) + = do { subst1 <- match_ty renv subst ty1 ty2 + ; subst2 <- match renv subst1 e1 e2 + ; let renv' = rnMatchBndr2 renv subst x1 x2 + ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted + } + +match renv subst (Type ty1) (Type ty2) + = match_ty renv subst ty1 ty2 +match renv subst (Coercion co1) (Coercion co2) + = match_co renv subst co1 co2 + +match renv subst (Cast e1 co1) (Cast e2 co2) + = do { subst1 <- match_co renv subst co1 co2 + ; match renv subst1 e1 e2 } + +-- Everything else fails +match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ + Nothing + +------------- +match_co :: RuleMatchEnv + -> RuleSubst + -> Coercion + -> Coercion + -> Maybe RuleSubst +match_co renv subst co1 co2 + | Just cv <- getCoVar_maybe co1 + = match_var renv subst cv (Coercion co2) + | Just (ty1, r1) <- isReflCo_maybe co1 + = do { (ty2, r2) <- isReflCo_maybe co2 + ; guard (r1 == r2) + ; match_ty renv subst ty1 ty2 } +match_co renv subst co1 co2 + | Just (tc1, cos1) <- splitTyConAppCo_maybe co1 + = case splitTyConAppCo_maybe co2 of + Just (tc2, cos2) + | tc1 == tc2 + -> match_cos renv subst cos1 cos2 + _ -> Nothing +match_co renv subst co1 co2 + | Just (arg1, res1) <- splitFunCo_maybe co1 + = case splitFunCo_maybe co2 of + Just (arg2, res2) + -> match_cos renv subst [arg1, res1] [arg2, res2] + _ -> Nothing +match_co _ _ _co1 _co2 + -- Currently just deals with CoVarCo, TyConAppCo and Refl +#if defined(DEBUG) + = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing +#else + = Nothing +#endif + +match_cos :: RuleMatchEnv + -> RuleSubst + -> [Coercion] + -> [Coercion] + -> Maybe RuleSubst +match_cos renv subst (co1:cos1) (co2:cos2) = + do { subst' <- match_co renv subst co1 co2 + ; match_cos renv subst' cos1 cos2 } +match_cos _ subst [] [] = Just subst +match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing + +------------- +rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv +rnMatchBndr2 renv subst x1 x2 + = renv { rv_lcl = rnBndr2 rn_env x1 x2 + , rv_fltR = delBndr (rv_fltR renv) x2 } + where + rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst) + -- Typically this is a no-op, but it may matter if + -- there are some floated let-bindings + +------------------------------------------ +match_alts :: RuleMatchEnv + -> RuleSubst + -> [CoreAlt] -- Template + -> [CoreAlt] -- Target + -> Maybe RuleSubst +match_alts _ subst [] [] + = return subst +match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) + | c1 == c2 + = do { subst1 <- match renv' subst r1 r2 + ; match_alts renv subst1 alts1 alts2 } + where + renv' = foldl' mb renv (vs1 `zip` vs2) + mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2 + +match_alts _ _ _ _ + = Nothing + +------------------------------------------ +okToFloat :: RnEnv2 -> VarSet -> Bool +okToFloat rn_env bind_fvs + = allVarSet not_captured bind_fvs + where + not_captured fv = not (inRnEnvR rn_env fv) + +------------------------------------------ +match_var :: RuleMatchEnv + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst +match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) + subst v1 e2 + | v1' `elemVarSet` tmpls + = match_tmpl_var renv subst v1' e2 + + | otherwise -- v1' is not a template variable; check for an exact match with e2 + = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR + Var v2 | v1' == rnOccR rn_env v2 + -> Just subst + + | Var v2' <- lookupIdSubst (text "match_var") flt_env v2 + , v1' == v2' + -> Just subst + + _ -> Nothing + + where + v1' = rnOccL rn_env v1 + -- If the template is + -- forall x. f x (\x -> x) = ... + -- Then the x inside the lambda isn't the + -- template x, so we must rename first! + +------------------------------------------ +match_tmpl_var :: RuleMatchEnv + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst + +match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) + subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) + v1' e2 + | any (inRnEnvR rn_env) (exprFreeVarsList e2) + = Nothing -- Occurs check failure + -- e.g. match forall a. (\x-> a x) against (\y. y y) + + | Just e1' <- lookupVarEnv id_subst v1' + = if eqExpr (rnInScopeSet rn_env) e1' e2' + then Just subst + else Nothing + + | otherwise + = -- Note [Matching variable types] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- However, we must match the *types*; e.g. + -- forall (c::Char->Int) (x::Char). + -- f (c x) = "RULE FIRED" + -- We must only match on args that have the right type + -- It's actually quite difficult to come up with an example that shows + -- you need type matching, esp since matching is left-to-right, so type + -- args get matched first. But it's possible (e.g. simplrun008) and + -- this is the Right Thing to do + do { subst' <- match_ty renv subst (idType v1') (exprType e2) + ; return (subst' { rs_id_subst = id_subst' }) } + where + -- e2' is the result of applying flt_env to e2 + e2' | isEmptyVarSet let_bndrs = e2 + | otherwise = substExpr (text "match_tmpl_var") flt_env e2 + + id_subst' = extendVarEnv (rs_id_subst subst) v1' e2' + -- No further renaming to do on e2', + -- because no free var of e2' is in the rnEnvR of the envt + +------------------------------------------ +match_ty :: RuleMatchEnv + -> RuleSubst + -> Type -- Template + -> Type -- Target + -> Maybe RuleSubst +-- Matching Core types: use the matcher in GHC.Tc.Utils.TcType. +-- Notice that we treat newtypes as opaque. For example, suppose +-- we have a specialised version of a function at a newtype, say +-- newtype T = MkT Int +-- We only want to replace (f T) with f', not (f Int). + +match_ty renv subst ty1 ty2 + = do { tv_subst' + <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2 + ; return (subst { rs_tv_subst = tv_subst' }) } + where + tv_subst = rs_tv_subst subst + +{- +Note [Expanding variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is another Very Important rule: if the term being matched is a +variable, we expand it so long as its unfolding is "expandable". (Its +occurrence information is not necessarily up to date, so we don't use +it.) By "expandable" we mean a WHNF or a "constructor-like" application. +This is the key reason for "constructor-like" Ids. If we have + {-# NOINLINE [1] CONLIKE g #-} + {-# RULE f (g x) = h x #-} +then in the term + let v = g 3 in ....(f v).... +we want to make the rule fire, to replace (f v) with (h 3). + +Note [Do not expand locally-bound variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do *not* expand locally-bound variables, else there's a worry that the +unfolding might mention variables that are themselves renamed. +Example + case x of y { (p,q) -> ...y... } +Don't expand 'y' to (p,q) because p,q might themselves have been +renamed. Essentially we only expand unfoldings that are "outside" +the entire match. + +Hence, (a) the guard (not (isLocallyBoundR v2)) + (b) when we expand we nuke the renaming envt (nukeRnEnvR). + +Note [Tick annotations in RULE matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We used to unconditionally look through Notes in both template and +expression being matched. This is actually illegal for counting or +cost-centre-scoped ticks, because we have no place to put them without +changing entry counts and/or costs. So now we just fail the match in +these cases. + +On the other hand, where we are allowed to insert new cost into the +tick scope, we can float them upwards to the rule application site. + +cf Note [Notes in call patterns] in GHC.Core.Opt.SpecConstr + +Note [Matching lets] +~~~~~~~~~~~~~~~~~~~~ +Matching a let-expression. Consider + RULE forall x. f (g x) = +and target expression + f (let { w=R } in g E)) +Then we'd like the rule to match, to generate + let { w=R } in (\x. ) E +In effect, we want to float the let-binding outward, to enable +the match to happen. This is the WHOLE REASON for accumulating +bindings in the RuleSubst + +We can only do this if the free variables of R are not bound by the +part of the target expression outside the let binding; e.g. + f (\v. let w = v+1 in g E) +Here we obviously cannot float the let-binding for w. Hence the +use of okToFloat. + +There are a couple of tricky points. + (a) What if floating the binding captures a variable? + f (let v = x+1 in v) v + --> NOT! + let v = x+1 in f (x+1) v + + (b) What if two non-nested let bindings bind the same variable? + f (let v = e1 in b1) (let v = e2 in b2) + --> NOT! + let v = e1 in let v = e2 in (f b2 b2) + See testsuite test "RuleFloatLet". + +Our cunning plan is this: + * Along with the growing substitution for template variables + we maintain a growing set of floated let-bindings (rs_binds) + plus the set of variables thus bound. + + * The RnEnv2 in the MatchEnv binds only the local binders + in the term (lambdas, case) + + * When we encounter a let in the term to be matched, we + check that does not mention any locally bound (lambda, case) + variables. If so we fail + + * We use GHC.Core.Subst.substBind to freshen the binding, using an + in-scope set that is the original in-scope variables plus the + rs_bndrs (currently floated let-bindings). So in (a) above + we'll freshen the 'v' binding; in (b) above we'll freshen + the *second* 'v' binding. + + * We apply that freshening substitution, in a lexically-scoped + way to the term, although lazily; this is the rv_fltR field. + + +Note [Matching cases] +~~~~~~~~~~~~~~~~~~~~~ +{- NOTE: This idea is currently disabled. It really only works if + the primops involved are OkForSpeculation, and, since + they have side effects readIntOfAddr and touch are not. + Maybe we'll get back to this later . -} + +Consider + f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> + case touch# fp s# of { _ -> + I# n# } } ) +This happened in a tight loop generated by stream fusion that +Roman encountered. We'd like to treat this just like the let +case, because the primops concerned are ok-for-speculation. +That is, we'd like to behave as if it had been + case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> + case touch# fp s# of { _ -> + f (I# n# } } ) + +Note [Lookup in-scope] +~~~~~~~~~~~~~~~~~~~~~~ +Consider this example + foo :: Int -> Maybe Int -> Int + foo 0 (Just n) = n + foo m (Just n) = foo (m-n) (Just n) + +SpecConstr sees this fragment: + + case w_smT of wild_Xf [Just A] { + Data.Maybe.Nothing -> lvl_smf; + Data.Maybe.Just n_acT [Just S(L)] -> + case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> + $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + }}; + +and correctly generates the rule + + RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# + sc_snn :: GHC.Prim.Int#} + $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) + = $s$wfoo_sno y_amr sc_snn ;] + +BUT we must ensure that this rule matches in the original function! +Note that the call to $wfoo is + $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + +During matching we expand wild_Xf to (Just n_acT). But then we must also +expand n_acT to (I# y_amr). And we can only do that if we look up n_acT +in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding +at all. + +That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' +is so important. + + +************************************************************************ +* * + Rule-check the program +* * +************************************************************************ + + We want to know what sites have rules that could have fired but didn't. + This pass runs over the tree (without changing it) and reports such. +-} + +-- | Report partial matches for rules beginning with the specified +-- string for the purposes of error reporting +ruleCheckProgram :: CompilerPhase -- ^ Rule activation test + -> String -- ^ Rule pattern + -> (Id -> [CoreRule]) -- ^ Rules for an Id + -> CoreProgram -- ^ Bindings to check in + -> SDoc -- ^ Resulting check message +ruleCheckProgram phase rule_pat rules binds + | isEmptyBag results + = text "Rule check results: no rule application sites" + | otherwise + = vcat [text "Rule check results:", + line, + vcat [ p $$ line | p <- bagToList results ] + ] + where + env = RuleCheckEnv { rc_is_active = isActive phase + , rc_id_unf = idUnfolding -- Not quite right + -- Should use activeUnfolding + , rc_pattern = rule_pat + , rc_rules = rules } + results = unionManyBags (map (ruleCheckBind env) binds) + line = text (replicate 20 '-') + +data RuleCheckEnv = RuleCheckEnv { + rc_is_active :: Activation -> Bool, + rc_id_unf :: IdUnfoldingFun, + rc_pattern :: String, + rc_rules :: Id -> [CoreRule] +} + +ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc + -- The Bag returned has one SDoc for each call site found +ruleCheckBind env (NonRec _ r) = ruleCheck env r +ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs] + +ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc +ruleCheck _ (Var _) = emptyBag +ruleCheck _ (Lit _) = emptyBag +ruleCheck _ (Type _) = emptyBag +ruleCheck _ (Coercion _) = emptyBag +ruleCheck env (App f a) = ruleCheckApp env (App f a) [] +ruleCheck env (Tick _ e) = ruleCheck env e +ruleCheck env (Cast e _) = ruleCheck env e +ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e +ruleCheck env (Lam _ e) = ruleCheck env e +ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` + unionManyBags [ruleCheck env r | (_,_,r) <- as] + +ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc +ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) +ruleCheckApp env (Var f) as = ruleCheckFun env f as +ruleCheckApp env other _ = ruleCheck env other + +ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc +-- Produce a report for all rules matching the predicate +-- saying why it doesn't match the specified application + +ruleCheckFun env fn args + | null name_match_rules = emptyBag + | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) + where + name_match_rules = filter match (rc_rules env fn) + match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) + +ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc +ruleAppCheck_help env fn args rules + = -- The rules match the pattern, so we want to print something + vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), + vcat (map check_rule rules)] + where + n_args = length args + i_args = args `zip` [1::Int ..] + rough_args = map roughTopName args + + check_rule rule = sdocWithDynFlags $ \dflags -> + rule_herald rule <> colon <+> rule_info dflags rule + + rule_herald (BuiltinRule { ru_name = name }) + = text "Builtin rule" <+> doubleQuotes (ftext name) + rule_herald (Rule { ru_name = name }) + = text "Rule" <+> doubleQuotes (ftext name) + + rule_info dflags rule + | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env) + noBlackList fn args rough_args rule + = text "matches (which is very peculiar!)" + + rule_info _ (BuiltinRule {}) = text "does not match" + + rule_info _ (Rule { ru_act = act, + ru_bndrs = rule_bndrs, ru_args = rule_args}) + | not (rc_is_active env act) = text "active only in later phase" + | n_args < n_rule_args = text "too few arguments" + | n_mismatches == n_rule_args = text "no arguments match" + | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" + | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" + where + n_rule_args = length rule_args + n_mismatches = length mismatches + mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, + not (isJust (match_fn rule_arg arg))] + + lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars + match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg + where + in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) + renv = RV { rv_lcl = mkRnEnv2 in_scope + , rv_tmpls = mkVarSet rule_bndrs + , rv_fltR = mkEmptySubst in_scope + , rv_unf = rc_id_unf env } diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Tidy.hs @@ -0,0 +1,286 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + + +This module contains "tidying" code for *nested* expressions, bindings, rules. +The code for *top-level* bindings is in GHC.Iface.Tidy. +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +module GHC.Core.Tidy ( + tidyExpr, tidyRules, tidyUnfolding + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Seq ( seqUnfolding ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand ( zapUsageEnvSig ) +import GHC.Core.Type ( tidyType, tidyVarBndr ) +import GHC.Core.Coercion ( tidyCo ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Unique.FM +import GHC.Types.Name hiding (tidyNameOcc) +import GHC.Types.SrcLoc +import GHC.Data.Maybe +import Data.List + +{- +************************************************************************ +* * +\subsection{Tidying expressions, rules} +* * +************************************************************************ +-} + +tidyBind :: TidyEnv + -> CoreBind + -> (TidyEnv, CoreBind) + +tidyBind env (NonRec bndr rhs) + = tidyLetBndr env env bndr =: \ (env', bndr') -> + (env', NonRec bndr' (tidyExpr env' rhs)) + +tidyBind env (Rec prs) + = let + (bndrs, rhss) = unzip prs + (env', bndrs') = mapAccumL (tidyLetBndr env') env bndrs + in + map (tidyExpr env') rhss =: \ rhss' -> + (env', Rec (zip bndrs' rhss')) + + +------------ Expressions -------------- +tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr +tidyExpr env (Var v) = Var (tidyVarOcc env v) +tidyExpr env (Type ty) = Type (tidyType env ty) +tidyExpr env (Coercion co) = Coercion (tidyCo env co) +tidyExpr _ (Lit lit) = Lit lit +tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) +tidyExpr env (Tick t e) = Tick (tidyTickish env t) (tidyExpr env e) +tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyCo env co) + +tidyExpr env (Let b e) + = tidyBind env b =: \ (env', b') -> + Let b' (tidyExpr env' e) + +tidyExpr env (Case e b ty alts) + = tidyBndr env b =: \ (env', b) -> + Case (tidyExpr env e) b (tidyType env ty) + (map (tidyAlt env') alts) + +tidyExpr env (Lam b e) + = tidyBndr env b =: \ (env', b) -> + Lam b (tidyExpr env' e) + +------------ Case alternatives -------------- +tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt +tidyAlt env (con, vs, rhs) + = tidyBndrs env vs =: \ (env', vs) -> + (con, vs, tidyExpr env' rhs) + +------------ Tickish -------------- +tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id +tidyTickish env (Breakpoint ix ids) = Breakpoint ix (map (tidyVarOcc env) ids) +tidyTickish _ other_tickish = other_tickish + +------------ Rules -------------- +tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule] +tidyRules _ [] = [] +tidyRules env (rule : rules) + = tidyRule env rule =: \ rule -> + tidyRules env rules =: \ rules -> + (rule : rules) + +tidyRule :: TidyEnv -> CoreRule -> CoreRule +tidyRule _ rule@(BuiltinRule {}) = rule +tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs, + ru_fn = fn, ru_rough = mb_ns }) + = tidyBndrs env bndrs =: \ (env', bndrs) -> + map (tidyExpr env') args =: \ args -> + rule { ru_bndrs = bndrs, ru_args = args, + ru_rhs = tidyExpr env' rhs, + ru_fn = tidyNameOcc env fn, + ru_rough = map (fmap (tidyNameOcc env')) mb_ns } + +{- +************************************************************************ +* * +\subsection{Tidying non-top-level binders} +* * +************************************************************************ +-} + +tidyNameOcc :: TidyEnv -> Name -> Name +-- In rules and instances, we have Names, and we must tidy them too +-- Fortunately, we can lookup in the VarEnv with a name +tidyNameOcc (_, var_env) n = case lookupUFM var_env n of + Nothing -> n + Just v -> idName v + +tidyVarOcc :: TidyEnv -> Var -> Var +tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v + +-- tidyBndr is used for lambda and case binders +tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) +tidyBndr env var + | isTyCoVar var = tidyVarBndr env var + | otherwise = tidyIdBndr env var + +tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) +tidyBndrs env vars = mapAccumL tidyBndr env vars + +-- Non-top-level variables, not covars +tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) +tidyIdBndr env@(tidy_env, var_env) id + = -- Do this pattern match strictly, otherwise we end up holding on to + -- stuff in the OccName. + case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + -- Give the Id a fresh print-name, *and* rename its type + -- The SrcLoc isn't important now, + -- though we could extract it from the Id + -- + ty' = tidyType env (idType id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + id' = mkLocalIdWithInfo name' ty' new_info + var_env' = extendVarEnv var_env id id' + + -- Note [Tidy IdInfo] + new_info = vanillaIdInfo `setOccInfo` occInfo old_info + `setUnfoldingInfo` new_unf + -- see Note [Preserve OneShotInfo] + `setOneShotInfo` oneShotInfo old_info + old_info = idInfo id + old_unf = unfoldingInfo old_info + new_unf = zapUnfolding old_unf -- See Note [Preserve evaluatedness] + in + ((tidy_env', var_env'), id') + } + +tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings + -> TidyEnv -- The one to extend + -> Id -> (TidyEnv, Id) +-- Used for local (non-top-level) let(rec)s +-- Just like tidyIdBndr above, but with more IdInfo +tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id + = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + ty' = tidyType env (idType id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + details = idDetails id + id' = mkLocalVar details name' ty' new_info + var_env' = extendVarEnv var_env id id' + + -- Note [Tidy IdInfo] + -- We need to keep around any interesting strictness and + -- demand info because later on we may need to use it when + -- converting to A-normal form. + -- eg. + -- f (g x), where f is strict in its argument, will be converted + -- into case (g x) of z -> f z by CorePrep, but only if f still + -- has its strictness info. + -- + -- Similarly for the demand info - on a let binder, this tells + -- CorePrep to turn the let into a case. + -- But: Remove the usage demand here + -- (See Note [Zapping DmdEnv after Demand Analyzer] in GHC.Core.Opt.WorkWrap) + -- + -- Similarly arity info for eta expansion in CorePrep + -- Don't attempt to recompute arity here; this is just tidying! + -- Trying to do so led to #17294 + -- + -- Set inline-prag info so that we preserve it across + -- separate compilation boundaries + old_info = idInfo id + new_info = vanillaIdInfo + `setOccInfo` occInfo old_info + `setArityInfo` arityInfo old_info + `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info) + `setDemandInfo` demandInfo old_info + `setInlinePragInfo` inlinePragInfo old_info + `setUnfoldingInfo` new_unf + + old_unf = unfoldingInfo old_info + new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf + | otherwise = zapUnfolding old_unf + -- See Note [Preserve evaluatedness] + + in + ((tidy_env', var_env'), id') } + +------------ Unfolding -------------- +tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding +tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _ + = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args } + where + (tidy_env', bndrs') = tidyBndrs tidy_env bndrs + +tidyUnfolding tidy_env + unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) + unf_from_rhs + | isStableSource src + = seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo + -- This seqIt avoids a space leak: otherwise the uf_is_value, + -- uf_is_conlike, ... fields may retain a reference to the + -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them) + + | otherwise + = unf_from_rhs + where seqIt unf = seqUnfolding unf `seq` unf +tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon + +{- +Note [Tidy IdInfo] +~~~~~~~~~~~~~~~~~~ +All nested Ids now have the same IdInfo, namely vanillaIdInfo, which +should save some space; except that we preserve occurrence info for +two reasons: + + (a) To make printing tidy core nicer + + (b) Because we tidy RULES and InlineRules, which may then propagate + via --make into the compilation of the next module, and we want + the benefit of that occurrence analysis when we use the rule or + or inline the function. In particular, it's vital not to lose + loop-breaker info, else we get an infinite inlining loop + +Note that tidyLetBndr puts more IdInfo back. + +Note [Preserve evaluatedness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Bool + ....(case v of MkT y -> + let z# = case y of + True -> 1# + False -> 2# + in ...) + +The z# binding is ok because the RHS is ok-for-speculation, +but Lint will complain unless it can *see* that. So we +preserve the evaluated-ness on 'y' in tidyBndr. + +(Another alternative would be to tidy unboxed lets into cases, +but that seems more indirect and surprising.) + +Note [Preserve OneShotInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We keep the OneShotInfo because we want it to propagate into the interface. +Not all OneShotInfo is determined by a compiler analysis; some is added by a +call of GHC.Exts.oneShot, which is then discarded before the end of the +optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we +must preserve this info in inlinings. See Note [The oneShot function] in GHC.Types.Id.Make. + +This applies to lambda binders only, hence it is stored in IfaceLamBndr. +-} + +(=:) :: a -> (a -> b) -> b +m =: k = m `seq` k m diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -12,7 +12,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.ByteCode.Instr import GHC.ByteCode.Asm @@ -23,7 +23,7 @@ import GHCi.RemoteTypes import GHC.Types.Basic import GHC.Driver.Session -import Outputable +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Name import GHC.Types.Id.Make @@ -35,28 +35,28 @@ import GHC.Core import GHC.Core.Ppr import GHC.Types.Literal -import PrimOp +import GHC.Builtin.PrimOps import GHC.Core.FVs import GHC.Core.Type import GHC.Types.RepType import GHC.Core.DataCon import GHC.Core.TyCon -import Util +import GHC.Utils.Misc import GHC.Types.Var.Set -import TysPrim +import GHC.Builtin.Types.Prim import GHC.Core.TyCo.Ppr ( pprType ) -import ErrUtils +import GHC.Utils.Error import GHC.Types.Unique -import FastString -import Panic +import GHC.Data.FastString +import GHC.Utils.Panic import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) import GHC.Data.Bitmap -import OrdList -import Maybes +import GHC.Data.OrdList +import GHC.Data.Maybe import GHC.Types.Var.Env -import PrelNames ( unsafeEqualityProofName ) +import GHC.Builtin.Names ( unsafeEqualityProofName ) import Data.List import Foreign @@ -64,7 +64,7 @@ import Data.Char import GHC.Types.Unique.Supply -import GHC.Types.Module +import GHC.Unit.Module import Control.Exception import Data.Array @@ -73,7 +73,7 @@ import Data.IntMap (IntMap) import qualified Data.Map as Map import qualified Data.IntMap as IntMap -import qualified FiniteMap as Map +import qualified GHC.Data.FiniteMap as Map import Data.Ord import GHC.Stack.CCS import Data.Either ( partitionEithers ) diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -15,7 +15,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Core.Utils ( exprType, findDefault, isJoinBind @@ -32,22 +32,22 @@ import GHC.Core.DataCon import GHC.Types.CostCentre import GHC.Types.Var.Env -import GHC.Types.Module +import GHC.Unit.Module import GHC.Types.Name ( isExternalName, nameModule_maybe ) import GHC.Types.Basic ( Arity ) -import TysWiredIn ( unboxedUnitDataCon, unitDataConId ) +import GHC.Builtin.Types ( unboxedUnitDataCon, unitDataConId ) import GHC.Types.Literal -import Outputable -import MonadUtils -import FastString -import Util +import GHC.Utils.Outputable +import GHC.Utils.Monad +import GHC.Data.FastString +import GHC.Utils.Misc import GHC.Driver.Session import GHC.Driver.Ways import GHC.Types.ForeignCall -import GHC.Types.Demand ( isUsedOnce ) -import PrimOp ( PrimCall(..), primOpWrapperId ) -import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) -import PrelNames ( unsafeEqualityProofName ) +import GHC.Types.Demand ( isUsedOnce ) +import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId ) +import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) +import GHC.Builtin.Names ( unsafeEqualityProofName ) import Data.List.NonEmpty (nonEmpty, toList) import Data.Maybe (fromMaybe) @@ -539,7 +539,7 @@ (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) -- Some primitive operator that might be implemented as a library call. - -- As described in Note [Primop wrappers] in PrimOp.hs, here we + -- As described in Note [Primop wrappers] in GHC.Builtin.PrimOps, here we -- turn unsaturated primop applications into applications of -- the primop's wrapper. PrimOpId op 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 @@ -17,25 +17,25 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform -import GHC.Core.Op.OccurAnal +import GHC.Core.Opt.OccurAnal import GHC.Driver.Types -import PrelNames +import GHC.Builtin.Names import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Core.Utils import GHC.Core.Arity import GHC.Core.FVs -import GHC.Core.Op.Monad ( CoreToDo(..) ) +import GHC.Core.Opt.Monad ( CoreToDo(..) ) import GHC.Core.Lint ( endPassIO ) import GHC.Core import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here import GHC.Core.Type import GHC.Types.Literal import GHC.Core.Coercion -import TcEnv +import GHC.Tc.Utils.Env import GHC.Core.TyCon import GHC.Types.Demand import GHC.Types.Var @@ -43,23 +43,23 @@ import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Id.Info -import TysWiredIn +import GHC.Builtin.Types import GHC.Core.DataCon import GHC.Types.Basic -import GHC.Types.Module +import GHC.Unit.Module import GHC.Types.Unique.Supply -import Maybes -import OrdList -import ErrUtils +import GHC.Data.Maybe +import GHC.Data.OrdList +import GHC.Utils.Error import GHC.Driver.Session import GHC.Driver.Ways -import Util -import Outputable -import FastString +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import Data.Bits -import MonadUtils ( mapAccumLM ) +import GHC.Utils.Monad ( mapAccumLM ) import Control.Monad import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) import qualified Data.Set as S @@ -347,10 +347,7 @@ * In cloneBndr, drop all unfoldings/rules * In deFloatTop, run a simple dead code analyser on each top-level - RHS to drop the dead local bindings. For that call to OccAnal, we - disable the binder swap, else the occurrence analyser sometimes - introduces new let bindings for cased binders, which lead to the bug - in #5433. + RHS to drop the dead local bindings. The reason we don't just OccAnal the whole output of CorePrep is that the tidier ensures that all top-level binders are GlobalIds, so they @@ -524,7 +521,7 @@ cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr -> UniqSM (JoinId, CpeRhs) -- Used for all join bindings --- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Op.Simplify.Utils +-- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils cpeJoinPair env bndr rhs = ASSERT(isJoinId bndr) do { let Just join_arity = isJoinId_maybe bndr @@ -1074,7 +1071,7 @@ CAFfyness made during tidying (see Note [CAFfyness inconsistencies due to eta expansion in CorePrep] in GHC.Iface.Tidy for details. We previously saturated primop applications here as well but due to this fragility (see #16846) we now deal -with this another way, as described in Note [Primop wrappers] in PrimOp. +with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps. It's quite likely that eta expansion of constructor applications will eventually break in a similar way to how primops did. We really should @@ -1316,14 +1313,13 @@ deFloatTop (Floats _ floats) = foldrOL get [] floats where - get (FloatLet b) bs = occurAnalyseRHSs b : bs - get (FloatCase body var _ _ _) bs - = occurAnalyseRHSs (NonRec var body) : bs + get (FloatLet b) bs = get_bind b : bs + get (FloatCase body var _ _ _) bs = get_bind (NonRec var body) : bs get b _ = pprPanic "corePrepPgm" (ppr b) -- See Note [Dead code in CorePrep] - occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e) - occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes] + get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e) + get_bind (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes] --------------------------------------------------------------------------- @@ -1473,7 +1469,7 @@ = guardNaturalUse dflags $ liftM tyThingId $ lookupGlobal hsc_env mkNaturalName --- See Note [The integer library] in PrelNames +-- See Note [The integer library] in GHC.Builtin.Names lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon) lookupIntegerSDataConName dflags hsc_env = case integerLibrary dflags of IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $ @@ -1566,7 +1562,7 @@ -- Drop (now-useless) rules/unfoldings -- See Note [Drop unfoldings and rules] - -- and Note [Preserve evaluatedness] in GHC.Core.Op.Tidy + -- and Note [Preserve evaluatedness] in GHC.Core.Tidy ; let unfolding' = zapUnfolding (realIdUnfolding bndr) -- Simplifier will set the Id's unfolding @@ -1599,7 +1595,7 @@ we'd have to substitute in them HOWEVER, we want to preserve evaluated-ness; -see Note [Preserve evaluatedness] in GHC.Core.Op.Tidy. +see Note [Preserve evaluatedness] in GHC.Core.Tidy. -} ------------------------------------------------------------------------------ diff --git a/compiler/GHC/Data/Bitmap.hs b/compiler/GHC/Data/Bitmap.hs --- a/compiler/GHC/Data/Bitmap.hs +++ b/compiler/GHC/Data/Bitmap.hs @@ -14,7 +14,7 @@ mAX_SMALL_BITMAP_SIZE, ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Runtime.Heap.Layout diff --git a/compiler/GHC/Data/Graph/Base.hs b/compiler/GHC/Data/Graph/Base.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Data/Graph/Base.hs @@ -0,0 +1,107 @@ + +-- | Types for the general graph colorer. +module GHC.Data.Graph.Base ( + Triv, + Graph (..), + initGraph, + graphMapModify, + + Node (..), newNode, +) + + +where + +import GHC.Prelude + +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM + + +-- | A fn to check if a node is trivially colorable +-- For graphs who's color classes are disjoint then a node is 'trivially colorable' +-- when it has less neighbors and exclusions than available colors for that node. +-- +-- For graph's who's color classes overlap, ie some colors alias other colors, then +-- this can be a bit more tricky. There is a general way to calculate this, but +-- it's likely be too slow for use in the code. The coloring algorithm takes +-- a canned function which can be optimised by the user to be specific to the +-- specific graph being colored. +-- +-- for details, see "A Generalised Algorithm for Graph-Coloring Register Allocation" +-- Smith, Ramsey, Holloway - PLDI 2004. +-- +type Triv k cls color + = cls -- the class of the node we're trying to color. + -> UniqSet k -- the node's neighbors. + -> UniqSet color -- the node's exclusions. + -> Bool + + +-- | The Interference graph. +-- There used to be more fields, but they were turfed out in a previous revision. +-- maybe we'll want more later.. +-- +data Graph k cls color + = Graph { + -- | All active nodes in the graph. + graphMap :: UniqFM (Node k cls color) } + + +-- | An empty graph. +initGraph :: Graph k cls color +initGraph + = Graph + { graphMap = emptyUFM } + + +-- | Modify the finite map holding the nodes in the graph. +graphMapModify + :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color)) + -> Graph k cls color -> Graph k cls color + +graphMapModify f graph + = graph { graphMap = f (graphMap graph) } + + + +-- | Graph nodes. +-- Represents a thing that can conflict with another thing. +-- For the register allocater the nodes represent registers. +-- +data Node k cls color + = Node { + -- | A unique identifier for this node. + nodeId :: k + + -- | The class of this node, + -- determines the set of colors that can be used. + , nodeClass :: cls + + -- | The color of this node, if any. + , nodeColor :: Maybe color + + -- | Neighbors which must be colored differently to this node. + , nodeConflicts :: UniqSet k + + -- | Colors that cannot be used by this node. + , nodeExclusions :: UniqSet color + + -- | Colors that this node would prefer to be, in descending order. + , nodePreference :: [color] + + -- | Neighbors that this node would like to be colored the same as. + , nodeCoalesce :: UniqSet k } + + +-- | An empty node. +newNode :: k -> cls -> Node k cls color +newNode k cls + = Node + { nodeId = k + , nodeClass = cls + , nodeColor = Nothing + , nodeConflicts = emptyUniqSet + , nodeExclusions = emptyUniqSet + , nodePreference = [] + , nodeCoalesce = emptyUniqSet } diff --git a/compiler/GHC/Data/Graph/Color.hs b/compiler/GHC/Data/Graph/Color.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Data/Graph/Color.hs @@ -0,0 +1,375 @@ +-- | Graph Coloring. +-- This is a generic graph coloring library, abstracted over the type of +-- the node keys, nodes and colors. +-- + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Data.Graph.Color ( + module GHC.Data.Graph.Base, + module GHC.Data.Graph.Ops, + module GHC.Data.Graph.Ppr, + colorGraph +) + +where + +import GHC.Prelude + +import GHC.Data.Graph.Base +import GHC.Data.Graph.Ops +import GHC.Data.Graph.Ppr + +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Utils.Outputable + +import Data.Maybe +import Data.List + + +-- | Try to color a graph with this set of colors. +-- Uses Chaitin's algorithm to color the graph. +-- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes +-- are pushed onto a stack and removed from the graph. +-- Once this process is complete the graph can be colored by removing nodes from +-- the stack (ie in reverse order) and assigning them colors different to their neighbors. +-- +colorGraph + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq cls, Ord k + , Outputable k, Outputable cls, Outputable color) + => Bool -- ^ whether to do iterative coalescing + -> Int -- ^ how many times we've tried to color this graph so far. + -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to color. + + -> ( Graph k cls color -- the colored graph. + , UniqSet k -- the set of nodes that we couldn't find a color for. + , UniqFM k ) -- map of regs (r1 -> r2) that were coalesced + -- r1 should be replaced by r2 in the source + +colorGraph iterative spinCount colors triv spill graph0 + = let + -- If we're not doing iterative coalescing then do an aggressive coalescing first time + -- around and then conservative coalescing for subsequent passes. + -- + -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if + -- there is a lot of register pressure and we do it on every round then it can make the + -- graph less colorable and prevent the algorithm from converging in a sensible number + -- of cycles. + -- + (graph_coalesced, kksCoalesce1) + = if iterative + then (graph0, []) + else if spinCount == 0 + then coalesceGraph True triv graph0 + else coalesceGraph False triv graph0 + + -- run the scanner to slurp out all the trivially colorable nodes + -- (and do coalescing if iterative coalescing is enabled) + (ksTriv, ksProblems, kksCoalesce2) + = colorScan iterative triv spill graph_coalesced + + -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. + -- We need to apply all the coalescences found by the scanner to the original + -- graph before doing assignColors. + -- + -- Because we've got the whole, non-pruned graph here we turn on aggressive coalescing + -- to force all the (conservative) coalescences found during scanning. + -- + (graph_scan_coalesced, _) + = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 + + -- color the trivially colorable nodes + -- during scanning, keys of triv nodes were added to the front of the list as they were found + -- this colors them in the reverse order, as required by the algorithm. + (graph_triv, ksNoTriv) + = assignColors colors graph_scan_coalesced ksTriv + + -- try and color the problem nodes + -- problem nodes are the ones that were left uncolored because they weren't triv. + -- theres a change we can color them here anyway. + (graph_prob, ksNoColor) + = assignColors colors graph_triv ksProblems + + -- if the trivially colorable nodes didn't color then something is probably wrong + -- with the provided triv function. + -- + in if not $ null ksNoTriv + then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty + ( empty + $$ text "ksTriv = " <> ppr ksTriv + $$ text "ksNoTriv = " <> ppr ksNoTriv + $$ text "colors = " <> ppr colors + $$ empty + $$ dotGraph (\_ -> text "white") triv graph_triv) + + else ( graph_prob + , mkUniqSet ksNoColor -- the nodes that didn't color (spills) + , if iterative + then (listToUFM kksCoalesce2) + else (listToUFM kksCoalesce1)) + + +-- | Scan through the conflict graph separating out trivially colorable and +-- potentially uncolorable (problem) nodes. +-- +-- Checking whether a node is trivially colorable or not is a reasonably expensive operation, +-- so after a triv node is found and removed from the graph it's no good to return to the 'start' +-- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. +-- +-- To ward against this, during each pass through the graph we collect up a list of triv nodes +-- that were found, and only remove them once we've finished the pass. The more nodes we can delete +-- at once the more likely it is that nodes we've already checked will become trivially colorable +-- for the next pass. +-- +-- TODO: add work lists to finding triv nodes is easier. +-- If we've just scanned the graph, and removed triv nodes, then the only +-- nodes that we need to rescan are the ones we've removed edges from. + +colorScan + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool -- ^ whether to do iterative coalescing + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to scan + + -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce + +colorScan iterative triv spill graph + = colorScan_spin iterative triv spill graph [] [] [] + +colorScan_spin + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) + +colorScan_spin iterative triv spill graph + ksTriv ksSpill kksCoalesce + + -- if the graph is empty then we're done + | isNullUFM $ graphMap graph + = (ksTriv, ksSpill, reverse kksCoalesce) + + -- Simplify: + -- Look for trivially colorable nodes. + -- If we can find some then remove them from the graph and go back for more. + -- + | nsTrivFound@(_:_) + <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + + -- for iterative coalescing we only want non-move related + -- nodes here + && (not iterative || isEmptyUniqSet (nodeCoalesce node))) + $ graph + + , ksTrivFound <- map nodeId nsTrivFound + , graph2 <- foldr (\k g -> let Just g' = delNode k g + in g') + graph ksTrivFound + + = colorScan_spin iterative triv spill graph2 + (ksTrivFound ++ ksTriv) + ksSpill + kksCoalesce + + -- Coalesce: + -- If we're doing iterative coalescing and no triv nodes are available + -- then it's time for a coalescing pass. + | iterative + = case coalesceGraph False triv graph of + + -- we were able to coalesce something + -- go back to Simplify and see if this frees up more nodes to be trivially colorable. + (graph2, kksCoalesceFound@(_:_)) + -> colorScan_spin iterative triv spill graph2 + ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) + + -- Freeze: + -- nothing could be coalesced (or was triv), + -- time to choose a node to freeze and give up on ever coalescing it. + (graph2, []) + -> case freezeOneInGraph graph2 of + + -- we were able to freeze something + -- hopefully this will free up something for Simplify + (graph3, True) + -> colorScan_spin iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- we couldn't find something to freeze either + -- time for a spill + (graph3, False) + -> colorScan_spill iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- spill time + | otherwise + = colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce + + +-- Select: +-- we couldn't find any triv nodes or things to freeze or coalesce, +-- and the graph isn't empty yet.. We'll have to choose a spill +-- candidate and leave it uncolored. +-- +colorScan_spill + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) + +colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce + + = let kSpill = spill graph + Just graph' = delNode kSpill graph + in colorScan_spin iterative triv spill graph' + ksTriv (kSpill : ksSpill) kksCoalesce + + +-- | Try to assign a color to all these nodes. + +assignColors + :: ( Uniquable k, Uniquable cls, Uniquable color + , Outputable cls) + => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> [k] -- ^ nodes to assign a color to. + -> ( Graph k cls color -- the colored graph + , [k]) -- the nodes that didn't color. + +assignColors colors graph ks + = assignColors' colors graph [] ks + + where assignColors' _ graph prob [] + = (graph, prob) + + assignColors' colors graph prob (k:ks) + = case assignColor colors k graph of + + -- couldn't color this node + Nothing -> assignColors' colors graph (k : prob) ks + + -- this node colored ok, so do the rest + Just graph' -> assignColors' colors graph' prob ks + + + assignColor colors u graph + | Just c <- selectColor colors graph u + = Just (setColor u c graph) + + | otherwise + = Nothing + + + +-- | Select a color for a certain node +-- taking into account preferences, neighbors and exclusions. +-- returns Nothing if no color can be assigned to this node. +-- +selectColor + :: ( Uniquable k, Uniquable cls, Uniquable color + , Outputable cls) + => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> k -- ^ key of the node to select a color for. + -> Maybe color + +selectColor colors graph u + = let -- lookup the node + Just node = lookupNode graph u + + -- lookup the available colors for the class of this node. + colors_avail + = case lookupUFM colors (nodeClass node) of + Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) + Just cs -> cs + + -- find colors we can't use because they're already being used + -- by a node that conflicts with this one. + Just nsConflicts + = sequence + $ map (lookupNode graph) + $ nonDetEltsUniqSet + $ nodeConflicts node + -- See Note [Unique Determinism and code generation] + + colors_conflict = mkUniqSet + $ catMaybes + $ map nodeColor nsConflicts + + -- the prefs of our neighbors + colors_neighbor_prefs + = mkUniqSet + $ concatMap nodePreference nsConflicts + + -- colors that are still valid for us + colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) + colors_ok = minusUniqSet colors_ok_ex colors_conflict + + -- the colors that we prefer, and are still ok + colors_ok_pref = intersectUniqSets + (mkUniqSet $ nodePreference node) colors_ok + + -- the colors that we could choose while being nice to our neighbors + colors_ok_nice = minusUniqSet + colors_ok colors_neighbor_prefs + + -- the best of all possible worlds.. + colors_ok_pref_nice + = intersectUniqSets + colors_ok_nice colors_ok_pref + + -- make the decision + chooseColor + + -- everyone is happy, yay! + | not $ isEmptyUniqSet colors_ok_pref_nice + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) + (nodePreference node) + = Just c + + -- we've got one of our preferences + | not $ isEmptyUniqSet colors_ok_pref + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) + (nodePreference node) + = Just c + + -- it wasn't a preference, but it was still ok + | not $ isEmptyUniqSet colors_ok + , c : _ <- nonDetEltsUniqSet colors_ok + -- See Note [Unique Determinism and code generation] + = Just c + + -- no colors were available for us this time. + -- looks like we're going around the loop again.. + | otherwise + = Nothing + + in chooseColor + + + diff --git a/compiler/GHC/Data/Graph/Ops.hs b/compiler/GHC/Data/Graph/Ops.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Data/Graph/Ops.hs @@ -0,0 +1,698 @@ +-- | Basic operations on graphs. +-- + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Data.Graph.Ops + ( addNode + , delNode + , getNode + , lookupNode + , modNode + + , size + , union + + , addConflict + , delConflict + , addConflicts + + , addCoalesce + , delCoalesce + + , addExclusion + , addExclusions + + , addPreference + , coalesceNodes + , coalesceGraph + , freezeNode + , freezeOneInGraph + , freezeAllInGraph + , scanGraph + , setColor + , validateGraph + , slurpNodeConflictCount + ) +where + +import GHC.Prelude + +import GHC.Data.Graph.Base + +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM + +import Data.List hiding (union) +import Data.Maybe + +-- | Lookup a node from the graph. +lookupNode + :: Uniquable k + => Graph k cls color + -> k -> Maybe (Node k cls color) + +lookupNode graph k + = lookupUFM (graphMap graph) k + + +-- | Get a node from the graph, throwing an error if it's not there +getNode + :: Uniquable k + => Graph k cls color + -> k -> Node k cls color + +getNode graph k + = case lookupUFM (graphMap graph) k of + Just node -> node + Nothing -> panic "ColorOps.getNode: not found" + + +-- | Add a node to the graph, linking up its edges +addNode :: Uniquable k + => k -> Node k cls color + -> Graph k cls color -> Graph k cls color + +addNode k node graph + = let + -- add back conflict edges from other nodes to this one + map_conflict = + nonDetFoldUniqSet + -- It's OK to use nonDetFoldUFM here because the + -- operation is commutative + (adjustUFM_C (\n -> n { nodeConflicts = + addOneToUniqSet (nodeConflicts n) k})) + (graphMap graph) + (nodeConflicts node) + + -- add back coalesce edges from other nodes to this one + map_coalesce = + nonDetFoldUniqSet + -- It's OK to use nonDetFoldUFM here because the + -- operation is commutative + (adjustUFM_C (\n -> n { nodeCoalesce = + addOneToUniqSet (nodeCoalesce n) k})) + map_conflict + (nodeCoalesce node) + + in graph + { graphMap = addToUFM map_coalesce k node} + + +-- | Delete a node and all its edges from the graph. +delNode :: (Uniquable k) + => k -> Graph k cls color -> Maybe (Graph k cls color) + +delNode k graph + | Just node <- lookupNode graph k + = let -- delete conflict edges from other nodes to this one. + graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph + $ nonDetEltsUniqSet (nodeConflicts node) + + -- delete coalesce edge from other nodes to this one. + graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 + $ nonDetEltsUniqSet (nodeCoalesce node) + -- See Note [Unique Determinism and code generation] + + -- delete the node + graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 + + in Just graph3 + + | otherwise + = Nothing + + +-- | Modify a node in the graph. +-- returns Nothing if the node isn't present. +-- +modNode :: Uniquable k + => (Node k cls color -> Node k cls color) + -> k -> Graph k cls color -> Maybe (Graph k cls color) + +modNode f k graph + = case lookupNode graph k of + Just Node{} + -> Just + $ graphMapModify + (\fm -> let Just node = lookupUFM fm k + node' = f node + in addToUFM fm k node') + graph + + Nothing -> Nothing + + +-- | Get the size of the graph, O(n) +size :: Graph k cls color -> Int + +size graph + = sizeUFM $ graphMap graph + + +-- | Union two graphs together. +union :: Graph k cls color -> Graph k cls color -> Graph k cls color + +union graph1 graph2 + = Graph + { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } + + +-- | Add a conflict between nodes to the graph, creating the nodes required. +-- Conflicts are virtual regs which need to be colored differently. +addConflict + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color + +addConflict (u1, c1) (u2, c2) + = let addNeighbor u c u' + = adjustWithDefaultUFM + (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) + (newNode u c) { nodeConflicts = unitUniqSet u' } + u + + in graphMapModify + ( addNeighbor u1 c1 u2 + . addNeighbor u2 c2 u1) + + +-- | Delete a conflict edge. k1 -> k2 +-- returns Nothing if the node isn't in the graph +delConflict + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) + +delConflict k1 k2 + = modNode + (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) + k1 + + +-- | Add some conflicts to the graph, creating nodes if required. +-- All the nodes in the set are taken to conflict with each other. +addConflicts + :: Uniquable k + => UniqSet k -> (k -> cls) + -> Graph k cls color -> Graph k cls color + +addConflicts conflicts getClass + + -- just a single node, but no conflicts, create the node anyway. + | (u : []) <- nonDetEltsUniqSet conflicts + = graphMapModify + $ adjustWithDefaultUFM + id + (newNode u (getClass u)) + u + + | otherwise + = graphMapModify + $ \fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm + $ nonDetEltsUniqSet conflicts + -- See Note [Unique Determinism and code generation] + + +addConflictSet1 :: Uniquable k + => k -> (k -> cls) -> UniqSet k + -> UniqFM (Node k cls color) + -> UniqFM (Node k cls color) +addConflictSet1 u getClass set + = case delOneFromUniqSet set u of + set' -> adjustWithDefaultUFM + (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) + (newNode u (getClass u)) { nodeConflicts = set' } + u + + +-- | Add an exclusion to the graph, creating nodes if required. +-- These are extra colors that the node cannot use. +addExclusion + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> color + -> Graph k cls color -> Graph k cls color + +addExclusion u getClass color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) + (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } + u + +addExclusions + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> [color] + -> Graph k cls color -> Graph k cls color + +addExclusions u getClass colors graph + = foldr (addExclusion u getClass) graph colors + + +-- | Add a coalescence edge to the graph, creating nodes if required. +-- It is considered adventageous to assign the same color to nodes in a coalesence. +addCoalesce + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color + +addCoalesce (u1, c1) (u2, c2) + = let addCoalesce u c u' + = adjustWithDefaultUFM + (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) + (newNode u c) { nodeCoalesce = unitUniqSet u' } + u + + in graphMapModify + ( addCoalesce u1 c1 u2 + . addCoalesce u2 c2 u1) + + +-- | Delete a coalescence edge (k1 -> k2) from the graph. +delCoalesce + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) + +delCoalesce k1 k2 + = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) + k1 + + +-- | Add a color preference to the graph, creating nodes if required. +-- The most recently added preference is the most preferred. +-- The algorithm tries to assign a node it's preferred color if possible. +-- +addPreference + :: Uniquable k + => (k, cls) -> color + -> Graph k cls color -> Graph k cls color + +addPreference (u, c) color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodePreference = color : (nodePreference node) }) + (newNode u c) { nodePreference = [color] } + u + + +-- | Do aggressive coalescing on this graph. +-- returns the new graph and the list of pairs of nodes that got coalesced together. +-- for each pair, the resulting node will have the least key and be second in the pair. +-- +coalesceGraph + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> ( Graph k cls color + , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the + -- coalescing was applied. + +coalesceGraph aggressive triv graph + = coalesceGraph' aggressive triv graph [] + +coalesceGraph' + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> [(k, k)] + -> ( Graph k cls color + , [(k, k)]) +coalesceGraph' aggressive triv graph kkPairsAcc + = let + -- find all the nodes that have coalescence edges + cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) + $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + + -- build a list of pairs of keys for node's we'll try and coalesce + -- every pair of nodes will appear twice in this list + -- ie [(k1, k2), (k2, k1) ... ] + -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for + -- build a list of what nodes get coalesced together for later on. + -- + cList = [ (nodeId node1, k2) + | node1 <- cNodes + , k2 <- nonDetEltsUniqSet $ nodeCoalesce node1 ] + -- See Note [Unique Determinism and code generation] + + -- do the coalescing, returning the new graph and a list of pairs of keys + -- that got coalesced together. + (graph', mPairs) + = mapAccumL (coalesceNodes aggressive triv) graph cList + + -- keep running until there are no more coalesces can be found + in case catMaybes mPairs of + [] -> (graph', reverse kkPairsAcc) + pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) + + +-- | Coalesce this pair of nodes unconditionally \/ aggressively. +-- The resulting node is the one with the least key. +-- +-- returns: Just the pair of keys if the nodes were coalesced +-- the second element of the pair being the least one +-- +-- Nothing if either of the nodes weren't in the graph + +coalesceNodes + :: (Uniquable k, Ord k, Eq cls) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> (k, k) -- ^ keys of the nodes to be coalesced + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes aggressive triv graph (k1, k2) + | (kMin, kMax) <- if k1 < k2 + then (k1, k2) + else (k2, k1) + + -- the nodes being coalesced must be in the graph + , Just nMin <- lookupNode graph kMin + , Just nMax <- lookupNode graph kMax + + -- can't coalesce conflicting modes + , not $ elementOfUniqSet kMin (nodeConflicts nMax) + , not $ elementOfUniqSet kMax (nodeConflicts nMin) + + -- can't coalesce the same node + , nodeId nMin /= nodeId nMax + + = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax + + -- don't do the coalescing after all + | otherwise + = (graph, Nothing) + +coalesceNodes_merge + :: (Uniquable k, Eq cls) + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax + + -- sanity checks + | nodeClass nMin /= nodeClass nMax + = error "GHC.Data.Graph.Ops.coalesceNodes: can't coalesce nodes of different classes." + + | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) + = error "GHC.Data.Graph.Ops.coalesceNodes: can't coalesce colored nodes." + + --- + | otherwise + = let + -- the new node gets all the edges from its two components + node = + Node { nodeId = kMin + , nodeClass = nodeClass nMin + , nodeColor = Nothing + + -- nodes don't conflict with themselves.. + , nodeConflicts + = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + + , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) + , nodePreference = nodePreference nMin ++ nodePreference nMax + + -- nodes don't coalesce with themselves.. + , nodeCoalesce + = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + } + + in coalesceNodes_check aggressive triv graph kMin kMax node + +coalesceNodes_check + :: Uniquable k + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes_check aggressive triv graph kMin kMax node + + -- Unless we're coalescing aggressively, if the result node is not trivially + -- colorable then don't do the coalescing. + | not aggressive + , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + = (graph, Nothing) + + | otherwise + = let -- delete the old nodes from the graph and add the new one + Just graph1 = delNode kMax graph + Just graph2 = delNode kMin graph1 + graph3 = addNode kMin node graph2 + + in (graph3, Just (kMax, kMin)) + + +-- | Freeze a node +-- This is for the iterative coalescer. +-- By freezing a node we give up on ever coalescing it. +-- Move all its coalesce edges into the frozen set - and update +-- back edges from other nodes. +-- +freezeNode + :: Uniquable k + => k -- ^ key of the node to freeze + -> Graph k cls color -- ^ the graph + -> Graph k cls color -- ^ graph with that node frozen + +freezeNode k + = graphMapModify + $ \fm -> + let -- freeze all the edges in the node to be frozen + Just node = lookupUFM fm k + node' = node + { nodeCoalesce = emptyUniqSet } + + fm1 = addToUFM fm k node' + + -- update back edges pointing to this node + freezeEdge k node + = if elementOfUniqSet k (nodeCoalesce node) + then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } + else node -- panic "GHC.Data.Graph.Ops.freezeNode: edge to freeze wasn't in the coalesce set" + -- If the edge isn't actually in the coelesce set then just ignore it. + + fm2 = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1 + -- It's OK to use nonDetFoldUFM here because the operation + -- is commutative + $ nodeCoalesce node + + in fm2 + + +-- | Freeze one node in the graph +-- This if for the iterative coalescer. +-- Look for a move related node of low degree and freeze it. +-- +-- We probably don't need to scan the whole graph looking for the node of absolute +-- lowest degree. Just sample the first few and choose the one with the lowest +-- degree out of those. Also, we don't make any distinction between conflicts of different +-- classes.. this is just a heuristic, after all. +-- +-- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv +-- right here, and add it to a worklist if known triv\/non-move nodes. +-- +freezeOneInGraph + :: (Uniquable k) + => Graph k cls color + -> ( Graph k cls color -- the new graph + , Bool ) -- whether we found a node to freeze + +freezeOneInGraph graph + = let compareNodeDegree n1 n2 + = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) + + candidates + = sortBy compareNodeDegree + $ take 5 -- 5 isn't special, it's just a small number. + $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph + + in case candidates of + + -- there wasn't anything available to freeze + [] -> (graph, False) + + -- we found something to freeze + (n : _) + -> ( freezeNode (nodeId n) graph + , True) + + +-- | Freeze all the nodes in the graph +-- for debugging the iterative allocator. +-- +freezeAllInGraph + :: (Uniquable k) + => Graph k cls color + -> Graph k cls color + +freezeAllInGraph graph + = foldr freezeNode graph + $ map nodeId + $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + + +-- | Find all the nodes in the graph that meet some criteria +-- +scanGraph + :: (Node k cls color -> Bool) + -> Graph k cls color + -> [Node k cls color] + +scanGraph match graph + = filter match $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + + +-- | validate the internal structure of a graph +-- all its edges should point to valid nodes +-- If they don't then throw an error +-- +validateGraph + :: (Uniquable k, Outputable k, Eq color) + => SDoc -- ^ extra debugging info to display on error + -> Bool -- ^ whether this graph is supposed to be colored. + -> Graph k cls color -- ^ graph to validate + -> Graph k cls color -- ^ validated graph + +validateGraph doc isColored graph + + -- Check that all edges point to valid nodes. + | edges <- unionManyUniqSets + ( (map nodeConflicts $ nonDetEltsUFM $ graphMap graph) + ++ (map nodeCoalesce $ nonDetEltsUFM $ graphMap graph)) + + , nodes <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph + , badEdges <- minusUniqSet edges nodes + , not $ isEmptyUniqSet badEdges + = pprPanic "GHC.Data.Graph.Ops.validateGraph" + ( text "Graph has edges that point to non-existent nodes" + $$ text " bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr) + $$ doc ) + + -- Check that no conflicting nodes have the same color + | badNodes <- filter (not . (checkNode graph)) + $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + , not $ null badNodes + = pprPanic "GHC.Data.Graph.Ops.validateGraph" + ( text "Node has same color as one of it's conflicts" + $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc) + + -- If this is supposed to be a colored graph, + -- check that all nodes have a color. + | isColored + , badNodes <- filter (\n -> isNothing $ nodeColor n) + $ nonDetEltsUFM $ graphMap graph + , not $ null badNodes + = pprPanic "GHC.Data.Graph.Ops.validateGraph" + ( text "Supposably colored graph has uncolored nodes." + $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc ) + + + -- graph looks ok + | otherwise + = graph + + +-- | If this node is colored, check that all the nodes which +-- conflict with it have different colors. +checkNode + :: (Uniquable k, Eq color) + => Graph k cls color + -> Node k cls color + -> Bool -- ^ True if this node is ok + +checkNode graph node + | Just color <- nodeColor node + , Just neighbors <- sequence $ map (lookupNode graph) + $ nonDetEltsUniqSet $ nodeConflicts node + -- See Note [Unique Determinism and code generation] + + , neighbourColors <- catMaybes $ map nodeColor neighbors + , elem color neighbourColors + = False + + | otherwise + = True + + + +-- | Slurp out a map of how many nodes had a certain number of conflict neighbours + +slurpNodeConflictCount + :: Graph k cls color + -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) + +slurpNodeConflictCount graph + = addListToUFM_C + (\(c1, n1) (_, n2) -> (c1, n1 + n2)) + emptyUFM + $ map (\node + -> let count = sizeUniqSet $ nodeConflicts node + in (count, (count, 1))) + $ nonDetEltsUFM + -- See Note [Unique Determinism and code generation] + $ graphMap graph + + +-- | Set the color of a certain node +setColor + :: Uniquable k + => k -> color + -> Graph k cls color -> Graph k cls color + +setColor u color + = graphMapModify + $ adjustUFM_C + (\n -> n { nodeColor = Just color }) + u + + +{-# INLINE adjustWithDefaultUFM #-} +adjustWithDefaultUFM + :: Uniquable k + => (a -> a) -> a -> k + -> UniqFM a -> UniqFM a + +adjustWithDefaultUFM f def k map + = addToUFM_C + (\old _ -> f old) + map + k def + +-- Argument order different from UniqFM's adjustUFM +{-# INLINE adjustUFM_C #-} +adjustUFM_C + :: Uniquable k + => (a -> a) + -> k -> UniqFM a -> UniqFM a + +adjustUFM_C f k map + = case lookupUFM map k of + Nothing -> map + Just a -> addToUFM map k (f a) + diff --git a/compiler/GHC/Data/Graph/Ppr.hs b/compiler/GHC/Data/Graph/Ppr.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Data/Graph/Ppr.hs @@ -0,0 +1,173 @@ + +-- | Pretty printing of graphs. + +module GHC.Data.Graph.Ppr + ( dumpGraph + , dotGraph + ) +where + +import GHC.Prelude + +import GHC.Data.Graph.Base + +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM + +import Data.List (mapAccumL) +import Data.Maybe + + +-- | Pretty print a graph in a somewhat human readable format. +dumpGraph + :: (Outputable k, Outputable color) + => Graph k cls color -> SDoc + +dumpGraph graph + = text "Graph" + $$ pprUFM (graphMap graph) (vcat . map dumpNode) + +dumpNode + :: (Outputable k, Outputable color) + => Node k cls color -> SDoc + +dumpNode node + = text "Node " <> ppr (nodeId node) + $$ text "conflicts " + <> parens (int (sizeUniqSet $ nodeConflicts node)) + <> text " = " + <> ppr (nodeConflicts node) + + $$ text "exclusions " + <> parens (int (sizeUniqSet $ nodeExclusions node)) + <> text " = " + <> ppr (nodeExclusions node) + + $$ text "coalesce " + <> parens (int (sizeUniqSet $ nodeCoalesce node)) + <> text " = " + <> ppr (nodeCoalesce node) + + $$ space + + + +-- | Pretty print a graph in graphviz .dot format. +-- Conflicts get solid edges. +-- Coalescences get dashed edges. +dotGraph + :: ( Uniquable k + , Outputable k, Outputable cls, Outputable color) + => (color -> SDoc) -- ^ What graphviz color to use for each node color + -- It's usually safe to return X11 style colors here, + -- ie "red", "green" etc or a hex triplet #aaff55 etc + -> Triv k cls color + -> Graph k cls color -> SDoc + +dotGraph colorMap triv graph + = let nodes = nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + in vcat + ( [ text "graph G {" ] + ++ map (dotNode colorMap triv) nodes + ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes) + ++ [ text "}" + , space ]) + + +dotNode :: ( Outputable k, Outputable cls, Outputable color) + => (color -> SDoc) + -> Triv k cls color + -> Node k cls color -> SDoc + +dotNode colorMap triv node + = let name = ppr $ nodeId node + cls = ppr $ nodeClass node + + excludes + = hcat $ punctuate space + $ map (\n -> text "-" <> ppr n) + $ nonDetEltsUniqSet $ nodeExclusions node + -- See Note [Unique Determinism and code generation] + + preferences + = hcat $ punctuate space + $ map (\n -> text "+" <> ppr n) + $ nodePreference node + + expref = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)] + then empty + else text "\\n" <> (excludes <+> preferences) + + -- if the node has been colored then show that, + -- otherwise indicate whether it looks trivially colorable. + color + | Just c <- nodeColor node + = text "\\n(" <> ppr c <> text ")" + + | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + = text "\\n(" <> text "triv" <> text ")" + + | otherwise + = text "\\n(" <> text "spill?" <> text ")" + + label = name <> text " :: " <> cls + <> expref + <> color + + pcolorC = case nodeColor node of + Nothing -> text "style=filled fillcolor=white" + Just c -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c) + + + pout = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]" + <> space <> doubleQuotes name + <> text ";" + + in pout + + +-- | Nodes in the graph are doubly linked, but we only want one edge for each +-- conflict if the graphviz graph. Traverse over the graph, but make sure +-- to only print the edges for each node once. + +dotNodeEdges + :: ( Uniquable k + , Outputable k) + => UniqSet k + -> Node k cls color + -> (UniqSet k, Maybe SDoc) + +dotNodeEdges visited node + | elementOfUniqSet (nodeId node) visited + = ( visited + , Nothing) + + | otherwise + = let dconflicts + = map (dotEdgeConflict (nodeId node)) + $ nonDetEltsUniqSet + -- See Note [Unique Determinism and code generation] + $ minusUniqSet (nodeConflicts node) visited + + dcoalesces + = map (dotEdgeCoalesce (nodeId node)) + $ nonDetEltsUniqSet + -- See Note [Unique Determinism and code generation] + $ minusUniqSet (nodeCoalesce node) visited + + out = vcat dconflicts + $$ vcat dcoalesces + + in ( addOneToUniqSet visited (nodeId node) + , Just out) + + where dotEdgeConflict u1 u2 + = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) + <> text ";" + + dotEdgeCoalesce u1 u2 + = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) + <> space <> text "[ style = dashed ];" diff --git a/compiler/GHC/Data/Graph/UnVar.hs b/compiler/GHC/Data/Graph/UnVar.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Data/Graph/UnVar.hs @@ -0,0 +1,145 @@ +{- + +Copyright (c) 2014 Joachim Breitner + +A data structure for undirected graphs of variables +(or in plain terms: Sets of unordered pairs of numbers) + + +This is very specifically tailored for the use in CallArity. In particular it +stores the graph as a union of complete and complete bipartite graph, which +would be very expensive to store as sets of edges or as adjanceny lists. + +It does not normalize the graphs. This means that g `unionUnVarGraph` g is +equal to g, but twice as expensive and large. + +-} +module GHC.Data.Graph.UnVar + ( UnVarSet + , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets + , delUnVarSet + , elemUnVarSet, isEmptyUnVarSet + , UnVarGraph + , emptyUnVarGraph + , unionUnVarGraph, unionUnVarGraphs + , completeGraph, completeBipartiteGraph + , neighbors + , hasLoopAt + , delNode + ) where + +import GHC.Prelude + +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Unique.FM +import GHC.Utils.Outputable +import GHC.Data.Bag +import GHC.Types.Unique + +import qualified Data.IntSet as S + +-- We need a type for sets of variables (UnVarSet). +-- We do not use VarSet, because for that we need to have the actual variable +-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet. +-- Therefore, use a IntSet directly (which is likely also a bit more efficient). + +-- Set of uniques, i.e. for adjancet nodes +newtype UnVarSet = UnVarSet (S.IntSet) + deriving Eq + +k :: Var -> Int +k v = getKey (getUnique v) + +emptyUnVarSet :: UnVarSet +emptyUnVarSet = UnVarSet S.empty + +elemUnVarSet :: Var -> UnVarSet -> Bool +elemUnVarSet v (UnVarSet s) = k v `S.member` s + + +isEmptyUnVarSet :: UnVarSet -> Bool +isEmptyUnVarSet (UnVarSet s) = S.null s + +delUnVarSet :: UnVarSet -> Var -> UnVarSet +delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s + +mkUnVarSet :: [Var] -> UnVarSet +mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs + +varEnvDom :: VarEnv a -> UnVarSet +varEnvDom ae = UnVarSet $ ufmToSet_Directly ae + +unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet +unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2) + +unionUnVarSets :: [UnVarSet] -> UnVarSet +unionUnVarSets = foldr unionUnVarSet emptyUnVarSet + +instance Outputable UnVarSet where + ppr (UnVarSet s) = braces $ + hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s] + + +-- The graph type. A list of complete bipartite graphs +data Gen = CBPG UnVarSet UnVarSet -- complete bipartite + | CG UnVarSet -- complete +newtype UnVarGraph = UnVarGraph (Bag Gen) + +emptyUnVarGraph :: UnVarGraph +emptyUnVarGraph = UnVarGraph emptyBag + +unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph +{- +Premature optimisation, it seems. +unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) + | s1 == s3 && s2 == s4 + = pprTrace "unionUnVarGraph fired" empty $ + completeGraph (s1 `unionUnVarSet` s2) +unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) + | s2 == s3 && s1 == s4 + = pprTrace "unionUnVarGraph fired2" empty $ + completeGraph (s1 `unionUnVarSet` s2) +-} +unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2) + = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $ + UnVarGraph (g1 `unionBags` g2) + +unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph +unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph + +-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B } +completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph +completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2 + +completeGraph :: UnVarSet -> UnVarGraph +completeGraph s = prune $ UnVarGraph $ unitBag $ CG s + +neighbors :: UnVarGraph -> Var -> UnVarSet +neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g + where go (CG s) = (if v `elemUnVarSet` s then [s] else []) + go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++ + (if v `elemUnVarSet` s2 then [s1] else []) + +-- hasLoopAt G v <=> v--v ∈ G +hasLoopAt :: UnVarGraph -> Var -> Bool +hasLoopAt (UnVarGraph g) v = any go $ bagToList g + where go (CG s) = v `elemUnVarSet` s + go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2 + + +delNode :: UnVarGraph -> Var -> UnVarGraph +delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g + where go (CG s) = CG (s `delUnVarSet` v) + go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v) + +prune :: UnVarGraph -> UnVarGraph +prune (UnVarGraph g) = UnVarGraph $ filterBag go g + where go (CG s) = not (isEmptyUnVarSet s) + go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2) + +instance Outputable Gen where + ppr (CG s) = ppr s <> char '²' + ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2 +instance Outputable UnVarGraph where + ppr (UnVarGraph g) = ppr g diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -18,43 +18,42 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -- In a separate module because it hooks into the parser. import GHC.Driver.Backpack.Syntax -import ApiAnnotation +import GHC.Parser.Annotation import GHC hiding (Failed, Succeeded) -import GHC.Driver.Packages -import Parser -import Lexer +import GHC.Parser +import GHC.Parser.Lexer import GHC.Driver.Monad import GHC.Driver.Session -import TcRnMonad -import TcRnDriver -import GHC.Types.Module +import GHC.Tc.Utils.Monad +import GHC.Tc.Module +import GHC.Unit import GHC.Driver.Types -import StringBuffer -import FastString -import ErrUtils +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Utils.Error import GHC.Types.SrcLoc import GHC.Driver.Main import GHC.Types.Unique.FM import GHC.Types.Unique.DFM -import Outputable -import Maybes -import HeaderInfo +import GHC.Utils.Outputable +import GHC.Data.Maybe +import GHC.Parser.Header import GHC.Iface.Recomp import GHC.Driver.Make import GHC.Types.Unique.DSet -import PrelNames +import GHC.Builtin.Names import GHC.Types.Basic hiding (SuccessFlag(..)) import GHC.Driver.Finder -import Util +import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt -import Panic +import GHC.Utils.Panic import Data.List ( partition ) import System.Exit import Control.Monad @@ -88,7 +87,7 @@ -- OK, so we have an LHsUnit PackageName, but we want an -- LHsUnit HsComponentId. So let's rename it. let pkgstate = pkgState dflags - let bkp = renameHsUnits pkgstate (packageNameMap pkgstate pkgname_bkp) pkgname_bkp + let bkp = renameHsUnits pkgstate (bkpPackageNameMap pkgstate pkgname_bkp) pkgname_bkp initBkpM src_filename bkp $ forM_ (zip [1..] bkp) $ \(i, lunit) -> do let comp_name = unLoc (hsunitName (unLoc lunit)) @@ -96,14 +95,14 @@ innerBkpM $ do let (cid, insts) = computeUnitId lunit if null insts - then if cid == ComponentId (fsLit "main") Nothing + then if cid == Indefinite (UnitId (fsLit "main")) Nothing then compileExe lunit else compileUnit cid [] else typecheckUnit cid insts doBackpack _ = throwGhcException (CmdLineError "--backpack can only process a single file") -computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)]) +computeUnitId :: LHsUnit HsComponentId -> (IndefUnitId, [(ModuleName, Module)]) computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ]) where cid = hsComponentId (unLoc (hsunitName unit)) @@ -112,7 +111,7 @@ get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) = - unitIdFreeHoles (convertHsUnitId hsuid) + unitFreeModuleHoles (convertHsComponentId hsuid) -- | Tiny enum for all types of Backpack operations we may do. data SessionType @@ -129,17 +128,17 @@ -- | Create a temporary Session to do some sort of type checking or -- compilation. -withBkpSession :: ComponentId +withBkpSession :: IndefUnitId -> [(ModuleName, Module)] - -> [(UnitId, ModRenaming)] + -> [(Unit, ModRenaming)] -> SessionType -- what kind of session are we doing -> BkpM a -- actual action to run -> BkpM a withBkpSession cid insts deps session_type do_this = do dflags <- getDynFlags - let (ComponentId cid_fs _) = cid + let cid_fs = unitIdFS (indefUnit cid) is_primary = False - uid_str = unpackFS (hashUnitId cid insts) + uid_str = unpackFS (mkInstantiatedUnitHash cid insts) cid_str = unpackFS cid_fs -- There are multiple units in a single Backpack file, so we -- need to separate out the results in those cases. Right now, @@ -174,12 +173,12 @@ _ -> hscTarget dflags, thisUnitIdInsts_ = Just insts, thisComponentId_ = Just cid, - thisInstalledUnitId = + thisUnitId = case session_type of - TcSession -> newInstalledUnitId cid Nothing + TcSession -> newUnitId cid Nothing -- No hash passed if no instances - _ | null insts -> newInstalledUnitId cid Nothing - | otherwise -> newInstalledUnitId cid (Just (hashUnitId cid insts)), + _ | null insts -> newUnitId cid Nothing + | otherwise -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts)), -- Setup all of the output directories according to our hierarchy objectDir = Just (outdir objectDir), hiDir = Just (outdir hiDir), @@ -192,7 +191,7 @@ importPaths = [], -- Synthesized the flags packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> - let uid = unwireUnitId dflags (improveUnitId (getUnitInfoMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0) + let uid = unwireUnit dflags (improveUnit (unitInfoMap (pkgState dflags)) $ renameHoleUnit (pkgState dflags) (listToUFM insts) uid0) in ExposePackage (showSDoc dflags (text "-unit-id" <+> ppr uid <+> ppr rn)) @@ -204,41 +203,41 @@ _ <- setSessionDynFlags dflags do_this -withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a +withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a withBkpExeSession deps do_this = do - withBkpSession (ComponentId (fsLit "main") Nothing) [] deps ExeSession do_this + withBkpSession (Indefinite (UnitId (fsLit "main")) Nothing) [] deps ExeSession do_this -getSource :: ComponentId -> BkpM (LHsUnit HsComponentId) +getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId) getSource cid = do bkp_env <- getBkpEnv case Map.lookup cid (bkp_table bkp_env) of Nothing -> pprPanic "missing needed dependency" (ppr cid) Just lunit -> return lunit -typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM () +typecheckUnit :: IndefUnitId -> [(ModuleName, Module)] -> BkpM () typecheckUnit cid insts = do lunit <- getSource cid buildUnit TcSession cid insts lunit -compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM () +compileUnit :: IndefUnitId -> [(ModuleName, Module)] -> BkpM () compileUnit cid insts = do - -- Let everyone know we're building this unit ID - msgUnitId (newUnitId cid insts) + -- Let everyone know we're building this unit + msgUnitId (mkVirtUnit cid insts) lunit <- getSource cid buildUnit CompSession cid insts lunit -- | Compute the dependencies with instantiations of a syntactic -- HsUnit; e.g., wherever you see @dependency p[A=]@ in a --- unit file, return the 'UnitId' corresponding to @p[A=]@. +-- unit file, return the 'Unit' corresponding to @p[A=]@. -- The @include_sigs@ parameter controls whether or not we also -- include @dependency signature@ declarations in this calculation. -- --- Invariant: this NEVER returns InstalledUnitId. -hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)] +-- Invariant: this NEVER returns UnitId. +hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(Unit, ModRenaming)] hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit) where get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig))) - | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)] + | include_sigs || not is_sig = [(convertHsComponentId hsuid, go mb_lrn)] | otherwise = [] where go Nothing = ModRenaming True [] @@ -248,7 +247,7 @@ convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to) get_dep _ = [] -buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () +buildUnit :: SessionType -> IndefUnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () buildUnit session cid insts lunit = do -- NB: include signature dependencies ONLY when typechecking. -- If we're compiling, it's not necessary to recursively @@ -260,7 +259,7 @@ -- The compilation dependencies are just the appropriately filled -- in unit IDs which must be compiled before we can compile. let hsubst = listToUFM insts - deps0 = map (renameHoleUnitId dflags hsubst) raw_deps + deps0 = map (renameHoleUnit (pkgState dflags) hsubst) raw_deps -- Build dependencies OR make sure they make sense. BUT NOTE, -- we can only check the ones that are fully filled; the rest @@ -273,7 +272,7 @@ dflags <- getDynFlags -- IMPROVE IT - let deps = map (improveUnitId (getUnitInfoMap dflags)) deps0 + let deps = map (improveUnit (unitInfoMap (pkgState dflags))) deps0 mb_old_eps <- case session of TcSession -> fmap Just getEpsGhc @@ -304,56 +303,56 @@ getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) obj_files = concatMap getOfiles linkables - let compat_fs = (case cid of ComponentId fs _ -> fs) + let compat_fs = unitIdFS (indefUnit cid) compat_pn = PackageName compat_fs - return InstalledPackageInfo { + return GenericUnitInfo { -- Stub data - abiHash = "", - sourcePackageId = SourcePackageId compat_fs, - packageName = compat_pn, - packageVersion = makeVersion [0], - unitId = toInstalledUnitId (thisPackage dflags), - sourceLibName = Nothing, - componentId = cid, - instantiatedWith = insts, + unitAbiHash = "", + unitPackageId = PackageId compat_fs, + unitPackageName = compat_pn, + unitPackageVersion = makeVersion [], + unitId = toUnitId (thisPackage dflags), + unitComponentName = Nothing, + unitInstanceOf = cid, + unitInstantiations = insts, -- Slight inefficiency here haha - exposedModules = map (\(m,n) -> (m,Just n)) mods, - hiddenModules = [], -- TODO: doc only - depends = case session of + unitExposedModules = map (\(m,n) -> (m,Just n)) mods, + unitHiddenModules = [], -- TODO: doc only + unitDepends = case session of -- Technically, we should state that we depend -- on all the indefinite libraries we used to -- typecheck this. However, this field isn't -- really used for anything, so we leave it -- blank for now. TcSession -> [] - _ -> map (toInstalledUnitId . unwireUnitId dflags) - $ deps ++ [ moduleUnitId mod + _ -> map (toUnitId . unwireUnit dflags) + $ deps ++ [ moduleUnit mod | (_, mod) <- insts , not (isHoleModule mod) ], - abiDepends = [], - ldOptions = case session of - TcSession -> [] - _ -> obj_files, - importDirs = [ hi_dir ], - exposed = False, - indefinite = case session of - TcSession -> True - _ -> False, + unitAbiDepends = [], + unitLinkerOptions = case session of + TcSession -> [] + _ -> obj_files, + unitImportDirs = [ hi_dir ], + unitIsExposed = False, + unitIsIndefinite = case session of + TcSession -> True + _ -> False, -- nope - hsLibraries = [], - extraLibraries = [], - extraGHCiLibraries = [], - libraryDynDirs = [], - libraryDirs = [], - frameworks = [], - frameworkDirs = [], - ccOptions = [], - includes = [], - includeDirs = [], - haddockInterfaces = [], - haddockHTMLs = [], - trusted = False + unitLibraries = [], + unitExtDepLibsSys = [], + unitExtDepLibsGhc = [], + unitLibraryDynDirs = [], + unitLibraryDirs = [], + unitExtDepFrameworks = [], + unitExtDepFrameworkDirs = [], + unitCcOptions = [], + unitIncludes = [], + unitIncludeDirs = [], + unitHaddockInterfaces = [], + unitHaddockHTMLs = [], + unitIsTrusted = False } @@ -391,21 +390,18 @@ _ <- GHC.setSessionDynFlags (dflags { pkgDatabase = Just (dbs ++ [newdb]) }) return () --- Precondition: UnitId is NOT InstalledUnitId -compileInclude :: Int -> (Int, UnitId) -> BkpM () +compileInclude :: Int -> (Int, Unit) -> BkpM () compileInclude n (i, uid) = do hsc_env <- getSession let dflags = hsc_dflags hsc_env msgInclude (i, n) uid -- Check if we've compiled it already - case lookupUnit dflags uid of - Nothing -> do - case splitUnitIdInsts uid of - (_, Just indef) -> - innerBkpM $ compileUnit (indefUnitIdComponentId indef) - (indefUnitIdInsts indef) - _ -> return () - Just _ -> return () + case uid of + HoleUnit -> return () + RealUnit _ -> return () + VirtUnit i -> case lookupUnit dflags uid of + Nothing -> innerBkpM $ compileUnit (instUnitInstanceOf i) (instUnitInsts i) + Just _ -> return () -- ---------------------------------------------------------------------------- -- Backpack monad @@ -423,7 +419,7 @@ -- | The filename of the bkp file we're compiling bkp_filename :: FilePath, -- | Table of source units which we know how to compile - bkp_table :: Map ComponentId (LHsUnit HsComponentId), + bkp_table :: Map IndefUnitId (LHsUnit HsComponentId), -- | When a package we are compiling includes another package -- which has not been compiled, we bump the level and compile -- that. @@ -535,7 +531,7 @@ $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn -- | Message when we instantiate a Backpack unit. -msgUnitId :: UnitId -> BkpM () +msgUnitId :: Unit -> BkpM () msgUnitId pk = do dflags <- getDynFlags level <- getBkpLevel @@ -545,7 +541,7 @@ (ppr pk) -- | Message when we include a Backpack unit. -msgInclude :: (Int,Int) -> UnitId -> BkpM () +msgInclude :: (Int,Int) -> Unit -> BkpM () msgInclude (i,n) uid = do dflags <- getDynFlags level <- getBkpLevel @@ -563,10 +559,10 @@ -- to use this for anything unitDefines :: PackageState -> LHsUnit PackageName -> (PackageName, HsComponentId) unitDefines pkgstate (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) }) - = (pn, HsComponentId pn (mkComponentId pkgstate fs)) + = (pn, HsComponentId pn (mkIndefUnitId pkgstate fs)) -packageNameMap :: PackageState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId -packageNameMap pkgstate units = Map.fromList (map (unitDefines pkgstate) units) +bkpPackageNameMap :: PackageState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId +bkpPackageNameMap pkgstate units = Map.fromList (map (unitDefines pkgstate) units) renameHsUnits :: PackageState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId] renameHsUnits pkgstate m units = map (fmap renameHsUnit) units @@ -609,16 +605,16 @@ renameHsModuleId (HsModuleVar lm) = HsModuleVar lm renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm -convertHsUnitId :: HsUnitId HsComponentId -> UnitId -convertHsUnitId (HsUnitId (L _ hscid) subst) - = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst) +convertHsComponentId :: HsUnitId HsComponentId -> Unit +convertHsComponentId (HsUnitId (L _ hscid) subst) + = mkVirtUnit (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst) convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module) convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m) convertHsModuleId :: HsModuleId HsComponentId -> Module convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname -convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname +convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsComponentId hsuid) modname @@ -824,8 +820,7 @@ -- | Create a new, externally provided hashed unit id from -- a hash. -newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId -newInstalledUnitId (ComponentId cid_fs _) (Just fs) - = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs) -newInstalledUnitId (ComponentId cid_fs _) Nothing - = InstalledUnitId cid_fs +newUnitId :: IndefUnitId -> Maybe FastString -> UnitId +newUnitId uid mhash = case mhash of + Nothing -> indefUnit uid + Just hash -> UnitId (unitIdFS (indefUnit uid) `appendFS` mkFastString "+" `appendFS` hash) 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 @@ -15,7 +15,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm ( nativeCodeGen ) import GHC.CmmToLlvm ( llvmCodeGen ) @@ -25,18 +25,17 @@ import GHC.Driver.Finder ( mkStubPaths ) import GHC.CmmToC ( writeC ) import GHC.Cmm.Lint ( cmmLint ) -import GHC.Driver.Packages import GHC.Cmm ( RawCmmGroup ) import GHC.Cmm.CLabel import GHC.Driver.Types import GHC.Driver.Session -import Stream ( Stream ) -import qualified Stream -import FileCleanup +import GHC.Data.Stream ( Stream ) +import qualified GHC.Data.Stream as Stream +import GHC.SysTools.FileCleanup -import ErrUtils -import Outputable -import GHC.Types.Module +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Unit import GHC.Types.SrcLoc import GHC.Types.CostCentre @@ -60,7 +59,7 @@ -> ForeignStubs -> [(ForeignSrcLang, FilePath)] -- ^ additional files to be compiled with with the C compiler - -> [InstalledUnitId] + -> [UnitId] -> Stream IO RawCmmGroup a -- Compiled C-- -> IO (FilePath, (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), @@ -120,7 +119,7 @@ outputC :: DynFlags -> FilePath -> Stream IO RawCmmGroup a - -> [InstalledUnitId] + -> [UnitId] -> IO a outputC dflags filenm cmm_stream packages @@ -133,16 +132,16 @@ -- * -#include options from the cmdline and OPTIONS pragmas -- * the _stub.h file, if there is one. -- - let rts = getPackageDetails dflags rtsUnitId + let rts = unsafeGetUnitInfo dflags rtsUnitId - let cc_injects = unlines (map mk_include (includes rts)) + let cc_injects = unlines (map mk_include (unitIncludes rts)) mk_include h_file = case h_file of '"':_{-"-} -> "#include "++h_file '<':_ -> "#include "++h_file _ -> "#include \""++h_file++"\"" - let pkg_names = map installedUnitIdString packages + let pkg_names = map unitIdString packages doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") @@ -225,8 +224,8 @@ -- we need the #includes from the rts package for the stub files let rts_includes = - let rts_pkg = getPackageDetails dflags rtsUnitId in - concatMap mk_include (includes rts_pkg) + let rts_pkg = unsafeGetUnitInfo dflags rtsUnitId in + concatMap mk_include (unitIncludes rts_pkg) mk_include i = "#include \"" ++ i ++ "\"\n" -- wrapper code mentions the ffi_arg type, which comes from ffi.h @@ -277,10 +276,9 @@ -- module; -- | Generate code to initialise cost centres -profilingInitCode :: Module -> CollectedCCs -> SDoc -profilingInitCode this_mod (local_CCs, singleton_CCSs) - = sdocWithDynFlags $ \dflags -> - if not (gopt Opt_SccProfilingOn dflags) +profilingInitCode :: DynFlags -> Module -> CollectedCCs -> SDoc +profilingInitCode dflags this_mod (local_CCs, singleton_CCSs) + = if not (gopt Opt_SccProfilingOn dflags) then empty else vcat $ map emit_cc_decl local_CCs diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs --- a/compiler/GHC/Driver/Finder.hs +++ b/compiler/GHC/Driver/Finder.hs @@ -5,6 +5,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} module GHC.Driver.Finder ( flushFinderCaches, @@ -33,17 +34,16 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import GHC.Types.Module +import GHC.Unit import GHC.Driver.Types -import GHC.Driver.Packages -import FastString -import Util -import PrelNames ( gHC_PRIM ) +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Builtin.Names ( gHC_PRIM ) import GHC.Driver.Session -import Outputable -import Maybes ( expectJust ) +import GHC.Utils.Outputable as Outputable +import GHC.Data.Maybe ( expectJust ) import Data.IORef ( IORef, readIORef, atomicModifyIORef' ) import System.Directory @@ -76,7 +76,7 @@ where this_pkg = thisPackage (hsc_dflags hsc_env) fc_ref = hsc_FC hsc_env - is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True + is_ext mod _ | not (moduleUnit mod `unitIdEq` this_pkg) = True | otherwise = False addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO () @@ -135,8 +135,8 @@ findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult findExactModule hsc_env mod = let dflags = hsc_dflags hsc_env - in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags - then findInstalledHomeModule hsc_env (installedModuleName mod) + in if moduleUnit mod `unitIdEq` thisPackage dflags + then findInstalledHomeModule hsc_env (moduleName mod) else findPackageModule hsc_env mod -- ----------------------------------------------------------------------------- @@ -194,7 +194,7 @@ findLookupResult :: HscEnv -> LookupResult -> IO FindResult findLookupResult hsc_env r = case r of LookupFound m pkg_conf -> do - let im = fst (splitModuleInsts m) + let im = fst (getModuleInstantiation m) r' <- findPackageModule_ hsc_env im pkg_conf case r' of -- TODO: ghc -M is unlikely to do the right thing @@ -202,8 +202,8 @@ -- instantiated; you probably also need all of the -- implicit locations from the instances InstalledFound loc _ -> return (Found loc m) - InstalledNoPackage _ -> return (NoPackage (moduleUnitId m)) - InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m) + InstalledNoPackage _ -> return (NoPackage (moduleUnit m)) + InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m) , fr_pkgs_hidden = [] , fr_mods_hidden = [] , fr_unusables = [] @@ -212,13 +212,13 @@ return (FoundMultiple rs) LookupHidden pkg_hiddens mod_hiddens -> return (NotFound{ fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = map (moduleUnitId.fst) pkg_hiddens - , fr_mods_hidden = map (moduleUnitId.fst) mod_hiddens + , fr_pkgs_hidden = map (moduleUnit.fst) pkg_hiddens + , fr_mods_hidden = map (moduleUnit.fst) mod_hiddens , fr_unusables = [] , fr_suggestions = [] }) LookupUnusable unusable -> let unusables' = map get_unusable unusable - get_unusable (m, ModUnusable r) = (moduleUnitId m, 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 @@ -245,8 +245,8 @@ mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule mkHomeInstalledModule dflags mod_name = - let iuid = thisInstalledUnitId dflags - in InstalledModule iuid mod_name + let iuid = thisUnitId dflags + in Module iuid mod_name -- This returns a module because it's more convenient for users addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module @@ -339,7 +339,7 @@ findPackageModule hsc_env mod = do let dflags = hsc_dflags hsc_env - pkg_id = installedModuleUnitId mod + pkg_id = moduleUnit mod pkgstate = pkgState dflags -- case lookupInstalledPackage pkgstate pkg_id of @@ -355,7 +355,7 @@ -- for the appropriate config. findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult findPackageModule_ hsc_env mod pkg_conf = - ASSERT2( installedModuleUnitId mod == installedUnitInfoId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedUnitInfoId pkg_conf) ) + ASSERT2( moduleUnit mod == unitId pkg_conf, ppr (moduleUnit mod) <+> ppr (unitId pkg_conf) ) modLocationCache hsc_env mod $ -- special case for GHC.Prim; we won't find it in the filesystem. @@ -373,7 +373,7 @@ mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf - import_dirs = importDirs pkg_conf + import_dirs = unitImportDirs pkg_conf -- we never look for a .hi-boot file in an external package; -- .hi-boot files only make sense for the home package. in @@ -381,7 +381,7 @@ [one] | MkDepend <- ghcMode dflags -> do -- there's only one place that this .hi file can be, so -- don't bother looking for it. - let basename = moduleNameSlashes (installedModuleName mod) + let basename = moduleNameSlashes (moduleName mod) loc <- mk_hi_loc one basename return (InstalledFound loc mod) _otherwise -> @@ -413,7 +413,7 @@ return result where - basename = moduleNameSlashes (installedModuleName mod) + basename = moduleNameSlashes (moduleName mod) to_search :: [(FilePath, IO ModLocation)] to_search = [ (file, fn path basename) @@ -424,7 +424,7 @@ file = base <.> ext ] - search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId mod))) + search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod))) search ((file, mk_result) : rest) = do b <- doesFileExist file @@ -649,7 +649,7 @@ where unambiguousPackages = foldl' unambiguousPackage (Just []) mods unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) - = Just (moduleUnitId m : xs) + = Just (moduleUnit m : xs) unambiguousPackage _ _ = Nothing pprMod (m, o) = text "it is bound as" <+> ppr m <+> @@ -658,10 +658,10 @@ 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 (moduleUnitId m)] + then [text "package" <+> ppr (moduleUnit m)] else [] ++ map ((text "a reexport in package" <+>) - .ppr.packageConfigId) res ++ + .ppr.mkUnit) res ++ if f then [text "a package flag"] else [] ) @@ -714,7 +714,7 @@ text "try running 'ghc-pkg check'." $$ tried_these files dflags - pkg_hidden :: UnitId -> SDoc + pkg_hidden :: Unit -> SDoc pkg_hidden uid = text "It is a member of the hidden package" <+> quotes (ppr uid) @@ -725,11 +725,11 @@ | gopt Opt_BuildingCabalPackage dflags = let pkg = expectJust "pkg_hidden" (lookupUnit dflags uid) in text "Perhaps you need to add" <+> - quotes (ppr (packageName pkg)) <+> + quotes (ppr (unitPackageName pkg)) <+> text "to the build-depends in your .cabal file." | Just pkg <- lookupUnit dflags uid = text "You can run" <+> - quotes (text ":set -package " <> ppr (packageName pkg)) <+> + 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 @@ -758,11 +758,11 @@ fromExposedReexport = res, fromPackageFlag = f }) | Just True <- e - = parens (text "from" <+> ppr (moduleUnitId mod)) + = parens (text "from" <+> ppr (moduleUnit mod)) | f && moduleName mod == m - = parens (text "from" <+> ppr (moduleUnitId mod)) + = parens (text "from" <+> ppr (moduleUnit mod)) | (pkg:_) <- res - = parens (text "from" <+> ppr (packageConfigId pkg) + = parens (text "from" <+> ppr (mkUnit pkg) <> comma <+> text "reexporting" <+> ppr mod) | f = parens (text "defined via package flags to be" @@ -775,10 +775,10 @@ fromHiddenReexport = rhs }) | Just False <- e = parens (text "needs flag -package-key" - <+> ppr (moduleUnitId mod)) + <+> ppr (moduleUnit mod)) | (pkg:_) <- rhs = parens (text "needs flag -package-id" - <+> ppr (packageConfigId pkg)) + <+> ppr (mkUnit pkg)) | otherwise = Outputable.empty cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName @@ -794,7 +794,7 @@ text "was found" $$ looks_like_srcpkgid pkg InstalledNotFound files mb_pkg - | Just pkg <- mb_pkg, not (pkg `installedUnitIdEq` thisPackage dflags) + | Just pkg <- mb_pkg, not (pkg `unitIdEq` thisPackage dflags) -> not_found_in_package pkg files | null files @@ -808,13 +808,13 @@ build_tag = buildTag dflags pkgstate = pkgState dflags - looks_like_srcpkgid :: InstalledUnitId -> SDoc + looks_like_srcpkgid :: UnitId -> SDoc looks_like_srcpkgid pk - -- Unsafely coerce a unit id FastString into a source package ID - -- FastString and see if it means anything. - | (pkg:pkgs) <- searchPackageId pkgstate (SourcePackageId (installedUnitIdFS 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 pkgstate (PackageId (unitIdFS pk)) = parens (text "This unit ID looks like the source package ID;" $$ - text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$ + 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! 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 @@ -84,7 +84,7 @@ , hscAddSptEntries ) where -import GhcPrelude +import GHC.Prelude import Data.Data hiding (Fixity, TyCon) import Data.Maybe ( fromJust ) @@ -93,31 +93,31 @@ import GHCi.RemoteTypes ( ForeignHValue ) import GHC.CoreToByteCode ( byteCodeGen, coreExprToBCOs ) import GHC.Runtime.Linker -import GHC.Core.Op.Tidy ( tidyExpr ) +import GHC.Core.Tidy ( tidyExpr ) import GHC.Core.Type ( Type, Kind ) import GHC.Core.Lint ( lintInteractiveExpr ) import GHC.Types.Var.Env ( emptyTidyEnv ) -import Panic +import GHC.Utils.Panic import GHC.Core.ConLike -import ApiAnnotation -import GHC.Types.Module -import GHC.Driver.Packages +import GHC.Parser.Annotation +import GHC.Unit.Module +import GHC.Unit.State import GHC.Types.Name.Reader import GHC.Hs import GHC.Hs.Dump import GHC.Core -import StringBuffer -import Parser -import Lexer +import GHC.Data.StringBuffer +import GHC.Parser +import GHC.Parser.Lexer as Lexer import GHC.Types.SrcLoc -import TcRnDriver +import GHC.Tc.Module import GHC.IfaceToCore ( typecheckIface ) -import TcRnMonad -import TcHsSyn ( ZonkFlexi (DefaultFlexi) ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) ) import GHC.Types.Name.Cache ( initNameCache ) -import PrelInfo -import GHC.Core.Op.Simplify.Driver +import GHC.Builtin.Utils +import GHC.Core.Opt.Driver import GHC.HsToCore import GHC.Iface.Load ( ifaceStats, initExternalPackageState, writeIface ) import GHC.Iface.Make @@ -134,35 +134,35 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Cmm -import GHC.Cmm.Parser ( parseCmmFile ) +import GHC.Cmm.Parser ( parseCmmFile ) import GHC.Cmm.Info.Build import GHC.Cmm.Pipeline import GHC.Cmm.Info import GHC.Driver.CodeOutput import GHC.Core.InstEnv import GHC.Core.FamInstEnv -import Fingerprint ( Fingerprint ) +import GHC.Utils.Fingerprint ( Fingerprint ) import GHC.Driver.Hooks -import TcEnv -import PrelNames +import GHC.Tc.Utils.Env +import GHC.Builtin.Names import GHC.Driver.Plugins import GHC.Runtime.Loader ( initializePlugins ) import GHC.Driver.Session -import ErrUtils +import GHC.Utils.Error -import Outputable +import GHC.Utils.Outputable import GHC.Types.Name.Env -import HscStats ( ppSourceStats ) +import GHC.Hs.Stats ( ppSourceStats ) import GHC.Driver.Types -import FastString +import GHC.Data.FastString import GHC.Types.Unique.Supply -import Bag -import Exception -import qualified Stream -import Stream (Stream) +import GHC.Data.Bag +import GHC.Utils.Exception +import qualified GHC.Data.Stream as Stream +import GHC.Data.Stream (Stream) -import Util +import GHC.Utils.Misc import Data.List ( nub, isPrefixOf, partition ) import Control.Monad @@ -425,14 +425,14 @@ hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) let out_file = ml_hie_file $ ms_location mod_summary liftIO $ writeHieFile out_file hieFile + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) -- Validate HIE files when (gopt Opt_ValidateHie dflags) $ do hs_env <- Hsc $ \e w -> return (e, w) liftIO $ do -- Validate Scopes - let mdl = hie_module hieFile - case validateScopes mdl $ getAsts $ hie_asts hieFile of + case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of [] -> putMsg dflags $ text "Got valid scopes" xs -> do putMsg dflags $ text "Got invalid scopes" @@ -445,7 +445,7 @@ putMsg dflags $ text "Got no roundtrip errors" xs -> do putMsg dflags $ text "Got roundtrip errors" - mapM_ (putMsg dflags) xs + mapM_ (putMsg (dopt_set dflags Opt_D_ppr_debug)) xs return rn_info @@ -475,7 +475,7 @@ src_filename = ms_hspp_file mod_summary real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 keep_rn' = gopt Opt_WriteHie dflags || keep_rn - MASSERT( moduleUnitId outer_mod == thisPackage dflags ) + MASSERT( moduleUnit outer_mod == thisPackage dflags ) tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc else @@ -519,36 +519,31 @@ let allSafeOK = safeInferred dflags && tcSafeOK -- end of the safe haskell line, how to respond to user? - res <- if not (safeHaskellOn dflags) - || (safeInferOn dflags && not allSafeOK) - -- if safe Haskell off or safe infer failed, mark unsafe - then markUnsafeInfer tcg_res whyUnsafe - - -- module (could be) safe, throw warning if needed - else do - tcg_res' <- hscCheckSafeImports tcg_res - safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res') - when safe $ do - case wopt Opt_WarnSafe dflags of - True - | safeHaskell dflags == Sf_Safe -> return () - | otherwise -> (logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnSafe) $ - mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ - errSafe tcg_res') - False | safeHaskell dflags == Sf_Trustworthy && - wopt Opt_WarnTrustworthySafe dflags -> - (logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnTrustworthySafe) $ - mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $ - errTwthySafe tcg_res') - False -> return () - return tcg_res' - - -- apply plugins to the type checking result - + if not (safeHaskellOn dflags) + || (safeInferOn dflags && not allSafeOK) + -- if safe Haskell off or safe infer failed, mark unsafe + then markUnsafeInfer tcg_res whyUnsafe - return res + -- module (could be) safe, throw warning if needed + else do + tcg_res' <- hscCheckSafeImports tcg_res + safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res') + when safe $ do + case wopt Opt_WarnSafe dflags of + True + | safeHaskell dflags == Sf_Safe -> return () + | otherwise -> (logWarnings $ unitBag $ + makeIntoWarning (Reason Opt_WarnSafe) $ + mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ + errSafe tcg_res') + False | safeHaskell dflags == Sf_Trustworthy && + wopt Opt_WarnTrustworthySafe dflags -> + (logWarnings $ unitBag $ + makeIntoWarning (Reason Opt_WarnTrustworthySafe) $ + mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $ + errTwthySafe tcg_res') + False -> return () + return tcg_res' where pprMod t = ppr $ moduleName $ tcg_mod t errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!" @@ -728,7 +723,7 @@ let hsc_env'' = hsc_env' { hsc_dflags = dflags } -- One-shot mode needs a knot-tying mutable variable for interface - -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. + -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. -- See also Note [hsc_type_env_var hack] type_env_var <- newIORef emptyNameEnv let mod = ms_mod mod_summary @@ -992,7 +987,6 @@ mkPlainWarnMsg dflags loc $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" - warnRules _ (L _ (XRuleDecl nec)) = noExtCon nec -- | Validate that safe imported modules are actually safe. For modules in the -- HomePackage (the package the module we are compiling in resides) this just @@ -1055,7 +1049,7 @@ imports = imp_mods impInfo -- ImportedMods imports1 = moduleEnvToList imports -- (Module, [ImportedBy]) imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal]) - pkgReqs = imp_trust_pkgs impInfo -- [UnitId] + pkgReqs = imp_trust_pkgs impInfo -- [Unit] condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) condense (_, []) = panic "GHC.Driver.Main.condense: Pattern match failure!" @@ -1075,11 +1069,11 @@ = return v1 -- easier interface to work with - checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId) + checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId) checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l -- what pkg's to add to our trust requirements - pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId -> + pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId -> Bool -> ImportAvails pkgTrustReqs dflags req inf infPassed | safeInferOn dflags && not (safeHaskellModeEnabled dflags) && infPassed @@ -1103,7 +1097,7 @@ return $ isEmptyBag errs -- | Return if a module is trusted and the pkgs it depends on to be trusted. -hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId) +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId) hscGetSafe hsc_env m l = runHsc hsc_env $ do (self, pkgs) <- hscCheckSafe' m l good <- isEmptyBag `fmap` getWarnings @@ -1117,7 +1111,7 @@ -- own package be trusted and a list of other packages required to be trusted -- (these later ones haven't been checked) but the own package trust has been. hscCheckSafe' :: Module -> SrcSpan - -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId) + -> Hsc (Maybe UnitId, Set UnitId) hscCheckSafe' m l = do dflags <- getDynFlags (tw, pkgs) <- isModSafe m l @@ -1126,9 +1120,9 @@ True | isHomePkg dflags m -> return (Nothing, pkgs) -- TODO: do we also have to check the trust of the instantiation? -- Not necessary if that is reflected in dependencies - | otherwise -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs) + | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) where - isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId) + isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set UnitId) isModSafe m l = do dflags <- getDynFlags iface <- lookup' m @@ -1176,7 +1170,7 @@ pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" - , text "The package (" <> ppr (moduleUnitId m) + , text "The package (" <> ppr (moduleUnit m) <> text ") the module resides in isn't trusted." ] modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ @@ -1198,7 +1192,7 @@ packageTrusted _ Sf_SafeInferred False _ = True packageTrusted dflags _ _ m | isHomePkg dflags m = True - | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m) + | otherwise = unitIsTrusted $ unsafeGetUnitInfo dflags (moduleUnit m) lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do @@ -1218,16 +1212,16 @@ isHomePkg :: DynFlags -> Module -> Bool isHomePkg dflags m - | thisPackage dflags == moduleUnitId m = True + | thisPackage dflags == moduleUnit m = True | otherwise = False -- | Check the list of packages are trusted. -checkPkgTrust :: Set InstalledUnitId -> Hsc () +checkPkgTrust :: Set UnitId -> Hsc () checkPkgTrust pkgs = do dflags <- getDynFlags let errors = S.foldr go [] pkgs go pkg acc - | trusted $ getInstalledPackageDetails (pkgState dflags) pkg + | unitIsTrusted $ getInstalledPackageDetails (pkgState dflags) pkg = acc | otherwise = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags) @@ -1421,7 +1415,7 @@ let cost_centre_info = (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) - prof_init = profilingInitCode this_mod cost_centre_info + prof_init = profilingInitCode dflags this_mod cost_centre_info foreign_stubs = foreign_stubs0 `appendStubC` prof_init ------------------ Code generation ------------------ @@ -1762,7 +1756,7 @@ -- that might later be looked up by name. But we can exclude -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Driver.Types -- - Implicit Ids, which are implicit in tcs - -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv + -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns ictxt = hsc_IC hsc_env @@ -1773,7 +1767,7 @@ return (new_tythings, new_ictxt) -- | Load the given static-pointer table entries into the interpreter. --- See Note [Grand plan for static forms] in StaticPtrTable. +-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. hscAddSptEntries :: HscEnv -> [SptEntry] -> IO () hscAddSptEntries hsc_env entries = do let add_spt_entry :: SptEntry -> IO () @@ -1788,7 +1782,7 @@ To support fixity declarations on types defined within GHCi (as requested in #10018) we record the fixity environment in InteractiveContext. - When we want to evaluate something TcRnDriver.runTcInteractive pulls out this + When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this fixity environment and uses it to initialize the global typechecker environment. After the typechecker has finished its business, an updated fixity environment (reflecting whatever fixity declarations were present in the statements we 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 @@ -33,50 +33,50 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import qualified GHC.Runtime.Linker as Linker import GHC.Driver.Phases import GHC.Driver.Pipeline import GHC.Driver.Session -import ErrUtils +import GHC.Utils.Error import GHC.Driver.Finder import GHC.Driver.Monad -import HeaderInfo +import GHC.Parser.Header import GHC.Driver.Types -import GHC.Types.Module -import GHC.IfaceToCore ( typecheckIface ) -import TcRnMonad ( initIfaceCheck ) +import GHC.Unit.Module +import GHC.IfaceToCore ( typecheckIface ) +import GHC.Tc.Utils.Monad ( initIfaceCheck ) import GHC.Driver.Main -import Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) +import GHC.Data.Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) import GHC.Types.Basic -import Digraph -import Exception ( tryIO, gbracket, gfinally ) -import FastString -import Maybes ( expectJust ) +import GHC.Data.Graph.Directed +import GHC.Utils.Exception ( tryIO, gbracket, gfinally ) +import GHC.Data.FastString +import GHC.Data.Maybe ( expectJust ) import GHC.Types.Name -import MonadUtils ( allM ) -import Outputable -import Panic +import GHC.Utils.Monad ( allM ) +import GHC.Utils.Outputable +import GHC.Utils.Panic import GHC.Types.SrcLoc -import StringBuffer +import GHC.Data.StringBuffer import GHC.Types.Unique.FM import GHC.Types.Unique.DSet -import TcBackpack -import GHC.Driver.Packages +import GHC.Tc.Utils.Backpack +import GHC.Unit.State import GHC.Types.Unique.Set -import Util +import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt import GHC.Types.Name.Env -import FileCleanup +import GHC.SysTools.FileCleanup import Data.Either ( rights, partitionEithers ) import qualified Data.Map as Map import Data.Map (Map) import qualified Data.Set as Set -import qualified FiniteMap as Map ( insertListWith ) +import qualified GHC.Data.FiniteMap as Map ( insertListWith ) import Control.Concurrent ( forkIOWithUnmask, killThread ) import qualified GHC.Conc as CC @@ -309,9 +309,9 @@ pit = eps_PIT eps let loadedPackages - = map (getPackageDetails dflags) + = map (unsafeGetUnitInfo dflags) . nub . sort - . map moduleUnitId + . map moduleUnit . moduleEnvKeys $ pit @@ -343,21 +343,21 @@ matchingStr :: String -> UnitInfo -> Bool matchingStr str p - = str == sourcePackageIdString p - || str == packageNameString p + = str == unitPackageIdString p + || str == unitPackageNameString p matching :: DynFlags -> PackageArg -> UnitInfo -> Bool matching _ (PackageArg str) p = matchingStr str p - matching dflags (UnitIdArg uid) p = uid == realUnitId dflags p + matching dflags (UnitIdArg uid) p = uid == realUnit dflags p -- For wired-in packages, we have to unwire their id, -- otherwise they won't match package flags - realUnitId :: DynFlags -> UnitInfo -> UnitId - realUnitId dflags - = unwireUnitId dflags - . DefiniteUnitId - . DefUnitId - . installedUnitInfoId + realUnit :: DynFlags -> UnitInfo -> Unit + realUnit dflags + = unwireUnit dflags + . RealUnit + . Definite + . unitId -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally @@ -935,7 +935,7 @@ -- | 'Bool' indicating if a module is a boot module or not. We need to treat -- boot modules specially when building compilation graphs, since they break -- cycles. Regular source files and signature files are treated equivalently. -data IsBoot = IsBoot | NotBoot +data IsBoot = NotBoot | IsBoot deriving (Ord, Eq, Show, Read) -- | Tests if an 'HscSource' is a boot file, primarily for constructing @@ -965,7 +965,7 @@ hsc_env <- getSession let dflags = hsc_dflags hsc_env - when (not (null (unitIdsToCheck dflags))) $ + when (not (null (instantiatedUnitsToCheck dflags))) $ throwGhcException (ProgramError "Backpack typechecking not supported with -j") -- The bits of shared state we'll be using: @@ -1374,7 +1374,7 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do dflags <- getSessionDynFlags (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs) - (unitIdsToCheck dflags) done_holes + (instantiatedUnitsToCheck dflags) done_holes return (res, reverse $ mgModSummaries done) where done_holes = emptyUniqSet @@ -1405,13 +1405,13 @@ -> [SCC ModSummary] -> Int -> Int - -> [UnitId] + -> [Unit] -> UniqSet ModuleName -> m (SuccessFlag, ModuleGraph) upsweep' _old_hpt done [] _ _ uids_to_check _ = do hsc_env <- getSession - liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check + liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnit hsc_env) uids_to_check return (Succeeded, done) upsweep' _old_hpt done @@ -1436,13 +1436,13 @@ -- our imports when you run --make. let (ready_uids, uids_to_check') = partition (\uid -> isEmptyUniqDSet - (unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes)) + (unitFreeModuleHoles uid `uniqDSetMinusUniqSet` done_holes)) uids_to_check done_holes' | ms_hsc_src mod == HsigFile = addOneToUniqSet done_holes (ms_mod_name mod) | otherwise = done_holes - liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids + liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnit hsc_env) ready_uids -- Remove unwanted tmp files between compilations liftIO (cleanup hsc_env) @@ -1505,7 +1505,7 @@ -- Add any necessary entries to the static pointer -- table. See Note [Grand plan for static forms] in - -- StaticPtrTable. + -- GHC.Iface.Tidy.StaticPtrTable. when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $ liftIO $ hscAddSptEntries hsc_env4 [ spt @@ -1517,16 +1517,17 @@ upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes' -unitIdsToCheck :: DynFlags -> [UnitId] -unitIdsToCheck dflags = - nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags)) +-- | Return a list of instantiated units to type check from the PackageState. +-- +-- Use explicit (instantiated) units as roots and also return their +-- instantiations that are themselves instantiations and so on recursively. +instantiatedUnitsToCheck :: DynFlags -> [Unit] +instantiatedUnitsToCheck dflags = + nubSort $ concatMap goUnit (explicitPackages (pkgState dflags)) where - goUnitId uid = - case splitUnitIdInsts uid of - (_, Just indef) -> - let insts = indefUnitIdInsts indef - in uid : concatMap (goUnitId . moduleUnitId . snd) insts - _ -> [] + goUnit HoleUnit = [] + goUnit (RealUnit _) = [] + goUnit uid@(VirtUnit i) = uid : concatMap (goUnit . moduleUnit . snd) (instUnitInsts i) maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime) maybeGetIfaceDate dflags location diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -15,27 +15,27 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import qualified GHC import GHC.Driver.Monad import GHC.Driver.Session import GHC.Driver.Ways -import Util +import GHC.Utils.Misc import GHC.Driver.Types -import qualified SysTools -import GHC.Types.Module -import Digraph ( SCC(..) ) +import qualified GHC.SysTools as SysTools +import GHC.Unit.Module +import GHC.Data.Graph.Directed ( SCC(..) ) import GHC.Driver.Finder -import Outputable -import Panic +import GHC.Utils.Outputable +import GHC.Utils.Panic import GHC.Types.SrcLoc import Data.List -import FastString -import FileCleanup +import GHC.Data.FastString +import GHC.SysTools.FileCleanup -import Exception -import ErrUtils +import GHC.Utils.Exception +import GHC.Utils.Error import System.Directory import System.FilePath 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 @@ -36,43 +36,43 @@ #include #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Driver.Pipeline.Monad -import GHC.Driver.Packages +import GHC.Unit.State import GHC.Driver.Ways -import HeaderInfo +import GHC.Parser.Header import GHC.Driver.Phases -import SysTools -import SysTools.ExtraObj +import GHC.SysTools +import GHC.SysTools.ExtraObj import GHC.Driver.Main import GHC.Driver.Finder import GHC.Driver.Types hiding ( Hsc ) -import Outputable -import GHC.Types.Module -import ErrUtils +import GHC.Utils.Outputable +import GHC.Unit.Module +import GHC.Utils.Error import GHC.Driver.Session -import Panic -import Util -import StringBuffer ( hGetStringBuffer, hPutStringBuffer ) -import GHC.Types.Basic ( SuccessFlag(..) ) -import Maybes ( expectJust ) +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer ) +import GHC.Types.Basic ( SuccessFlag(..) ) +import GHC.Data.Maybe ( expectJust ) import GHC.Types.SrcLoc -import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) -import MonadUtils +import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) +import GHC.Utils.Monad import GHC.Platform -import TcRnTypes -import ToolSettings +import GHC.Tc.Types import GHC.Driver.Hooks import qualified GHC.LanguageExtensions as LangExt -import FileCleanup -import Ar -import Bag ( unitBag ) -import FastString ( mkFastString ) -import GHC.Iface.Make ( mkFullIface ) -import UpdateCafInfos ( updateModDetailsCafInfos ) +import GHC.SysTools.FileCleanup +import GHC.SysTools.Ar +import GHC.Settings +import GHC.Data.Bag ( unitBag ) +import GHC.Data.FastString ( mkFastString ) +import GHC.Iface.Make ( mkFullIface ) +import GHC.Iface.UpdateCafInfos ( updateModDetailsCafInfos ) -import Exception +import GHC.Utils.Exception as Exception import System.Directory import System.FilePath import System.IO @@ -490,7 +490,7 @@ return Succeeded -linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool +linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool linkingNeeded dflags staticLink linkables pkg_deps = do -- if the modification time on the executable is later than the -- modification times on all of the objects and libraries, then omit @@ -866,20 +866,6 @@ | otherwise = persistent --- | The fast LLVM Pipeline skips the mangler and assembler, --- emitting object code directly from llc. --- --- slow: opt -> llc -> .s -> mangler -> as -> .o --- fast: opt -> llc -> .o --- --- hidden flag: -ffast-llvm --- --- if keep-s-files is specified, we need to go through --- the slow pipeline (Kavon Farvardin requested this). -fastLlvmPipeline :: DynFlags -> Bool -fastLlvmPipeline dflags - = not (gopt Opt_KeepSFiles dflags) && gopt Opt_FastLlvm dflags - -- | LLVM Options. These are flags to be passed to opt and llc, to ensure -- consistency we list them in pairs, so that they form groups. llvmOptions :: DynFlags @@ -890,7 +876,6 @@ ,"-relocation-model=" ++ rmodel) | not (null rmodel)] ++ [("-stack-alignment=" ++ (show align) ,"-stack-alignment=" ++ (show align)) | align > 0 ] - ++ [("", "-filetype=obj") | fastLlvmPipeline dflags ] -- Additional llc flags ++ [("", "-mcpu=" ++ mcpu) | not (null mcpu) @@ -955,14 +940,14 @@ let flags = [ -- The -h option passes the file name for unlit to -- put in a #line directive - SysTools.Option "-h" + GHC.SysTools.Option "-h" -- See Note [Don't normalise input filenames]. - , SysTools.Option $ escape input_fn - , SysTools.FileOption "" input_fn - , SysTools.FileOption "" output_fn + , GHC.SysTools.Option $ escape input_fn + , GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.FileOption "" output_fn ] - liftIO $ SysTools.runUnlit dflags flags + liftIO $ GHC.SysTools.runUnlit dflags flags return (RealPhase (Cpp sf), output_fn) where @@ -1030,10 +1015,10 @@ PipeEnv{src_basename, src_suffix} <- getPipeEnv let orig_fn = src_basename <.> src_suffix output_fn <- phaseOutputFilename (Hsc sf) - liftIO $ SysTools.runPp dflags - ( [ SysTools.Option orig_fn - , SysTools.Option input_fn - , SysTools.FileOption "" output_fn + liftIO $ GHC.SysTools.runPp dflags + ( [ GHC.SysTools.Option orig_fn + , GHC.SysTools.Option input_fn + , GHC.SysTools.FileOption "" output_fn ] ) @@ -1311,12 +1296,12 @@ ghcVersionH <- liftIO $ getGhcVersionPathName dflags - liftIO $ SysTools.runCc (phaseForeignLanguage cc_phase) dflags ( - [ SysTools.FileOption "" input_fn - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn + liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) dflags ( + [ GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn ] - ++ map SysTools.Option ( + ++ map GHC.SysTools.Option ( pic_c_flags -- Stub files generated for foreign exports references the runIO_closure @@ -1370,8 +1355,8 @@ -- assembler, so we use clang as the assembler instead. (#5636) let as_prog | hscTarget dflags == HscLlvm && platformOS (targetPlatform dflags) == OSDarwin - = SysTools.runClang - | otherwise = SysTools.runAs + = GHC.SysTools.runClang + | otherwise = GHC.SysTools.runAs let cmdline_include_paths = includePaths dflags let pic_c_flags = picCCOpts dflags @@ -1384,9 +1369,9 @@ liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) ccInfo <- liftIO $ getCompilerInfo dflags - let global_includes = [ SysTools.Option ("-I" ++ p) + let global_includes = [ GHC.SysTools.Option ("-I" ++ p) | p <- includePathsGlobal cmdline_include_paths ] - let local_includes = [ SysTools.Option ("-iquote" ++ p) + let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p) | p <- includePathsQuote cmdline_include_paths ] let runAssembler inputFilename outputFilename = liftIO $ do @@ -1395,9 +1380,9 @@ dflags (local_includes ++ global_includes -- See Note [-fPIC for assembler] - ++ map SysTools.Option pic_c_flags + ++ map GHC.SysTools.Option pic_c_flags -- See Note [Produce big objects on Windows] - ++ [ SysTools.Option "-Wa,-mbig-obj" + ++ [ GHC.SysTools.Option "-Wa,-mbig-obj" | platformOS (targetPlatform dflags) == OSMinGW32 , not $ target32Bit (targetPlatform dflags) ] @@ -1410,19 +1395,19 @@ -- -- This is a temporary hack. ++ (if platformArch (targetPlatform dflags) == ArchSPARC - then [SysTools.Option "-mcpu=v9"] + then [GHC.SysTools.Option "-mcpu=v9"] else []) ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51] - then [SysTools.Option "-Qunused-arguments"] + then [GHC.SysTools.Option "-Qunused-arguments"] else []) - ++ [ SysTools.Option "-x" + ++ [ GHC.SysTools.Option "-x" , if with_cpp - then SysTools.Option "assembler-with-cpp" - else SysTools.Option "assembler" - , SysTools.Option "-c" - , SysTools.FileOption "" inputFilename - , SysTools.Option "-o" - , SysTools.FileOption "" temp_outputFilename + then GHC.SysTools.Option "assembler-with-cpp" + else GHC.SysTools.Option "assembler" + , GHC.SysTools.Option "-c" + , GHC.SysTools.FileOption "" inputFilename + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" temp_outputFilename ]) liftIO $ debugTraceMsg dflags 4 (text "Running the assembler") @@ -1437,12 +1422,12 @@ = do output_fn <- phaseOutputFilename LlvmLlc - liftIO $ SysTools.runLlvmOpt dflags + liftIO $ GHC.SysTools.runLlvmOpt dflags ( optFlag ++ defaultOptions ++ - [ SysTools.FileOption "" input_fn - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn] + [ GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn] ) return (RealPhase LlvmLlc, output_fn) @@ -1461,10 +1446,10 @@ -- passes only, so if the user is passing us extra options we assume -- they know what they are doing and don't get in the way. optFlag = if null (getOpts dflags opt_lo) - then map SysTools.Option $ words llvmOpts + then map GHC.SysTools.Option $ words llvmOpts else [] - defaultOptions = map SysTools.Option . concat . fmap words . fst + defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst $ unzip (llvmOptions dflags) ----------------------------------------------------------------------------- @@ -1472,19 +1457,18 @@ runPhase (RealPhase LlvmLlc) input_fn dflags = do - next_phase <- if | fastLlvmPipeline dflags -> maybeMergeForeign - -- hidden debugging flag '-dno-llvm-mangler' to skip mangling + next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling | gopt Opt_NoLlvmMangler dflags -> return (As False) | otherwise -> return LlvmMangle output_fn <- phaseOutputFilename next_phase - liftIO $ SysTools.runLlvmLlc dflags + liftIO $ GHC.SysTools.runLlvmLlc dflags ( optFlag ++ defaultOptions - ++ [ SysTools.FileOption "" input_fn - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn + ++ [ GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn ] ) @@ -1535,10 +1519,10 @@ _ -> "-O2" optFlag = if null (getOpts dflags opt_lc) - then map SysTools.Option $ words llvmOpts + then map GHC.SysTools.Option $ words llvmOpts else [] - defaultOptions = map SysTools.Option . concatMap words . snd + defaultOptions = map GHC.SysTools.Option . concatMap words . snd $ unzip (llvmOptions dflags) @@ -1627,13 +1611,13 @@ ----------------------------------------------------------------------------- -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file -getHCFilePackages :: FilePath -> IO [InstalledUnitId] +getHCFilePackages :: FilePath -> IO [UnitId] getHCFilePackages filename = Exception.bracket (openFile filename ReadMode) hClose $ \h -> do l <- hGetLine h case l of '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> - return (map stringToInstalledUnitId (words rest)) + return (map stringToUnitId (words rest)) _other -> return [] @@ -1664,10 +1648,10 @@ -Xlinker, but not -Wl. -} -linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () +linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO () linkBinary = linkBinary' False -linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () +linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO () linkBinary' staticLink dflags o_files dep_packages = do let platform = targetPlatform dflags toolSettings' = toolSettings dflags @@ -1781,15 +1765,15 @@ rc_objs <- maybeCreateManifest dflags output_fn let link = if staticLink - then SysTools.runLibtool - else SysTools.runLink + then GHC.SysTools.runLibtool + else GHC.SysTools.runLink link dflags ( - map SysTools.Option verbFlags - ++ [ SysTools.Option "-o" - , SysTools.FileOption "" output_fn + map GHC.SysTools.Option verbFlags + ++ [ GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn ] ++ libmLinkOpts - ++ map SysTools.Option ( + ++ map GHC.SysTools.Option ( [] -- See Note [No PIE when linking] @@ -1841,7 +1825,7 @@ ++ o_files ++ lib_path_opts) ++ extra_ld_inputs - ++ map SysTools.Option ( + ++ map GHC.SysTools.Option ( rc_objs ++ framework_opts ++ pkg_lib_path_opts @@ -1911,7 +1895,7 @@ -- show is a bit hackish above, but we need to escape the -- backslashes in the path. - runWindres dflags $ map SysTools.Option $ + runWindres dflags $ map GHC.SysTools.Option $ ["--input="++rc_filename, "--output="++rc_obj_filename, "--output-format=coff"] @@ -1924,7 +1908,7 @@ | otherwise = return [] -linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO () +linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO () linkDynLibCheck dflags o_files dep_packages = do when (haveRtsOptsFlags dflags) $ do @@ -1938,7 +1922,7 @@ -- | Linking a static lib will not really link anything. It will merely produce -- a static archive of all dependent static libraries. The resulting library -- will still need to be linked with any remaining link flags. -linkStaticLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO () +linkStaticLib :: DynFlags -> [String] -> [UnitId] -> IO () linkStaticLib dflags o_files dep_packages = do let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] modules = o_files ++ extra_ld_inputs @@ -1963,7 +1947,7 @@ else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar -- run ranlib over the archive. write*Ar does *not* create the symbol index. - runRanlib dflags [SysTools.FileOption "" output_fn] + runRanlib dflags [GHC.SysTools.FileOption "" output_fn] -- ----------------------------------------------------------------------------- -- Running CPP @@ -1982,8 +1966,8 @@ let verbFlags = getVerbFlags dflags - let cpp_prog args | raw = SysTools.runCpp dflags args - | otherwise = SysTools.runCc Nothing dflags (SysTools.Option "-E" : args) + let cpp_prog args | raw = GHC.SysTools.runCpp dflags args + | otherwise = GHC.SysTools.runCc Nothing dflags (GHC.SysTools.Option "-E" : args) let targetArch = stringEncodeArch $ platformArch $ targetPlatform dflags targetOS = stringEncodeOS $ platformOS $ targetPlatform dflags @@ -2027,26 +2011,26 @@ -- size of 1000 packages, it takes cpp an estimated 2 -- milliseconds to process this file. See #10970 -- comment 8. - return [SysTools.FileOption "-include" macro_stub] + return [GHC.SysTools.FileOption "-include" macro_stub] else return [] - cpp_prog ( map SysTools.Option verbFlags - ++ map SysTools.Option include_paths - ++ map SysTools.Option hsSourceCppOpts - ++ map SysTools.Option target_defs - ++ map SysTools.Option backend_defs - ++ map SysTools.Option th_defs - ++ map SysTools.Option hscpp_opts - ++ map SysTools.Option sse_defs - ++ map SysTools.Option avx_defs + cpp_prog ( map GHC.SysTools.Option verbFlags + ++ map GHC.SysTools.Option include_paths + ++ map GHC.SysTools.Option hsSourceCppOpts + ++ map GHC.SysTools.Option target_defs + ++ map GHC.SysTools.Option backend_defs + ++ map GHC.SysTools.Option th_defs + ++ map GHC.SysTools.Option hscpp_opts + ++ map GHC.SysTools.Option sse_defs + ++ map GHC.SysTools.Option avx_defs ++ mb_macro_include -- Set the language mode to assembler-with-cpp when preprocessing. This -- alleviates some of the C99 macro rules relating to whitespace and the hash -- operator, which we tend to abuse. Clang in particular is not very happy -- about this. - ++ [ SysTools.Option "-x" - , SysTools.Option "assembler-with-cpp" - , SysTools.Option input_fn + ++ [ GHC.SysTools.Option "-x" + , GHC.SysTools.Option "assembler-with-cpp" + , GHC.SysTools.Option input_fn -- We hackily use Option instead of FileOption here, so that the file -- name is not back-slashed on Windows. cpp is capable of -- dealing with / in filenames, so it works fine. Furthermore @@ -2055,8 +2039,8 @@ -- our error messages get double backslashes in them. -- In due course we should arrange that the lexer deals -- with these \\ escapes properly. - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn ]) getBackendDefs :: DynFlags -> IO [String] @@ -2082,8 +2066,8 @@ -- Do not add any C-style comments. See #3389. [ generateMacros "" pkgname version | pkg <- pkgs - , let version = packageVersion pkg - pkgname = map fixchar (packageNameString pkg) + , let version = unitPackageVersion pkg + pkgname = map fixchar (unitPackageNameString pkg) ] fixchar :: Char -> Char @@ -2137,20 +2121,20 @@ let toolSettings' = toolSettings dflags ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' osInfo = platformOS (targetPlatform dflags) - ld_r args cc = SysTools.runLink dflags ([ - SysTools.Option "-nostdlib", - SysTools.Option "-Wl,-r" + ld_r args cc = GHC.SysTools.runLink dflags ([ + GHC.SysTools.Option "-nostdlib", + GHC.SysTools.Option "-Wl,-r" ] -- See Note [No PIE while linking] in GHC.Driver.Session ++ (if toolSettings_ccSupportsNoPie toolSettings' - then [SysTools.Option "-no-pie"] + then [GHC.SysTools.Option "-no-pie"] else []) ++ (if any (cc ==) [Clang, AppleClang, AppleClang51] then [] - else [SysTools.Option "-nodefaultlibs"]) + else [GHC.SysTools.Option "-nodefaultlibs"]) ++ (if osInfo == OSFreeBSD - then [SysTools.Option "-L/usr/lib"] + then [GHC.SysTools.Option "-L/usr/lib"] else []) -- gcc on sparc sets -Wl,--relax implicitly, but -- -r and --relax are incompatible for ld, so @@ -2158,16 +2142,16 @@ ++ (if platformArch (targetPlatform dflags) `elem` [ArchSPARC, ArchSPARC64] && ldIsGnuLd - then [SysTools.Option "-Wl,-no-relax"] + then [GHC.SysTools.Option "-Wl,-no-relax"] else []) -- See Note [Produce big objects on Windows] - ++ [ SysTools.Option "-Wl,--oformat,pe-bigobj-x86-64" + ++ [ GHC.SysTools.Option "-Wl,--oformat,pe-bigobj-x86-64" | OSMinGW32 == osInfo , not $ target32Bit (targetPlatform dflags) ] - ++ map SysTools.Option ld_build_id - ++ [ SysTools.Option "-o", - SysTools.FileOption "" output_fn ] + ++ map GHC.SysTools.Option ld_build_id + ++ [ GHC.SysTools.Option "-o", + GHC.SysTools.FileOption "" output_fn ] ++ args) -- suppress the generation of the .note.gnu.build-id section, @@ -2183,15 +2167,15 @@ cwd <- getCurrentDirectory let o_files_abs = map (\x -> "\"" ++ (cwd x) ++ "\"") o_files writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" - ld_r [SysTools.FileOption "" script] ccInfo + ld_r [GHC.SysTools.FileOption "" script] ccInfo else if toolSettings_ldSupportsFilelist toolSettings' then do filelist <- newTempName dflags TFL_CurrentModule "filelist" writeFile filelist $ unlines o_files - ld_r [SysTools.Option "-Wl,-filelist", - SysTools.FileOption "-Wl," filelist] ccInfo + ld_r [GHC.SysTools.Option "-Wl,-filelist", + GHC.SysTools.FileOption "-Wl," filelist] ccInfo else do - ld_r (map (SysTools.FileOption "") o_files) ccInfo + ld_r (map (GHC.SysTools.FileOption "") o_files) ccInfo -- ----------------------------------------------------------------------------- -- Misc. @@ -2228,7 +2212,7 @@ touchObjectFile :: DynFlags -> FilePath -> IO () touchObjectFile dflags path = do createDirectoryIfMissing True $ takeDirectory path - SysTools.touch dflags "Touching object file" path + GHC.SysTools.touch dflags "Touching object file" path -- | Find out path to @ghcversion.h@ file getGhcVersionPathName :: DynFlags -> IO FilePath @@ -2236,7 +2220,7 @@ candidates <- case ghcVersionFile dflags of Just path -> return [path] Nothing -> (map ( "ghcversion.h")) <$> - (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]) + (getPackageIncludePath dflags [toUnitId rtsUnitId]) found <- filterM doesFileExist candidates case found of diff --git a/compiler/GHC/Hs/Stats.hs b/compiler/GHC/Hs/Stats.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Hs/Stats.hs @@ -0,0 +1,187 @@ +-- | +-- Statistics for per-module compilations +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-- + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Hs.Stats ( ppSourceStats ) where + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Hs +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Utils.Misc + +import Data.Char + +-- | Source Statistics +ppSourceStats :: Bool -> Located HsModule -> SDoc +ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) + = (if short then hcat else vcat) + (map pp_val + [("ExportAll ", export_all), -- 1 if no export list + ("ExportDecls ", export_ds), + ("ExportModules ", export_ms), + ("Imports ", imp_no), + (" ImpSafe ", imp_safe), + (" ImpQual ", imp_qual), + (" ImpAs ", imp_as), + (" ImpAll ", imp_all), + (" ImpPartial ", imp_partial), + (" ImpHiding ", imp_hiding), + ("FixityDecls ", fixity_sigs), + ("DefaultDecls ", default_ds), + ("TypeDecls ", type_ds), + ("DataDecls ", data_ds), + ("NewTypeDecls ", newt_ds), + ("TypeFamilyDecls ", type_fam_ds), + ("DataConstrs ", data_constrs), + ("DataDerivings ", data_derivs), + ("ClassDecls ", class_ds), + ("ClassMethods ", class_method_ds), + ("DefaultMethods ", default_method_ds), + ("InstDecls ", inst_ds), + ("InstMethods ", inst_method_ds), + ("InstType ", inst_type_ds), + ("InstData ", inst_data_ds), + ("TypeSigs ", bind_tys), + ("ClassOpSigs ", generic_sigs), + ("ValBinds ", val_bind_ds), + ("FunBinds ", fn_bind_ds), + ("PatSynBinds ", patsyn_ds), + ("InlineMeths ", method_inlines), + ("InlineBinds ", bind_inlines), + ("SpecialisedMeths ", method_specs), + ("SpecialisedBinds ", bind_specs) + ]) + where + decls = map unLoc ldecls + + pp_val (_, 0) = empty + pp_val (str, n) + | not short = hcat [text str, int n] + | otherwise = hcat [text (trim str), equals, int n, semi] + + trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) + + (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) + = count_sigs [d | SigD _ d <- decls] + -- NB: this omits fixity decls on local bindings and + -- in class decls. ToDo + + tycl_decls = [d | TyClD _ d <- decls] + (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = + countTyClDecls tycl_decls + + inst_decls = [d | InstD _ d <- decls] + inst_ds = length inst_decls + default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls + val_decls = [d | ValD _ d <- decls] + + real_exports = case exports of { Nothing -> []; Just (L _ es) -> es } + n_exports = length real_exports + export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True + ; _ -> False}) + real_exports + export_ds = n_exports - export_ms + export_all = case exports of { Nothing -> 1; _ -> 0 } + + (val_bind_ds, fn_bind_ds, patsyn_ds) + = sum3 (map count_bind val_decls) + + (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding) + = sum7 (map import_info imports) + (data_constrs, data_derivs) + = sum2 (map data_info tycl_decls) + (class_method_ds, default_method_ds) + = sum2 (map class_info tycl_decls) + (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) + = sum5 (map inst_info inst_decls) + + count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0) + count_bind (PatBind {}) = (0,1,0) + count_bind (FunBind {}) = (0,1,0) + count_bind (PatSynBind {}) = (0,0,1) + count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) + + count_sigs sigs = sum5 (map sig_info sigs) + + sig_info (FixSig {}) = (1,0,0,0,0) + sig_info (TypeSig {}) = (0,1,0,0,0) + sig_info (SpecSig {}) = (0,0,1,0,0) + sig_info (InlineSig {}) = (0,0,0,1,0) + sig_info (ClassOpSig {}) = (0,0,0,0,1) + sig_info _ = (0,0,0,0,0) + + import_info :: LImportDecl GhcPs -> (Int, Int, Int, Int, Int, Int, Int) + import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual + , ideclAs = as, ideclHiding = spec })) + = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) + + safe_info False = 0 + safe_info True = 1 + qual_info NotQualified = 0 + qual_info _ = 1 + as_info Nothing = 0 + as_info (Just _) = 1 + spec_info Nothing = (0,0,0,0,1,0,0) + spec_info (Just (False, _)) = (0,0,0,0,0,1,0) + spec_info (Just (True, _)) = (0,0,0,0,0,0,1) + + data_info (DataDecl { tcdDataDefn = HsDataDefn + { dd_cons = cs + , dd_derivs = L _ derivs}}) + = ( length cs + , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s) + 0 derivs ) + data_info _ = (0,0) + + class_info decl@(ClassDecl {}) + = (classops, addpr (sum3 (map count_bind methods))) + where + methods = map unLoc $ bagToList (tcdMeths decl) + (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl)) + class_info _ = (0,0) + + inst_info :: InstDecl GhcPs -> (Int, Int, Int, Int, Int) + inst_info (TyFamInstD {}) = (0,0,0,1,0) + inst_info (DataFamInstD {}) = (0,0,0,0,1) + inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths + , cid_sigs = inst_sigs + , cid_tyfam_insts = ats + , cid_datafam_insts = adts } }) + = case count_sigs (map unLoc inst_sigs) of + (_,_,ss,is,_) -> + (addpr (sum3 (map count_bind methods)), + ss, is, length ats, length adts) + where + methods = map unLoc $ bagToList inst_meths + + -- TODO: use Sum monoid + addpr :: (Int,Int,Int) -> Int + sum2 :: [(Int, Int)] -> (Int, Int) + sum3 :: [(Int, Int, Int)] -> (Int, Int, Int) + sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int) + sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int) + add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int) + -> (Int, Int, Int, Int, Int, Int, Int) + + addpr (x,y,z) = x+y+z + sum2 = foldr add2 (0,0) + where + add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) + sum3 = foldr add3 (0,0,0) + where + add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3) + sum5 = foldr add5 (0,0,0,0,0) + where + add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) + sum7 = foldr add7 (0,0,0,0,0,0,0) + + add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7) diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -18,15 +18,15 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.HsToCore.Usage import GHC.Driver.Session import GHC.Driver.Types import GHC.Hs -import TcRnTypes -import TcRnMonad ( finalSafeMode, fixSafeInstances ) -import TcRnDriver ( runTcInteractive ) +import GHC.Tc.Types +import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances ) +import GHC.Tc.Module ( runTcInteractive ) import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name @@ -43,28 +43,28 @@ import GHC.HsToCore.Expr import GHC.HsToCore.Binds import GHC.HsToCore.Foreign.Decl -import PrelNames -import TysPrim +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim import GHC.Core.Coercion -import TysWiredIn +import GHC.Builtin.Types import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make -import GHC.Types.Module +import GHC.Unit.Module import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Core.Rules import GHC.Types.Basic -import GHC.Core.Op.Monad ( CoreToDo(..) ) +import GHC.Core.Opt.Monad ( CoreToDo(..) ) import GHC.Core.Lint ( endPassIO ) import GHC.Types.Var.Set -import FastString -import ErrUtils -import Outputable +import GHC.Data.FastString +import GHC.Utils.Error +import GHC.Utils.Outputable import GHC.Types.SrcLoc import GHC.HsToCore.Coverage -import Util -import MonadUtils -import OrdList +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Data.OrdList import GHC.HsToCore.Docs import Data.List @@ -174,7 +174,7 @@ ; let used_names = mkUsedNames tcg_env pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env)) - ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env)) + ; deps <- mkDependencies (thisUnitId (hsc_dflags hsc_env)) (map mi_module pluginModules) tcg_env ; used_th <- readIORef tc_splice_used @@ -417,7 +417,6 @@ ; return (Just rule) } } } -dsRule (L _ (XRuleDecl nec)) = noExtCon nec warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM () -- See Note [Rules and inlining/other rules] @@ -559,7 +558,7 @@ Note [Patching magic definitions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We sometimes need to have access to defined Ids in pure contexts. Usually, we -simply "wire in" these entities, as we do for types in TysWiredIn and for Ids +simply "wire in" these entities, as we do for types in GHC.Builtin.Types and for Ids in GHC.Types.Id.Make. See Note [Wired-in Ids] in GHC.Types.Id.Make. However, it is sometimes *much* easier to define entities in Haskell, 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 @@ -16,7 +16,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.HsToCore.Match import GHC.HsToCore.Utils @@ -25,7 +25,7 @@ import GHC.Hs hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders ) -import TcHsSyn +import GHC.Tc.Utils.Zonk import qualified GHC.Hs.Utils as HsUtils -- NB: The desugarer, which straddles the source and Core worlds, sometimes @@ -36,9 +36,9 @@ import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) -import TcType +import GHC.Tc.Utils.TcType import GHC.Core.Type( splitPiTy ) -import TcEvidence +import GHC.Tc.Types.Evidence import GHC.Core import GHC.Core.FVs import GHC.Core.Utils @@ -47,15 +47,15 @@ import GHC.Types.Id import GHC.Core.ConLike -import TysWiredIn +import GHC.Builtin.Types import GHC.Types.Basic -import PrelNames -import Outputable +import GHC.Builtin.Names +import GHC.Utils.Outputable import GHC.Types.Var.Set import GHC.Types.SrcLoc -import ListSetOps( assocMaybe ) +import GHC.Data.List.SetOps( assocMaybe ) import Data.List -import Util +import GHC.Utils.Misc import GHC.Types.Unique.DSet data DsCmdEnv = DsCmdEnv { @@ -333,7 +333,6 @@ (Lam var match_code) core_cmd return (mkLets meth_binds proc_code) -dsProcExpr _ _ = panic "dsProcExpr" {- Translation of a command judgement of the form @@ -448,45 +447,12 @@ free_vars `unionDVarSet` (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)) --- D; ys |-a cmd : stk t' --- ----------------------------------------------- --- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t' --- --- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd - dsCmd ids local_vars stack_ty res_ty (HsCmdLam _ (MG { mg_alts = (L _ [L _ (Match { m_pats = pats , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) })) - env_ids = do - let pat_vars = mkVarSet (collectPatsBinders pats) - let - local_vars' = pat_vars `unionVarSet` local_vars - (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty - (core_body, free_vars, env_ids') - <- dsfixCmd ids local_vars' stack_ty' res_ty body - param_ids <- mapM newSysLocalDsNoLP pat_tys - stack_id' <- newSysLocalDs stack_ty' - - -- the expression is built from the inside out, so the actions - -- are presented in reverse order - - let - -- build a new environment, plus what's left of the stack - core_expr = buildEnvStack env_ids' stack_id' - in_ty = envStackType env_ids stack_ty - in_ty' = envStackType env_ids' stack_ty' - - fail_expr <- mkFailExpr LambdaExpr in_ty' - -- match the patterns against the parameters - match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr - fail_expr - -- match the parameters against the top of the old stack - (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code - -- match the old environment and stack against the input - select_code <- matchEnvStack env_ids stack_id param_code - return (do_premap ids in_ty in_ty' res_ty select_code core_body, - free_vars `uniqDSetMinusUniqSet` pat_vars) + env_ids + = dsCmdLam ids local_vars stack_ty res_ty pats body env_ids dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids = dsLCmd ids local_vars stack_ty res_ty cmd env_ids @@ -627,6 +593,12 @@ return (do_premap ids in_ty sum_ty res_ty core_matches core_choices, exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars) +dsCmd ids local_vars stack_ty res_ty + (HsCmdLamCase _ mg@MG { mg_ext = MatchGroupTc [arg_ty] _ }) env_ids = do + arg_id <- newSysLocalDs arg_ty + let case_cmd = noLoc $ HsCmdCase noExtField (nlHsVar arg_id) mg + dsCmdLam ids local_vars stack_ty res_ty [nlVarPat arg_id] case_cmd env_ids + -- D; ys |-a cmd : stk --> t -- ---------------------------------- -- D; xs |-a let binds in cmd : stk --> t @@ -694,7 +666,7 @@ core_wrap <- dsHsWrapper wrap return (core_wrap core_cmd, env_ids') -dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) +dsCmd _ _ _ _ c _ = pprPanic "dsCmd" (ppr c) -- D; ys |-a c : stk --> t (ys <= xs) -- --------------------- @@ -721,7 +693,6 @@ arg_code = if env_ids' == env_ids then core_cmd else do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd return (mkLets meth_binds arg_code, free_vars) -dsTrimCmdArg _ _ _ = panic "dsTrimCmdArg" -- Given D; xs |-a c : stk --> t, builds c with xs fed back. -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk)) @@ -755,6 +726,52 @@ (core_cmd, free_vars) <- build_arrow env_ids return (core_cmd, free_vars, dVarSetElems free_vars)) +-- Desugaring for both HsCmdLam and HsCmdLamCase. +-- +-- D; ys |-a cmd : stk t' +-- ----------------------------------------------- +-- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t' +-- +-- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd +dsCmdLam :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this command + -> Type -- type of the stack (right-nested tuple) + -> Type -- return type of the command + -> [LPat GhcTc] -- argument patterns to desugar + -> LHsCmd GhcTc -- body to desugar + -> [Id] -- list of vars in the input to this command + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free +dsCmdLam ids local_vars stack_ty res_ty pats body env_ids = do + let pat_vars = mkVarSet (collectPatsBinders pats) + let local_vars' = pat_vars `unionVarSet` local_vars + (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty + (core_body, free_vars, env_ids') + <- dsfixCmd ids local_vars' stack_ty' res_ty body + param_ids <- mapM newSysLocalDsNoLP pat_tys + stack_id' <- newSysLocalDs stack_ty' + + -- the expression is built from the inside out, so the actions + -- are presented in reverse order + + let -- build a new environment, plus what's left of the stack + core_expr = buildEnvStack env_ids' stack_id' + in_ty = envStackType env_ids stack_ty + in_ty' = envStackType env_ids' stack_ty' + + fail_expr <- mkFailExpr LambdaExpr in_ty' + -- match the patterns against the parameters + match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr + fail_expr + -- match the parameters against the top of the old stack + (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code + -- match the old environment and stack against the input + select_code <- matchEnvStack env_ids stack_id param_code + return (do_premap ids in_ty in_ty' res_ty select_code core_body, + free_vars `uniqDSetMinusUniqSet` pat_vars) + {- Translation of command judgements of the form @@ -868,7 +885,7 @@ -- It would be simpler and more consistent to do this using second, -- but that's likely to be defined in terms of first. -dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do +dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do let pat_ty = hsLPatType pat (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd let pat_vars = mkVarSet (collectPatBinders pat) @@ -1151,7 +1168,6 @@ mkVarSet (collectLStmtsBinders stmts) `unionVarSet` defined_vars) | L _ (GRHS _ stmts body) <- grhss] -leavesMatch _ = panic "leavesMatch" -- Replace the leaf commands in a match @@ -1168,7 +1184,6 @@ (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) -replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch" replaceLeavesGRHS :: [Located (body' GhcTc)] -- replacement leaf expressions of that type @@ -1178,7 +1193,6 @@ replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _)) = (leaves, L loc (GRHS x stmts leaf)) replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" -replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS" -- Balanced fold of a non-empty list. @@ -1196,7 +1210,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The following functions to collect value variables from patterns are copied from GHC.Hs.Utils, with one change: we also collect the dictionary -bindings (pat_binds) from ConPatOut. We need them for cases like +bindings (cpt_binds) from ConPatOut. We need them for cases like h :: Arrow a => Int -> a (Int,Int) Int h x = proc (y,z) -> case compare x y of @@ -1236,8 +1250,8 @@ go (TuplePat _ pats _) = foldr collectl bndrs pats go (SumPat _ pat _ _) = collectl pat bndrs - go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) - go (ConPatOut {pat_args=ps, pat_binds=ds}) = + go (ConPat { pat_args = ps + , pat_con_ext = ConPatTc { cpt_binds = ds }}) = collectEvBinders ds ++ foldr collectl bndrs (hsConPatArgs ps) go (LitPat _ _) = bndrs @@ -1245,10 +1259,9 @@ go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs go (SigPat _ pat _) = collectl pat bndrs - go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs + go (XPat (CoPat _ pat _)) = collectl (noLoc pat) bndrs go (ViewPat _ _ pat) = collectl pat bndrs go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p) - go (XPat nec) = noExtCon nec collectEvBinders :: TcEvBinds -> [Id] collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs 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 @@ -25,7 +25,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr ) import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper ) @@ -38,22 +38,22 @@ import GHC.Hs -- lots of things import GHC.Core -- lots of things import GHC.Core.SimpleOpt ( simpleOptExpr ) -import GHC.Core.Op.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Core.Make import GHC.Core.Utils import GHC.Core.Arity ( etaExpand ) import GHC.Core.Unfold import GHC.Core.FVs -import Digraph +import GHC.Data.Graph.Directed import GHC.Core.Predicate -import PrelNames +import GHC.Builtin.Names import GHC.Core.TyCon -import TcEvidence -import TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Coercion -import TysWiredIn ( typeNatKind, typeSymbolKind ) +import GHC.Builtin.Types ( typeNatKind, typeSymbolKind ) import GHC.Types.Id import GHC.Types.Id.Make(proxyHashId) import GHC.Types.Name @@ -61,18 +61,18 @@ import GHC.Core.Rules import GHC.Types.Var.Env import GHC.Types.Var( EvVar ) -import Outputable -import GHC.Types.Module +import GHC.Utils.Outputable +import GHC.Unit.Module import GHC.Types.SrcLoc -import Maybes -import OrdList -import Bag +import GHC.Data.Maybe +import GHC.Data.OrdList +import GHC.Data.Bag import GHC.Types.Basic import GHC.Driver.Session -import FastString -import Util +import GHC.Data.FastString +import GHC.Utils.Misc import GHC.Types.Unique.Set( nonDetEltsUniqSet ) -import MonadUtils +import GHC.Utils.Monad import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Data.List.NonEmpty ( nonEmpty ) @@ -205,7 +205,6 @@ ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" -dsHsBind _ (XHsBindsLR nec) = noExtCon nec ----------------------- @@ -265,7 +264,6 @@ ; return (makeCorePair dflags global (isDefaultMethod prags) 0 (core_wrap (Var local))) } - mk_bind (XABExport nec) = noExtCon nec ; main_binds <- mapM mk_bind exports ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) } @@ -310,7 +308,6 @@ -- the user written (local) function. The global -- Id is just the selector. Hmm. ; return ((global', rhs) : fromOL spec_binds) } - mk_bind (XABExport nec) = noExtCon nec ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) @@ -376,7 +373,7 @@ -> (Id, CoreExpr) makeCorePair dflags gbl_id is_default_method dict_arity rhs | is_default_method -- Default methods are *always* inlined - -- See Note [INLINE and default methods] in TcInstDcls + -- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs) | otherwise @@ -647,7 +644,7 @@ -> TcSpecPrags -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids , [CoreRule] ) -- Rules for the Global Ids --- See Note [Handling SPECIALISE pragmas] in TcBinds +-- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind dsSpecs _ IsDefaultMethod = return (nilOL, []) dsSpecs poly_rhs (SpecPrags sps) = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps @@ -701,7 +698,7 @@ { this_mod <- getModule ; let fn_unf = realIdUnfolding poly_id - spec_unf = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf + spec_unf = specUnfolding dflags poly_id spec_bndrs core_app arity_decrease fn_unf spec_id = mkLocalId spec_name spec_ty `setInlinePragma` inl_prag `setIdUnfolding` spec_unf @@ -960,9 +957,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 TcHsSyn is careful not to +is an unbound meta-tyvar. The zonker in GHC.Tc.Utils.Zonk is careful not to turn the free alpha into Any (as it usually does). Instead it turns it -into a TyVar 'a'. See TcHsSyn Note [Zonking the LHS of a RULE]. +into a TyVar 'a'. See Note [Zonking the LHS of a RULE] in Ghc.Tc.Syntax. 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/ @@ -1124,7 +1121,7 @@ dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1 ; w2 <- dsHsWrapper c2 ; return (w1 . w2) } - -- See comments on WpFun in TcEvidence for an explanation of what + -- See comments on WpFun in GHC.Tc.Types.Evidence for an explanation of what -- the specification of this clause is dsHsWrapper (WpFun c1 c2 t1 doc) = do { x <- newSysLocalDsNoLP t1 @@ -1176,7 +1173,7 @@ coVarsOfType (varType var) } -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices -- is still deterministic even if the edges are in nondeterministic order - -- as explained in Note [Deterministic SCC] in Digraph. + -- 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 @@ -1285,7 +1282,7 @@ } ds_ev_typeable ty (EvTypeableTyLit ev) - = -- See Note [Typeable for Nat and Symbol] in TcInteract + = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Solver.Interact do { fun <- dsLookupGlobalId tr_fun ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSymbol ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty] 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 @@ -1,6 +1,6 @@ module GHC.HsToCore.Binds where import GHC.HsToCore.Monad ( DsM ) import GHC.Core ( CoreExpr ) -import TcEvidence (HsWrapper) +import GHC.Tc.Types.Evidence (HsWrapper) dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -12,7 +12,7 @@ module GHC.HsToCore.Coverage (addTicksToBinds, hpcInitCode) where -import GhcPrelude as Prelude +import GHC.Prelude as Prelude import qualified GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes @@ -21,30 +21,30 @@ import GHC.Stack.CCS import GHC.Core.Type import GHC.Hs -import GHC.Types.Module as Module -import Outputable +import GHC.Unit +import GHC.Utils.Outputable as Outputable import GHC.Driver.Session import GHC.Core.ConLike import Control.Monad import GHC.Types.SrcLoc -import ErrUtils +import GHC.Utils.Error import GHC.Types.Name.Set hiding (FreeVars) import GHC.Types.Name -import Bag +import GHC.Data.Bag import GHC.Types.CostCentre import GHC.Types.CostCentre.State import GHC.Core import GHC.Types.Id import GHC.Types.Var.Set import Data.List -import FastString +import GHC.Data.FastString import GHC.Driver.Types import GHC.Core.TyCon import GHC.Types.Basic -import MonadUtils -import Maybes +import GHC.Utils.Monad +import GHC.Data.Maybe import GHC.Cmm.CLabel -import Util +import GHC.Utils.Misc import Data.Time import System.Directory @@ -181,8 +181,8 @@ mod_name = moduleNameString (moduleName mod) hpc_mod_dir - | moduleUnitId mod == mainUnitId = hpc_dir - | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod) + | moduleUnit mod == mainUnitId = hpc_dir + | otherwise = hpc_dir ++ "/" ++ unitString (moduleUnit mod) tabStop = 8 -- counts as a normal char in GHC's -- location ranges. @@ -304,10 +304,6 @@ addPathEntry name $ addTickMatchGroup False (fun_matches funBind) - case mg of - MG {} -> return () - _ -> panic "addTickLHsBind" - blackListed <- isBlackListed pos exported_names <- liftM exports getEnv @@ -378,7 +374,6 @@ -- Only internal stuff, not from source, uses VarBind, so we ignore it. addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind -addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind bindTick :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) @@ -647,7 +642,6 @@ addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e ; return (L l (Present x e')) } addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) -addTickTupArg (L _ (XTupArg nec)) = noExtCon nec addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) @@ -656,7 +650,6 @@ let isOneOfMany = matchesOneOfMany matches matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches return $ mg { mg_alts = L l matches' } -addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) -> TM (Match GhcTc (LHsExpr GhcTc)) @@ -665,7 +658,6 @@ bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs return $ match { m_grhss = gRHSs' } -addTickMatch _ _ (XMatch nec) = noExtCon nec addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc)) @@ -676,7 +668,6 @@ return $ GRHSs x guarded' (L l local_binds') where binders = collectLocalBinders local_binds -addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc)) @@ -684,7 +675,6 @@ (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (addTickGRHSBody isOneOfMany isLambda expr) return $ GRHS x stmts' expr' -addTickGRHS _ _ (XGRHS nec) = noExtCon nec addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do @@ -719,12 +709,16 @@ (addTickLHsExpr e) (pure noret) (addTickSyntaxExpr hpcSrcSpan ret) -addTickStmt _isGuard (BindStmt x pat e bind fail) = do - liftM4 (BindStmt x) +addTickStmt _isGuard (BindStmt xbs pat e) = do + liftM4 (\b f -> BindStmt $ XBindStmtTc + { xbstc_bindOp = b + , xbstc_boundResultType = xbstc_boundResultType xbs + , xbstc_failOp = f + }) + (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs)) + (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs)) (addTickLPat pat) (addTickLHsExprRHS e) - (addTickSyntaxExpr hpcSrcSpan bind) - (addTickSyntaxExpr hpcSrcSpan fail) addTickStmt isGuard (BodyStmt x e bind' guard') = do liftM3 (BodyStmt x) (addTick isGuard e) @@ -763,8 +757,6 @@ ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } -addTickStmt _ (XStmtLR nec) = noExtCon nec - addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e | otherwise = addTickLHsExprRHS e @@ -775,18 +767,17 @@ addTickApplicativeArg isGuard (op, arg) = liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) where - addTickArg (ApplicativeArgOne x pat expr isBody fail) = - (ApplicativeArgOne x) - <$> addTickLPat pat + addTickArg (ApplicativeArgOne m_fail pat expr isBody) = + ApplicativeArgOne + <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail + <*> addTickLPat pat <*> addTickLHsExpr expr <*> pure isBody - <*> addTickSyntaxExpr hpcSrcSpan fail addTickArg (ApplicativeArgMany x stmts ret pat) = (ApplicativeArgMany x) <$> addTickLStmts isGuard stmts <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) <*> addTickLPat pat - addTickArg (XApplicativeArg nec) = noExtCon nec addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc) @@ -795,7 +786,6 @@ (addTickLStmts isGuard stmts) (return ids) (addTickSyntaxExpr hpcSrcSpan returnExpr) -addTickStmtAndBinders _ (XParStmtBlock nec) = noExtCon nec addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) addTickHsLocalBinds (HsValBinds x binds) = @@ -805,7 +795,6 @@ liftM (HsIPBinds x) (addTickHsIPBinds binds) addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x) -addTickHsLocalBinds (XHsLocalBindsLR x) = return (XHsLocalBindsLR x) addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) -> TM (HsValBindsLR GhcTc (GhcPass b)) @@ -825,14 +814,12 @@ liftM2 IPBinds (return dictbinds) (mapM (liftL (addTickIPBind)) ipbinds) -addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x) addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) addTickIPBind (IPBind x nm e) = liftM2 (IPBind x) (return nm) (addTickLHsExpr e) -addTickIPBind (XIPBind x) = return (XIPBind x) -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) @@ -850,7 +837,6 @@ liftM2 HsCmdTop (return x) (addTickLHsCmd cmd) -addTickHsCmdTop (XCmdTop nec) = noExtCon nec addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) addTickLHsCmd (L pos c0) = do @@ -875,6 +861,8 @@ liftM2 (HsCmdCase x) (addTickLHsExpr e) (addTickCmdMatchGroup mgs) +addTickHsCmd (HsCmdLamCase x mgs) = + liftM (HsCmdLamCase x) (addTickCmdMatchGroup mgs) addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = liftM3 (HsCmdIf x cnd) (addBinTickLHsExpr (BinBox CondBinBox) e1) @@ -915,14 +903,12 @@ addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do matches' <- mapM (liftL addTickCmdMatch) matches return $ mg { mg_alts = L l matches' } -addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickCmdGRHSs gRHSs return $ match { m_grhss = gRHSs' } -addTickCmdMatch (XMatch nec) = noExtCon nec addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do @@ -932,7 +918,6 @@ return $ GRHSs x guarded' (L l local_binds') where binders = collectLocalBinders local_binds -addTickCmdGRHSs (XGRHSs nec) = noExtCon nec addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) -- The *guards* are *not* Cmds, although the body is @@ -941,7 +926,6 @@ = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (addTickLHsCmd cmd) ; return $ GRHS x stmts' expr' } -addTickCmdGRHS (XGRHS nec) = noExtCon nec addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM [LStmt GhcTc (LHsCmd GhcTc)] @@ -960,12 +944,10 @@ binders = collectLStmtsBinders lstmts addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) -addTickCmdStmt (BindStmt x pat c bind fail) = do - liftM4 (BindStmt x) +addTickCmdStmt (BindStmt x pat c) = do + liftM2 (BindStmt x) (addTickLPat pat) (addTickLHsCmd c) - (return bind) - (return fail) addTickCmdStmt (LastStmt x c noret ret) = do liftM3 (LastStmt x) (addTickLHsCmd c) @@ -988,8 +970,6 @@ , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } addTickCmdStmt ApplicativeStmt{} = panic "ToDo: addTickCmdStmt ApplicativeLastStmt" -addTickCmdStmt (XStmtLR nec) = - noExtCon nec -- Others should never happen in a command context. addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt) @@ -1296,11 +1276,9 @@ matchesOneOfMany :: [LMatch GhcTc body] -> Bool matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 where + matchCount :: LMatch GhcTc body -> Int matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) = length grhss - matchCount (L _ (Match { m_grhss = XGRHSs nec })) - = noExtCon nec - matchCount (L _ (XMatch nec)) = noExtCon nec type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) @@ -1358,11 +1336,11 @@ tickboxes = ppr (mkHpcTicksLabel $ this_mod) module_name = hcat (map (text.charToC) $ BS.unpack $ - bytesFS (moduleNameFS (Module.moduleName this_mod))) + bytesFS (moduleNameFS (moduleName this_mod))) package_name = hcat (map (text.charToC) $ BS.unpack $ - bytesFS (unitIdFS (moduleUnitId this_mod))) + bytesFS (unitFS (moduleUnit this_mod))) full_name_str - | moduleUnitId this_mod == mainUnitId + | moduleUnit this_mod == mainUnitId = module_name | otherwise = package_name <> char '/' <> module_name 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 @@ -8,8 +8,8 @@ module GHC.HsToCore.Docs (extractDocs) where -import GhcPrelude -import Bag +import GHC.Prelude +import GHC.Data.Bag import GHC.Hs.Binds import GHC.Hs.Doc import GHC.Hs.Decls @@ -19,7 +19,7 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.SrcLoc -import TcRnTypes +import GHC.Tc.Types import Control.Applicative import Data.Bifunctor (first) @@ -117,7 +117,9 @@ (associated with InstDecls and DerivDecls). -} -getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)] +getMainDeclBinder :: (CollectPass (GhcPass p)) + => HsDecl (GhcPass p) + -> [IdP (GhcPass p)] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of @@ -151,12 +153,6 @@ -- equation. This does not happen for data family instances, for some -- reason. { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l - ClsInstD _ (XClsInstDecl _) -> error "getInstLoc" - DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" - TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" - XInstDecl _ -> error "getInstLoc" - DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc" - TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc" -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data @@ -292,9 +288,11 @@ mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++ mkDecls (valbinds . hs_valds) (ValD noExtField) group_ where + typesigs :: HsValBinds GhcRn -> [LSig GhcRn] typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig typesigs ValBinds{} = error "expected XValBindsLR" + valbinds :: HsValBinds GhcRn -> [LHsBind GhcRn] valbinds (XValBindsLR (NValBinds binds _)) = concatMap bagToList . snd . unzip $ binds valbinds ValBinds{} = error "expected XValBindsLR" 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 @@ -22,7 +22,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.HsToCore.Match import GHC.HsToCore.Match.Literal @@ -41,9 +41,9 @@ -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types -import TcType -import TcEvidence -import TcRnMonad +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.Monad import GHC.Core.Type import GHC.Core import GHC.Core.Utils @@ -53,19 +53,19 @@ import GHC.Types.CostCentre import GHC.Types.Id import GHC.Types.Id.Make -import GHC.Types.Module +import GHC.Unit.Module import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCo.Ppr( pprWithTYPE ) -import TysWiredIn -import PrelNames +import GHC.Builtin.Types +import GHC.Builtin.Names import GHC.Types.Basic -import Maybes +import GHC.Data.Maybe import GHC.Types.Var.Env import GHC.Types.SrcLoc -import Util -import Bag -import Outputable +import GHC.Utils.Misc +import GHC.Data.Bag +import GHC.Utils.Outputable as Outputable import GHC.Core.PatSyn import Control.Monad @@ -84,7 +84,6 @@ dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ dsValBinds binds body dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body -dsLocalBinds _ _ = panic "dsLocalBinds" ------------------------- -- caller sets location @@ -105,8 +104,6 @@ ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body = do e' <- dsLExpr e return (Let (NonRec n e') body) - ds_ip_bind _ _ = panic "dsIPBinds" -dsIPBinds (XHsIPBinds nec) _ = noExtCon nec ------------------------- -- caller sets location @@ -181,7 +178,7 @@ -- mixed up, which is what happens in one rare case -- Namely, for an AbsBind with no tyvars and no dicts, -- but which does have dictionary bindings. - -- See notes with TcSimplify.inferLoop [NO TYVARS] + -- See notes with GHC.Tc.Solver.inferLoop [NO TYVARS] -- It turned out that wrapping a Rec here was the easiest solution -- -- NB The previous case dealt with unlifted bindings, so we @@ -242,7 +239,7 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ do { core_expr <- dsExpr e - -- uncomment this check to test the hsExprType function in TcHsSyn + -- uncomment this check to test the hsExprType function in GHC.Tc.Utils.Zonk -- ; MASSERT2( exprType core_expr `eqType` hsExprType e -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$ -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) ) @@ -319,9 +316,9 @@ ; dsWhenNoErrs (dsLExprNoLP arg) (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } -dsExpr (HsAppType _ e _) - -- ignore type arguments here; they're in the wrappers instead at this point - = dsLExpr e +dsExpr (HsAppType ty e _) + = do { e' <- dsLExpr e + ; return (App e' (Type ty)) } {- Note [Desugaring vars] @@ -396,7 +393,6 @@ -- lambdas, just arguments. = do { core_expr <- dsLExprNoLP expr ; return (lam_vars, core_expr : args) } - go _ _ = panic "dsExpr" ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) -- The reverse is because foldM goes left-to-right @@ -475,7 +471,7 @@ Static Pointers ~~~~~~~~~~~~~~~ -See Note [Grand plan for static forms] in StaticPtrTable for an overview. +See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. g = ... static f ... ==> @@ -645,11 +641,7 @@ mk_alt upd_fld_env con = do { let (univ_tvs, ex_tvs, eq_spec, prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con - user_tvs = - case con of - RealDataCon data_con -> dataConUserTyVars data_con - PatSynCon _ -> univ_tvs ++ ex_tvs - -- The order here is because of the order in `TcPatSyn`. + user_tvs = binderVars $ conLikeUserTyVarBinders con in_subst = zipTvSubst univ_tvs in_inst_tys out_subst = zipTvSubst univ_tvs out_inst_tys @@ -705,13 +697,16 @@ req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys - pat = noLoc $ ConPatOut { pat_con = noLoc con - , pat_tvs = ex_tvs - , pat_dicts = eqs_vars ++ theta_vars - , pat_binds = emptyTcEvBinds - , pat_args = PrefixCon $ map nlVarPat arg_ids - , pat_arg_tys = in_inst_tys - , pat_wrap = req_wrap } + pat = noLoc $ ConPat { pat_con = noLoc con + , pat_args = PrefixCon $ map nlVarPat arg_ids + , pat_con_ext = ConPatTc + { cpt_tvs = ex_tvs + , cpt_dicts = eqs_vars ++ theta_vars + , cpt_binds = emptyTcEvBinds + , cpt_arg_tys = in_inst_tys + , cpt_wrap = req_wrap + } + } ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } {- Note [Scrutinee in Record updates] @@ -786,7 +781,6 @@ if gopt Opt_Hpc dflags then panic "dsExpr:HsPragTick" else dsLExpr expr -ds_prag_expr (XHsPragE x) _ = noExtCon x ------------------------------ dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr @@ -797,7 +791,7 @@ = do { fun <- dsExpr expr ; core_arg_wraps <- mapM dsHsWrapper arg_wraps ; core_res_wrap <- dsHsWrapper res_wrap - ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs + ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]) (\_ -> core_res_wrap (mkApps fun wrapped_args)) } where @@ -942,25 +936,24 @@ = do { rest <- goL stmts ; dsLocalBinds binds rest } - go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts + go _ (BindStmt xbs pat rhs) stmts = do { body <- goL stmts ; rhs' <- dsLExpr rhs ; var <- selectSimpleMatchVarL pat ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat - res1_ty (cantFailMatchResult body) - ; match_code <- dsHandleMonadicFailure pat match fail_op - ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } + (xbstc_boundResultType xbs) (cantFailMatchResult body) + ; match_code <- dsHandleMonadicFailure pat match (xbstc_failOp xbs) + ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] } go _ (ApplicativeStmt body_ty args mb_join) stmts = do { let (pats, rhss) = unzip (map (do_arg . snd) args) - do_arg (ApplicativeArgOne _ pat expr _ fail_op) = + do_arg (ApplicativeArgOne fail_op pat expr _) = ((pat, fail_op), dsLExpr expr) do_arg (ApplicativeArgMany _ stmts ret pat) = - ((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) - do_arg (XApplicativeArg nec) = noExtCon nec + ((pat, Nothing), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) ; rhss' <- sequence rhss @@ -991,9 +984,14 @@ , recS_ret_ty = body_ty} }) stmts = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } where - new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats) - mfix_app bind_op - noSyntaxExpr -- Tuple cannot fail + new_bind_stmt = L loc $ BindStmt + XBindStmtTc + { xbstc_bindOp = bind_op + , xbstc_boundResultType = bind_ty + , xbstc_failOp = Nothing -- Tuple cannot fail + } + (mkBigLHsPatTupId later_pats) + mfix_app tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case @@ -1018,19 +1016,27 @@ go _ (ParStmt {}) _ = panic "dsDo ParStmt" go _ (TransStmt {}) _ = panic "dsDo TransStmt" - go _ (XStmtLR nec) _ = noExtCon nec -dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr +dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr -- In a do expression, pattern-match failure just calls -- the monadic 'fail' rather than throwing an exception -dsHandleMonadicFailure pat match fail_op - | matchCanFail match - = do { dflags <- getDynFlags - ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) - ; fail_expr <- dsSyntaxExpr fail_op [fail_msg] - ; extractMatchResult match fail_expr } - | otherwise - = extractMatchResult match (error "It can't fail") +dsHandleMonadicFailure pat match m_fail_op = + case shareFailureHandler match of + MR_Infallible body -> body + MR_Fallible body -> do + fail_op <- case m_fail_op of + -- Note that (non-monadic) list comprehension, pattern guards, etc could + -- have fallible bindings without an explicit failure op, but this is + -- handled elsewhere. See Note [Failing pattern matches in Stmts] the + -- breakdown of regular and special binds. + Nothing -> pprPanic "missing fail op" $ + text "Pattern match:" <+> ppr pat <+> + text "is failable, and fail_expr was left unset" + Just fail_op -> pure fail_op + dflags <- getDynFlags + fail_msg <- mkStringExpr (mk_fail_msg dflags pat) + fail_expr <- dsSyntaxExpr fail_op [fail_msg] + body fail_expr mk_fail_msg :: DynFlags -> Located e -> String mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ diff --git a/compiler/GHC/HsToCore/Expr.hs-boot b/compiler/GHC/HsToCore/Expr.hs-boot --- a/compiler/GHC/HsToCore/Expr.hs-boot +++ b/compiler/GHC/HsToCore/Expr.hs-boot @@ -1,5 +1,5 @@ module GHC.HsToCore.Expr where -import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr ) +import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr, FailOperator ) import GHC.HsToCore.Monad ( DsM, MatchResult ) import GHC.Core ( CoreExpr ) import GHC.Hs.Extension ( GhcTc) @@ -9,4 +9,4 @@ dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr +dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr 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 @@ -22,7 +22,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Core @@ -35,20 +35,20 @@ import GHC.Core.DataCon import GHC.HsToCore.Utils -import TcType +import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Types.Id ( Id ) import GHC.Core.Coercion -import PrimOp -import TysPrim +import GHC.Builtin.PrimOps +import GHC.Builtin.Types.Prim import GHC.Core.TyCon -import TysWiredIn +import GHC.Builtin.Types import GHC.Types.Basic import GHC.Types.Literal -import PrelNames +import GHC.Builtin.Names import GHC.Driver.Session -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import Data.Maybe 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 @@ -16,9 +16,9 @@ module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import TcRnMonad -- temp +import GHC.Tc.Utils.Monad -- temp import GHC.Core @@ -30,32 +30,32 @@ import GHC.Core.Unfold import GHC.Types.Id import GHC.Types.Literal -import GHC.Types.Module +import GHC.Unit.Module import GHC.Types.Name import GHC.Core.Type import GHC.Types.RepType import GHC.Core.TyCon import GHC.Core.Coercion -import TcEnv -import TcType +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcType import GHC.Cmm.Expr import GHC.Cmm.Utils import GHC.Driver.Types import GHC.Types.ForeignCall -import TysWiredIn -import TysPrim -import PrelNames +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Builtin.Names import GHC.Types.Basic import GHC.Types.SrcLoc -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Driver.Session import GHC.Platform -import OrdList -import Util +import GHC.Data.OrdList +import GHC.Utils.Misc import GHC.Driver.Hooks -import Encoding +import GHC.Utils.Encoding import Data.Maybe import Data.List @@ -100,6 +100,7 @@ where do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) + do_decl :: ForeignDecl GhcTc -> DsM (SDoc, SDoc, [Id], [Binding]) do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do traceIf (text "fi start" <+> ppr id) let id' = unLoc id @@ -113,7 +114,6 @@ (L _ (CExportStatic _ ext_nm cconv)) _ }) = do (h, c, _, _) <- dsFExport id co ext_nm cconv False return (h, c, [id], []) - do_decl (XForeignDecl nec) = noExtCon nec {- ************************************************************************ 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 @@ -13,7 +13,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsLocalBinds ) import {-# SOURCE #-} GHC.HsToCore.Match ( matchSinglePatVar ) @@ -27,9 +27,9 @@ import GHC.HsToCore.Utils import GHC.HsToCore.PmCheck.Types ( Deltas, initDeltas ) import GHC.Core.Type ( Type ) -import Util +import GHC.Utils.Misc import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import Control.Monad ( zipWithM ) import Data.List.NonEmpty ( NonEmpty, toList ) @@ -52,7 +52,7 @@ error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty extractMatchResult match_result error_expr --- In contrast, @dsGRHSs@ produces a @MatchResult@. +-- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@. dsGRHSs :: HsMatchContext GhcRn -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs @@ -60,7 +60,7 @@ -> Maybe (NonEmpty Deltas) -- ^ Refined pattern match checking -- models, one for each GRHS. Defaults -- to 'initDeltas' if 'Nothing'. - -> DsM MatchResult + -> DsM (MatchResult CoreExpr) dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty mb_rhss_deltas = ASSERT( notNull grhss ) do { match_results <- case toList <$> mb_rhss_deltas of @@ -71,18 +71,16 @@ match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1 -- NB: nested dsLet inside matchResult ; return match_result2 } -dsGRHSs _ (XGRHSs nec) _ _ = noExtCon nec dsGRHS :: HsMatchContext GhcRn -> Type -> Deltas -> LGRHS GhcTc (LHsExpr GhcTc) - -> DsM MatchResult + -> DsM (MatchResult CoreExpr) dsGRHS hs_ctx rhs_ty rhs_deltas (L _ (GRHS _ guards rhs)) = updPmDeltas rhs_deltas (matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty) -dsGRHS _ _ _ (L _ (XGRHS nec)) = noExtCon nec {- ************************************************************************ * * -* matchGuard : make a MatchResult from a guarded RHS * +* matchGuard : make a MatchResult CoreExpr CoreExpr from a guarded RHS * * * ************************************************************************ -} @@ -91,7 +89,7 @@ -> HsStmtContext GhcRn -- Context -> LHsExpr GhcTc -- RHS -> Type -- Type of RHS of guard - -> DsM MatchResult + -> DsM (MatchResult CoreExpr) -- See comments with HsExpr.Stmt re what a BodyStmt means -- Here we must be in a guard context (not do-expression, nor list-comp) @@ -124,7 +122,7 @@ -- so we can't desugar the bindings without the -- body expression in hand -matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do +matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do let upat = unLoc pat match_var <- selectMatchVar upat @@ -132,7 +130,7 @@ core_rhs <- dsLExpr bind_rhs match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty match_result - pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result' + pure $ bindNonRec match_var core_rhs <$> match_result' matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt" matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt" @@ -140,8 +138,6 @@ matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt" matchGuards (ApplicativeStmt {} : _) _ _ _ = panic "matchGuards ApplicativeLastStmt" -matchGuards (XStmtLR nec : _) _ _ _ = - noExtCon nec {- Should {\em fail} if @e@ returns @D@ 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 @@ -14,12 +14,12 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.HsToCore.Expr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) import GHC.Hs -import TcHsSyn +import GHC.Tc.Utils.Zonk import GHC.Core import GHC.Core.Make @@ -30,14 +30,14 @@ import GHC.Core.Utils import GHC.Types.Id import GHC.Core.Type -import TysWiredIn +import GHC.Builtin.Types import GHC.HsToCore.Match -import PrelNames +import GHC.Builtin.Names import GHC.Types.SrcLoc -import Outputable -import TcType -import ListSetOps( getNth ) -import Util +import GHC.Utils.Outputable +import GHC.Tc.Utils.TcType +import GHC.Data.List.SetOps( getNth ) +import GHC.Utils.Misc {- List comprehensions may be desugared in one of two ways: ``ordinary'' @@ -91,7 +91,6 @@ ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty ; return (expr, bndrs_tuple_type) } -dsInnerListComp (XParStmtBlock nec) = noExtCon nec -- This function factors out commonality between the desugaring strategies for GroupStmt. -- Given such a statement it gives you back an expression representing how to compute the transformed @@ -242,7 +241,7 @@ (inner_list_expr, pat) <- dsTransStmt stmt deBindComp pat inner_list_expr quals list -deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above +deListComp (BindStmt _ pat list1 : quals) core_list2 = do -- rule A' above core_list1 <- dsLExprNoLP list1 deBindComp pat core_list1 quals core_list2 @@ -267,10 +266,7 @@ deListComp (ApplicativeStmt {} : _) _ = panic "deListComp ApplicativeStmt" -deListComp (XStmtLR nec : _) _ = - noExtCon nec - -deBindComp :: OutPat GhcTc +deBindComp :: LPat GhcTc -> CoreExpr -> [ExprStmt GhcTc] -> CoreExpr @@ -353,7 +349,7 @@ -- Anyway, we bind the newly grouped list via the generic binding function dfBindComp c_id n_id (pat, inner_list_expr) quals -dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do +dfListComp c_id n_id (BindStmt _ pat list1 : quals) = do -- evaluate the two lists core_list1 <- dsLExpr list1 @@ -364,8 +360,6 @@ dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" dfListComp _ _ (ApplicativeStmt {} : _) = panic "dfListComp ApplicativeStmt" -dfListComp _ _ (XStmtLR nec : _) = - noExtCon nec dfBindComp :: Id -> Id -- 'c' and 'n' -> (LPat GhcTc, CoreExpr) @@ -501,9 +495,9 @@ ; dsLocalBinds binds rest } -- [ .. | a <- m, stmts ] -dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts +dsMcStmt (BindStmt xbs pat rhs) stmts = do { rhs' <- dsLExpr rhs - ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts } + ; dsMcBindStmt pat rhs' (xbstc_bindOp xbs) (xbstc_failOp xbs) (xbstc_boundResultType xbs) stmts } -- Apply `guard` to the `exp` expression -- @@ -591,12 +585,12 @@ mkBoxedTupleTy [t1,t2])) exps_w_tys - ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest } + ; dsMcBindStmt pat rhs bind_op Nothing bind_ty stmts_rest } where + ds_inner :: ParStmtBlock GhcTc GhcTc -> DsM (CoreExpr, Type) ds_inner (ParStmtBlock _ stmts bndrs return_op) = do { exp <- dsInnerMonadComp stmts bndrs return_op ; return (exp, mkBigCoreVarTupTy bndrs) } - ds_inner (XParStmtBlock nec) = noExtCon nec dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) @@ -615,7 +609,7 @@ dsMcBindStmt :: LPat GhcTc -> CoreExpr -- ^ the desugared rhs of the bind statement -> SyntaxExpr GhcTc - -> SyntaxExpr GhcTc + -> Maybe (SyntaxExpr GhcTc) -> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T -> [ExprLStmt GhcTc] -> DsM CoreExpr 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 @@ -23,7 +23,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr) @@ -31,9 +31,9 @@ import GHC.Types.Basic ( Origin(..) ) import GHC.Driver.Session import GHC.Hs -import TcHsSyn -import TcEvidence -import TcRnMonad +import GHC.Tc.Utils.Zonk +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.Monad import GHC.HsToCore.PmCheck import GHC.Core import GHC.Types.Literal @@ -52,14 +52,14 @@ import GHC.Core.Type import GHC.Core.Coercion ( eqCoercion ) import GHC.Core.TyCon ( isNewTyCon ) -import TysWiredIn +import GHC.Builtin.Types import GHC.Types.SrcLoc -import Maybes -import Util +import GHC.Data.Maybe +import GHC.Utils.Misc import GHC.Types.Name -import Outputable +import GHC.Utils.Outputable import GHC.Types.Basic ( isGenerated, il_value, fl_value ) -import FastString +import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM @@ -174,7 +174,7 @@ match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with. See Note [Match Ids] -> Type -- ^ Type of the case expression -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below) - -> DsM MatchResult -- ^ Desugared result! + -> DsM (MatchResult CoreExpr) -- ^ Desugared result! match [] ty eqns = ASSERT2( not (null eqns), ppr ty ) @@ -198,20 +198,21 @@ ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped) ; match_results <- match_groups grouped - ; return (adjustMatchResult (foldr (.) id aux_binds) $ - foldr1 combineMatchResults match_results) } + ; return $ foldr (.) id aux_binds <$> + foldr1 combineMatchResults match_results + } where vars = v :| vs dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo dropGroup = fmap snd - match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty MatchResult) - -- Result list of [MatchResult] is always non-empty + match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty (MatchResult CoreExpr)) + -- Result list of [MatchResult CoreExpr] is always non-empty match_groups [] = matchEmpty v ty match_groups (g:gs) = mapM match_group $ g :| gs - match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM MatchResult + match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr) match_group eqns@((group,_) :| _) = case group of PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns']) @@ -245,29 +246,29 @@ maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) (filter (not . null) gs)) -matchEmpty :: MatchId -> Type -> DsM (NonEmpty MatchResult) +matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr)) -- See Note [Empty case expressions] matchEmpty var res_ty - = return [MatchResult CanFail mk_seq] + = return [MR_Fallible mk_seq] where mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty [(DEFAULT, [], fail)] -matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- Real true variables, just like in matchVar, SLPJ p 94 -- No binding to do: they'll all be wildcards by now (done in tidy) matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns -matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) matchBangs (var :| vars) ty eqns = do { match_result <- match (var:vars) ty $ NEL.toList $ decomposeFirstPat getBangPat <$> eqns ; return (mkEvalMatchResult var ty match_result) } -matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- Apply the coercion to the match variable and then match that matchCoercion (var :| vars) ty (eqns@(eqn1 :| _)) - = do { let CoPat _ co pat _ = firstPat eqn1 + = do { let XPat (CoPat co pat _) = firstPat eqn1 ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var pat_ty' ; match_result <- match (var':vars) ty $ NEL.toList $ @@ -276,7 +277,7 @@ ; let bind = NonRec var' (core_wrap (Var var)) ; return (mkCoLetMatchResult bind match_result) } -matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- Apply the view function to the match variable and then match that matchView (var :| vars) ty (eqns@(eqn1 :| _)) = do { -- we could pass in the expr from the PgView, @@ -294,7 +295,7 @@ (mkCoreAppDs (text "matchView") viewExpr' (Var var)) match_result) } -matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _)) -- Since overloaded list patterns are treated as view patterns, -- the code is roughly the same as for matchView @@ -313,7 +314,7 @@ decomposeFirstPat _ _ = panic "decomposeFirstPat" getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc -getCoPat (CoPat _ _ pat _) = pat +getCoPat (XPat (CoPat _ pat _)) = pat getCoPat _ = panic "getCoPat" getBangPat (BangPat _ pat ) = unLoc pat getBangPat _ = panic "getBangPat" @@ -339,7 +340,7 @@ error "empty case" or some such, because 'x' might be bound to (error "hello"), in which case we want to see that "hello" exception, not (error "empty case"). -See also Note [Case elimination: lifted case] in GHC.Core.Op.Simplify. +See also Note [Case elimination: lifted case] in GHC.Core.Opt.Simplify. ************************************************************************ @@ -512,8 +513,8 @@ -- it may disappear next time tidy_bang_pat v o l (AsPat x v' p) = tidy1 v o (AsPat x v' (L l (BangPat noExtField p))) -tidy_bang_pat v o l (CoPat x w p t) - = tidy1 v o (CoPat x w (BangPat noExtField (L l p)) t) +tidy_bang_pat v o l (XPat (CoPat w p t)) + = tidy1 v o (XPat $ CoPat w (BangPat noExtField (L l p)) t) -- Discard bang around strict pattern tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p @@ -522,9 +523,12 @@ tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p -- Data/newtype constructors -tidy_bang_pat v o l p@(ConPatOut { pat_con = L _ (RealDataCon dc) - , pat_args = args - , pat_arg_tys = arg_tys }) +tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc) + , pat_args = args + , pat_con_ext = ConPatTc + { cpt_arg_tys = arg_tys + } + }) -- Newtypes: push bang inwards (#9844) = if isNewTyCon (dataConTyCon dc) @@ -770,7 +774,6 @@ mk_eqn_infos [] _ = return [] -- Called once per equation in the match, or alternative in the case mk_eqn_info (Match { m_pats = pats, m_grhss = grhss }) rhss_deltas - | XGRHSs nec <- grhss = noExtCon nec | GRHSs _ grhss' _ <- grhss, let n_grhss = length grhss' = do { dflags <- getDynFlags ; let upats = map (unLoc . decideBangHood dflags) pats @@ -786,12 +789,10 @@ , eqn_orig = FromSource , eqn_rhs = match_result } , rhss_deltas' ) } - mk_eqn_info (XMatch nec) _ = noExtCon nec handleWarnings = if isGenerated origin then discardWarningsDs else id -matchWrapper _ _ (XMatchGroup nec) = noExtCon nec matchEquations :: HsMatchContext GhcRn -> [MatchId] -> [EquationInfo] -> Type @@ -832,7 +833,7 @@ extractMatchResult match_result' fail_expr matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc - -> Type -> MatchResult -> DsM MatchResult + -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) -- matchSinglePat ensures that the scrutinee is a variable -- and then calls matchSinglePatVar -- @@ -847,11 +848,12 @@ matchSinglePat scrut hs_ctx pat ty match_result = do { var <- selectSimpleMatchVarL pat ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result - ; return (adjustMatchResult (bindNonRec var scrut) match_result') } + ; return $ bindNonRec var scrut <$> match_result' + } matchSinglePatVar :: Id -- See Note [Match Ids] -> HsMatchContext GhcRn -> LPat GhcTc - -> Type -> MatchResult -> DsM MatchResult + -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) matchSinglePatVar var ctx pat ty match_result = ASSERT2( isInternalName (idName var), ppr var ) do { dflags <- getDynFlags @@ -1120,8 +1122,9 @@ eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys patGroup :: Platform -> Pat GhcTc -> PatGroup -patGroup _ (ConPatOut { pat_con = L _ con - , pat_arg_tys = tys }) +patGroup _ (ConPat { pat_con = L _ con + , pat_con_ext = ConPatTc { cpt_arg_tys = tys } + }) | RealDataCon dcon <- con = PgCon dcon | PatSynCon psyn <- con = PgSyn psyn tys patGroup _ (WildPat {}) = PgAny @@ -1138,7 +1141,7 @@ case oval of HsIntegral i -> PgNpK (il_value i) _ -> pprPanic "patGroup NPlusKPat" (ppr oval) -patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p) +patGroup _ (XPat (CoPat _ p _)) = PgCo (hsPatType p) -- Type of innelexp pattern patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p)) patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList 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 @@ -1,8 +1,8 @@ module GHC.HsToCore.Match where -import GhcPrelude +import GHC.Prelude import GHC.Types.Var ( Id ) -import TcType ( Type ) +import GHC.Tc.Utils.TcType ( Type ) import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult ) import GHC.Core ( CoreExpr ) import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr ) @@ -11,7 +11,7 @@ match :: [Id] -> Type -> [EquationInfo] - -> DsM MatchResult + -> DsM (MatchResult CoreExpr) matchWrapper :: HsMatchContext GhcRn @@ -32,5 +32,5 @@ -> HsMatchContext GhcRn -> LPat GhcTc -> Type - -> MatchResult - -> DsM MatchResult + -> MatchResult CoreExpr + -> DsM (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 @@ -16,7 +16,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.HsToCore.Match ( match ) @@ -24,16 +24,17 @@ import GHC.HsToCore.Binds import GHC.Core.ConLike import GHC.Types.Basic ( Origin(..) ) -import TcType +import GHC.Tc.Utils.TcType import GHC.HsToCore.Monad import GHC.HsToCore.Utils +import GHC.Core ( CoreExpr ) import GHC.Core.Make ( mkCoreLets ) -import Util +import GHC.Utils.Misc import GHC.Types.Id import GHC.Types.Name.Env import GHC.Types.FieldLabel ( flSelector ) import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import Control.Monad(liftM) import Data.List (groupBy) import Data.List.NonEmpty (NonEmpty(..)) @@ -94,7 +95,7 @@ matchConFamily :: NonEmpty Id -> Type -> NonEmpty (NonEmpty EquationInfo) - -> DsM MatchResult + -> DsM (MatchResult CoreExpr) -- Each group of eqns is for a single constructor matchConFamily (var :| vars) ty groups = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups @@ -107,7 +108,7 @@ matchPatSyn :: NonEmpty Id -> Type -> NonEmpty EquationInfo - -> DsM MatchResult + -> DsM (MatchResult CoreExpr) matchPatSyn (var :| vars) ty eqns = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns return (mkCoSynCaseMatchResult var ty alt) @@ -134,18 +135,26 @@ -- and returns the types of the *value* args, which is what we want match_group :: [Id] - -> [(ConArgPats, EquationInfo)] -> DsM MatchResult + -> [(ConArgPats, EquationInfo)] -> DsM (MatchResult CoreExpr) -- All members of the group have compatible ConArgPats match_group arg_vars arg_eqn_prs = ASSERT( notNull arg_eqn_prs ) do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs) ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs ; match_result <- match (group_arg_vars ++ vars) ty eqns' - ; return (adjustMatchResult (foldr1 (.) wraps) match_result) } + ; return $ foldr1 (.) wraps <$> match_result + } - shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, - pat_binds = bind, pat_args = args - } : pats })) + shift (_, eqn@(EqnInfo + { eqn_pats = ConPat + { pat_args = args + , pat_con_ext = ConPatTc + { cpt_tvs = tvs + , cpt_dicts = ds + , cpt_binds = bind + } + } : pats + })) = do ds_bind <- dsTcEvBinds bind return ( wrapBinds (tvs `zip` tvs1) . wrapBinds (ds `zip` dicts1) @@ -171,10 +180,15 @@ alt_wrapper = wrapper1, alt_result = foldr1 combineMatchResults match_results } } where - ConPatOut { pat_con = L _ con1 - , pat_arg_tys = arg_tys, pat_wrap = wrapper1, - pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 } - = firstPat eqn1 + ConPat { pat_con = L _ con1 + , pat_args = args1 + , pat_con_ext = ConPatTc + { cpt_arg_tys = arg_tys + , cpt_wrap = wrapper1 + , cpt_tvs = tvs1 + , cpt_dicts = dicts1 + } + } = firstPat eqn1 fields1 = map flSelector (conLikeFieldLabels con1) ex_tvs = conLikeExTyCoVars con1 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 @@ -23,7 +23,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import {-# SOURCE #-} GHC.HsToCore.Match ( match ) @@ -39,21 +39,21 @@ import GHC.Core.Make import GHC.Core.TyCon import GHC.Core.DataCon -import TcHsSyn ( shortCutLit ) -import TcType +import GHC.Tc.Utils.Zonk ( shortCutLit ) +import GHC.Tc.Utils.TcType import GHC.Types.Name import GHC.Core.Type -import PrelNames -import TysWiredIn -import TysPrim +import GHC.Builtin.Names +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim import GHC.Types.Literal import GHC.Types.SrcLoc import Data.Ratio -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Types.Basic import GHC.Driver.Session -import Util -import FastString +import GHC.Utils.Misc +import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt import Control.Monad @@ -103,7 +103,6 @@ HsString _ str -> mkStringExprFS str HsInteger _ i _ -> mkIntegerExpr i HsInt _ i -> return (mkIntExpr platform (il_value i)) - XLit nec -> noExtCon nec HsRat _ (FL _ _ val) ty -> do num <- mkIntegerExpr (numerator val) denom <- mkIntegerExpr (denominator val) @@ -125,7 +124,6 @@ case shortCutLit platform val ty of Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut] _ -> dsExpr witness -dsOverLit (XOverLit nec) = noExtCon nec {- Note [Literal short cut] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -372,7 +370,7 @@ -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3 -- If we do convert to the constructor form, we'll generate a case -- expression on a Float# or Double# and that's not allowed in Core; see - -- #9238 and Note [Rules for floating-point comparisons] in GHC.Core.Op.ConstantFold + -- #9238 and Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold where -- Sometimes (like in test case -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include @@ -409,7 +407,7 @@ matchLiterals :: NonEmpty Id -> Type -- ^ Type of the whole case expression -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits - -> DsM MatchResult + -> DsM (MatchResult CoreExpr) matchLiterals (var :| vars) ty sub_groups = do { -- Deal with each group @@ -426,7 +424,7 @@ return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts) } where - match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult) + match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr) match_group eqns@(firstEqn :| _) = do { dflags <- getDynFlags ; let platform = targetPlatform dflags @@ -434,7 +432,7 @@ ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns) ; return (hsLitKey platform hs_lit, match_result) } - wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult + wrap_str_guard :: Id -> (Literal,MatchResult CoreExpr) -> DsM (MatchResult CoreExpr) -- Equality check for string literals wrap_str_guard eq_str (LitString s, mr) = do { -- We now have to convert back to FastString. Perhaps there @@ -475,7 +473,7 @@ ************************************************************************ -} -matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) matchNPats (var :| vars) ty (eqn1 :| eqns) -- All for the same literal = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1 ; lit_expr <- dsOverLit lit @@ -504,7 +502,7 @@ \end{verbatim} -} -matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- All NPlusKPats, for the *same* literal k matchNPlusKPats (var :| vars) ty (eqn1 :| eqns) = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus @@ -517,7 +515,7 @@ ; match_result <- match vars ty eqns' ; return (mkGuardedMatchResult pred_expr $ mkCoLetMatchResult (NonRec n1 minusk_expr) $ - adjustMatchResult (foldr1 (.) wraps) $ + fmap (foldr1 (.) wraps) $ match_result) } where shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats }) 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 @@ -6,10 +6,14 @@ Monadery used in desugaring -} -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan + module GHC.HsToCore.Monad ( DsM, mapM, mapAndUnzipM, initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs, @@ -42,8 +46,7 @@ -- Data types DsMatchContext(..), - EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper, - CanItFail(..), orFail, + EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper, -- Levity polymorphism dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs, @@ -52,36 +55,36 @@ pprRuntimeTrace ) where -import GhcPrelude +import GHC.Prelude -import TcRnMonad +import GHC.Tc.Utils.Monad import GHC.Core.FamInstEnv import GHC.Core import GHC.Core.Make ( unitExpr ) import GHC.Core.Utils ( exprType, isExprLevPoly ) import GHC.Hs import GHC.IfaceToCore -import TcMType ( checkForLevPolyX, formatLevPolyErr ) -import PrelNames +import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr ) +import GHC.Builtin.Names import GHC.Types.Name.Reader import GHC.Driver.Types -import Bag +import GHC.Data.Bag import GHC.Types.Basic ( Origin ) import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.TyCon import GHC.HsToCore.PmCheck.Types import GHC.Types.Id -import GHC.Types.Module -import Outputable +import GHC.Unit.Module +import GHC.Utils.Outputable import GHC.Types.SrcLoc import GHC.Core.Type import GHC.Types.Unique.Supply import GHC.Types.Name import GHC.Types.Name.Env import GHC.Driver.Session -import ErrUtils -import FastString +import GHC.Utils.Error +import GHC.Data.FastString import GHC.Types.Unique.FM ( lookupWithDefaultUFM ) import GHC.Types.Literal ( mkLitString ) import GHC.Types.CostCentre.State @@ -119,7 +122,7 @@ -- @W# -1## :: Word@, but we shouldn't warn about an overflowed -- literal for /both/ of these cases. - , eqn_rhs :: MatchResult + , eqn_rhs :: MatchResult CoreExpr -- ^ What to do after match } @@ -130,25 +133,38 @@ idDsWrapper :: DsWrapper idDsWrapper e = e --- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult +-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult CoreExpr -- \fail. wrap (case vs of { pats -> rhs fail }) -- where vs are not bound by wrap - --- A MatchResult is an expression with a hole in it -data MatchResult - = MatchResult - CanItFail -- Tells whether the failure expression is used - (CoreExpr -> DsM CoreExpr) - -- Takes a expression to plug in at the - -- failure point(s). The expression should - -- be duplicatable! +-- | This is a value of type a with potentially a CoreExpr-shaped hole in it. +-- This is used to deal with cases where we are potentially handling pattern +-- match failure, and want to later specify how failure is handled. +data MatchResult a + -- | We represent the case where there is no hole without a function from + -- 'CoreExpr', like this, because sometimes we have nothing to put in the + -- hole and so want to be sure there is in fact no hole. + = MR_Infallible (DsM a) + | MR_Fallible (CoreExpr -> DsM a) + deriving (Functor) -data CanItFail = CanFail | CantFail +-- | Product is an "or" on falliblity---the combined match result is infallible +-- only if the left and right argument match results both were. +-- +-- This is useful for combining a bunch of alternatives together and then +-- getting the overall falliblity of the entire group. See 'mkDataConCase' for +-- an example. +instance Applicative MatchResult where + pure v = MR_Infallible (pure v) + MR_Infallible f <*> MR_Infallible x = MR_Infallible (f <*> x) + f <*> x = MR_Fallible $ \fail -> runMatchResult fail f <*> runMatchResult fail x -orFail :: CanItFail -> CanItFail -> CanItFail -orFail CantFail CantFail = CantFail -orFail _ _ = CanFail +-- Given a fail expression to use, and a MatchResult CoreExpr, compute the filled CoreExpr whether +-- the MatchResult CoreExpr was failable or not. +runMatchResult :: CoreExpr -> MatchResult a -> DsM a +runMatchResult fail = \case + MR_Infallible body -> body + MR_Fallible body_fn -> body_fn fail {- ************************************************************************ @@ -449,7 +465,7 @@ -- Regardless of success or failure, -- propagate any errors/warnings generated by m -- --- c.f. TcRnMonad.askNoErrs +-- c.f. GHC.Tc.Utils.Monad.askNoErrs askNoErrsDs :: DsM a -> DsM (a, Bool) askNoErrsDs thing_inside = do { errs_var <- newMutVar emptyMessages @@ -478,7 +494,7 @@ lookupThing = dsLookupGlobal dsLookupGlobal :: Name -> DsM TyThing --- Very like TcEnv.tcLookupGlobal +-- Very like GHC.Tc.Utils.Env.tcLookupGlobal dsLookupGlobal name = do { env <- getGblEnv ; setEnvs (ds_if_env env) diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -22,44 +22,44 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.HsToCore.PmCheck.Types import GHC.HsToCore.PmCheck.Oracle import GHC.HsToCore.PmCheck.Ppr import GHC.Types.Basic (Origin, isGenerated) import GHC.Core (CoreExpr, Expr(Var,App)) -import FastString (unpackFS, lengthFS) +import GHC.Data.FastString (unpackFS, lengthFS) import GHC.Driver.Session import GHC.Hs -import TcHsSyn ( shortCutLit ) +import GHC.Tc.Utils.Zonk (shortCutLit) import GHC.Types.Id import GHC.Core.ConLike import GHC.Types.Name -import FamInst -import TysWiredIn +import GHC.Tc.Instance.Family +import GHC.Builtin.Types import GHC.Types.SrcLoc -import Util -import Outputable +import GHC.Utils.Misc +import GHC.Utils.Outputable import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Types.Var (EvVar) import GHC.Core.Coercion -import TcEvidence ( HsWrapper(..), isIdHsWrapper ) -import TcType (evVarPred) +import GHC.Tc.Types.Evidence ( HsWrapper(..), isIdHsWrapper ) +import GHC.Tc.Utils.TcType (evVarPred) import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr) import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper) import GHC.HsToCore.Utils (selectMatchVar) import GHC.HsToCore.Match.Literal (dsLit, dsOverLit) import GHC.HsToCore.Monad -import Bag -import OrdList +import GHC.Data.Bag +import GHC.Data.OrdList import GHC.Core.TyCo.Rep import GHC.Core.Type import GHC.HsToCore.Utils (isTrueLHsExpr) -import Maybes +import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt -import MonadUtils (concatMapM) +import GHC.Utils.Monad (concatMapM) import Control.Monad (when, forM_, zipWithM) import Data.List (elemIndex) @@ -286,7 +286,6 @@ , m_pats = [] , m_grhss = guards } checkMatches dsMatchContext [] [match] -checkGuardMatches _ (XGRHSs nec) = noExtCon nec -- | Check a list of syntactic /match/es (part of case, functions, etc.), each -- with a /pat/ and one or more /grhss/: @@ -444,7 +443,7 @@ -- See Note [Translate CoPats] -- Generally the translation is -- pat |> co ===> let y = x |> co, pat <- y where y is a match var of pat - CoPat _ wrapper p _ty + XPat (CoPat wrapper p _ty) | isIdHsWrapper wrapper -> translatePat fam_insts x p | WpCast co <- wrapper, isReflexiveCo co -> translatePat fam_insts x p | otherwise -> do @@ -499,11 +498,14 @@ -- -- See #14547, especially comment#9 and comment#10. - ConPatOut { pat_con = L _ con - , pat_arg_tys = arg_tys - , pat_tvs = ex_tvs - , pat_dicts = dicts - , pat_args = ps } -> do + ConPat { pat_con = L _ con + , pat_args = ps + , pat_con_ext = ConPatTc + { cpt_arg_tys = arg_tys + , cpt_tvs = ex_tvs + , cpt_dicts = dicts + } + } -> do translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps NPat ty (L _ olit) mb_neg _ -> do @@ -545,9 +547,7 @@ -- -------------------------------------------------------------------------- -- Not supposed to happen - ConPatIn {} -> panic "Check.translatePat: ConPatIn" SplicePat {} -> panic "Check.translatePat: SplicePat" - XPat n -> noExtCon n -- | 'translatePat', but also select and return a new match var. translatePatV :: FamInstEnvs -> Pat GhcTc -> DsM (Id, GrdVec) @@ -642,7 +642,6 @@ grhss' <- mapM (translateLGRHS fam_insts match_loc pats) (grhssGRHSs grhss) -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr grhss, ppr grhss']) return (mkGrdTreeMany pats' grhss') -translateMatch _ _ (L _ (XMatch nec)) = noExtCon nec -- ----------------------------------------------------------------------- -- * Transform source guards (GuardStmt Id) to simpler PmGrds @@ -657,20 +656,18 @@ | null gs = L match_loc (sep (map ppr pats)) | otherwise = L grd_loc (sep (map ppr pats) <+> vbar <+> interpp'SP gs) L grd_loc _ = head gs -translateLGRHS _ _ _ (L _ (XGRHS nec)) = noExtCon nec -- | Translate a guard statement to a 'GrdVec' translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM GrdVec translateGuard fam_insts guard = case guard of BodyStmt _ e _ _ -> translateBoolGuard e LetStmt _ binds -> translateLet (unLoc binds) - BindStmt _ p e _ _ -> translateBind fam_insts p e + BindStmt _ p e -> translateBind fam_insts p e LastStmt {} -> panic "translateGuard LastStmt" ParStmt {} -> panic "translateGuard ParStmt" TransStmt {} -> panic "translateGuard TransStmt" RecStmt {} -> panic "translateGuard RecStmt" ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt" - XStmtLR nec -> noExtCon nec -- | Translate let-bindings translateLet :: HsLocalBinds GhcTc -> DsM GrdVec diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs --- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs +++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs @@ -25,15 +25,15 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.HsToCore.PmCheck.Types import GHC.Driver.Session -import Outputable -import ErrUtils -import Util -import Bag +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Data.Bag import GHC.Types.Unique.Set import GHC.Types.Unique.DSet import GHC.Types.Unique @@ -49,24 +49,24 @@ import GHC.Core.Utils (exprType) import GHC.Core.Make (mkListExpr, mkCharExpr) import GHC.Types.Unique.Supply -import FastString +import GHC.Data.FastString import GHC.Types.SrcLoc -import Maybes +import GHC.Data.Maybe import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Core.TyCon -import TysWiredIn -import TysPrim (tYPETyCon) +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim (tYPETyCon) import GHC.Core.TyCo.Rep import GHC.Core.Type -import TcSimplify (tcNormalise, tcCheckSatisfiability) -import GHC.Core.Unify (tcMatchTy) -import TcRnTypes (completeMatchConLikes) +import GHC.Tc.Solver (tcNormalise, tcCheckSatisfiability) +import GHC.Core.Unify (tcMatchTy) +import GHC.Tc.Types (completeMatchConLikes) import GHC.Core.Coercion -import MonadUtils hiding (foldlM) +import GHC.Utils.Monad hiding (foldlM) import GHC.HsToCore.Monad hiding (foldlM) -import FamInst +import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv import Control.Monad (guard, mzero, when) @@ -1319,10 +1319,11 @@ checkAllNonVoid rec_ts amb_cs strict_arg_tys = do let definitely_inhabited = definitelyInhabitedType (delta_ty_st amb_cs) tys_to_check <- filterOutM definitely_inhabited strict_arg_tys + -- See Note [Fuel for the inhabitation test] let rec_max_bound | tys_to_check `lengthExceeds` 1 = 1 | otherwise - = defaultRecTcMaxBound + = 3 rec_ts' = setRecTcMaxBound rec_max_bound rec_ts allM (nonVoid rec_ts' amb_cs) tys_to_check @@ -1342,6 +1343,7 @@ mb_cands <- inhabitationCandidates amb_cs strict_arg_ty case mb_cands of Right (tc, _, cands) + -- See Note [Fuel for the inhabitation test] | Just rec_ts' <- checkRecTc rec_ts tc -> anyM (cand_is_inhabitable rec_ts' amb_cs) cands -- A strict argument type is inhabitable by a terminating value if @@ -1390,7 +1392,7 @@ null (dataConImplBangs con) -- (2) {- Note [Strict argument type constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the ConVar case of clause processing, each conlike K traditionally generates two different forms of constraints: @@ -1420,6 +1422,7 @@ Since neither the term nor type constraints mentioned above take strict argument types into account, we make use of the `nonVoid` function to determine whether a strict type is inhabitable by a terminating value or not. +We call this the "inhabitation test". `nonVoid ty` returns True when either: 1. `ty` has at least one InhabitationCandidate for which both its term and type @@ -1445,15 +1448,20 @@ `nonVoid MyVoid` returns False. The InhabitationCandidate for the MkMyVoid constructor contains Void as a strict argument type, and since `nonVoid Void` returns False, that InhabitationCandidate is discarded, leaving no others. +* Whether or not a type is inhabited is undecidable in general. + See Note [Fuel for the inhabitation test]. +* For some types, inhabitation is evident immediately and we don't need to + perform expensive tests. See Note [Types that are definitely inhabitable]. -* Performance considerations +Note [Fuel for the inhabitation test] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Whether or not a type is inhabited is undecidable in general. As a result, we +can run into infinite loops in `nonVoid`. Therefore, we adopt a fuel-based +approach to prevent that. -We must be careful when recursively calling `nonVoid` on the strict argument -types of an InhabitationCandidate, because doing so naïvely can cause GHC to -fall into an infinite loop. Consider the following example: +Consider the following example: data Abyss = MkAbyss !Abyss - stareIntoTheAbyss :: Abyss -> a stareIntoTheAbyss x = case x of {} @@ -1474,7 +1482,6 @@ newtypes, like in the following code: newtype Chasm = MkChasm Chasm - gazeIntoTheChasm :: Chasm -> a gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive @@ -1498,9 +1505,26 @@ is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay to stick with a larger maximum recursion depth. +In #17977 we saw that the defaultRecTcMaxBound (100 at the time of writing) was +too large and had detrimental effect on performance of the coverage checker. +Given that we only commit to a best effort anyway, we decided to substantially +decrement the recursion depth to 3, at the cost of precision in some edge cases +like + + data Nat = Z | S Nat + data Down :: Nat -> Type where + Down :: !(Down n) -> Down (S n) + f :: Down (S (S (S (S (S Z))))) -> () + f x = case x of {} + +Since the coverage won't bother to instantiate Down 4 levels deep to see that it +is in fact uninhabited, it will emit a inexhaustivity warning for the case. + +Note [Types that are definitely inhabitable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Another microoptimization applies to data types like this one: - data S a = ![a] !T + data S a = S ![a] !T Even though there is a strict field of type [a], it's quite silly to call nonVoid on it, since it's "obvious" that it is inhabitable. To make this diff --git a/compiler/GHC/HsToCore/PmCheck/Ppr.hs b/compiler/GHC/HsToCore/PmCheck/Ppr.hs --- a/compiler/GHC/HsToCore/PmCheck/Ppr.hs +++ b/compiler/GHC/HsToCore/PmCheck/Ppr.hs @@ -10,7 +10,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic import GHC.Types.Id @@ -18,11 +18,11 @@ import GHC.Types.Unique.DFM import GHC.Core.ConLike import GHC.Core.DataCon -import TysWiredIn -import Outputable +import GHC.Builtin.Types +import GHC.Utils.Outputable import Control.Monad.Trans.RWS.CPS -import Util -import Maybes +import GHC.Utils.Misc +import GHC.Data.Maybe import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) import GHC.HsToCore.PmCheck.Types 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 @@ -17,8 +17,8 @@ -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype. -- -- It also defines a bunch of knownKeyNames, in the same way as is done --- in prelude/PrelNames. It's much more convenient to do it here, because --- otherwise we have to recompile PrelNames whenever we add a Name, which is +-- in prelude/GHC.Builtin.Names. It's much more convenient to do it here, because +-- otherwise we have to recompile GHC.Builtin.Names whenever we add a Name, which is -- a Royal Pain (triggers other recompilation). ----------------------------------------------------------------------------- @@ -26,7 +26,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) @@ -37,31 +37,31 @@ import qualified Language.Haskell.TH as TH import GHC.Hs -import PrelNames +import GHC.Builtin.Names -import GHC.Types.Module +import GHC.Unit.Module import GHC.Types.Id import GHC.Types.Name hiding( varName, tcName ) -import THNames +import GHC.Builtin.Names.TH import GHC.Types.Name.Env -import TcType +import GHC.Tc.Utils.TcType import GHC.Core.TyCon -import TysWiredIn +import GHC.Builtin.Types import GHC.Core import GHC.Core.Make import GHC.Core.Utils import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Unique import GHC.Types.Basic -import Outputable -import Bag +import GHC.Utils.Outputable +import GHC.Data.Bag import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Types.ForeignCall -import Util -import Maybes -import MonadUtils -import TcEvidence +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Monad +import GHC.Tc.Types.Evidence import Control.Monad.Trans.Reader import Control.Monad.Trans.Class import GHC.Core.Class @@ -169,7 +169,6 @@ do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 } do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL" do_brack (TExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 } - do_brack (XBracket nec) = noExtCon nec {- Note [Desugaring Brackets] @@ -192,7 +191,7 @@ > USE THE `wrapName` FUNCTION TO APPLY THE `m` TYPE VARIABLE TO A TYPE CONSTRUCTOR. What the arguments should be instantiated to is supplied by the `QuoteWrapper` -datatype which is produced by `TcSplice`. It is a pair of an evidence variable +datatype which is produced by `GHC.Tc.Gen.Splice`. It is a pair of an evidence variable for `Quote m` and a type variable `m`. All the polymorphic combinators in desugaring need to be applied to these two type variables. @@ -317,13 +316,12 @@ = notHandledL loc "Splices within declaration brackets" empty no_default_decl (L loc decl) = notHandledL loc "Default declarations" (ppr decl) + no_warn :: LWarnDecl GhcRn -> MetaM a no_warn (L loc (Warning _ thing _)) = notHandledL loc "WARNING and DEPRECATION pragmas" $ text "Pragma for declaration of" <+> ppr thing - no_warn (L _ (XWarnDecl nec)) = noExtCon nec no_doc (L loc _) = notHandledL loc "Haddock documentation" empty -repTopDs (XHsGroup nec) = noExtCon nec hsScopedTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in bindings] @@ -345,6 +343,7 @@ | otherwise = [] where + get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name] get_scoped_tvs_from_sig sig -- Both implicit and explicit quantified variables -- We need the implicit ones for f :: forall (a::k). blah @@ -353,8 +352,6 @@ , hsib_body = hs_ty } <- sig , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty = implicit_vars ++ hsLTyVarNames explicit_vars - get_scoped_tvs_from_sig (XHsImplicitBndrs nec) - = noExtCon nec {- Notes @@ -480,8 +477,6 @@ ; return $ Just (loc, dec) } -repTyClD (L _ (XTyClDecl nec)) = noExtCon nec - ------------------------- repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repRoleD (L loc (RoleAnnotDecl _ tycon roles)) @@ -490,14 +485,12 @@ ; roles2 <- coreList roleTyConName roles1 ; dec <- repRoleAnnotD tycon1 roles2 ; return (loc, dec) } -repRoleD (L _ (XRoleAnnotDecl nec)) = noExtCon nec ------------------------- repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repKiSigD (L loc kisig) = case kisig of StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v - XStandaloneKindSig nec -> noExtCon nec ------------------------- repDataDefn :: Core TH.Name @@ -526,7 +519,6 @@ ; repData cxt1 tc opts ksig' cons1 derivs1 } } -repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec repSynDecl :: Core TH.Name -> Core [(M TH.TyVarBndr)] -> LHsType GhcRn @@ -568,7 +560,6 @@ ; repDataFamilyD tc1 bndrs kind } ; return (loc, dec) } -repFamilyDecl (L _ (XFamilyDecl nec)) = noExtCon nec -- | Represent result signature of a type family repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig)) @@ -577,7 +568,6 @@ ; repKindSig ki' } repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr ; repTyVarSig bndr' } -repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec -- | Represent result signature using a Maybe Kind. Used with data families, -- where the result signature can be either missing or a kind but never a named @@ -590,7 +580,6 @@ do { coreJustM kindTyConName =<< repLTy ki } repFamilyResultSigToMaybeKind TyVarSig{} = panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig" -repFamilyResultSigToMaybeKind (XFamilyResultSig nec) = noExtCon nec -- | Represent injectivity annotation of a type family repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) @@ -634,7 +623,6 @@ repInstD (L loc (ClsInstD { cid_inst = cls_decl })) = do { dec <- repClsInstD cls_decl ; return (loc, dec) } -repInstD (L _ (XInstDecl nec)) = noExtCon nec repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec)) repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds @@ -664,7 +652,6 @@ ; wrapGenSyms ss decls2 } where (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty -repClsInstD (XClsInstDecl nec) = noExtCon nec repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat @@ -677,7 +664,6 @@ ; return (loc, dec) } where (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty) -repStandaloneDerivD (L _ (XDerivDecl nec)) = noExtCon nec repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec)) repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) @@ -709,8 +695,6 @@ where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] checkTys tys@(HsValArg _:HsValArg _:_) = return tys checkTys _ = panic "repTyFamEqn:checkTys" -repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec -repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type)) repTyArgs f [] = f @@ -749,11 +733,6 @@ checkTys tys@(HsValArg _: HsValArg _: _) = return tys checkTys _ = panic "repDataFamInstD:checkTys" -repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec)) - = noExtCon nec -repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec))) - = noExtCon nec - repForD :: Located (ForeignDecl GhcRn) -> MetaM (SrcSpan, Core (M TH.Dec)) repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ , fd_fi = CImport (L _ cc) @@ -784,7 +763,6 @@ Just (Header _ h) | not raw_cconv -> unpackFS h ++ " " _ -> "" repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl) -repForD (L _ (XForeignDecl nec)) = noExtCon nec repCCallConv :: CCallConv -> MetaM (Core TH.Callconv) repCCallConv CCallConv = rep2_nw cCallName [] @@ -813,7 +791,6 @@ ; dec <- rep2 rep_fn [prec', name'] ; return (loc,dec) } ; mapM do_one names } -rep_fix_d _ (XFixitySig nec) = noExtCon nec repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repRuleD (L loc (HsRule { rd_name = n @@ -840,18 +817,12 @@ ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' } ; wrapGenSyms ss rule } ; return (loc, rule) } -repRuleD (L _ (XRuleDecl nec)) = noExtCon nec ruleBndrNames :: LRuleBndr GhcRn -> [Name] ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n] ruleBndrNames (L _ (RuleBndrSig _ n sig)) | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig = unLoc n : vars -ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs nec)))) - = noExtCon nec -ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs nec))) - = noExtCon nec -ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr)) repRuleBndr (L _ (RuleBndr _ n)) @@ -861,7 +832,6 @@ = do { MkC n' <- lookupLBinder n ; MkC ty' <- repLTy (hsSigWcType sig) ; rep2 typedRuleVarName [n', ty'] } -repRuleBndr (L _ (XRuleBndr nec)) = noExtCon nec repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp))) @@ -869,7 +839,6 @@ ; exp' <- repE exp ; dec <- repPragAnn target exp' ; return (loc, dec) } -repAnnD (L _ (XAnnDecl nec)) = noExtCon nec repAnnProv :: AnnProvenance Name -> MetaM (Core TH.AnnTarget) repAnnProv (ValueAnnProvenance (L _ n)) @@ -925,9 +894,7 @@ then return c' else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } -repC (L _ (XConDecl nec)) = noExtCon nec - repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt)) repMbContext Nothing = repContext [] repMbContext (Just (L _ cxt)) = repContext cxt @@ -973,7 +940,6 @@ where rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type)) rep_deriv_ty ty = repLTy ty -repDerivClause (L _ (XHsDerivingClause nec)) = noExtCon nec rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn -> MetaM ([GenSymBind], [Core (M TH.Dec)]) @@ -1017,7 +983,6 @@ rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty rep_sig (L loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty loc -rep_sig (L _ (XSig nec)) = noExtCon nec rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name -> MetaM (SrcSpan, Core (M TH.Dec)) @@ -1043,7 +1008,6 @@ else repTForall th_explicit_tvs th_ctxt th_ty ; sig <- repProto mk_sig nm1 ty1 ; return (loc, sig) } -rep_ty_sig _ _ (XHsImplicitBndrs nec) _ = noExtCon nec rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name -> MetaM (SrcSpan, Core (M TH.Dec)) @@ -1072,7 +1036,6 @@ repTForall th_exis th_provs th_ty ; sig <- repProto patSynSigDName nm1 ty1 ; return (loc, sig) } -rep_patsyn_ty_sig _ (XHsImplicitBndrs nec) _ = noExtCon nec rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name -> MetaM (SrcSpan, Core (M TH.Dec)) @@ -1180,7 +1143,6 @@ = addSimpleTyVarBinds imp_tvs $ addHsTyVarBinds exp_tvs $ thing_inside -addTyVarBinds (XLHsQTyVars nec) _ = noExtCon nec addTyClTyVarBinds :: LHsQTyVars GhcRn -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) @@ -1217,7 +1179,6 @@ = repPlainTV nm repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm = repLTy ki >>= repKindedTV nm -repTyVarBndrWithKind (L _ (XTyVarBndr nec)) _ = noExtCon nec -- | Represent a type variable binder repTyVarBndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr)) @@ -1228,7 +1189,6 @@ = do { nm' <- lookupBinder nm ; ki' <- repLTy ki ; repKindedTV nm' ki' } -repTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec -- represent a type context -- @@ -1251,12 +1211,10 @@ ; if null explicit_tvs && null (unLoc ctxt) then return th_ty else repTForall th_explicit_tvs th_ctxt th_ty } -repHsSigType (XHsImplicitBndrs nec) = noExtCon nec repHsSigWcType :: LHsSigWcType GhcRn -> MetaM (Core (M TH.Type)) repHsSigWcType (HsWC { hswc_body = sig1 }) = repHsSigType sig1 -repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec -- yield the representation of a list of types repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)] @@ -1383,13 +1341,12 @@ ----------------------------------------------------------------------------- repSplice :: HsSplice GhcRn -> MetaM (Core a) --- See Note [How brackets and nested splices are handled] in TcSplice +-- See Note [How brackets and nested splices are handled] in GHC.Tc.Gen.Splice -- We return a CoreExpr of any old type; the context should know repSplice (HsTypedSplice _ _ n _) = rep_splice n repSplice (HsUntypedSplice _ _ n _) = rep_splice n repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) -repSplice (XSplice nec) = noExtCon nec rep_splice :: Name -> MetaM (Core a) rep_splice splice_name @@ -1428,7 +1385,6 @@ repE e@(HsRecFld _ f) = case f of Unambiguous x _ -> repE (HsVar noExtField (noLoc x)) Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e) - XAmbiguousFieldOcc nec -> noExtCon nec -- Remember, we're desugaring renamer output here, so -- HsOverlit can definitely occur @@ -1556,7 +1512,6 @@ repE e@(HsPragE _ HsPragCore {} _) = notHandled "Core annotations" (ppr e) repE e@(HsPragE _ HsPragSCC {} _) = notHandled "Cost centres" (ppr e) repE e@(HsPragE _ HsPragTick {} _) = notHandled "Tick Pragma" (ppr e) -repE (XExpr nec) = noExtCon nec repE e = notHandled "Expression form" (ppr e) ----------------------------------------------------------------------------- @@ -1586,8 +1541,6 @@ gs <- repGuards guards ; clause <- repClause ps1 gs ds ; wrapGenSyms (ss1++ss2) clause }}} -repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec -repClauseTup (L _ (XMatch nec)) = noExtCon nec repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> MetaM (Core (M TH.Body)) repGuards [L _ (GRHS _ [] e)] @@ -1608,7 +1561,6 @@ ; rhs' <- addBinds gs $ repLE rhs ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' ; return (gs, guarded) } -repLGRHS (L _ (XGRHS nec)) = noExtCon nec repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp]) repFields (HsRecFields { rec_flds = flds }) @@ -1629,7 +1581,6 @@ ; e <- repLE (hsRecFieldArg fld) ; repFieldExp fn e } Ambiguous{} -> notHandled "Ambiguous record updates" (ppr fld) - XAmbiguousFieldOcc nec -> noExtCon nec @@ -1662,7 +1613,7 @@ repLSts stmts = repSts (map unLoc stmts) repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)]) -repSts (BindStmt _ p e _ _ : ss) = +repSts (BindStmt _ p e : ss) = do { e2 <- repLE e ; ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { @@ -1694,7 +1645,6 @@ do { (ss1, zs) <- repSts (map unLoc stmts) ; zs1 <- coreListM stmtTyConName zs ; return (ss1, zs1) } - rep_stmt_block (XParStmtBlock nec) = noExtCon nec repSts [LastStmt _ e _ _] = do { e2 <- repLE e ; z <- repNoBindSt e2 @@ -1709,7 +1659,6 @@ ; z <- repRecSt (nonEmptyCoreList rss) ; (ss2,zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } -repSts (XStmtLR nec : _) = noExtCon nec repSts [] = return ([],[]) repSts other = notHandled "Exotic statement" (ppr other) @@ -1730,8 +1679,6 @@ ; return ([], core_list) } -repBinds (HsIPBinds _ (XHsIPBinds nec)) = noExtCon nec - repBinds (HsValBinds _ decs) = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs } -- No need to worry about detailed scopes within @@ -1744,7 +1691,6 @@ ; core_list <- coreListM decTyConName (de_loc (sort_by_loc prs)) ; return (ss, core_list) } -repBinds (XHsLocalBindsLR nec) = noExtCon nec rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs))) @@ -1755,7 +1701,6 @@ ; rhs' <- repE rhs ; ipb <- repImplicitParamBind name rhs' ; return (loc, ipb) } -rep_implicit_param_bind (L _ (XIPBind nec)) = noExtCon nec rep_implicit_param_name :: HsIPName -> MetaM (Core String) rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name) @@ -1800,8 +1745,6 @@ ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } -rep_bind (L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec - rep_bind (L loc (PatBind { pat_lhs = pat , pat_rhs = GRHSs _ guards (L _ wheres) })) = do { patcore <- repLP pat @@ -1810,7 +1753,6 @@ ; ans <- repVal patcore guardcore wherecore ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } -rep_bind (L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) = do { v' <- lookupBinder v @@ -1860,9 +1802,6 @@ wrapGenArgSyms (RecCon _) _ dec = return dec wrapGenArgSyms _ ss dec = wrapGenSyms ss dec -rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec -rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec - repPatSynD :: Core TH.Name -> Core (M TH.PatSynArgs) -> Core (M TH.PatSynDir) @@ -1900,7 +1839,6 @@ repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) })) = do { clauses' <- mapM repClauseTup clauses ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } -repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec repExplBidirPatSynDir :: Core [(M TH.Clause)] -> MetaM (Core (M TH.PatSynDir)) repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] @@ -1939,9 +1877,6 @@ ; lam <- addBinds ss ( do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyms ss lam } -repLambda (L _ (Match { m_grhss = GRHSs _ [L _ (GRHS _ [] _)] - (L _ (XHsLocalBindsLR nec)) } )) - = noExtCon nec repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m) @@ -1979,7 +1914,7 @@ | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } repP (SumPat _ p alt arity) = do { p1 <- repLP p ; repPunboxedSum p1 alt arity } -repP (ConPatIn dc details) +repP (ConPat NoExtField dc details) = do { con_str <- lookupLOcc dc ; case details of PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } @@ -2003,7 +1938,6 @@ ; t' <- repLTy (hsSigWcType t) ; repPsig p' t' } repP (SplicePat _ splice) = repSplice splice -repP (XPat nec) = noExtCon nec repP other = notHandled "Exotic pattern" (ppr other) ---------------------------------------------------------- @@ -2098,7 +2032,7 @@ where mod = ASSERT( isExternalName name) nameModule name name_mod = moduleNameString (moduleName mod) - name_pkg = unitIdString (moduleUnitId mod) + name_pkg = unitString (moduleUnit mod) name_occ = nameOccName name mk_varg | isDataOcc name_occ = mkNameG_dName | isVarOcc name_occ = mkNameG_vName @@ -2797,7 +2731,6 @@ -- The type Rational will be in the environment, because -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used -repOverloadedLiteral (XOverLit nec) = noExtCon nec mk_lit :: OverLitVal -> MetaM (HsLit GhcRn) mk_lit (HsIntegral i) = mk_integer (il_value i) 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 @@ -11,22 +11,21 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Driver.Ways import GHC.Driver.Types -import TcRnTypes +import GHC.Tc.Types import GHC.Types.Name import GHC.Types.Name.Set -import GHC.Types.Module -import Outputable -import Util +import GHC.Unit +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Types.Unique.Set import GHC.Types.Unique.FM -import Fingerprint -import Maybes -import GHC.Driver.Packages +import GHC.Utils.Fingerprint +import GHC.Data.Maybe import GHC.Driver.Finder import Control.Monad (filterM) @@ -61,7 +60,7 @@ -- a dependencies information for the module being compiled. -- -- The first argument is additional dependencies from plugins -mkDependencies :: InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies +mkDependencies :: UnitId -> [Module] -> TcGblEnv -> IO Dependencies mkDependencies iuid pluginModules (TcGblEnv{ tcg_mod = mod, tcg_imports = imports, @@ -70,7 +69,7 @@ = do -- Template Haskell used? let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ] - plugin_dep_pkgs = filter (/= iuid) (map (toInstalledUnitId . moduleUnitId) ms) + plugin_dep_pkgs = filter (/= iuid) (map (toUnitId . moduleUnit) ms) th_used <- readIORef th_var let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports) (moduleName mod)) @@ -87,7 +86,7 @@ raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs - pkgs | th_used = Set.insert (toInstalledUnitId thUnitId) raw_pkgs + pkgs | th_used = Set.insert (toUnitId thUnitId) raw_pkgs | otherwise = raw_pkgs -- Set the packages required to be Safe according to Safe Haskell. @@ -132,6 +131,8 @@ -- the entire collection of Ifaces. {- Note [Plugin dependencies] + ~~~~~~~~~~~~~~~~~~~~~~~~~~ + Modules for which plugins were used in the compilation process, should be recompiled whenever one of those plugins changes. But how do we know if a plugin changed from the previous time a module was compiled? @@ -155,7 +156,7 @@ if anything has changed. One issue with this approach is that object files are currently (GHC 8.6.1) -not created fully deterministicly, which could sometimes induce accidental +not created fully deterministically, which could sometimes induce accidental recompilation of a module for which plugins were used in the compile process. One way to improve this is to either: @@ -215,7 +216,7 @@ dflags = hsc_dflags hsc_env platform = targetPlatform dflags pNm = moduleName (mi_module pluginModule) - pPkg = moduleUnitId (mi_module pluginModule) + pPkg = moduleUnit (mi_module pluginModule) deps = map fst (dep_mods (mi_deps pluginModule)) -- Lookup object file for a plugin dependency, @@ -224,7 +225,7 @@ foundM <- findImportedModule hsc_env nm Nothing case foundM of Found ml m - | moduleUnitId m == pPkg -> Just <$> hashFile (ml_obj_file ml) + | moduleUnit m == pPkg -> Just <$> hashFile (ml_obj_file ml) | otherwise -> return Nothing _ -> pprPanic "mkPluginUsage: no object for dependency" (ppr pNm <+> ppr nm) @@ -294,7 +295,7 @@ -- things in *this* module = Nothing - | moduleUnitId mod /= this_pkg + | moduleUnit mod /= this_pkg = Just UsagePackageModule{ usg_mod = mod, usg_mod_hash = mod_hash, usg_safe = imp_safe } 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 @@ -10,6 +10,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -18,10 +19,11 @@ EquationInfo(..), firstPat, shiftEqns, - MatchResult(..), CanItFail(..), CaseAlt(..), + MatchResult (..), CaseAlt(..), cantFailMatchResult, alwaysFailMatchResult, extractMatchResult, combineMatchResults, - adjustMatchResult, adjustMatchResultDs, + adjustMatchResultDs, + shareFailureHandler, mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, matchCanFail, mkEvalMatchResult, mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult, @@ -44,14 +46,14 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply ) import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr ) import GHC.Hs -import TcHsSyn -import TcType( tcSplitTyConApp ) +import GHC.Tc.Utils.Zonk +import GHC.Tc.Utils.TcType( tcSplitTyConApp ) import GHC.Core import GHC.HsToCore.Monad @@ -65,26 +67,27 @@ import GHC.Core.PatSyn import GHC.Core.Type import GHC.Core.Coercion -import TysPrim -import TysWiredIn +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types import GHC.Types.Basic import GHC.Core.ConLike import GHC.Types.Unique.Set import GHC.Types.Unique.Supply -import GHC.Types.Module -import PrelNames +import GHC.Unit.Module +import GHC.Builtin.Names import GHC.Types.Name( isInternalName ) -import Outputable +import GHC.Utils.Outputable import GHC.Types.SrcLoc -import Util +import GHC.Utils.Misc import GHC.Driver.Session -import FastString +import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt -import TcEvidence +import GHC.Tc.Types.Evidence import Control.Monad ( zipWithM ) import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (maybeToList) import qualified Data.List.NonEmpty as NEL {- @@ -192,48 +195,42 @@ -- Drop the first pattern in each equation shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) } --- Functions on MatchResults - -matchCanFail :: MatchResult -> Bool -matchCanFail (MatchResult CanFail _) = True -matchCanFail (MatchResult CantFail _) = False - -alwaysFailMatchResult :: MatchResult -alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail) - -cantFailMatchResult :: CoreExpr -> MatchResult -cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr) +-- Functions on MatchResult CoreExprs -extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr -extractMatchResult (MatchResult CantFail match_fn) _ - = match_fn (error "It can't fail!") +matchCanFail :: MatchResult a -> Bool +matchCanFail (MR_Fallible {}) = True +matchCanFail (MR_Infallible {}) = False -extractMatchResult (MatchResult CanFail match_fn) fail_expr = do - (fail_bind, if_it_fails) <- mkFailurePair fail_expr - body <- match_fn if_it_fails - return (mkCoreLet fail_bind body) +alwaysFailMatchResult :: MatchResult CoreExpr +alwaysFailMatchResult = MR_Fallible $ \fail -> return fail +cantFailMatchResult :: CoreExpr -> MatchResult CoreExpr +cantFailMatchResult expr = MR_Infallible $ return expr -combineMatchResults :: MatchResult -> MatchResult -> MatchResult -combineMatchResults (MatchResult CanFail body_fn1) - (MatchResult can_it_fail2 body_fn2) - = MatchResult can_it_fail2 body_fn - where - body_fn fail = do body2 <- body_fn2 fail - (fail_bind, duplicatable_expr) <- mkFailurePair body2 - body1 <- body_fn1 duplicatable_expr - return (Let fail_bind body1) +extractMatchResult :: MatchResult CoreExpr -> CoreExpr -> DsM CoreExpr +extractMatchResult match_result failure_expr = + runMatchResult + failure_expr + (shareFailureHandler match_result) -combineMatchResults match_result1@(MatchResult CantFail _) _ +combineMatchResults :: MatchResult CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr +combineMatchResults match_result1@(MR_Infallible _) _ = match_result1 - -adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult -adjustMatchResult encl_fn (MatchResult can_it_fail body_fn) - = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail) +combineMatchResults match_result1 match_result2 = + -- if the first pattern needs a failure handler (i.e. if it is is fallible), + -- make it let-bind it bind it with `shareFailureHandler`. + case shareFailureHandler match_result1 of + MR_Infallible _ -> match_result1 + MR_Fallible body_fn1 -> MR_Fallible $ \fail_expr -> + -- Before actually failing, try the next match arm. + body_fn1 =<< runMatchResult fail_expr match_result2 -adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult -adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn) - = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail) +adjustMatchResultDs :: (a -> DsM b) -> MatchResult a -> MatchResult b +adjustMatchResultDs encl_fn = \case + MR_Infallible body_fn -> MR_Infallible $ + encl_fn =<< body_fn + MR_Fallible body_fn -> MR_Fallible $ \fail -> + encl_fn =<< body_fn fail wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr wrapBinds [] e = e @@ -247,51 +244,50 @@ seqVar :: Var -> CoreExpr -> CoreExpr seqVar var body = mkDefaultCase (Var var) var body -mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult -mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind) +mkCoLetMatchResult :: CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr +mkCoLetMatchResult bind = fmap (mkCoreLet bind) -- (mkViewMatchResult var' viewExpr mr) makes the expression -- let var' = viewExpr in mr -mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult -mkViewMatchResult var' viewExpr = - adjustMatchResult (mkCoreLet (NonRec var' viewExpr)) +mkViewMatchResult :: Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr +mkViewMatchResult var' viewExpr = fmap $ mkCoreLet $ NonRec var' viewExpr -mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult -mkEvalMatchResult var ty - = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)]) +mkEvalMatchResult :: Id -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr +mkEvalMatchResult var ty = fmap $ \e -> + Case (Var var) var ty [(DEFAULT, [], e)] -mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult -mkGuardedMatchResult pred_expr (MatchResult _ body_fn) - = MatchResult CanFail (\fail -> do body <- body_fn fail - return (mkIfThenElse pred_expr body fail)) +mkGuardedMatchResult :: CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr +mkGuardedMatchResult pred_expr mr = MR_Fallible $ \fail -> do + body <- runMatchResult fail mr + return (mkIfThenElse pred_expr body fail) mkCoPrimCaseMatchResult :: Id -- Scrutinee -> Type -- Type of the case - -> [(Literal, MatchResult)] -- Alternatives - -> MatchResult -- Literals are all unlifted + -> [(Literal, MatchResult CoreExpr)] -- Alternatives + -> MatchResult CoreExpr -- Literals are all unlifted mkCoPrimCaseMatchResult var ty match_alts - = MatchResult CanFail mk_case + = MR_Fallible mk_case where mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts return (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) sorted_alts = sortWith fst match_alts -- Right order for a Case - mk_alt fail (lit, MatchResult _ body_fn) + mk_alt fail (lit, mr) = ASSERT( not (litIsLifted lit) ) - do body <- body_fn fail + do body <- runMatchResult fail mr return (LitAlt lit, [], body) data CaseAlt a = MkCaseAlt{ alt_pat :: a, alt_bndrs :: [Var], alt_wrapper :: HsWrapper, - alt_result :: MatchResult } + alt_result :: MatchResult CoreExpr } mkCoAlgCaseMatchResult :: Id -- ^ Scrutinee -> Type -- ^ Type of exp -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts) - -> MatchResult + -> MatchResult CoreExpr mkCoAlgCaseMatchResult var ty match_alts | isNewtype -- Newtype case; use a let = ASSERT( null match_alts_tail && null (tail arg_ids1) ) @@ -314,15 +310,14 @@ -- (not that splitTyConApp does, these days) newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) -mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult -mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt +mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult CoreExpr +mkCoSynCaseMatchResult var ty alt = MR_Fallible $ mkPatSynCase var ty alt mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr mkPatSynCase var ty alt fail = do matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [getRuntimeRep ty, ty] - let MatchResult _ mkCont = match_result - cont <- mkCoreLams bndrs <$> mkCont fail + cont <- mkCoreLams bndrs <$> runMatchResult fail match_result return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] where MkCaseAlt{ alt_pat = psyn, @@ -336,49 +331,47 @@ ensure_unstrict cont | needs_void_lam = Lam voidArgId cont | otherwise = cont -mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult -mkDataConCase var ty alts@(alt1 :| _) = MatchResult fail_flag mk_case +mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult CoreExpr +mkDataConCase var ty alts@(alt1 :| _) + = liftA2 mk_case mk_default mk_alts + -- The liftA2 combines the failability of all the alternatives and the default where con1 = alt_pat alt1 tycon = dataConTyCon con1 data_cons = tyConDataCons tycon - match_results = fmap alt_result alts - sorted_alts :: NonEmpty (CaseAlt DataCon) - sorted_alts = NEL.sortWith (dataConTag . alt_pat) alts + sorted_alts :: [ CaseAlt DataCon ] + sorted_alts = sortWith (dataConTag . alt_pat) $ NEL.toList alts var_ty = idType var (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes -- (not that splitTyConApp does, these days) - mk_case :: CoreExpr -> DsM CoreExpr - mk_case fail = do - alts <- mapM (mk_alt fail) sorted_alts - return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ NEL.toList alts) + mk_case :: Maybe CoreAlt -> [CoreAlt] -> CoreExpr + mk_case def alts = mkWildCase (Var var) (idType var) ty $ + maybeToList def ++ alts - mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt - mk_alt fail MkCaseAlt{ alt_pat = con, - alt_bndrs = args, - alt_result = MatchResult _ body_fn } - = do { body <- body_fn fail - ; case dataConBoxer con of { - Nothing -> return (DataAlt con, args, body) ; - Just (DCB boxer) -> - do { us <- newUniqueSupply - ; let (rep_ids, binds) = initUs_ us (boxer ty_args args) - ; return (DataAlt con, rep_ids, mkLets binds body) } } } + mk_alts :: MatchResult [CoreAlt] + mk_alts = traverse mk_alt sorted_alts - mk_default :: CoreExpr -> [CoreAlt] - mk_default fail | exhaustive_case = [] - | otherwise = [(DEFAULT, [], fail)] + mk_alt :: CaseAlt DataCon -> MatchResult CoreAlt + mk_alt MkCaseAlt { alt_pat = con + , alt_bndrs = args + , alt_result = match_result } = + flip adjustMatchResultDs match_result $ \body -> do + case dataConBoxer con of + Nothing -> return (DataAlt con, args, body) + Just (DCB boxer) -> do + us <- newUniqueSupply + let (rep_ids, binds) = initUs_ us (boxer ty_args args) + return (DataAlt con, rep_ids, mkLets binds body) - fail_flag :: CanItFail - fail_flag | exhaustive_case - = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- NEL.toList match_results] - | otherwise - = CanFail + mk_default :: MatchResult (Maybe CoreAlt) + mk_default + | exhaustive_case = MR_Infallible $ return Nothing + | otherwise = MR_Fallible $ \fail -> return $ Just (DEFAULT, [], fail) - mentioned_constructors = mkUniqSet $ map alt_pat $ NEL.toList alts + mentioned_constructors = mkUniqSet $ map alt_pat sorted_alts un_mentioned_constructors = mkUniqSet data_cons `minusUniqSet` mentioned_constructors exhaustive_case = isEmptyUniqSet un_mentioned_constructors @@ -578,7 +571,7 @@ let { t = case e of Just (Just v) -> Unit v ; v = case t of Unit v -> v } in t `seq` body - The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn + The 'Unit' is a one-tuple; see Note [One-tuples] in GHC.Builtin.Types Note that forcing 't' makes the pattern match happen, but does not force 'v'. @@ -599,7 +592,7 @@ - Forcing 't' will force the pattern to match fully; e.g. will diverge if (snd e) is bottom - But 'a' itself is not forced; it is wrapped in a one-tuple - (see Note [One-tuples] in TysWiredIn) + (see Note [One-tuples] in GHC.Builtin.Types) * !(Just x) = e ==> @@ -723,14 +716,14 @@ strip_bangs (L _ (BangPat _ p)) = strip_bangs p strip_bangs lp = lp -is_flat_prod_lpat :: LPat (GhcPass p) -> Bool +is_flat_prod_lpat :: LPat GhcTc -> Bool is_flat_prod_lpat = is_flat_prod_pat . unLoc -is_flat_prod_pat :: Pat (GhcPass p) -> Bool +is_flat_prod_pat :: Pat GhcTc -> Bool is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps -is_flat_prod_pat (ConPatOut { pat_con = L _ pcon - , pat_args = ps}) +is_flat_prod_pat (ConPat { pat_con = L _ pcon + , pat_args = ps}) | RealDataCon con <- pcon , isProductTyCon (dataConTyCon con) = all is_triv_lpat (hsConPatArgs ps) @@ -760,7 +753,7 @@ mkLHsPatTup lpats = L (getLoc (head lpats)) $ mkVanillaTuplePat lpats Boxed -mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc +mkVanillaTuplePat :: [LPat GhcTc] -> Boxity -> Pat GhcTc -- A vanilla tuple pattern simply gets its type from its sub-patterns mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box @@ -857,13 +850,25 @@ where ty = exprType expr +-- Uses '@mkFailurePair@' to bind the failure case. Infallible matches have +-- neither a failure arg or failure "hole", so nothing is let-bound, and no +-- extraneous Core is produced. +shareFailureHandler :: MatchResult CoreExpr -> MatchResult CoreExpr +shareFailureHandler = \case + mr@(MR_Infallible _) -> mr + MR_Fallible match_fn -> MR_Fallible $ \fail_expr -> do + (fail_bind, shared_failure_handler) <- mkFailurePair fail_expr + body <- match_fn shared_failure_handler + -- Never unboxed, per the above, so always OK for `let` not `case`. + return $ Let fail_bind body + {- Note [Failure thunks and CPR] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (This note predates join points as formal entities (hence the quotation marks). We can't use actual join points here (see above); if we did, this would also solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR -join points] in GHC.Core.Op.WorkWrap.) +join points] in GHC.Core.Opt.WorkWrap.) When we make a failure point we ensure that it does not look like a thunk. Example: 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 @@ -33,29 +33,29 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import TcRnMonad -import PrelInfo ( isKnownKeyName, lookupKnownKeyName ) +import GHC.Tc.Utils.Monad +import GHC.Builtin.Utils ( isKnownKeyName, lookupKnownKeyName ) import GHC.Iface.Env import GHC.Driver.Types -import GHC.Types.Module +import GHC.Unit import GHC.Types.Name import GHC.Driver.Session import GHC.Types.Unique.FM import GHC.Types.Unique.Supply -import Panic -import Binary +import GHC.Utils.Panic +import GHC.Utils.Binary as Binary import GHC.Types.SrcLoc -import ErrUtils -import FastMutInt +import GHC.Utils.Error +import GHC.Data.FastMutInt import GHC.Types.Unique -import Outputable +import GHC.Utils.Outputable import GHC.Types.Name.Cache import GHC.Platform -import FastString -import Constants -import Util +import GHC.Data.FastString +import GHC.Settings.Constants +import GHC.Utils.Misc import Data.Array import Data.Array.ST @@ -148,9 +148,17 @@ wantedGot "Way" way_descr check_way ppr when (checkHiWay == CheckHiWay) $ errorOnMismatch "mismatched interface file ways" way_descr check_way - getWithUserData ncu bh + extFields_p <- get bh + mod_iface <- getWithUserData ncu bh + + seekBin bh extFields_p + extFields <- get bh + + return mod_iface{mi_ext_fields = extFields} + + -- | This performs a get action after reading the dictionary and symbol -- table. It is necessary to run this before trying to deserialise any -- Names or FastStrings. @@ -200,8 +208,16 @@ let way_descr = getWayDescr dflags put_ bh way_descr + extFields_p_p <- tellBin bh + put_ bh extFields_p_p putWithUserData (debugTraceMsg dflags 3) bh mod_iface + + extFields_p <- tellBin bh + putAt bh extFields_p_p extFields_p + seekBin bh extFields_p + put_ bh (mi_ext_fields mod_iface) + -- And send the result to the file writeBinMem bh hi_path @@ -309,7 +325,7 @@ newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name) newSTArray_ = newArray_ -type OnDiskName = (UnitId, ModuleName, OccName) +type OnDiskName = (Unit, ModuleName, OccName) fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name) fromOnDiskName nc (pid, mod_name, occ) = @@ -326,7 +342,7 @@ serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do let mod = ASSERT2( isExternalName name, ppr name ) nameModule name - put_ bh (moduleUnitId mod, moduleName mod, nameOccName name) + put_ bh (moduleUnit mod, moduleName mod, nameOccName name) -- Note [Symbol table representation of names] @@ -339,7 +355,7 @@ -- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy -- A known-key name. x is the Unique's Char, y is the int part. We assume that -- all known-key uniques fit in this space. This is asserted by --- PrelInfo.knownKeyNamesOkay. +-- GHC.Builtin.Utils.knownKeyNamesOkay. -- -- During serialization we check for known-key things using isKnownKeyName. -- During deserialization we use lookupKnownKeyName to get from the unique back 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 @@ -22,23 +22,23 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import TcRnMonad +import GHC.Tc.Utils.Monad import GHC.Driver.Types import GHC.Core.Type import GHC.Types.Var import GHC.Types.Name import GHC.Types.Avail -import GHC.Types.Module -import FastString -import FastStringEnv +import GHC.Unit.Module +import GHC.Data.FastString +import GHC.Data.FastString.Env import GHC.Iface.Type import GHC.Types.Name.Cache import GHC.Types.Unique.Supply import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import Data.List ( partition ) {- diff --git a/compiler/GHC/Iface/Env.hs-boot b/compiler/GHC/Iface/Env.hs-boot --- a/compiler/GHC/Iface/Env.hs-boot +++ b/compiler/GHC/Iface/Env.hs-boot @@ -1,8 +1,8 @@ module GHC.Iface.Env where -import GHC.Types.Module +import GHC.Unit.Module import GHC.Types.Name.Occurrence -import TcRnMonad +import GHC.Tc.Utils.Monad import GHC.Types.Name import GHC.Types.SrcLoc 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 @@ -1,6 +1,7 @@ {- Main functions for .hie file generation -} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -16,12 +17,12 @@ module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Avail ( Avails ) -import Bag ( Bag, bagToList ) +import GHC.Data.Bag ( Bag, bagToList ) import GHC.Types.Basic -import BooleanFormula +import GHC.Data.BooleanFormula import GHC.Core.Class ( FunDep ) import GHC.Core.Utils ( exprType ) import GHC.Core.ConLike ( conLikeName ) @@ -29,19 +30,19 @@ import GHC.Types.FieldLabel import GHC.Hs import GHC.Driver.Types -import GHC.Types.Module ( ModuleName, ml_hs_file ) -import MonadUtils ( concatMapM, liftIO ) +import GHC.Unit.Module ( ModuleName, ml_hs_file ) +import GHC.Utils.Monad ( concatMapM, liftIO ) import GHC.Types.Name ( Name, nameSrcSpan, setNameLoc ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import GHC.Types.SrcLoc -import TcHsSyn ( hsLitType, hsPatType ) +import GHC.Tc.Utils.Zonk ( hsLitType, hsPatType ) import GHC.Core.Type ( mkVisFunTys, Type ) -import TysWiredIn ( mkListTy, mkSumTy ) +import GHC.Builtin.Types ( mkListTy, mkSumTy ) import GHC.Types.Var ( Id, Var, setVarName, varName, varType ) -import TcRnTypes +import GHC.Tc.Types import GHC.Iface.Make ( mkIfaceExports ) -import Panic -import Maybes +import GHC.Utils.Panic +import GHC.Data.Maybe import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils @@ -441,8 +442,6 @@ instance ProtectSig GhcRn where protectSig sc (HsWC a (HsIB b sig)) = HsWC a (HsIB b (SH sc sig)) - protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec - protectSig _ (XHsWildCardBndrs nec) = noExtCon nec class HasLoc a where -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can @@ -457,7 +456,6 @@ instance HasLoc (LHsQTyVars GhcRn) where loc (HsQTvs _ vs) = loc vs - loc _ = noSrcSpan instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where loc (HsIB _ a) = loc a @@ -488,7 +486,6 @@ loc def@(HsDataDefn{}) = loc $ dd_cons def -- Only used for data family instances, so we only need rhs -- Most probably the rest will be unhelpful anyway - loc _ = noSrcSpan {- Note [Real DataCon Name] The typechecker substitutes the conLikeWrapId for the name, but we don't want @@ -753,7 +750,6 @@ in toHie $ patScopes Nothing rhsScope NoScope pats , toHie grhss ] - XMatch nec -> noExtCon nec instance ( ToHie (Context (Located (IdP a))) ) => ToHie (HsMatchContext a) where @@ -769,6 +765,7 @@ toHie _ = pure [] instance ( a ~ GhcPass p + , IsPass p , ToHie (Context (Located (IdP a))) , ToHie (RContext (HsRecFields a (PScoped (LPat a)))) , ToHie (LHsExpr a) @@ -811,12 +808,11 @@ SumPat _ pat _ _ -> [ toHie $ PS rsp scope pscope pat ] - ConPatIn c dets -> - [ toHie $ C Use c - , toHie $ contextify dets - ] - ConPatOut {pat_con = con, pat_args = dets}-> - [ toHie $ C Use $ fmap conLikeName con + ConPat {pat_con = con, pat_args = dets}-> + [ case ghcPass @p of + GhcPs -> toHie $ C Use $ con + GhcRn -> toHie $ C Use $ con + GhcTc -> toHie $ C Use $ fmap conLikeName con , toHie $ contextify dets ] ViewPat _ expr pat -> @@ -840,9 +836,15 @@ (protectSig @a cscope sig) -- See Note [Scoping Rules for SigPat] ] - CoPat _ _ _ _ -> - [] - XPat nec -> noExtCon nec + XPat e -> case ghcPass @p of +#if __GLASGOW_HASKELL__ < 811 + GhcPs -> noExtCon e + GhcRn -> noExtCon e +#endif + GhcTc -> [] + where + -- Make sure we get an error if this changes + _noWarn@(CoPat _ _ _) = e where contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args contextify (InfixCon a b) = InfixCon a' b' @@ -1039,7 +1041,6 @@ [ toHie expr ] Missing _ -> [] - XTupArg nec -> noExtCon nec instance ( a ~ GhcPass p , ToHie (PScoped (LPat a)) @@ -1055,7 +1056,7 @@ LastStmt _ body _ _ -> [ toHie body ] - BindStmt _ pat body _ _ -> + BindStmt _ pat body -> [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat , toHie body ] @@ -1081,7 +1082,6 @@ RecStmt {recS_stmts = stmts} -> [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts ] - XStmtLR nec -> noExtCon nec instance ( ToHie (LHsExpr a) , ToHie (PScoped (LPat a)) @@ -1145,7 +1145,6 @@ FieldOcc name _ -> [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name) ] - XFieldOcc nec -> noExtCon nec instance ToHie (RFContext (LFieldOcc GhcTc)) where toHie (RFC c rhs (L nspan f)) = concatM $ case f of @@ -1153,7 +1152,6 @@ let var' = setVarName var (removeDefSrcSpan $ varName var) in [ toHie $ C (RecField c rhs) (L nspan var') ] - XFieldOcc nec -> noExtCon nec instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of @@ -1162,7 +1160,6 @@ ] Ambiguous _name _ -> [ ] - XAmbiguousFieldOcc nec -> noExtCon nec instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of @@ -1174,7 +1171,6 @@ let var' = setVarName var (removeDefSrcSpan $ varName var) in [ toHie $ C (RecField c rhs) (L nspan var') ] - XAmbiguousFieldOcc nec -> noExtCon nec instance ( a ~ GhcPass p , ToHie (PScoped (LPat a)) @@ -1185,7 +1181,7 @@ , Data (StmtLR a a (Located (HsExpr a))) , Data (HsLocalBinds a) ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where - toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM + toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM [ toHie $ PS Nothing sc NoScope pat , toHie expr ] @@ -1193,7 +1189,6 @@ [ toHie $ listScopes NoScope stmts , toHie $ PS Nothing sc NoScope pat ] - toHie (RS _ (XApplicativeArg nec)) = noExtCon nec instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where toHie (PrefixCon args) = toHie args @@ -1245,6 +1240,9 @@ [ toHie expr , toHie alts ] + HsCmdLamCase _ alts -> + [ toHie alts + ] HsCmdIf _ _ a b c -> [ toHie a , toHie b @@ -1271,7 +1269,6 @@ , toHie roles , toHie instances ] - toHie (XTyClGroup nec) = noExtCon nec instance ToHie (LTyClDecl GhcRn) where toHie (L span decl) = concatM $ makeNode decl span : case decl of @@ -1317,7 +1314,6 @@ context_scope = mkLScope context rhs_scope = foldl1' combineScopes $ map mkScope [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] - XTyClDecl nec -> noExtCon nec instance ToHie (LFamilyDecl GhcRn) where toHie (L span decl) = concatM $ makeNode decl span : case decl of @@ -1332,7 +1328,6 @@ rhsSpan = sigSpan `combineScopes` injSpan sigSpan = mkScope $ getLoc sig injSpan = maybe NoScope (mkScope . getLoc) inj - XFamilyDecl nec -> noExtCon nec instance ToHie (FamilyInfo GhcRn) where toHie (ClosedTypeFamily (Just eqns)) = concatM $ @@ -1353,7 +1348,6 @@ TyVarSig _ bndr -> [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr ] - XFamilyResultSig nec -> noExtCon nec instance ToHie (Located (FunDep (Located Name))) where toHie (L span fd@(lhs, rhs)) = concatM $ @@ -1377,7 +1371,6 @@ where scope = combineScopes patsScope rhsScope patsScope = mkScope (loc pats) rhsScope = mkScope (loc rhs) - toHie (XFamEqn nec) = noExtCon nec instance ToHie (LInjectivityAnn GhcRn) where toHie (L span ann) = concatM $ makeNode ann span : case ann of @@ -1393,7 +1386,6 @@ , toHie cons , toHie derivs ] - toHie (XHsDataDefn nec) = noExtCon nec instance ToHie (HsDeriving GhcRn) where toHie (L span clauses) = concatM @@ -1408,7 +1400,6 @@ , pure $ locOnly ispan , toHie $ map (TS (ResolvedScopes [])) tys ] - XHsDerivingClause nec -> noExtCon nec instance ToHie (Located (DerivStrategy GhcRn)) where toHie (L span strat) = concatM $ makeNode strat span : case strat of @@ -1446,7 +1437,6 @@ rhsScope = combineScopes ctxScope argsScope ctxScope = maybe NoScope mkLScope ctx argsScope = condecl_scope dets - XConDecl nec -> noExtCon nec where condecl_scope args = case args of PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs InfixCon a b -> combineScopes (mkLScope a) (mkLScope b) @@ -1466,7 +1456,6 @@ , toHie $ TS sc a ] where span = loc a - toHie (TS _ (XHsImplicitBndrs nec)) = noExtCon nec instance ( HasLoc thing , ToHie (TScoped thing) @@ -1476,7 +1465,6 @@ , toHie $ TS sc a ] where span = loc a - toHie (TS _ (XHsWildCardBndrs nec)) = noExtCon nec instance ToHie (LStandaloneKindSig GhcRn) where toHie (L sp sig) = concatM [makeNode sig sp, toHie sig] @@ -1487,7 +1475,6 @@ [ toHie $ C TyDecl name , toHie $ TS (ResolvedScopes []) typ ] - XStandaloneKindSig nec -> noExtCon nec instance ToHie (SigContext (LSig GhcRn)) where toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of @@ -1531,7 +1518,6 @@ , toHie $ map (C Use) names , toHie $ fmap (C Use) typ ] - XSig nec -> noExtCon nec instance ToHie (LHsType GhcRn) where toHie x = toHie $ TS (ResolvedScopes []) x @@ -1623,7 +1609,6 @@ [ toHie $ C (TyVarBind sc tsc) var , toHie kind ] - XTyVarBndr nec -> noExtCon nec instance ToHie (TScoped (LHsQTyVars GhcRn)) where toHie (TS sc (HsQTvs implicits vars)) = concatM $ @@ -1633,7 +1618,6 @@ where varLoc = loc vars bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits - toHie (TS _ (XLHsQTyVars nec)) = noExtCon nec instance ToHie (LHsContext GhcRn) where toHie (L span tys) = concatM $ @@ -1647,7 +1631,6 @@ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields , toHie typ ] - XConDeclField nec -> noExtCon nec instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where toHie (From expr) = toHie expr @@ -1670,7 +1653,6 @@ SpliceDecl _ splice _ -> [ toHie splice ] - XSpliceDecl nec -> noExtCon nec instance ToHie (HsBracket a) where toHie _ = pure [] @@ -1717,8 +1699,10 @@ HsSpliced _ _ _ -> [] XSplice x -> case ghcPass @p of +#if __GLASGOW_HASKELL__ < 811 GhcPs -> noExtCon x GhcRn -> noExtCon x +#endif GhcTc -> case x of HsSplicedT _ -> [] @@ -1728,7 +1712,6 @@ [ toHie $ C Use var , concatMapM (pure . locOnly . getLoc) roles ] - XRoleAnnotDecl nec -> noExtCon nec instance ToHie (LInstDecl GhcRn) where toHie (L span decl) = concatM $ makeNode decl span : case decl of @@ -1741,7 +1724,6 @@ TyFamInstD _ d -> [ toHie $ L span d ] - XInstDecl nec -> noExtCon nec instance ToHie (LClsInstDecl GhcRn) where toHie (L span decl) = concatM @@ -1775,21 +1757,18 @@ , toHie strat , toHie overlap ] - XDerivDecl nec -> noExtCon nec instance ToHie (LFixitySig GhcRn) where toHie (L span sig) = concatM $ makeNode sig span : case sig of FixitySig _ vars _ -> [ toHie $ map (C Use) vars ] - XFixitySig nec -> noExtCon nec instance ToHie (LDefaultDecl GhcRn) where toHie (L span decl) = concatM $ makeNode decl span : case decl of DefaultDecl _ typs -> [ toHie typs ] - XDefaultDecl nec -> noExtCon nec instance ToHie (LForeignDecl GhcRn) where toHie (L span decl) = concatM $ makeNode decl span : case decl of @@ -1803,7 +1782,6 @@ , toHie $ TS (ResolvedScopes []) sig , toHie fe ] - XForeignDecl nec -> noExtCon nec instance ToHie ForeignImport where toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $ @@ -1823,14 +1801,12 @@ Warnings _ _ warnings -> [ toHie warnings ] - XWarnDecls nec -> noExtCon nec instance ToHie (LWarnDecl GhcRn) where toHie (L span decl) = concatM $ makeNode decl span : case decl of Warning _ vars _ -> [ toHie $ map (C Use) vars ] - XWarnDecl nec -> noExtCon nec instance ToHie (LAnnDecl GhcRn) where toHie (L span decl) = concatM $ makeNode decl span : case decl of @@ -1838,7 +1814,6 @@ [ toHie prov , toHie expr ] - XAnnDecl nec -> noExtCon nec instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where toHie (ValueAnnProvenance a) = toHie $ C Use a @@ -1850,10 +1825,8 @@ HsRules _ _ rules -> [ toHie rules ] - XRuleDecls nec -> noExtCon nec instance ToHie (LRuleDecl GhcRn) where - toHie (L _ (XRuleDecl nec)) = noExtCon nec toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM [ makeNode r span , pure $ locOnly $ getLoc rname @@ -1876,7 +1849,6 @@ [ toHie $ C (ValBind RegularBind sc Nothing) var , toHie $ TS (ResolvedScopes [sc]) typ ] - XRuleBndr nec -> noExtCon nec instance ToHie (LImportDecl GhcRn) where toHie (L span decl) = concatM $ makeNode decl span : case decl of @@ -1885,7 +1857,6 @@ , toHie $ fmap (IEC ImportAs) as , maybe (pure []) goIE hidden ] - XImportDecl nec -> noExtCon nec where goIE (hiding, (L sp liens)) = concatM $ [ pure $ locOnly sp @@ -1916,7 +1887,6 @@ IEGroup _ _ _ -> [] IEDoc _ _ -> [] IEDocNamed _ _ -> [] - XIE nec -> noExtCon nec instance ToHie (IEContext (LIEWrappedName Name)) where toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs --- a/compiler/GHC/Iface/Ext/Binary.hs +++ b/compiler/GHC/Iface/Ext/Binary.hs @@ -15,24 +15,24 @@ ) where -import GHC.Settings ( maybeRead ) +import GHC.Settings.Utils ( maybeRead ) import Config ( cProjectVersion ) -import GhcPrelude -import Binary +import GHC.Prelude +import GHC.Utils.Binary import GHC.Iface.Binary ( getDictFastString ) -import FastMutInt -import FastString ( FastString ) -import GHC.Types.Module ( Module ) +import GHC.Data.FastMutInt +import GHC.Data.FastString ( FastString ) +import GHC.Unit.Module ( Module ) import GHC.Types.Name import GHC.Types.Name.Cache -import Outputable -import PrelInfo +import GHC.Utils.Outputable +import GHC.Builtin.Utils import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Unique.Supply ( takeUniqFromSupply ) import GHC.Types.Unique import GHC.Types.Unique.FM -import Util +import GHC.Utils.Misc import qualified Data.Array as A import Data.IORef diff --git a/compiler/GHC/Iface/Ext/Debug.hs b/compiler/GHC/Iface/Ext/Debug.hs --- a/compiler/GHC/Iface/Ext/Debug.hs +++ b/compiler/GHC/Iface/Ext/Debug.hs @@ -7,12 +7,12 @@ module GHC.Iface.Ext.Debug where -import GhcPrelude +import GHC.Prelude import GHC.Types.SrcLoc -import GHC.Types.Module -import FastString -import Outputable +import GHC.Unit.Module +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Iface.Ext.Types import GHC.Iface.Ext.Binary @@ -23,35 +23,6 @@ import qualified Data.Set as S import Data.Function ( on ) import Data.List ( sortOn ) -import Data.Foldable ( toList ) - -ppHies :: Outputable a => (HieASTs a) -> SDoc -ppHies (HieASTs asts) = M.foldrWithKey go "" asts - where - go k a rest = vcat $ - [ "File: " <> ppr k - , ppHie a - , rest - ] - -ppHie :: Outputable a => HieAST a -> SDoc -ppHie = go 0 - where - go n (Node inf sp children) = hang header n rest - where - rest = vcat $ map (go (n+2)) children - header = hsep - [ "Node" - , ppr sp - , ppInfo inf - ] - -ppInfo :: Outputable a => NodeInfo a -> SDoc -ppInfo ni = hsep - [ ppr $ toList $ nodeAnnotations ni - , ppr $ nodeType ni - , ppr $ M.toList $ nodeIdentifiers ni - ] type Diff a = a -> a -> [SDoc] diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs --- a/compiler/GHC/Iface/Ext/Types.hs +++ b/compiler/GHC/Iface/Ext/Types.hs @@ -5,22 +5,25 @@ -} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module GHC.Iface.Ext.Types where -import GhcPrelude +import GHC.Prelude import Config -import Binary -import FastString ( FastString ) +import GHC.Utils.Binary +import GHC.Data.FastString ( FastString ) import GHC.Iface.Type -import GHC.Types.Module ( ModuleName, Module ) +import GHC.Unit.Module ( ModuleName, Module ) import GHC.Types.Name ( Name ) -import Outputable hiding ( (<>) ) +import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Types.SrcLoc ( RealSrcSpan ) import GHC.Types.Avail +import qualified GHC.Utils.Outputable as O ( (<>) ) import qualified Data.Array as A import qualified Data.Map as M @@ -210,7 +213,16 @@ put_ bh asts = put_ bh $ M.toAscList $ getAsts asts get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh) +instance Outputable a => Outputable (HieASTs a) where + ppr (HieASTs asts) = M.foldrWithKey go "" asts + where + go k a rest = vcat $ + [ "File: " O.<> ppr k + , ppr a + , rest + ] + data HieAST a = Node { nodeInfo :: NodeInfo a @@ -229,6 +241,11 @@ <*> get bh <*> get bh +instance Outputable a => Outputable (HieAST a) where + ppr (Node ni sp ch) = hang header 2 rest + where + header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni + rest = vcat (map ppr ch) -- | The information stored in one AST node. -- @@ -255,6 +272,22 @@ <*> get bh <*> fmap (M.fromList) (get bh) +instance Outputable a => Outputable (NodeInfo a) where + ppr (NodeInfo anns typs idents) = braces $ fsep $ punctuate ", " + [ parens (text "annotations:" <+> ppr anns) + , parens (text "types:" <+> ppr typs) + , parens (text "identifier info:" <+> pprNodeIdents idents) + ] + +pprNodeIdents :: Outputable a => NodeIdentifiers a -> SDoc +pprNodeIdents ni = braces $ fsep $ punctuate ", " $ map go $ M.toList ni + where + go (i,id) = parens $ hsep $ punctuate ", " [pprIdentifier i, ppr id] + +pprIdentifier :: Identifier -> SDoc +pprIdentifier (Left mod) = text "module" <+> ppr mod +pprIdentifier (Right name) = text "name" <+> ppr name + type Identifier = Either ModuleName Name type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a) @@ -269,7 +302,7 @@ } deriving (Eq, Functor, Foldable, Traversable) instance Outputable a => Outputable (IdentifierDetails a) where - ppr x = text "IdentifierDetails" <+> ppr (identType x) <+> ppr (identInfo x) + ppr x = text "Details: " <+> ppr (identType x) <+> ppr (identInfo x) instance Semigroup (IdentifierDetails a) where d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2) @@ -284,7 +317,7 @@ put_ bh $ S.toAscList $ identInfo dets get bh = IdentifierDetails <$> get bh - <*> fmap (S.fromDistinctAscList) (get bh) + <*> fmap S.fromDistinctAscList (get bh) -- | Different contexts under which identifiers exist @@ -330,11 +363,33 @@ -- | Record field | RecField RecFieldContext (Maybe Span) - deriving (Eq, Ord, Show) + deriving (Eq, Ord) instance Outputable ContextInfo where - ppr = text . show + ppr (Use) = text "usage" + ppr (MatchBind) = text "LHS of a match group" + ppr (IEThing x) = ppr x + ppr (TyDecl) = text "bound in a type signature declaration" + ppr (ValBind t sc sp) = + ppr t <+> text "value bound with scope:" <+> ppr sc <+> pprBindSpan sp + ppr (PatternBind sc1 sc2 sp) = + text "bound in a pattern with scope:" + <+> ppr sc1 <+> "," <+> ppr sc2 + <+> pprBindSpan sp + ppr (ClassTyDecl sp) = + text "bound in a class type declaration" <+> pprBindSpan sp + ppr (Decl d sp) = + text "declaration of" <+> ppr d <+> pprBindSpan sp + ppr (TyVarBind sc1 sc2) = + text "type variable binding with scope:" + <+> ppr sc1 <+> "," <+> ppr sc2 + ppr (RecField ctx sp) = + text "record field" <+> ppr ctx <+> pprBindSpan sp +pprBindSpan :: Maybe Span -> SDoc +pprBindSpan Nothing = text "" +pprBindSpan (Just sp) = text "at:" <+> ppr sp + instance Binary ContextInfo where put_ bh Use = putByte bh 0 put_ bh (IEThing t) = do @@ -383,15 +438,20 @@ 9 -> return MatchBind _ -> panic "Binary ContextInfo: invalid tag" - -- | Types of imports and exports data IEType = Import | ImportAs | ImportHiding | Export - deriving (Eq, Enum, Ord, Show) + deriving (Eq, Enum, Ord) +instance Outputable IEType where + ppr Import = text "import" + ppr ImportAs = text "import as" + ppr ImportHiding = text "import hiding" + ppr Export = text "export" + instance Binary IEType where put_ bh b = putByte bh (fromIntegral (fromEnum b)) get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) @@ -402,8 +462,14 @@ | RecFieldAssign | RecFieldMatch | RecFieldOcc - deriving (Eq, Enum, Ord, Show) + deriving (Eq, Enum, Ord) +instance Outputable RecFieldContext where + ppr RecFieldDecl = text "declaration" + ppr RecFieldAssign = text "assignment" + ppr RecFieldMatch = text "pattern match" + ppr RecFieldOcc = text "occurence" + instance Binary RecFieldContext where put_ bh b = putByte bh (fromIntegral (fromEnum b)) get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) @@ -412,13 +478,16 @@ data BindType = RegularBind | InstanceBind - deriving (Eq, Ord, Show, Enum) + deriving (Eq, Ord, Enum) +instance Outputable BindType where + ppr RegularBind = "regular" + ppr InstanceBind = "instance" + instance Binary BindType where put_ bh b = putByte bh (fromIntegral (fromEnum b)) get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) - data DeclType = FamDec -- ^ type or data family | SynDec -- ^ type synonym @@ -427,18 +496,26 @@ | PatSynDec -- ^ pattern synonym | ClassDec -- ^ class declaration | InstDec -- ^ instance declaration - deriving (Eq, Ord, Show, Enum) + deriving (Eq, Ord, Enum) +instance Outputable DeclType where + ppr FamDec = text "type or data family" + ppr SynDec = text "type synonym" + ppr DataDec = text "data" + ppr ConDec = text "constructor" + ppr PatSynDec = text "pattern synonym" + ppr ClassDec = text "class" + ppr InstDec = text "instance" + instance Binary DeclType where put_ bh b = putByte bh (fromIntegral (fromEnum b)) get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) - data Scope = NoScope | LocalScope Span | ModuleScope - deriving (Eq, Ord, Show, Typeable, Data) + deriving (Eq, Ord, Typeable, Data) instance Outputable Scope where ppr NoScope = text "NoScope" @@ -488,9 +565,12 @@ -- method type signature deriving (Eq, Ord) -instance Show TyVarScope where - show (ResolvedScopes sc) = show sc - show _ = error "UnresolvedScope" +instance Outputable TyVarScope where + ppr (ResolvedScopes xs) = + text "type variable scopes:" <+> hsep (punctuate ", " $ map ppr xs) + ppr (UnresolvedScope ns sp) = + text "unresolved type variable scope for name" O.<> plural ns + <+> pprBindSpan sp instance Binary TyVarScope where put_ bh (ResolvedScopes xs) = do 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 @@ -4,14 +4,14 @@ {-# LANGUAGE FlexibleInstances #-} module GHC.Iface.Ext.Utils where -import GhcPrelude +import GHC.Prelude import GHC.Core.Map -import GHC.Driver.Session ( DynFlags ) -import FastString ( FastString, mkFastString ) +import GHC.Driver.Session ( DynFlags ) +import GHC.Data.FastString ( FastString, mkFastString ) import GHC.Iface.Type import GHC.Types.Name hiding (varName) -import Outputable ( renderWithStyle, ppr, defaultUserStyle, initSDocContext ) +import GHC.Utils.Outputable ( renderWithStyle, ppr, defaultUserStyle, initSDocContext ) import GHC.Types.SrcLoc import GHC.CoreToIface import GHC.Core.TyCon 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 @@ -34,7 +34,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.IfaceToCore ( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst @@ -46,14 +46,15 @@ import GHC.Driver.Types import GHC.Types.Basic hiding (SuccessFlag(..)) -import TcRnMonad +import GHC.Tc.Utils.Monad -import Constants -import PrelNames -import PrelInfo -import PrimOp ( allThePrimOps, primOpFixity, primOpOcc ) -import GHC.Types.Id.Make ( seqId ) -import TysPrim ( funTyConName ) +import GHC.Utils.Binary ( BinData(..) ) +import GHC.Settings.Constants +import GHC.Builtin.Names +import GHC.Builtin.Utils +import GHC.Builtin.PrimOps ( allThePrimOps, primOpFixity, primOpOcc ) +import GHC.Types.Id.Make ( seqId ) +import GHC.Builtin.Types.Prim ( funTyConName ) import GHC.Core.Rules import GHC.Core.TyCon import GHC.Types.Annotations @@ -62,18 +63,18 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Avail -import GHC.Types.Module -import Maybes -import ErrUtils +import GHC.Unit.Module +import GHC.Data.Maybe +import GHC.Utils.Error import GHC.Driver.Finder import GHC.Types.Unique.FM import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Iface.Binary -import Panic -import Util -import FastString -import Fingerprint +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Utils.Fingerprint import GHC.Driver.Hooks import GHC.Types.FieldLabel import GHC.Iface.Rename @@ -83,6 +84,7 @@ import Control.Monad import Control.Exception import Data.IORef +import Data.Map ( toList ) import System.FilePath import System.Directory @@ -204,7 +206,7 @@ checkWiredInTyCon :: TyCon -> TcM () -- Ensure that the home module of the TyCon (and hence its instances) -- are loaded. See Note [Loading instances for wired-in things] --- It might not be a wired-in tycon (see the calls in TcUnify), +-- It might not be a wired-in tycon (see the calls in GHC.Tc.Utils.Unify), -- in which case this is a no-op. checkWiredInTyCon tc | not (isWiredInName tc_name) @@ -542,7 +544,7 @@ * At the end of tcRnImports, we call checkFamInstConsistency to check consistency of imported type-family instances - See Note [The type family instance consistency story] in FamInst + See Note [The type family instance consistency story] in GHC.Tc.Instance.Family * Alas, those instances may refer to data types defined in M, if there is a M.hs-boot. @@ -617,7 +619,7 @@ -- It's a signature iface... mi_semantic_module iface /= mi_module iface && -- and it's not from the local package - moduleUnitId (mi_module iface) /= thisPackage dflags + moduleUnit (mi_module iface) /= thisPackage dflags -- | This is an improved version of 'findAndReadIface' which can also -- handle the case when a user requests @p[A=]:M@ but we only @@ -639,14 +641,14 @@ computeInterface doc_str hi_boot_file mod0 = do MASSERT( not (isHoleModule mod0) ) dflags <- getDynFlags - case splitModuleInsts mod0 of - (imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do + case getModuleInstantiation mod0 of + (imod, Just indef) | not (unitIsDefinite (thisPackage dflags)) -> do r <- findAndReadIface doc_str imod mod0 hi_boot_file case r of Succeeded (iface0, path) -> do hsc_env <- getTopEnv r <- liftIO $ - rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef)) + rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 case r of Right x -> return (Succeeded (x, path)) @@ -670,9 +672,9 @@ moduleFreeHolesPrecise doc_str mod | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) | otherwise = - case splitModuleInsts mod of + case getModuleInstantiation mod of (imod, Just indef) -> do - let insts = indefUnitIdInsts (indefModuleUnitId indef) + let insts = instUnitInsts (moduleUnit indef) traceIf (text "Considering whether to load" <+> ppr mod <+> text "to compute precise free module holes") (eps, hpt) <- getEpsAndHpt @@ -724,13 +726,13 @@ -- The boot-ness of the requested interface, -- based on the dependencies in directly-imported modules where - this_package = thisPackage dflags == moduleUnitId mod + this_package = thisPackage dflags == moduleUnit mod badSourceImport :: Module -> SDoc badSourceImport mod = hang (text "You cannot {-# SOURCE #-} import a module from another package") 2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package") - <+> quotes (ppr (moduleUnitId mod))) + <+> quotes (ppr (moduleUnit mod))) ----------------------------------------------------- -- Loading type/class/value decls @@ -923,7 +925,7 @@ (ml_hi_file loc) -- See Note [Home module load error] - if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags && + if moduleUnit mod `unitIdEq` thisPackage dflags && not (isOneShot (ghcMode dflags)) then return (Failed (homeModError mod loc)) else do r <- read_file file_path @@ -933,7 +935,7 @@ traceIf (text "...not found") dflags <- getDynFlags return (Failed (cannotFindInterface dflags - (installedModuleName mod) err)) + (moduleName mod) err)) where read_file file_path = do traceIf (text "readIFace" <+> text file_path) -- Figure out what is recorded in mi_module. If this is @@ -941,11 +943,11 @@ -- if it's indefinite, the inside will be uninstantiated! dflags <- getDynFlags let wanted_mod = - case splitModuleInsts wanted_mod_with_insts of + case getModuleInstantiation wanted_mod_with_insts of (_, Nothing) -> wanted_mod_with_insts (_, Just indef_mod) -> - indefModuleToModule dflags - (generalizeIndefModule indef_mod) + instModuleToModule (pkgState dflags) + (uninstantiateInstantiatedModule indef_mod) read_result <- readIface wanted_mod file_path case read_result of Failed err -> return (Failed (badIfaceFile file_path err)) @@ -1047,7 +1049,8 @@ mi_exports = ghcPrimExports, mi_decls = [], mi_fixities = fixities, - mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities } + mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities }, + mi_decl_docs = ghcPrimDeclDocs -- See Note [GHC.Prim Docs] } where empty_iface = emptyFullModIface gHC_PRIM @@ -1159,6 +1162,7 @@ , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface)) , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface)) , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface)) + , text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface)) ] where pp_hsc_src HsBootFile = text "[boot]" @@ -1248,6 +1252,11 @@ pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized }) = ppr target <+> text "annotated by" <+> ppr serialized +pprExtensibleFields :: ExtensibleFields -> SDoc +pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs + where + pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes" + {- ********************************************************* * * @@ -1263,7 +1272,7 @@ hiModuleNameMismatchWarn :: DynFlags -> Module -> Module -> MsgDoc hiModuleNameMismatchWarn dflags requested_mod read_mod - | moduleUnitId requested_mod == moduleUnitId 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", diff --git a/compiler/GHC/Iface/Load.hs-boot b/compiler/GHC/Iface/Load.hs-boot --- a/compiler/GHC/Iface/Load.hs-boot +++ b/compiler/GHC/Iface/Load.hs-boot @@ -1,8 +1,8 @@ module GHC.Iface.Load where -import GHC.Types.Module (Module) -import TcRnMonad (IfM) +import GHC.Unit.Module (Module) +import GHC.Tc.Utils.Monad (IfM) import GHC.Driver.Types (ModIface) -import Outputable (SDoc) +import GHC.Utils.Outputable (SDoc) loadSysInterface :: SDoc -> Module -> IfM lcl ModIface 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 @@ -21,7 +21,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Iface.Syntax import GHC.Iface.Recomp @@ -38,10 +38,10 @@ import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.Type -import TcType +import GHC.Tc.Utils.TcType import GHC.Core.InstEnv import GHC.Core.FamInstEnv -import TcRnMonad +import GHC.Tc.Utils.Monad import GHC.Hs import GHC.Driver.Types import GHC.Driver.Session @@ -52,13 +52,13 @@ import GHC.Types.Name.Reader import GHC.Types.Name.Env import GHC.Types.Name.Set -import GHC.Types.Module -import ErrUtils -import Outputable -import GHC.Types.Basic hiding ( SuccessFlag(..) ) -import Util hiding ( eqListBy ) -import FastString -import Maybes +import GHC.Unit.Module +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Types.Basic hiding ( SuccessFlag(..) ) +import GHC.Utils.Misc hiding ( eqListBy ) +import GHC.Data.FastString +import GHC.Data.Maybe import GHC.HsToCore.Docs import Data.Function @@ -153,7 +153,7 @@ let pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env)) deps <- mkDependencies - (thisInstalledUnitId (hsc_dflags hsc_env)) + (thisUnitId (hsc_dflags hsc_env)) (map mi_module pluginModules) tc_result let hpc_info = emptyHpcInfo other_hpc_info used_th <- readIORef tc_splice_used @@ -218,7 +218,7 @@ not (isWiredInName name), -- Nor wired-in things; the compiler knows about them anyhow nameIsLocalOrFrom semantic_mod name ] - -- Sigh: see Note [Root-main Id] in TcRnDriver + -- Sigh: see Note [Root-main Id] in GHC.Tc.Module -- NB: ABSOLUTELY need to check against semantic_mod, -- because all of the names in an hsig p[H=]:H -- are going to be for , not the former id! @@ -268,7 +268,8 @@ mi_doc_hdr = doc_hdr, mi_decl_docs = decl_docs, mi_arg_docs = arg_docs, - mi_final_exts = () } + mi_final_exts = (), + mi_ext_fields = emptyExtensibleFields } where cmp_rule = comparing ifRuleName -- Compare these lexicographically by OccName, *not* by unique, @@ -528,7 +529,7 @@ ifaceConDecls AbstractTyCon = IfAbstractTyCon -- The AbstractTyCon case happens when a TyCon has been trimmed -- during tidying. - -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver + -- 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.) 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 @@ -12,35 +12,35 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Iface.Syntax -import BinFingerprint +import GHC.Iface.Recomp.Binary import GHC.Iface.Load -import FlagChecker +import GHC.Iface.Recomp.Flags import GHC.Types.Annotations import GHC.Core -import TcRnMonad +import GHC.Tc.Utils.Monad import GHC.Hs import GHC.Driver.Types import GHC.Driver.Finder import GHC.Driver.Session import GHC.Types.Name import GHC.Types.Name.Set -import GHC.Types.Module -import ErrUtils -import Digraph +import GHC.Unit.Module +import GHC.Utils.Error +import GHC.Data.Graph.Directed import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Types.Unique -import Util hiding ( eqListBy ) -import Maybes -import Binary -import Fingerprint -import Exception +import GHC.Utils.Misc hiding ( eqListBy ) +import GHC.Data.Maybe +import GHC.Utils.Binary +import GHC.Utils.Fingerprint +import GHC.Utils.Exception import GHC.Types.Unique.Set -import GHC.Driver.Packages +import GHC.Unit.State import Control.Monad import Data.Function @@ -209,10 +209,10 @@ = do { traceHiDiffs (text "Considering whether compilation is required for" <+> ppr (mi_module iface) <> colon) - -- readIface will have verified that the InstalledUnitId matches, + -- readIface will have verified that the UnitId matches, -- but we ALSO must make sure the instantiation matches up. See -- test case bkpcabal04! - ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env) + ; if moduleUnit (mi_module iface) /= thisPackage (hsc_dflags hsc_env) then return (RecompBecause "-this-unit-id changed", Nothing) else do { ; recomp <- checkFlagHash hsc_env iface ; if recompileRequired recomp then return (recomp, Nothing) else do { @@ -332,7 +332,7 @@ dflags <- getDynFlags let outer_mod = ms_mod mod_summary inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod) - MASSERT( moduleUnitId outer_mod == thisPackage dflags ) + MASSERT( moduleUnit outer_mod == thisPackage dflags ) case inner_mod == mi_semantic_module iface of True -> up_to_date (text "implementing module unchanged") False -> return (RecompBecause "implementing module changed") @@ -405,7 +405,7 @@ new_merged = case Map.lookup (ms_mod_name mod_summary) (requirementContext (pkgState dflags)) of Nothing -> [] - Just r -> sort $ map (indefModuleToModule dflags) r + Just r -> sort $ map (instModuleToModule (pkgState dflags)) r if old_merged == new_merged then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged) else return (RecompBecause "signatures to merge in changed") @@ -463,7 +463,7 @@ else return UpToDate | otherwise - -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs) + -> if toUnitId pkg `notElem` (map fst prev_dep_pkgs) then do traceHiDiffs $ text "imported module " <> quotes (ppr mod) <> text " is from package " <> quotes (ppr pkg) <> @@ -471,7 +471,7 @@ return (RecompBecause reason) else return UpToDate - where pkg = moduleUnitId mod + where pkg = moduleUnit mod _otherwise -> return (RecompBecause reason) old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods @@ -561,7 +561,7 @@ -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled. -checkModUsage :: UnitId -> Usage -> IfG RecompileRequired +checkModUsage :: Unit -> Usage -> IfG RecompileRequired checkModUsage _this_pkg UsagePackageModule{ usg_mod = mod, usg_mod_hash = old_mod_hash } @@ -766,7 +766,7 @@ -- used to construct the edges and -- stronglyConnCompFromEdgedVertices is deterministic -- even with non-deterministic order of edges as - -- explained in Note [Deterministic SCC] in Digraph. + -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. where getParent :: OccName -> OccName getParent occ = lookupOccEnv parent_map occ `orElse` occ diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Iface/Recomp/Flags.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | This module manages storing the various GHC option flags in a modules +-- interface file as part of the recompilation checking infrastructure. +module GHC.Iface.Recomp.Flags ( + fingerprintDynFlags + , fingerprintOptFlags + , fingerprintHpcFlags + ) where + +import GHC.Prelude + +import GHC.Utils.Binary +import GHC.Driver.Session +import GHC.Driver.Types +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Utils.Fingerprint +import GHC.Iface.Recomp.Binary +-- import GHC.Utils.Outputable + +import GHC.Data.EnumSet as EnumSet +import System.FilePath (normalise) + +-- | Produce a fingerprint of a @DynFlags@ value. We only base +-- the finger print on important fields in @DynFlags@ so that +-- the recompilation checker can use this fingerprint. +-- +-- NB: The 'Module' parameter is the 'Module' recorded by the +-- *interface* file, not the actual 'Module' according to our +-- 'DynFlags'. +fingerprintDynFlags :: DynFlags -> Module + -> (BinHandle -> Name -> IO ()) + -> IO Fingerprint + +fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = + let mainis = if mainModIs == this_mod then Just mainFunIs else Nothing + -- see #5878 + -- pkgopts = (thisPackage dflags, sort $ packageFlags dflags) + safeHs = setSafeMode safeHaskell + -- oflags = sort $ filter filterOFlags $ flags dflags + + -- *all* the extension flags and the language + lang = (fmap fromEnum language, + map fromEnum $ EnumSet.toList extensionFlags) + + -- -I, -D and -U flags affect CPP + cpp = ( map normalise $ flattenIncludes includePaths + -- normalise: eliminate spurious differences due to "./foo" vs "foo" + , picPOpts dflags + , opt_P_signature dflags) + -- See Note [Repeated -optP hashing] + + -- Note [path flags and recompilation] + paths = [ hcSuf ] + + -- -fprof-auto etc. + prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0 + + -- Ticky + ticky = + map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk] + + flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel)) + + in -- pprTrace "flags" (ppr flags) $ + computeFingerprint nameio flags + +-- Fingerprint the optimisation info. We keep this separate from the rest of +-- the flags because GHCi users (especially) may wish to ignore changes in +-- optimisation level or optimisation flags so as to use as many pre-existing +-- object files as they can. +-- See Note [Ignoring some flag changes] +fingerprintOptFlags :: DynFlags + -> (BinHandle -> Name -> IO ()) + -> IO Fingerprint +fingerprintOptFlags DynFlags{..} nameio = + let + -- See https://gitlab.haskell.org/ghc/ghc/issues/10923 + -- We used to fingerprint the optimisation level, but as Joachim + -- Breitner pointed out in comment 9 on that ticket, it's better + -- to ignore that and just look at the individual optimisation flags. + opt_flags = map fromEnum $ filter (`EnumSet.member` optimisationFlags) + (EnumSet.toList generalFlags) + + in computeFingerprint nameio opt_flags + +-- Fingerprint the HPC info. We keep this separate from the rest of +-- the flags because GHCi users (especially) may wish to use an object +-- file compiled for HPC when not actually using HPC. +-- See Note [Ignoring some flag changes] +fingerprintHpcFlags :: DynFlags + -> (BinHandle -> Name -> IO ()) + -> IO Fingerprint +fingerprintHpcFlags dflags@DynFlags{..} nameio = + let + -- -fhpc, see https://gitlab.haskell.org/ghc/ghc/issues/11798 + -- hpcDir is output-only, so we should recompile if it changes + hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing + + in computeFingerprint nameio hpc + + +{- Note [path flags and recompilation] + +There are several flags that we deliberately omit from the +recompilation check; here we explain why. + +-osuf, -odir, -hisuf, -hidir + If GHC decides that it does not need to recompile, then + it must have found an up-to-date .hi file and .o file. + There is no point recording these flags - the user must + have passed the correct ones. Indeed, the user may + have compiled the source file in one-shot mode using + -o to specify the .o file, and then loaded it in GHCi + using -odir. + +-stubdir + We omit this one because it is automatically set by -outputdir, and + we don't want changes in -outputdir to automatically trigger + recompilation. This could be wrong, but only in very rare cases. + +-i (importPaths) + For the same reason as -osuf etc. above: if GHC decides not to + recompile, then it must have already checked all the .hi files on + which the current module depends, so it must have found them + successfully. It is occasionally useful to be able to cd to a + different directory and use -i flags to enable GHC to find the .hi + files; we don't want this to force recompilation. + +The only path-related flag left is -hcsuf. +-} + +{- Note [Ignoring some flag changes] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Normally, --make tries to reuse only compilation products that are +the same as those that would have been produced compiling from +scratch. Sometimes, however, users would like to be more aggressive +about recompilation avoidance. This is particularly likely when +developing using GHCi (see #13604). Currently, we allow users to +ignore optimisation changes using -fignore-optim-changes, and to +ignore HPC option changes using -fignore-hpc-changes. If there's a +demand for it, we could also allow changes to -fprof-auto-* flags +(although we can't allow -prof flags to differ). The key thing about +these options is that we can still successfully link a library or +executable when some of its components differ in these ways. + +The way we accomplish this is to leave the optimization and HPC +options out of the flag hash, hashing them separately. +-} + +{- Note [Repeated -optP hashing] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We invoke fingerprintDynFlags for each compiled module to include +the hash of relevant DynFlags in the resulting interface file. +-optP (preprocessor) flags are part of that hash. +-optP flags can come from multiple places: + + 1. -optP flags directly passed on command line. + 2. -optP flags implied by other flags. Eg. -DPROFILING implied by -prof. + 3. -optP flags added with {-# OPTIONS -optP-D__F__ #-} in a file. + +When compiling many modules at once with many -optP command line arguments +the work of hashing -optP flags would be repeated. This can get expensive +and as noted on #14697 it can take 7% of time and 14% of allocations on +a real codebase. + +The obvious solution is to cache the hash of -optP flags per GHC invocation. +However, one has to be careful there, as the flags that were added in 3. way +have to be accounted for. + +The current strategy is as follows: + + 1. Lazily compute the hash of sOpt_p in sOpt_P_fingerprint whenever sOpt_p + is modified. This serves dual purpose. It ensures correctness for when + we add per file -optP flags and lets us save work for when we don't. + 2. When computing the fingerprint in fingerprintDynFlags use the cached + value *and* fingerprint the additional implied (see 2. above) -optP flags. + This is relatively cheap and saves the headache of fingerprinting all + the -optP flags and tracking all the places that could invalidate the + cache. +-} 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 @@ -17,23 +17,23 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Types -import GHC.Types.Module +import GHC.Unit import GHC.Types.Unique.FM import GHC.Types.Avail import GHC.Iface.Syntax import GHC.Types.FieldLabel import GHC.Types.Var -import ErrUtils +import GHC.Utils.Error import GHC.Types.Name -import TcRnMonad -import Util -import Fingerprint +import GHC.Tc.Utils.Monad +import GHC.Utils.Misc +import GHC.Utils.Fingerprint import GHC.Types.Basic -- a bit vexing @@ -42,7 +42,7 @@ import qualified Data.Traversable as T -import Bag +import GHC.Data.Bag import Data.IORef import GHC.Types.Name.Shape import GHC.Iface.Env @@ -164,7 +164,7 @@ -- not to do it in this case either...) -- -- This mistake was bug #15594. - let mod' = renameHoleModule dflags hmap mod + let mod' = renameHoleModule (pkgState dflags) hmap mod if isHoleModule mod then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env $ loadSysInterface (text "rnDepModule") mod' @@ -186,7 +186,7 @@ errs_var <- newIORef emptyBag let dflags = hsc_dflags hsc_env hsubst = listToUFM insts - rn_mod = renameHoleModule dflags hsubst + rn_mod = renameHoleModule (pkgState dflags) hsubst env = ShIfEnv { sh_if_module = rn_mod (mi_module iface), sh_if_semantic_module = rn_mod (mi_semantic_module iface), @@ -211,7 +211,7 @@ -- The semantic module that we are renaming to sh_if_semantic_module :: Module, -- Cached hole substitution, e.g. - -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@ + -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnit . sh_if_module@ sh_if_hole_subst :: ShHoleSubst, -- An optional name substitution to be applied when renaming -- the names in the interface. If this is 'Nothing', then @@ -233,7 +233,7 @@ rnModule mod = do hmap <- getHoleSubst dflags <- getDynFlags - return (renameHoleModule dflags hmap mod) + return (renameHoleModule (pkgState dflags) hmap mod) rnAvailInfo :: Rename AvailInfo rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n @@ -302,7 +302,7 @@ mb_nsubst <- fmap sh_if_shape getGblEnv hmap <- getHoleSubst let m = nameModule n - m' = renameHoleModule dflags hmap m + m' = renameHoleModule (pkgState dflags) hmap m case () of -- Did we encounter {A.T} while renaming p[A=]:A? If so, -- do NOT assume B.hi is available. @@ -363,7 +363,7 @@ hmap <- getHoleSubst dflags <- getDynFlags iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv - let m = renameHoleModule dflags hmap $ nameModule name + let m = renameHoleModule (pkgState dflags) hmap $ nameModule name -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined. MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m ) setNameModule (Just m) name 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 @@ -14,15 +14,15 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import TcRnTypes +import GHC.Tc.Types import GHC.Driver.Session import GHC.Core import GHC.Core.Unfold import GHC.Core.FVs -import GHC.Core.Op.Tidy -import GHC.Core.Op.Monad +import GHC.Core.Tidy +import GHC.Core.Opt.Monad import GHC.Core.Stats (coreBindsStats, CoreStats(..)) import GHC.Core.Seq (seqBinds) import GHC.Core.Lint @@ -30,7 +30,7 @@ import GHC.Core.PatSyn import GHC.Core.ConLike import GHC.Core.Arity ( exprArity, exprBotStrictness_maybe ) -import StaticPtrTable +import GHC.Iface.Tidy.StaticPtrTable import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Var @@ -47,18 +47,18 @@ import GHC.Types.Name.Cache import GHC.Types.Avail import GHC.Iface.Env -import TcEnv -import TcRnMonad +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class -import GHC.Types.Module +import GHC.Unit.Module import GHC.Driver.Types -import Maybes +import GHC.Data.Maybe import GHC.Types.Unique.Supply -import Outputable -import Util( filterOut ) -import qualified ErrUtils as Err +import GHC.Utils.Outputable +import GHC.Utils.Misc( filterOut ) +import qualified GHC.Utils.Error as Err import Control.Monad import Data.Function @@ -378,7 +378,7 @@ ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env unfold_env tidy_occ_env trimmed_binds - -- See Note [Grand plan for static forms] in StaticPtrTable. + -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. ; (spt_entries, tidy_binds') <- sptCreateStaticBinds hsc_env mod tidy_binds ; let { spt_init_code = sptModuleInitCode mod spt_entries @@ -529,7 +529,7 @@ Note [Injecting implicit bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We inject the implicit bindings right at the end, in GHC.Core.Op.Tidy. +We inject the implicit bindings right at the end, in GHC.Core.Tidy. Some of these bindings, notably record selectors, are not constructed in an optimised form. E.g. record selector for data T = MkT { x :: {-# UNPACK #-} !Int } @@ -896,7 +896,7 @@ purely speculative, and meanwhile the code is taking up space and codegen time. I found that binary sizes jumped by 6-10% when I started to specialise INLINE functions (again, Note [Inline -specialisations] in GHC.Core.Op.Specialise). +specialisations] in GHC.Core.Opt.Specialise). So it seems better to drop the binding for f_spec, and the rule itself, if the auto-generated rule is the *only* reason that it is @@ -904,7 +904,7 @@ (The RULE still might have been useful in the past; that is, it was the right thing to have generated it in the first place. See Note -[Inline specialisations] in GHC.Core.Op.Specialise. But now it has +[Inline specialisations] in GHC.Core.Opt.Specialise. But now it has served its purpose, and can be discarded.) So findExternalRules does this: @@ -1186,12 +1186,12 @@ | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough; - -- c.f. GHC.Core.Op.Tidy.tidyLetBndr + -- c.f. GHC.Core.Tidy.tidyLetBndr `setArityInfo` arity `setStrictnessInfo` final_sig `setCprInfo` final_cpr `setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness] - -- in GHC.Core.Op.Tidy + -- in GHC.Core.Tidy | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo @@ -1239,8 +1239,7 @@ | otherwise = minimal_unfold_info minimal_unfold_info = zapUnfolding unf_info - unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs - is_bot = isBottomingSig final_sig + unf_from_rhs = mkFinalUnfolding dflags InlineRhs final_sig tidy_rhs -- NB: do *not* expose the worker if show_unfold is off, -- because that means this thing is a loop breaker or -- marked NOINLINE or something like that @@ -1254,7 +1253,7 @@ -- In this case, show_unfold will be false (we don't expose unfoldings -- for bottoming functions), but we might still have a worker/wrapper -- split (see Note [Worker-wrapper for bottoming functions] in - -- GHC.Core.Op.WorkWrap) + -- GHC.Core.Opt.WorkWrap) --------- Arity ------------ diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs @@ -0,0 +1,294 @@ +-- | Code generation for the Static Pointer Table +-- +-- (c) 2014 I/O Tweag +-- +-- Each module that uses 'static' keyword declares an initialization function of +-- the form hs_spt_init_() which is emitted into the _stub.c file and +-- annotated with __attribute__((constructor)) so that it gets executed at +-- startup time. +-- +-- The function's purpose is to call hs_spt_insert to insert the static +-- pointers of this module in the hashtable of the RTS, and it looks something +-- like this: +-- +-- > static void hs_hpc_init_Main(void) __attribute__((constructor)); +-- > static void hs_hpc_init_Main(void) { +-- > +-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; +-- > extern StgPtr Main_r2wb_closure; +-- > hs_spt_insert(k0, &Main_r2wb_closure); +-- > +-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; +-- > extern StgPtr Main_r2wc_closure; +-- > hs_spt_insert(k1, &Main_r2wc_closure); +-- > +-- > } +-- +-- where the constants are fingerprints produced from the static forms. +-- +-- The linker must find the definitions matching the @extern StgPtr @ +-- declarations. For this to work, the identifiers of static pointers need to be +-- exported. This is done in GHC.Core.Opt.SetLevels.newLvlVar. +-- +-- There is also a finalization function for the time when the module is +-- unloaded. +-- +-- > static void hs_hpc_fini_Main(void) __attribute__((destructor)); +-- > static void hs_hpc_fini_Main(void) { +-- > +-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; +-- > hs_spt_remove(k0); +-- > +-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; +-- > hs_spt_remove(k1); +-- > +-- > } +-- + +{-# LANGUAGE ViewPatterns, TupleSections #-} +module GHC.Iface.Tidy.StaticPtrTable + ( sptCreateStaticBinds + , sptModuleInitCode + ) where + +{- Note [Grand plan for static forms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Static forms go through the compilation phases as follows. +Here is a running example: + + f x = let k = map toUpper + in ...(static k)... + +* The renamer looks for out-of-scope names in the body of the static + form, as always. If all names are in scope, the free variables of the + body are stored in AST at the location of the static form. + +* The typechecker verifies that all free variables occurring in the + static form are floatable to top level (see Note [Meaning of + IdBindingInfo] in GHC.Tc.Types). In our example, 'k' is floatable. + Even though it is bound in a nested let, we are fine. + +* The desugarer replaces the static form with an application of the + function 'makeStatic' (defined in module GHC.StaticPtr.Internal of + base). So we get + + f x = let k = map toUpper + in ...fromStaticPtr (makeStatic location k)... + +* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic' + to the top level. Thus the FloatOut pass is always executed, even when + optimizations are disabled. So we get + + k = map toUpper + static_ptr = makeStatic location k + f x = ...fromStaticPtr static_ptr... + + The FloatOut pass is careful to produce an /exported/ Id for a floated + 'makeStatic' call, so the binding is not removed or inlined by the + simplifier. + E.g. the code for `f` above might look like + + static_ptr = makeStatic location k + f x = ...(case static_ptr of ...)... + + which might be simplified to + + f x = ...(case makeStatic location k of ...)... + + BUT the top-level binding for static_ptr must remain, so that it can be + collected to populate the Static Pointer Table. + + Making the binding exported also has a necessary effect during the + CoreTidy pass. + +* The CoreTidy pass replaces all bindings of the form + + b = /\ ... -> makeStatic location value + + with + + b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value + + where a distinct key is generated for each binding. + +* If we are compiling to object code we insert a C stub (generated by + sptModuleInitCode) into the final object which runs when the module is loaded, + inserting the static forms defined by the module into the RTS's static pointer + table. + +* If we are compiling for the byte-code interpreter, we instead explicitly add + the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter + process' SPT table using the addSptEntry interpreter message. This happens + in upsweep after we have compiled the module (see GHC.Driver.Make.upsweep'). +-} + +import GHC.Prelude + +import GHC.Cmm.CLabel +import GHC.Core +import GHC.Core.Utils (collectMakeStaticArgs) +import GHC.Core.DataCon +import GHC.Driver.Session +import GHC.Driver.Types +import GHC.Types.Id +import GHC.Core.Make (mkStringExprFSWith) +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Utils.Outputable as Outputable +import GHC.Platform +import GHC.Builtin.Names +import GHC.Tc.Utils.Env (lookupGlobal) +import GHC.Core.Type + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State +import Data.List +import Data.Maybe +import GHC.Fingerprint +import qualified GHC.LanguageExtensions as LangExt + +-- | Replaces all bindings of the form +-- +-- > b = /\ ... -> makeStatic location value +-- +-- with +-- +-- > b = /\ ... -> +-- > StaticPtr key (StaticPtrInfo "pkg key" "module" location) value +-- +-- where a distinct key is generated for each binding. +-- +-- It also yields the C stub that inserts these bindings into the static +-- pointer table. +sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram + -> IO ([SptEntry], CoreProgram) +sptCreateStaticBinds hsc_env this_mod binds + | not (xopt LangExt.StaticPointers dflags) = + return ([], binds) + | otherwise = do + -- Make sure the required interface files are loaded. + _ <- lookupGlobal hsc_env unpackCStringName + (fps, binds') <- evalStateT (go [] [] binds) 0 + return (fps, binds') + where + go fps bs xs = case xs of + [] -> return (reverse fps, reverse bs) + bnd : xs' -> do + (fps', bnd') <- replaceStaticBind bnd + go (reverse fps' ++ fps) (bnd' : bs) xs' + + dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + + -- Generates keys and replaces 'makeStatic' with 'StaticPtr'. + -- + -- The 'Int' state is used to produce a different key for each binding. + replaceStaticBind :: CoreBind + -> StateT Int IO ([SptEntry], CoreBind) + replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e + return (maybeToList mfp, NonRec b' e') + replaceStaticBind (Rec rbs) = do + (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs + return (catMaybes mfps, Rec rbs') + + replaceStatic :: Id -> CoreExpr + -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr)) + replaceStatic b e@(collectTyBinders -> (tvs, e0)) = + case collectMakeStaticArgs e0 of + Nothing -> return (Nothing, (b, e)) + Just (_, t, info, arg) -> do + (fp, e') <- mkStaticBind t info arg + return (Just (SptEntry b fp), (b, foldr Lam e' tvs)) + + mkStaticBind :: Type -> CoreExpr -> CoreExpr + -> StateT Int IO (Fingerprint, CoreExpr) + mkStaticBind t srcLoc e = do + i <- get + put (i + 1) + staticPtrInfoDataCon <- + lift $ lookupDataConHscEnv staticPtrInfoDataConName + let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i + info <- mkConApp staticPtrInfoDataCon <$> + (++[srcLoc]) <$> + mapM (mkStringExprFSWith (lift . lookupIdHscEnv)) + [ unitFS $ moduleUnit this_mod + , moduleNameFS $ moduleName this_mod + ] + + -- The module interface of GHC.StaticPtr should be loaded at least + -- when looking up 'fromStatic' during type-checking. + staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName + return (fp, mkConApp staticPtrDataCon + [ Type t + , mkWord64LitWordRep platform w0 + , mkWord64LitWordRep platform w1 + , info + , e ]) + + mkStaticPtrFingerprint :: Int -> Fingerprint + mkStaticPtrFingerprint n = fingerprintString $ intercalate ":" + [ unitString $ moduleUnit this_mod + , moduleNameString $ moduleName this_mod + , show n + ] + + -- Choose either 'Word64#' or 'Word#' to represent the arguments of the + -- 'Fingerprint' data constructor. + mkWord64LitWordRep platform = + case platformWordSize platform of + PW4 -> mkWord64LitWord64 + PW8 -> mkWordLit platform . toInteger + + lookupIdHscEnv :: Name -> IO Id + lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>= + maybe (getError n) (return . tyThingId) + + lookupDataConHscEnv :: Name -> IO DataCon + lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>= + maybe (getError n) (return . tyThingDataCon) + + getError n = pprPanic "sptCreateStaticBinds.get: not found" $ + text "Couldn't find" <+> ppr n + +-- | @sptModuleInitCode module fps@ is a C stub to insert the static entries +-- of @module@ into the static pointer table. +-- +-- @fps@ is a list associating each binding corresponding to a static entry with +-- its fingerprint. +sptModuleInitCode :: Module -> [SptEntry] -> SDoc +sptModuleInitCode _ [] = Outputable.empty +sptModuleInitCode this_mod entries = vcat + [ text "static void hs_spt_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)" + , braces $ vcat $ + [ text "static StgWord64 k" <> int i <> text "[2] = " + <> pprFingerprint fp <> semi + $$ text "extern StgPtr " + <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi + $$ text "hs_spt_insert" <> parens + (hcat $ punctuate comma + [ char 'k' <> int i + , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n)) + ] + ) + <> semi + | (i, SptEntry n fp) <- zip [0..] entries + ] + , text "static void hs_spt_fini_" <> ppr this_mod + <> text "(void) __attribute__((destructor));" + , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)" + , braces $ vcat $ + [ text "StgWord64 k" <> int i <> text "[2] = " + <> pprFingerprint fp <> semi + $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi + | (i, (SptEntry _ fp)) <- zip [0..] entries + ] + ] + where + pprFingerprint :: Fingerprint -> SDoc + pprFingerprint (Fingerprint w1 w2) = + braces $ hcat $ punctuate comma + [ integer (fromIntegral w1) <> text "ULL" + , integer (fromIntegral w2) <> text "ULL" + ] diff --git a/compiler/GHC/Iface/UpdateCafInfos.hs b/compiler/GHC/Iface/UpdateCafInfos.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Iface/UpdateCafInfos.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-} + +module GHC.Iface.UpdateCafInfos + ( updateModDetailsCafInfos + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Driver.Session +import GHC.Driver.Types +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.InstEnv +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Utils.Misc +import GHC.Types.Var +import GHC.Utils.Outputable + +#include "HsVersions.h" + +-- | Update CafInfos of all occurences (in rules, unfoldings, class instances) +updateModDetailsCafInfos + :: DynFlags + -> NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY. + -> ModDetails -- ^ ModDetails to update + -> ModDetails + +updateModDetailsCafInfos dflags _ mod_details + | gopt Opt_OmitInterfacePragmas dflags + = mod_details + +updateModDetailsCafInfos _ non_cafs mod_details = + {- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -} + let + ModDetails{ md_types = type_env -- for unfoldings + , md_insts = insts + , md_rules = rules + } = mod_details + + -- type TypeEnv = NameEnv TyThing + ~type_env' = mapNameEnv (updateTyThingCafInfos type_env' non_cafs) type_env + -- Not strict! + + !insts' = strictMap (updateInstCafInfos type_env' non_cafs) insts + !rules' = strictMap (updateRuleCafInfos type_env') rules + in + mod_details{ md_types = type_env' + , md_insts = insts' + , md_rules = rules' + } + +-------------------------------------------------------------------------------- +-- Rules +-------------------------------------------------------------------------------- + +updateRuleCafInfos :: TypeEnv -> CoreRule -> CoreRule +updateRuleCafInfos _ rule@BuiltinRule{} = rule +updateRuleCafInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. } + +-------------------------------------------------------------------------------- +-- Instances +-------------------------------------------------------------------------------- + +updateInstCafInfos :: TypeEnv -> NameSet -> ClsInst -> ClsInst +updateInstCafInfos type_env non_cafs = + updateClsInstDFun (updateIdUnfolding type_env . updateIdCafInfo non_cafs) + +-------------------------------------------------------------------------------- +-- TyThings +-------------------------------------------------------------------------------- + +updateTyThingCafInfos :: TypeEnv -> NameSet -> TyThing -> TyThing + +updateTyThingCafInfos type_env non_cafs (AnId id) = + AnId (updateIdUnfolding type_env (updateIdCafInfo non_cafs id)) + +updateTyThingCafInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom + +-------------------------------------------------------------------------------- +-- Unfoldings +-------------------------------------------------------------------------------- + +updateIdUnfolding :: TypeEnv -> Id -> Id +updateIdUnfolding type_env id = + case idUnfolding id of + CoreUnfolding{ .. } -> + setIdUnfolding id CoreUnfolding{ uf_tmpl = updateGlobalIds type_env uf_tmpl, .. } + DFunUnfolding{ .. } -> + setIdUnfolding id DFunUnfolding{ df_args = map (updateGlobalIds type_env) df_args, .. } + _ -> id + +-------------------------------------------------------------------------------- +-- Expressions +-------------------------------------------------------------------------------- + +updateIdCafInfo :: NameSet -> Id -> Id +updateIdCafInfo non_cafs id + | idName id `elemNameSet` non_cafs + = -- pprTrace "updateIdCafInfo" (text "Marking" <+> ppr id <+> parens (ppr (idName id)) <+> text "as non-CAFFY") $ + id `setIdCafInfo` NoCafRefs + | otherwise + = id + +-------------------------------------------------------------------------------- + +updateGlobalIds :: NameEnv TyThing -> CoreExpr -> CoreExpr +-- Update occurrences of GlobalIds as directed by 'env' +-- The 'env' maps a GlobalId to a version with accurate CAF info +-- (and in due course perhaps other back-end-related info) +updateGlobalIds env e = go env e + where + go_id :: NameEnv TyThing -> Id -> Id + go_id env var = + case lookupNameEnv env (varName var) of + Nothing -> var + Just (AnId id) -> id + Just other -> pprPanic "GHC.Iface.UpdateCafInfos.updateGlobalIds" $ + text "Found a non-Id for Id Name" <+> ppr (varName var) $$ + nest 4 (text "Id:" <+> ppr var $$ + text "TyThing:" <+> ppr other) + + go :: NameEnv TyThing -> CoreExpr -> CoreExpr + go env (Var v) = Var (go_id env v) + go _ e@Lit{} = e + go env (App e1 e2) = App (go env e1) (go env e2) + go env (Lam b e) = assertNotInNameEnv env [b] (Lam b (go env e)) + go env (Let bs e) = Let (go_binds env bs) (go env e) + go env (Case e b ty alts) = + assertNotInNameEnv env [b] (Case (go env e) b ty (map go_alt alts)) + where + go_alt (k,bs,e) = assertNotInNameEnv env bs (k, bs, go env e) + go env (Cast e c) = Cast (go env e) c + go env (Tick t e) = Tick t (go env e) + go _ e@Type{} = e + go _ e@Coercion{} = e + + go_binds :: NameEnv TyThing -> CoreBind -> CoreBind + go_binds env (NonRec b e) = + assertNotInNameEnv env [b] (NonRec b (go env e)) + go_binds env (Rec prs) = + assertNotInNameEnv env (map fst prs) (Rec (mapSnd (go env) prs)) + +-- In `updateGlobaLIds` Names of local binders should not shadow Name of +-- globals. This assertion is to check that. +assertNotInNameEnv :: NameEnv a -> [Id] -> b -> b +assertNotInNameEnv env ids x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -24,15 +24,15 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import TcTypeNats(typeNatCoAxiomRules) +import GHC.Builtin.Types.Literals(typeNatCoAxiomRules) import GHC.Iface.Syntax import GHC.Iface.Load import GHC.Iface.Env -import BuildTyCl -import TcRnMonad -import TcType +import GHC.Tc.TyCl.Build +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Coercion.Axiom @@ -54,29 +54,28 @@ import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon -import PrelNames -import TysWiredIn +import GHC.Builtin.Names +import GHC.Builtin.Types import GHC.Types.Literal import GHC.Types.Var as Var import GHC.Types.Var.Set import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set -import GHC.Core.Op.OccurAnal ( occurAnalyseExpr ) -import GHC.Types.Demand -import GHC.Types.Module +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Unit.Module import GHC.Types.Unique.FM import GHC.Types.Unique.Supply -import Outputable -import Maybes +import GHC.Utils.Outputable +import GHC.Data.Maybe import GHC.Types.SrcLoc import GHC.Driver.Session -import Util -import FastString +import GHC.Utils.Misc +import GHC.Data.FastString import GHC.Types.Basic hiding ( SuccessFlag(..) ) -import ListSetOps +import GHC.Data.List.SetOps import GHC.Fingerprint -import qualified BooleanFormula as BF +import qualified GHC.Data.BooleanFormula as BF import Control.Monad import qualified Data.Map as Map @@ -286,7 +285,7 @@ = d1 { ifRoles = mergeRoles roles1 roles2 } | otherwise = d1 where - mergeRoles roles1 roles2 = zipWith max roles1 roles2 + mergeRoles roles1 roles2 = zipWithEqual "mergeRoles" max roles1 roles2 isRepInjectiveIfaceDecl :: IfaceDecl -> Bool isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True @@ -516,7 +515,7 @@ -- to check consistency against, rather than just when we notice -- that an hi-boot is necessary due to a circular import. { read_result <- findAndReadIface - need (fst (splitModuleInsts mod)) mod + need (fst (getModuleInstantiation mod)) mod True -- Hi-boot file ; case read_result of { @@ -1506,14 +1505,12 @@ | otherwise = InlineRhs ; return $ case mb_expr of Nothing -> NoUnfolding - Just expr -> mkUnfolding dflags unf_src - True {- Top level -} - (isBottomingSig strict_sig) - expr + Just expr -> mkFinalUnfolding dflags unf_src strict_sig expr } where -- Strictness should occur before unfolding! strict_sig = strictnessInfo info + tcUnfolding toplvl name _ _ (IfCompulsory if_expr) = do { mb_expr <- tcPragExpr True toplvl name if_expr ; return (case mb_expr of diff --git a/compiler/GHC/IfaceToCore.hs-boot b/compiler/GHC/IfaceToCore.hs-boot --- a/compiler/GHC/IfaceToCore.hs-boot +++ b/compiler/GHC/IfaceToCore.hs-boot @@ -1,10 +1,10 @@ module GHC.IfaceToCore where -import GhcPrelude +import GHC.Prelude import GHC.Iface.Syntax ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule , IfaceAnnotation, IfaceCompleteMatch ) import GHC.Core.TyCo.Rep ( TyThing ) -import TcRnTypes ( IfL ) +import GHC.Tc.Types ( IfL ) import GHC.Core.InstEnv ( ClsInst ) import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core ( CoreRule ) 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 @@ -2,10 +2,10 @@ module GHC.Llvm.MetaData where -import GhcPrelude +import GHC.Prelude import GHC.Llvm.Types -import Outputable +import GHC.Utils.Outputable -- The LLVM Metadata System. -- 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 @@ -25,7 +25,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Llvm.Syntax import GHC.Llvm.MetaData @@ -33,9 +33,9 @@ import GHC.Platform import Data.List ( intersperse ) -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique -import FastString ( sLit ) +import GHC.Data.FastString ( sLit ) -------------------------------------------------------------------------------- -- * Top Level Print functions 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 @@ -4,7 +4,7 @@ module GHC.Llvm.Syntax where -import GhcPrelude +import GHC.Prelude import GHC.Llvm.MetaData import GHC.Llvm.Types 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 @@ -9,7 +9,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import Data.Char import Data.Int @@ -17,8 +17,8 @@ import GHC.Platform import GHC.Driver.Session -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Types.Unique -- from NCG @@ -225,26 +225,26 @@ -- | Print a literal value. No type. ppLit :: LlvmLit -> SDoc -ppLit (LMIntLit i (LMInt 32)) = ppr (fromInteger i :: Int32) -ppLit (LMIntLit i (LMInt 64)) = ppr (fromInteger i :: Int64) -ppLit (LMIntLit i _ ) = ppr ((fromInteger i)::Int) -ppLit (LMFloatLit r LMFloat ) = ppFloat $ narrowFp r -ppLit (LMFloatLit r LMDouble) = ppDouble r -ppLit f@(LMFloatLit _ _) = pprPanic "ppLit" (text "Can't print this float literal: " <> ppr f) -ppLit (LMVectorLit ls ) = char '<' <+> ppCommaJoin ls <+> char '>' -ppLit (LMNullLit _ ) = text "null" --- #11487 was an issue where we passed undef for some arguments --- that were actually live. By chance the registers holding those --- arguments usually happened to have the right values anyways, but --- that was not guaranteed. To find such bugs reliably, we set the --- flag below when validating, which replaces undef literals (at --- common types) with values that are likely to cause a crash or test --- failure. -ppLit (LMUndefLit t ) = sdocWithDynFlags f - where f dflags - | gopt Opt_LlvmFillUndefWithGarbage dflags, - Just lit <- garbageLit t = ppLit lit - | otherwise = text "undef" +ppLit l = sdocWithDynFlags $ \dflags -> 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) + (LMFloatLit r LMFloat ) -> ppFloat (targetPlatform dflags) $ narrowFp r + (LMFloatLit r LMDouble) -> ppDouble (targetPlatform dflags) r + f@(LMFloatLit _ _) -> pprPanic "ppLit" (text "Can't print this float literal: " <> ppr f) + (LMVectorLit ls ) -> char '<' <+> ppCommaJoin 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 + -- arguments usually happened to have the right values anyways, but + -- that was not guaranteed. To find such bugs reliably, we set the + -- flag below when validating, which replaces undef literals (at + -- common types) with values that are likely to cause a crash or test + -- failure. + (LMUndefLit t ) + | gopt Opt_LlvmFillUndefWithGarbage dflags + , Just lit <- garbageLit t -> ppLit lit + | otherwise -> text "undef" garbageLit :: LlvmType -> Maybe LlvmLit garbageLit t@(LMInt w) = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t) @@ -836,19 +836,20 @@ -- regardless of underlying architecture. -- -- See Note [LLVM Float Types]. -ppDouble :: Double -> SDoc -ppDouble d +ppDouble :: Platform -> Double -> SDoc +ppDouble platform d = let bs = doubleToBytes d hex d' = case showHex d' "" of - [] -> error "dToStr: too few hex digits for float" - [x] -> ['0',x] - [x,y] -> [x,y] - _ -> error "dToStr: too many hex digits for float" + [] -> error "ppDouble: too few hex digits for float" + [x] -> ['0',x] + [x,y] -> [x,y] + _ -> error "ppDouble: too many hex digits for float" - in sdocWithDynFlags (\dflags -> - let fixEndian = if wORDS_BIGENDIAN dflags then id else reverse - str = map toUpper $ concat $ fixEndian $ map hex bs - in text "0x" <> text str) + fixEndian = case platformByteOrder platform of + BigEndian -> id + LittleEndian -> reverse + str = map toUpper $ concat $ fixEndian $ map hex bs + in text "0x" <> text str -- Note [LLVM Float Types] -- ~~~~~~~~~~~~~~~~~~~~~~~ @@ -875,8 +876,8 @@ {-# NOINLINE widenFp #-} widenFp = float2Double -ppFloat :: Float -> SDoc -ppFloat = ppDouble . widenFp +ppFloat :: Platform -> Float -> SDoc +ppFloat platform = ppDouble platform . widenFp -------------------------------------------------------------------------------- diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs --- a/compiler/GHC/Plugins.hs +++ b/compiler/GHC/Plugins.hs @@ -6,7 +6,7 @@ -- with saying "import GHC.Plugins". -- -- Particularly interesting modules for plugin writers include --- "GHC.Core" and "GHC.Core.Op.Monad". +-- "GHC.Core" and "GHC.Core.Opt.Monad". module GHC.Plugins ( module GHC.Driver.Plugins , module GHC.Types.Name.Reader @@ -15,7 +15,7 @@ , module GHC.Types.Var , module GHC.Types.Id , module GHC.Types.Id.Info - , module GHC.Core.Op.Monad + , module GHC.Core.Opt.Monad , module GHC.Core , module GHC.Types.Literal , module GHC.Core.DataCon @@ -26,12 +26,12 @@ , module GHC.Core.Rules , module GHC.Types.Annotations , module GHC.Driver.Session - , module GHC.Driver.Packages - , module GHC.Types.Module + , module GHC.Unit.State + , module GHC.Unit.Module , module GHC.Core.Type , module GHC.Core.TyCon , module GHC.Core.Coercion - , module TysWiredIn + , module GHC.Builtin.Types , module GHC.Driver.Types , module GHC.Types.Basic , module GHC.Types.Var.Set @@ -41,13 +41,13 @@ , module GHC.Types.Unique , module GHC.Types.Unique.Set , module GHC.Types.Unique.FM - , module FiniteMap - , module Util + , module GHC.Data.FiniteMap + , module GHC.Utils.Misc , module GHC.Serialized , module GHC.Types.SrcLoc - , module Outputable + , module GHC.Utils.Outputable , module GHC.Types.Unique.Supply - , module FastString + , module GHC.Data.FastString , -- * Getting 'Name's thNameToGhcName ) @@ -65,7 +65,7 @@ import GHC.Types.Id.Info -- Core -import GHC.Core.Op.Monad +import GHC.Core.Opt.Monad import GHC.Core import GHC.Types.Literal import GHC.Core.DataCon @@ -81,16 +81,16 @@ -- Pipeline-related stuff import GHC.Driver.Session -import GHC.Driver.Packages +import GHC.Unit.State -- Important GHC types -import GHC.Types.Module +import GHC.Unit.Module import GHC.Core.Type hiding {- conflict with GHC.Core.Subst -} ( substTy, extendTvSubst, extendTvSubstList, isInScope ) import GHC.Core.Coercion hiding {- conflict with GHC.Core.Subst -} ( substCo ) import GHC.Core.TyCon -import TysWiredIn +import GHC.Builtin.Types import GHC.Driver.Types import GHC.Types.Basic hiding ( Version {- conflicts with Packages.Version -} ) @@ -103,28 +103,28 @@ import GHC.Types.Unique.FM -- Conflicts with UniqFM: --import LazyUniqFM -import FiniteMap +import GHC.Data.FiniteMap -- Common utilities -import Util +import GHC.Utils.Misc import GHC.Serialized import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique.Supply import GHC.Types.Unique ( Unique, Uniquable(..) ) -import FastString +import GHC.Data.FastString import Data.Maybe import GHC.Iface.Env ( lookupOrigIO ) -import GhcPrelude -import MonadUtils ( mapMaybeM ) +import GHC.Prelude +import GHC.Utils.Monad ( mapMaybeM ) import GHC.ThToHs ( thRdrNameGuesses ) -import TcEnv ( lookupGlobal ) +import GHC.Tc.Utils.Env ( lookupGlobal ) import qualified Language.Haskell.TH as TH -{- This instance is defined outside GHC.Core.Op.Monad.hs so that - GHC.Core.Op.Monad does not depend on TcEnv -} +{- This instance is defined outside GHC.Core.Opt.Monad.hs so that + GHC.Core.Opt.Monad does not depend on GHC.Tc.Utils.Env -} instance MonadThings CoreM where lookupThing name = do { hsc_env <- getHscEnv ; liftIO $ lookupGlobal hsc_env name } diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Rename/Bind.hs @@ -0,0 +1,1322 @@ +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Renaming and dependency analysis of bindings + +This module does renaming and dependency analysis on value bindings in +the abstract syntax. It does {\em not} do cycle-checks on class or +type-synonym declarations; those cannot be done at this stage because +they may be affected by renaming (which isn't fully worked out yet). +-} + +module GHC.Rename.Bind ( + -- Renaming top-level bindings + rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS, + + -- Renaming local bindings + rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, + + -- Other bindings + rnMethodBinds, renameSigs, + rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl, + makeMiniFixityEnv, MiniFixityEnv, + HsSigCtxt(..) + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr, rnStmts ) + +import GHC.Hs +import GHC.Tc.Utils.Monad +import GHC.Rename.HsType +import GHC.Rename.Pat +import GHC.Rename.Names +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn + , checkDupRdrNames, warnUnusedLocalBinds + , checkUnusedRecordWildcard + , checkDupAndShadowedNames, bindLocalNamesFV ) +import GHC.Driver.Session +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Reader ( RdrName, rdrNameOcc ) +import GHC.Types.SrcLoc as SrcLoc +import GHC.Data.List.SetOps ( findDupsEq ) +import GHC.Types.Basic ( RecFlag(..), TypeOrKind(..) ) +import GHC.Data.Graph.Directed ( SCC(..) ) +import GHC.Data.Bag +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Types.Unique.Set +import GHC.Data.Maybe ( orElse ) +import GHC.Data.OrdList +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.Foldable ( toList ) +import Data.List ( partition, sortBy ) +import Data.List.NonEmpty ( NonEmpty(..) ) + +{- +-- ToDo: Put the annotations into the monad, so that they arrive in the proper +-- place and can be used when complaining. + +The code tree received by the function @rnBinds@ contains definitions +in where-clauses which are all apparently mutually recursive, but which may +not really depend upon each other. For example, in the top level program +\begin{verbatim} +f x = y where a = x + y = x +\end{verbatim} +the definitions of @a@ and @y@ do not depend on each other at all. +Unfortunately, the typechecker cannot always check such definitions. +\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive +definitions. In Proceedings of the International Symposium on Programming, +Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} +However, the typechecker usually can check definitions in which only the +strongly connected components have been collected into recursive bindings. +This is precisely what the function @rnBinds@ does. + +ToDo: deal with case where a single monobinds binds the same variable +twice. + +The vertag tag is a unique @Int@; the tags only need to be unique +within one @MonoBinds@, so that unique-Int plumbing is done explicitly +(heavy monad machinery not needed). + + +************************************************************************ +* * +* naming conventions * +* * +************************************************************************ + +\subsection[name-conventions]{Name conventions} + +The basic algorithm involves walking over the tree and returning a tuple +containing the new tree plus its free variables. Some functions, such +as those walking polymorphic bindings (HsBinds) and qualifier lists in +list comprehensions (@Quals@), return the variables bound in local +environments. These are then used to calculate the free variables of the +expression evaluated in these environments. + +Conventions for variable names are as follows: +\begin{itemize} +\item +new code is given a prime to distinguish it from the old. + +\item +a set of variables defined in @Exp@ is written @dvExp@ + +\item +a set of variables free in @Exp@ is written @fvExp@ +\end{itemize} + +************************************************************************ +* * +* analysing polymorphic bindings (HsBindGroup, HsBind) +* * +************************************************************************ + +\subsubsection[dep-HsBinds]{Polymorphic bindings} + +Non-recursive expressions are reconstructed without any changes at top +level, although their component expressions may have to be altered. +However, non-recursive expressions are currently not expected as +\Haskell{} programs, and this code should not be executed. + +Monomorphic bindings contain information that is returned in a tuple +(a @FlatMonoBinds@) containing: + +\begin{enumerate} +\item +a unique @Int@ that serves as the ``vertex tag'' for this binding. + +\item +the name of a function or the names in a pattern. These are a set +referred to as @dvLhs@, the defined variables of the left hand side. + +\item +the free variables of the body. These are referred to as @fvBody@. + +\item +the definition's actual code. This is referred to as just @code@. +\end{enumerate} + +The function @nonRecDvFv@ returns two sets of variables. The first is +the set of variables defined in the set of monomorphic bindings, while the +second is the set of free variables in those bindings. + +The set of variables defined in a non-recursive binding is just the +union of all of them, as @union@ removes duplicates. However, the +free variables in each successive set of cumulative bindings is the +union of those in the previous set plus those of the newest binding after +the defined variables of the previous set have been removed. + +@rnMethodBinds@ deals only with the declarations in class and +instance declarations. It expects only to see @FunMonoBind@s, and +it expects the global environment to contain bindings for the binders +(which are all class operations). + +************************************************************************ +* * +\subsubsection{ Top-level bindings} +* * +************************************************************************ +-} + +-- for top-level bindings, we need to make top-level names, +-- so we have a different entry point than for local bindings +rnTopBindsLHS :: MiniFixityEnv + -> HsValBinds GhcPs + -> RnM (HsValBindsLR GhcRn GhcPs) +rnTopBindsLHS fix_env binds + = rnValBindsLHS (topRecNameMaker fix_env) binds + +rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) +-- A hs-boot file has no bindings. +-- Return a single HsBindGroup with empty binds and renamed signatures +rnTopBindsBoot bound_names (ValBinds _ mbinds sigs) + = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) + ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs + ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) } +rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) + +{- +********************************************************* +* * + HsLocalBinds +* * +********************************************************* +-} + +rnLocalBindsAndThen :: HsLocalBinds GhcPs + -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +-- This version (a) assumes that the binding vars are *not* already in scope +-- (b) removes the binders from the free vars of the thing inside +-- The parser doesn't produce ThenBinds +rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside = + thing_inside (EmptyLocalBinds x) emptyNameSet + +rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside + = rnLocalValBindsAndThen val_binds $ \ val_binds' -> + thing_inside (HsValBinds x val_binds') + +rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do + (binds',fv_binds) <- rnIPBinds binds + (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds + return (thing, fvs_thing `plusFV` fv_binds) + +rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars) +rnIPBinds (IPBinds _ ip_binds ) = do + (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds + return (IPBinds noExtField ip_binds', plusFVs fvs_s) + +rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) +rnIPBind (IPBind _ ~(Left n) expr) = do + (expr',fvExpr) <- rnLExpr expr + return (IPBind noExtField (Left n) expr', fvExpr) + +{- +************************************************************************ +* * + ValBinds +* * +************************************************************************ +-} + +-- Renaming local binding groups +-- Does duplicate/shadow check +rnLocalValBindsLHS :: MiniFixityEnv + -> HsValBinds GhcPs + -> RnM ([Name], HsValBindsLR GhcRn GhcPs) +rnLocalValBindsLHS fix_env binds + = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds + + -- Check for duplicates and shadowing + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in GHC.Hs.Utils + + -- We need to check for dups here because we + -- don't don't bind all of the variables from the ValBinds at once + -- with bindLocatedLocals any more. + -- + -- Note that we don't want to do this at the top level, since + -- sorting out duplicates and shadowing there happens elsewhere. + -- The behavior is even different. For example, + -- import A(f) + -- f = ... + -- should not produce a shadowing warning (but it will produce + -- an ambiguity warning if you use f), but + -- import A(f) + -- g = let f = ... in f + -- should. + ; let bound_names = collectHsValBinders binds' + -- There should be only Ids, but if there are any bogus + -- pattern synonyms, we'll collect them anyway, so that + -- we don't generate subsequent out-of-scope messages + ; envs <- getRdrEnvs + ; checkDupAndShadowedNames envs bound_names + + ; return (bound_names, binds') } + +-- renames the left-hand sides +-- generic version used both at the top level and for local binds +-- does some error checking, but not what gets done elsewhere at the top level +rnValBindsLHS :: NameMaker + -> HsValBinds GhcPs + -> RnM (HsValBindsLR GhcRn GhcPs) +rnValBindsLHS topP (ValBinds x mbinds sigs) + = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds + ; return $ ValBinds x mbinds' sigs } + where + bndrs = collectHsBindsBinders mbinds + doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs + +rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) + +-- General version used both from the top-level and for local things +-- Assumes the LHS vars are in scope +-- +-- Does not bind the local fixity declarations +rnValBindsRHS :: HsSigCtxt + -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) + +rnValBindsRHS ctxt (ValBinds _ mbinds sigs) + = do { (sigs', sig_fvs) <- renameSigs ctxt sigs + ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds + ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus + + ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $ + getPatSynBinds anal_binds + -- The uses in binds_w_dus for PatSynBinds do not include + -- variables used in the patsyn builders; see + -- Note [Pattern synonym builders don't yield dependencies] + -- But psb_fvs /does/ include those builder fvs. So we + -- add them back in here to avoid bogus warnings about + -- unused variables (#12548) + + valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs + `plusDU` usesOnly patsyn_fvs + -- Put the sig uses *after* the bindings + -- so that the binders are removed from + -- the uses in the sigs + + ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) } + +rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) + +-- Wrapper for local binds +-- +-- The *client* of this function is responsible for checking for unused binders; +-- it doesn't (and can't: we don't have the thing inside the binds) happen here +-- +-- The client is also responsible for bringing the fixities into scope +rnLocalValBindsRHS :: NameSet -- names bound by the LHSes + -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) +rnLocalValBindsRHS bound_names binds + = rnValBindsRHS (LocalBindCtxt bound_names) binds + +-- for local binds +-- wrapper that does both the left- and right-hand sides +-- +-- here there are no local fixity decls passed in; +-- the local fixity decls come from the ValBinds sigs +rnLocalValBindsAndThen + :: HsValBinds GhcPs + -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside + = do { -- (A) Create the local fixity environment + new_fixities <- makeMiniFixityEnv [ L loc sig + | L loc (FixSig _ sig) <- sigs] + + -- (B) Rename the LHSes + ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds + + -- ...and bring them (and their fixities) into scope + ; bindLocalNamesFV bound_names $ + addLocalFixities new_fixities bound_names $ do + + { -- (C) Do the RHS and thing inside + (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs + ; (result, result_fvs) <- thing_inside binds' (allUses dus) + + -- Report unused bindings based on the (accurate) + -- findUses. E.g. + -- let x = x in 3 + -- should report 'x' unused + ; let real_uses = findUses dus result_fvs + -- Insert fake uses for variables introduced implicitly by + -- wildcards (#4404) + rec_uses = hsValBindsImplicits binds' + implicit_uses = mkNameSet $ concatMap snd + $ rec_uses + ; mapM_ (\(loc, ns) -> + checkUnusedRecordWildcard loc real_uses (Just ns)) + rec_uses + ; warnUnusedLocalBinds bound_names + (real_uses `unionNameSet` implicit_uses) + + ; let + -- The variables "used" in the val binds are: + -- (1) the uses of the binds (allUses) + -- (2) the FVs of the thing-inside + all_uses = allUses dus `plusFV` result_fvs + -- Note [Unused binding hack] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Note that *in contrast* to the above reporting of + -- unused bindings, (1) above uses duUses to return *all* + -- the uses, even if the binding is unused. Otherwise consider: + -- x = 3 + -- y = let p = x in 'x' -- NB: p not used + -- If we don't "see" the dependency of 'y' on 'x', we may put the + -- bindings in the wrong order, and the type checker will complain + -- that x isn't in scope + -- + -- But note that this means we won't report 'x' as unused, + -- whereas we would if we had { x = 3; p = x; y = 'x' } + + ; return (result, all_uses) }} + -- The bound names are pruned out of all_uses + -- by the bindLocalNamesFV call above + +rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) + + +--------------------- + +-- renaming a single bind + +rnBindLHS :: NameMaker + -> SDoc + -> HsBind GhcPs + -- returns the renamed left-hand side, + -- and the FreeVars *of the LHS* + -- (i.e., any free variables of the pattern) + -> RnM (HsBindLR GhcRn GhcPs) + +rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat }) + = do + -- we don't actually use the FV processing of rnPatsAndThen here + (pat',pat'_fvs) <- rnBindPat name_maker pat + return (bind { pat_lhs = pat', pat_ext = pat'_fvs }) + -- We temporarily store the pat's FVs in bind_fvs; + -- gets updated to the FVs of the whole bind + -- when doing the RHS below + +rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name }) + = do { name <- applyNameMaker name_maker rdr_name + ; return (bind { fun_id = name + , fun_ext = noExtField }) } + +rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname }) + | isTopRecNameMaker name_maker + = do { addLocM checkConName rdrname + ; name <- lookupLocatedTopBndrRn rdrname -- Should be in scope already + ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) } + + | otherwise -- Pattern synonym, not at top level + = do { addErr localPatternSynonymErr -- Complain, but make up a fake + -- name so that we can carry on + ; name <- applyNameMaker name_maker rdrname + ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) } + where + localPatternSynonymErr :: SDoc + localPatternSynonymErr + = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) + 2 (text "Pattern synonym declarations are only valid at top level") + +rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) + +rnLBind :: (Name -> [Name]) -- Signature tyvar function + -> LHsBindLR GhcRn GhcPs + -> RnM (LHsBind GhcRn, [Name], Uses) +rnLBind sig_fn (L loc bind) + = setSrcSpan loc $ + do { (bind', bndrs, dus) <- rnBind sig_fn bind + ; return (L loc bind', bndrs, dus) } + +-- assumes the left-hands-side vars are in scope +rnBind :: (Name -> [Name]) -- Signature tyvar function + -> HsBindLR GhcRn GhcPs + -> RnM (HsBind GhcRn, [Name], Uses) +rnBind _ bind@(PatBind { pat_lhs = pat + , pat_rhs = grhss + -- pat fvs were stored in bind_fvs + -- after processing the LHS + , pat_ext = pat_fvs }) + = do { mod <- getModule + ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss + + -- No scoped type variables for pattern bindings + ; let all_fvs = pat_fvs `plusFV` rhs_fvs + fvs' = filterNameSet (nameIsLocalOrFrom mod) all_fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan + bndrs = collectPatBinders pat + bind' = bind { pat_rhs = grhss' + , pat_ext = fvs' } + + ok_nobind_pat + = -- See Note [Pattern bindings that bind no variables] + case unLoc pat of + WildPat {} -> True + BangPat {} -> True -- #9127, #13646 + SplicePat {} -> True + _ -> False + + -- Warn if the pattern binds no variables + -- See Note [Pattern bindings that bind no variables] + ; whenWOptM Opt_WarnUnusedPatternBinds $ + when (null bndrs && not ok_nobind_pat) $ + addWarn (Reason Opt_WarnUnusedPatternBinds) $ + unusedPatBindWarn bind' + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind', bndrs, all_fvs) } + +rnBind sig_fn bind@(FunBind { fun_id = name + , fun_matches = matches }) + -- invariant: no free vars here when it's a FunBind + = do { let plain_name = unLoc name + + ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ + -- bindSigTyVars tests for LangExt.ScopedTyVars + rnMatchGroup (mkPrefixFunRhs name) + rnLExpr matches + ; let is_infix = isInfixFunBind bind + ; when is_infix $ checkPrecMatch plain_name matches' + + ; mod <- getModule + ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind { fun_matches = matches' + , fun_ext = fvs' }, + [plain_name], rhs_fvs) + } + +rnBind sig_fn (PatSynBind x bind) + = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind + ; return (PatSynBind x bind', name, fvs) } + +rnBind _ b = pprPanic "rnBind" (ppr b) + +{- Note [Pattern bindings that bind no variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally, we want to warn about pattern bindings like + Just _ = e +because they don't do anything! But we have three exceptions: + +* A wildcard pattern + _ = rhs + which (a) is not that different from _v = rhs + (b) is sometimes used to give a type sig for, + or an occurrence of, a variable on the RHS + +* A strict pattern binding; that is, one with an outermost bang + !Just _ = e + This can fail, so unlike the lazy variant, it is not a no-op. + Moreover, #13646 argues that even for single constructor + types, you might want to write the constructor. See also #9127. + +* A splice pattern + $(th-lhs) = rhs + It is impossible to determine whether or not th-lhs really + binds any variable. We should disable the warning for any pattern + which contain splices, but that is a more expensive check. + +Note [Free-variable space leak] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have + fvs' = trim fvs +and we seq fvs' before turning it as part of a record. + +The reason is that trim is sometimes something like + \xs -> intersectNameSet (mkNameSet bound_names) xs +and we don't want to retain the list bound_names. This showed up in +trac ticket #1136. +-} + +{- ********************************************************************* +* * + Dependency analysis and other support functions +* * +********************************************************************* -} + +depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses) + -> ([(RecFlag, LHsBinds GhcRn)], DefUses) +-- Dependency analysis; this is important so that +-- unused-binding reporting is accurate +depAnalBinds binds_w_dus + = (map get_binds sccs, toOL $ map get_du sccs) + where + sccs = depAnal (\(_, defs, _) -> defs) + (\(_, _, uses) -> nonDetEltsUniqSet uses) + -- It's OK to use nonDetEltsUniqSet here as explained in + -- Note [depAnal determinism] in GHC.Types.Name.Env. + (bagToList binds_w_dus) + + get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind) + get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus]) + + get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses) + get_du (CyclicSCC binds_w_dus) = (Just defs, uses) + where + defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs] + uses = unionNameSets [u | (_,_,u) <- binds_w_dus] + +--------------------- +-- Bind the top-level forall'd type variables in the sigs. +-- E.g f :: forall a. a -> a +-- f = rhs +-- The 'a' scopes over the rhs +-- +-- NB: there'll usually be just one (for a function binding) +-- but if there are many, one may shadow the rest; too bad! +-- e.g x :: forall a. [a] -> [a] +-- y :: forall a. [(a,a)] -> a +-- (x,y) = e +-- In e, 'a' will be in scope, and it'll be the one from 'y'! + +mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name]) +-- Return a lookup function that maps an Id Name to the names +-- of the type variables that should scope over its body. +mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` [] + where + env = mkHsSigEnv get_scoped_tvs sigs + + get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name]) + -- Returns (binders, scoped tvs for those binders) + get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty)) + = Just (names, hsScopedTvs sig_ty) + get_scoped_tvs (L _ (TypeSig _ names sig_ty)) + = Just (names, hsWcScopedTvs sig_ty) + get_scoped_tvs (L _ (PatSynSig _ names sig_ty)) + = Just (names, hsScopedTvs sig_ty) + get_scoped_tvs _ = Nothing + +-- Process the fixity declarations, making a FastString -> (Located Fixity) map +-- (We keep the location around for reporting duplicate fixity declarations.) +-- +-- Checks for duplicates, but not that only locally defined things are fixed. +-- Note: for local fixity declarations, duplicates would also be checked in +-- check_sigs below. But we also use this function at the top level. + +makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv + +makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls + where + add_one_sig :: MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv + add_one_sig env (L loc (FixitySig _ names fixity)) = + foldlM add_one env [ (loc,name_loc,name,fixity) + | L name_loc name <- names ] + + add_one env (loc, name_loc, name,fixity) = do + { -- this fixity decl is a duplicate iff + -- the ReaderName's OccName's FastString is already in the env + -- (we only need to check the local fix_env because + -- definitions of non-local will be caught elsewhere) + let { fs = occNameFS (rdrNameOcc name) + ; fix_item = L loc fixity }; + + case lookupFsEnv env fs of + Nothing -> return $ extendFsEnv env fs fix_item + Just (L loc' _) -> do + { setSrcSpan loc $ + addErrAt name_loc (dupFixityDecl loc' name) + ; return env} + } + +dupFixityDecl :: SrcSpan -> RdrName -> SDoc +dupFixityDecl loc rdr_name + = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), + text "also at " <+> ppr loc] + + +{- ********************************************************************* +* * + Pattern synonym bindings +* * +********************************************************************* -} + +rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function + -> PatSynBind GhcRn GhcPs + -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses) +rnPatSynBind sig_fn bind@(PSB { psb_id = L l name + , psb_args = details + , psb_def = pat + , 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) + ; let scoped_tvs = sig_fn name + + ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $ + rnPat PatSyn pat $ \pat' -> + -- We check the 'RdrName's instead of the 'Name's + -- so that the binding locations are reported + -- from the left-hand side + case details of + PrefixCon vars -> + do { checkDupRdrNames vars + ; names <- mapM lookupPatSynBndr vars + ; return ( (pat', PrefixCon names) + , mkFVs (map unLoc names)) } + InfixCon var1 var2 -> + do { checkDupRdrNames [var1, var2] + ; name1 <- lookupPatSynBndr var1 + ; name2 <- lookupPatSynBndr var2 + -- ; checkPrecMatch -- TODO + ; return ( (pat', InfixCon name1 name2) + , mkFVs (map unLoc [name1, name2])) } + RecCon vars -> + do { checkDupRdrNames (map recordPatSynSelectorId vars) + ; let rnRecordPatSynField + (RecordPatSynField { recordPatSynSelectorId = visible + , recordPatSynPatVar = hidden }) + = do { visible' <- lookupLocatedTopBndrRn visible + ; hidden' <- lookupPatSynBndr hidden + ; return $ RecordPatSynField { recordPatSynSelectorId = visible' + , recordPatSynPatVar = hidden' } } + ; names <- mapM rnRecordPatSynField vars + ; return ( (pat', RecCon names) + , mkFVs (map (unLoc . recordPatSynPatVar) names)) } + + ; (dir', fvs2) <- case dir of + Unidirectional -> return (Unidirectional, emptyFVs) + ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs) + ExplicitBidirectional mg -> + do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $ + rnMatchGroup (mkPrefixFunRhs (L l name)) + rnLExpr mg + ; return (ExplicitBidirectional mg', fvs) } + + ; mod <- getModule + ; let fvs = fvs1 `plusFV` fvs2 + fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan + + bind' = bind{ psb_args = details' + , psb_def = pat' + , psb_dir = dir' + , psb_ext = fvs' } + selector_names = case details' of + RecCon names -> + map (unLoc . recordPatSynSelectorId) names + _ -> [] + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind', name : selector_names , fvs1) + -- Why fvs1? See Note [Pattern synonym builders don't yield dependencies] + } + where + -- See Note [Renaming pattern synonym variables] + lookupPatSynBndr = wrapLocM lookupLocalOccRn + + patternSynonymErr :: SDoc + patternSynonymErr + = hang (text "Illegal pattern synonym declaration") + 2 (text "Use -XPatternSynonyms to enable this extension") + +{- +Note [Renaming pattern synonym variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We rename pattern synonym declaractions backwards to normal to reuse +the logic already implemented for renaming patterns. + +We first rename the RHS of a declaration which brings into +scope the variables bound by the pattern (as they would be +in normal function definitions). We then lookup the variables +which we want to bind in this local environment. + +It is crucial that we then only lookup in the *local* environment which +only contains the variables brought into scope by the pattern and nothing +else. Amazingly no-one encountered this bug for 3 GHC versions but +it was possible to define a pattern synonym which referenced global +identifiers and worked correctly. + +``` +x = 5 + +pattern P :: Int -> () +pattern P x <- _ + +f (P x) = x + +> f () = 5 +``` + +See #13470 for the original report. + +Note [Pattern synonym builders don't yield dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When renaming a pattern synonym that has an explicit builder, +references in the builder definition should not be used when +calculating dependencies. For example, consider the following pattern +synonym definition: + +pattern P x <- C1 x where + P x = f (C1 x) + +f (P x) = C2 x + +In this case, 'P' needs to be typechecked in two passes: + +1. Typecheck the pattern definition of 'P', which fully determines the + type of 'P'. This step doesn't require knowing anything about 'f', + since the builder definition is not looked at. + +2. Typecheck the builder definition, which needs the typechecked + definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind + in GHC.Tc.Gen.Bind.tcValBinds. + +This behaviour is implemented in 'tcValBinds', but it crucially +depends on 'P' not being put in a recursive group with 'f' (which +would make it look like a recursive pattern synonym a la 'pattern P = +P' which is unsound and rejected). + +So: + * We do not include builder fvs in the Uses returned by rnPatSynBind + (which is then used for dependency analysis) + * But we /do/ include them in the psb_fvs for the PatSynBind + * In rnValBinds we record these builder uses, to avoid bogus + unused-variable warnings (#12548) +-} + +{- ********************************************************************* +* * + Class/instance method bindings +* * +********************************************************************* -} + +{- @rnMethodBinds@ is used for the method bindings of a class and an instance +declaration. Like @rnBinds@ but without dependency analysis. + +NOTA BENE: we record each {\em binder} of a method-bind group as a free variable. +That's crucial when dealing with an instance decl: +\begin{verbatim} + instance Foo (T a) where + op x = ... +\end{verbatim} +This might be the {\em sole} occurrence of @op@ for an imported class @Foo@, +and unless @op@ occurs we won't treat the type signature of @op@ in the class +decl for @Foo@ as a source of instance-decl gates. But we should! Indeed, +in many ways the @op@ in an instance decl is just like an occurrence, not +a binder. +-} + +rnMethodBinds :: Bool -- True <=> is a class declaration + -> Name -- Class name + -> [Name] -- Type variables from the class/instance header + -> LHsBinds GhcPs -- Binds + -> [LSig GhcPs] -- and signatures/pragmas + -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars) +-- Used for +-- * 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 { checkDupRdrNames (collectMethodBinders binds) + -- Check that the same method is not given twice in the + -- same instance decl instance C T where + -- f x = ... + -- g y = ... + -- f x = ... + -- We must use checkDupRdrNames because the Name of the + -- method is the Name of the class selector, whose SrcSpan + -- points to the class declaration; and we use rnMethodBinds + -- for instance decls too + + -- Rename the bindings LHSs + ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) emptyBag binds + + -- Rename the pragmas and signatures + -- Annoyingly the type variables /are/ in scope for signatures, but + -- /are not/ in scope in the SPECIALISE instance pramas; e.g. + -- instance Eq a => Eq (T a) where + -- (==) :: a -> a -> a + -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} + ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs + bound_nms = mkNameSet (collectHsBindsBinders binds') + sig_ctxt | is_cls_decl = ClsDeclCtxt cls + | otherwise = InstDeclCtxt bound_nms + ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags + ; (other_sigs', sig_fvs) <- extendTyVarEnvFVRn ktv_names $ + renameSigs sig_ctxt other_sigs + + -- Rename the bindings RHSs. Again there's an issue about whether the + -- type variables from the class/instance head are in scope. + -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables + ; scoped_tvs <- xoptM LangExt.ScopedTypeVariables + ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $ + do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds' + ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2) + emptyFVs binds_w_dus + ; return (mapBag fstOf3 binds_w_dus, bind_fvs) } + + ; return ( binds'', spec_inst_prags' ++ other_sigs' + , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) } + where + -- For the method bindings in class and instance decls, we extend + -- the type variable environment iff -XScopedTypeVariables + maybe_extend_tyvar_env scoped_tvs thing_inside + | scoped_tvs = extendTyVarEnvFVRn ktv_names thing_inside + | otherwise = thing_inside + +rnMethodBindLHS :: Bool -> Name + -> LHsBindLR GhcPs GhcPs + -> LHsBindsLR GhcRn GhcPs + -> RnM (LHsBindsLR GhcRn GhcPs) +rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest + = setSrcSpan loc $ do + do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name + -- We use the selector name as the binder + ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField } + ; return (L loc bind' `consBag` rest ) } + +-- 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 loc $ + vcat [ what <+> text "not allowed in" <+> decl_sort + , nest 2 (ppr 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) + +{- +************************************************************************ +* * +\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} +* * +************************************************************************ + +@renameSigs@ checks for: +\begin{enumerate} +\item more than one sig for one thing; +\item signatures given for things not bound here; +\end{enumerate} + +At the moment we don't gather free-var info from the types in +signatures. We'd only need this if we wanted to report unused tyvars. +-} + +renameSigs :: HsSigCtxt + -> [LSig GhcPs] + -> RnM ([LSig GhcRn], FreeVars) +-- Renames the signatures and performs error checks +renameSigs ctxt sigs + = do { mapM_ dupSigDeclErr (findDupSigs sigs) + + ; checkDupMinimalSigs sigs + + ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs + + ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs' + ; mapM_ misplacedSigErr bad_sigs -- Misplaced + + ; return (good_sigs, sig_fvs) } + +---------------------- +-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory +-- because this won't work for: +-- instance Foo T where +-- {-# INLINE op #-} +-- Baz.op = ... +-- We'll just rename the INLINE prag to refer to whatever other 'op' +-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) +-- Doesn't seem worth much trouble to sort this. + +renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) +renameSig _ (IdSig _ x) + = return (IdSig noExtField x, emptyFVs) -- Actually this never occurs + +renameSig ctxt sig@(TypeSig _ vs ty) + = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + ; let doc = TypeSigCtx (ppr_sig_bndrs vs) + ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty + ; return (TypeSig noExtField new_vs new_ty, fvs) } + +renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) + = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures + ; when (is_deflt && not defaultSigs_on) $ + addErr (defaultSigErr sig) + ; new_v <- mapM (lookupSigOccRn ctxt sig) vs + ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty + ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) } + where + (v1:_) = vs + ty_ctxt = GenericCtx (text "a class method signature for" + <+> quotes (ppr v1)) + +renameSig _ (SpecInstSig _ src ty) + = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel ty + ; return (SpecInstSig noExtField src new_ty,fvs) } + +-- {-# SPECIALISE #-} pragmas can refer to imported Ids +-- so, in the top-level case (when mb_names is Nothing) +-- we use lookupOccRn. If there's both an imported and a local 'f' +-- then the SPECIALISE pragma is ambiguous, unlike all other signatures +renameSig ctxt sig@(SpecSig _ v tys inl) + = do { new_v <- case ctxt of + TopSigCtxt {} -> lookupLocatedOccRn v + _ -> lookupSigOccRn ctxt sig v + ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys + ; return (SpecSig noExtField new_v new_ty inl, fvs) } + where + ty_ctxt = GenericCtx (text "a SPECIALISE signature for" + <+> quotes (ppr v)) + do_one (tys,fvs) ty + = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty + ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } + +renameSig ctxt sig@(InlineSig _ v s) + = do { new_v <- lookupSigOccRn ctxt sig v + ; return (InlineSig noExtField new_v s, emptyFVs) } + +renameSig ctxt (FixSig _ fsig) + = do { new_fsig <- rnSrcFixityDecl ctxt fsig + ; return (FixSig noExtField new_fsig, emptyFVs) } + +renameSig ctxt sig@(MinimalSig _ s (L l bf)) + = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf + return (MinimalSig noExtField s (L l new_bf), emptyFVs) + +renameSig ctxt sig@(PatSynSig _ vs ty) + = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty + ; return (PatSynSig noExtField new_vs ty', fvs) } + where + ty_ctxt = GenericCtx (text "a pattern synonym signature for" + <+> ppr_sig_bndrs vs) + +renameSig ctxt sig@(SCCFunSig _ st v s) + = do { new_v <- lookupSigOccRn ctxt sig v + ; return (SCCFunSig noExtField st new_v s, emptyFVs) } + +-- COMPLETE Sigs can refer to imported IDs which is why we use +-- lookupLocatedOccRn rather than lookupSigOccRn +renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty) + = do new_bf <- traverse lookupLocatedOccRn bf + new_mty <- traverse lookupLocatedOccRn mty + + this_mod <- fmap tcg_mod getGblEnv + unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do + -- Why 'any'? See Note [Orphan COMPLETE pragmas] + addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError + + return (CompleteMatchSig noExtField s (L l new_bf) new_mty, emptyFVs) + where + orphanError :: SDoc + orphanError = + 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We define a COMPLETE pragma to be a non-orphan if it includes at least +one conlike defined in the current module. Why is this sufficient? +Well if you have a pattern match + + case expr of + P1 -> ... + P2 -> ... + P3 -> ... + +any COMPLETE pragma which mentions a conlike other than P1, P2 or P3 +will not be of any use in verifying that the pattern match is +exhaustive. So as we have certainly read the interface files that +define P1, P2 and P3, we will have loaded all non-orphan COMPLETE +pragmas that could be relevant to this pattern match. + +For now we simply disallow orphan COMPLETE pragmas, as the added +complexity of supporting them properly doesn't seem worthwhile. +-} + +ppr_sig_bndrs :: [Located RdrName] -> SDoc +ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) + +okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool +okHsSig ctxt (L _ sig) + = case (sig, ctxt) of + (ClassOpSig {}, ClsDeclCtxt {}) -> True + (ClassOpSig {}, InstDeclCtxt {}) -> True + (ClassOpSig {}, _) -> False + + (TypeSig {}, ClsDeclCtxt {}) -> False + (TypeSig {}, InstDeclCtxt {}) -> False + (TypeSig {}, _) -> True + + (PatSynSig {}, TopSigCtxt{}) -> True + (PatSynSig {}, _) -> False + + (FixSig {}, InstDeclCtxt {}) -> False + (FixSig {}, _) -> True + + (IdSig {}, TopSigCtxt {}) -> True + (IdSig {}, InstDeclCtxt {}) -> True + (IdSig {}, _) -> False + + (InlineSig {}, HsBootCtxt {}) -> False + (InlineSig {}, _) -> True + + (SpecSig {}, TopSigCtxt {}) -> True + (SpecSig {}, LocalBindCtxt {}) -> True + (SpecSig {}, InstDeclCtxt {}) -> True + (SpecSig {}, _) -> False + + (SpecInstSig {}, InstDeclCtxt {}) -> True + (SpecInstSig {}, _) -> False + + (MinimalSig {}, ClsDeclCtxt {}) -> True + (MinimalSig {}, _) -> False + + (SCCFunSig {}, HsBootCtxt {}) -> False + (SCCFunSig {}, _) -> True + + (CompleteMatchSig {}, TopSigCtxt {} ) -> True + (CompleteMatchSig {}, _) -> False + +------------------- +findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)] +-- Check for duplicates on RdrName version, +-- because renamed version has unboundName for +-- not-in-scope binders, which gives bogus dup-sig errors +-- NB: in a class decl, a 'generic' sig is not considered +-- equal to an ordinary sig, so we allow, say +-- class C a where +-- op :: a -> a +-- default op :: Eq a => a -> a +findDupSigs sigs + = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) + where + expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig) + expand_sig sig@(InlineSig _ n _) = [(n,sig)] + expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns] + expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns] + expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns] + expand_sig sig@(SCCFunSig _ _ n _) = [(n,sig)] + expand_sig _ = [] + + matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 + mtch (FixSig {}) (FixSig {}) = True + mtch (InlineSig {}) (InlineSig {}) = True + mtch (TypeSig {}) (TypeSig {}) = True + mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2 + mtch (PatSynSig _ _ _) (PatSynSig _ _ _) = True + mtch (SCCFunSig{}) (SCCFunSig{}) = True + mtch _ _ = False + +-- Warn about multiple MINIMAL signatures +checkDupMinimalSigs :: [LSig GhcPs] -> RnM () +checkDupMinimalSigs sigs + = case filter isMinimalLSig sigs of + minSigs@(_:_:_) -> dupMinimalSigErr minSigs + _ -> return () + +{- +************************************************************************ +* * +\subsection{Match} +* * +************************************************************************ +-} + +rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> MatchGroup GhcPs (Located (body GhcPs)) + -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars) +rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin }) + = do { empty_case_ok <- xoptM LangExt.EmptyCase + ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) + ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms + ; return (mkMatchGroup origin new_ms, ms_fvs) } + +rnMatch :: Outputable (body GhcPs) => HsMatchContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> LMatch GhcPs (Located (body GhcPs)) + -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars) +rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) + +rnMatch' :: Outputable (body GhcPs) => HsMatchContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> Match GhcPs (Located (body GhcPs)) + -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars) +rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) + = do { -- Note that there are no local fixity decls for matches + ; rnPats ctxt pats $ \ pats' -> do + { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss + ; let mf' = case (ctxt, mf) of + (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ }) + -> mf { mc_fun = L lf funid } + _ -> ctxt + ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = pats' + , m_grhss = grhss'}, grhss_fvs ) }} + +emptyCaseErr :: HsMatchContext GhcRn -> SDoc +emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) + 2 (text "Use EmptyCase to allow this") + where + pp_ctxt = case ctxt of + CaseAlt -> text "case expression" + LambdaExpr -> text "\\case expression" + _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt + +{- +************************************************************************ +* * +\subsubsection{Guarded right-hand sides (GRHSs)} +* * +************************************************************************ +-} + +rnGRHSs :: HsMatchContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> GRHSs GhcPs (Located (body GhcPs)) + -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars) +rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds)) + = rnLocalBindsAndThen binds $ \ binds' _ -> do + (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss + return (GRHSs noExtField grhss' (L l binds'), fvGRHSs) + +rnGRHS :: HsMatchContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> LGRHS GhcPs (Located (body GhcPs)) + -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars) +rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) + +rnGRHS' :: HsMatchContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> GRHS GhcPs (Located (body GhcPs)) + -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars) +rnGRHS' ctxt rnBody (GRHS _ guards rhs) + = do { pattern_guards_allowed <- xoptM LangExt.PatternGuards + ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> + rnBody rhs + + ; unless (pattern_guards_allowed || is_standard_guard guards') + (addWarn NoReason (nonStdGuardErr guards')) + + ; return (GRHS noExtField guards' rhs', fvs) } + where + -- Standard Haskell 1.4 guards are just a single boolean + -- expression, rather than a list of qualifiers as in the + -- Glasgow extension + is_standard_guard [] = True + is_standard_guard [L _ (BodyStmt {})] = True + is_standard_guard _ = False + +{- +********************************************************* +* * + Source-code fixity declarations +* * +********************************************************* +-} + +rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn) +-- Rename a fixity decl, so we can put +-- the renamed decl in the renamed syntax tree +-- Errors if the thing being fixed is not defined locally. +rnSrcFixityDecl sig_ctxt = rn_decl + where + rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn) + -- GHC extension: look up both the tycon and data con + -- for con-like things; hence returning a list + -- If neither are in scope, report an error; otherwise + -- return a fixity sig for each (slightly odd) + rn_decl (FixitySig _ fnames fixity) + = do names <- concatMapM lookup_one fnames + return (FixitySig noExtField names fixity) + + lookup_one :: Located RdrName -> RnM [Located Name] + lookup_one (L name_loc rdr_name) + = setSrcSpan name_loc $ + -- This lookup will fail if the name is not defined in the + -- same binding group as this fixity declaration. + do names <- lookupLocalTcNames sig_ctxt what rdr_name + return [ L name_loc name | (_, name) <- names ] + what = text "fixity signature" + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM () +dupSigDeclErr pairs@((L loc name, sig) :| _) + = addErrAt loc $ + vcat [ text "Duplicate" <+> what_it_is + <> text "s for" <+> quotes (ppr name) + , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest + $ map (getLoc . fst) + $ toList pairs) + ] + where + what_it_is = hsSigDoc sig + +misplacedSigErr :: LSig GhcRn -> RnM () +misplacedSigErr (L loc sig) + = addErrAt loc $ + sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] + +defaultSigErr :: Sig GhcPs -> SDoc +defaultSigErr sig = vcat [ hang (text "Unexpected default signature:") + 2 (ppr sig) + , text "Use DefaultSignatures to enable default signatures" ] + +bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc +bindsInHsBootFile mbinds + = hang (text "Bindings in hs-boot files are not allowed") + 2 (ppr mbinds) + +nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc +nonStdGuardErr guards + = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)") + 4 (interpp'SP guards) + +unusedPatBindWarn :: HsBind GhcRn -> SDoc +unusedPatBindWarn bind + = hang (text "This pattern-binding binds no variables:") + 2 (ppr bind) + +dupMinimalSigErr :: [LSig GhcPs] -> RnM () +dupMinimalSigErr sigs@(L loc _ : _) + = addErrAt loc $ + vcat [ text "Multiple minimal complete definitions" + , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLoc sigs) + , text "Combine alternative minimal complete definitions with `|'" ] +dupMinimalSigErr [] = panic "dupMinimalSigErr" diff --git a/compiler/GHC/Rename/Binds.hs b/compiler/GHC/Rename/Binds.hs deleted file mode 100644 --- a/compiler/GHC/Rename/Binds.hs +++ /dev/null @@ -1,1337 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -Renaming and dependency analysis of bindings - -This module does renaming and dependency analysis on value bindings in -the abstract syntax. It does {\em not} do cycle-checks on class or -type-synonym declarations; those cannot be done at this stage because -they may be affected by renaming (which isn't fully worked out yet). --} - -module GHC.Rename.Binds ( - -- Renaming top-level bindings - rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS, - - -- Renaming local bindings - rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, - - -- Other bindings - rnMethodBinds, renameSigs, - rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl, - makeMiniFixityEnv, MiniFixityEnv, - HsSigCtxt(..) - ) where - -import GhcPrelude - -import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr, rnStmts ) - -import GHC.Hs -import TcRnMonad -import GHC.Rename.Types -import GHC.Rename.Pat -import GHC.Rename.Names -import GHC.Rename.Env -import GHC.Rename.Fixity -import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn - , checkDupRdrNames, warnUnusedLocalBinds - , checkUnusedRecordWildcard - , checkDupAndShadowedNames, bindLocalNamesFV ) -import GHC.Driver.Session -import GHC.Types.Module -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Name.Reader ( RdrName, rdrNameOcc ) -import GHC.Types.SrcLoc as SrcLoc -import ListSetOps ( findDupsEq ) -import GHC.Types.Basic ( RecFlag(..), TypeOrKind(..) ) -import Digraph ( SCC(..) ) -import Bag -import Util -import Outputable -import GHC.Types.Unique.Set -import Maybes ( orElse ) -import OrdList -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Foldable ( toList ) -import Data.List ( partition, sortBy ) -import Data.List.NonEmpty ( NonEmpty(..) ) - -{- --- ToDo: Put the annotations into the monad, so that they arrive in the proper --- place and can be used when complaining. - -The code tree received by the function @rnBinds@ contains definitions -in where-clauses which are all apparently mutually recursive, but which may -not really depend upon each other. For example, in the top level program -\begin{verbatim} -f x = y where a = x - y = x -\end{verbatim} -the definitions of @a@ and @y@ do not depend on each other at all. -Unfortunately, the typechecker cannot always check such definitions. -\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive -definitions. In Proceedings of the International Symposium on Programming, -Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} -However, the typechecker usually can check definitions in which only the -strongly connected components have been collected into recursive bindings. -This is precisely what the function @rnBinds@ does. - -ToDo: deal with case where a single monobinds binds the same variable -twice. - -The vertag tag is a unique @Int@; the tags only need to be unique -within one @MonoBinds@, so that unique-Int plumbing is done explicitly -(heavy monad machinery not needed). - - -************************************************************************ -* * -* naming conventions * -* * -************************************************************************ - -\subsection[name-conventions]{Name conventions} - -The basic algorithm involves walking over the tree and returning a tuple -containing the new tree plus its free variables. Some functions, such -as those walking polymorphic bindings (HsBinds) and qualifier lists in -list comprehensions (@Quals@), return the variables bound in local -environments. These are then used to calculate the free variables of the -expression evaluated in these environments. - -Conventions for variable names are as follows: -\begin{itemize} -\item -new code is given a prime to distinguish it from the old. - -\item -a set of variables defined in @Exp@ is written @dvExp@ - -\item -a set of variables free in @Exp@ is written @fvExp@ -\end{itemize} - -************************************************************************ -* * -* analysing polymorphic bindings (HsBindGroup, HsBind) -* * -************************************************************************ - -\subsubsection[dep-HsBinds]{Polymorphic bindings} - -Non-recursive expressions are reconstructed without any changes at top -level, although their component expressions may have to be altered. -However, non-recursive expressions are currently not expected as -\Haskell{} programs, and this code should not be executed. - -Monomorphic bindings contain information that is returned in a tuple -(a @FlatMonoBinds@) containing: - -\begin{enumerate} -\item -a unique @Int@ that serves as the ``vertex tag'' for this binding. - -\item -the name of a function or the names in a pattern. These are a set -referred to as @dvLhs@, the defined variables of the left hand side. - -\item -the free variables of the body. These are referred to as @fvBody@. - -\item -the definition's actual code. This is referred to as just @code@. -\end{enumerate} - -The function @nonRecDvFv@ returns two sets of variables. The first is -the set of variables defined in the set of monomorphic bindings, while the -second is the set of free variables in those bindings. - -The set of variables defined in a non-recursive binding is just the -union of all of them, as @union@ removes duplicates. However, the -free variables in each successive set of cumulative bindings is the -union of those in the previous set plus those of the newest binding after -the defined variables of the previous set have been removed. - -@rnMethodBinds@ deals only with the declarations in class and -instance declarations. It expects only to see @FunMonoBind@s, and -it expects the global environment to contain bindings for the binders -(which are all class operations). - -************************************************************************ -* * -\subsubsection{ Top-level bindings} -* * -************************************************************************ --} - --- for top-level bindings, we need to make top-level names, --- so we have a different entry point than for local bindings -rnTopBindsLHS :: MiniFixityEnv - -> HsValBinds GhcPs - -> RnM (HsValBindsLR GhcRn GhcPs) -rnTopBindsLHS fix_env binds - = rnValBindsLHS (topRecNameMaker fix_env) binds - -rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs - -> RnM (HsValBinds GhcRn, DefUses) --- A hs-boot file has no bindings. --- Return a single HsBindGroup with empty binds and renamed signatures -rnTopBindsBoot bound_names (ValBinds _ mbinds sigs) - = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) - ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs - ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) } -rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) - -{- -********************************************************* -* * - HsLocalBinds -* * -********************************************************* --} - -rnLocalBindsAndThen :: HsLocalBinds GhcPs - -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) --- This version (a) assumes that the binding vars are *not* already in scope --- (b) removes the binders from the free vars of the thing inside --- The parser doesn't produce ThenBinds -rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside = - thing_inside (EmptyLocalBinds x) emptyNameSet - -rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside - = rnLocalValBindsAndThen val_binds $ \ val_binds' -> - thing_inside (HsValBinds x val_binds') - -rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do - (binds',fv_binds) <- rnIPBinds binds - (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds - return (thing, fvs_thing `plusFV` fv_binds) - -rnLocalBindsAndThen (XHsLocalBindsLR nec) _ = noExtCon nec - -rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars) -rnIPBinds (IPBinds _ ip_binds ) = do - (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds - return (IPBinds noExtField ip_binds', plusFVs fvs_s) -rnIPBinds (XHsIPBinds nec) = noExtCon nec - -rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) -rnIPBind (IPBind _ ~(Left n) expr) = do - (expr',fvExpr) <- rnLExpr expr - return (IPBind noExtField (Left n) expr', fvExpr) -rnIPBind (XIPBind nec) = noExtCon nec - -{- -************************************************************************ -* * - ValBinds -* * -************************************************************************ --} - --- Renaming local binding groups --- Does duplicate/shadow check -rnLocalValBindsLHS :: MiniFixityEnv - -> HsValBinds GhcPs - -> RnM ([Name], HsValBindsLR GhcRn GhcPs) -rnLocalValBindsLHS fix_env binds - = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds - - -- Check for duplicates and shadowing - -- Must do this *after* renaming the patterns - -- See Note [Collect binders only after renaming] in GHC.Hs.Utils - - -- We need to check for dups here because we - -- don't don't bind all of the variables from the ValBinds at once - -- with bindLocatedLocals any more. - -- - -- Note that we don't want to do this at the top level, since - -- sorting out duplicates and shadowing there happens elsewhere. - -- The behavior is even different. For example, - -- import A(f) - -- f = ... - -- should not produce a shadowing warning (but it will produce - -- an ambiguity warning if you use f), but - -- import A(f) - -- g = let f = ... in f - -- should. - ; let bound_names = collectHsValBinders binds' - -- There should be only Ids, but if there are any bogus - -- pattern synonyms, we'll collect them anyway, so that - -- we don't generate subsequent out-of-scope messages - ; envs <- getRdrEnvs - ; checkDupAndShadowedNames envs bound_names - - ; return (bound_names, binds') } - --- renames the left-hand sides --- generic version used both at the top level and for local binds --- does some error checking, but not what gets done elsewhere at the top level -rnValBindsLHS :: NameMaker - -> HsValBinds GhcPs - -> RnM (HsValBindsLR GhcRn GhcPs) -rnValBindsLHS topP (ValBinds x mbinds sigs) - = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds - ; return $ ValBinds x mbinds' sigs } - where - bndrs = collectHsBindsBinders mbinds - doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs - -rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) - --- General version used both from the top-level and for local things --- Assumes the LHS vars are in scope --- --- Does not bind the local fixity declarations -rnValBindsRHS :: HsSigCtxt - -> HsValBindsLR GhcRn GhcPs - -> RnM (HsValBinds GhcRn, DefUses) - -rnValBindsRHS ctxt (ValBinds _ mbinds sigs) - = do { (sigs', sig_fvs) <- renameSigs ctxt sigs - ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds - ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus - - ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $ - getPatSynBinds anal_binds - -- The uses in binds_w_dus for PatSynBinds do not include - -- variables used in the patsyn builders; see - -- Note [Pattern synonym builders don't yield dependencies] - -- But psb_fvs /does/ include those builder fvs. So we - -- add them back in here to avoid bogus warnings about - -- unused variables (#12548) - - valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs - `plusDU` usesOnly patsyn_fvs - -- Put the sig uses *after* the bindings - -- so that the binders are removed from - -- the uses in the sigs - - ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) } - -rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) - --- Wrapper for local binds --- --- The *client* of this function is responsible for checking for unused binders; --- it doesn't (and can't: we don't have the thing inside the binds) happen here --- --- The client is also responsible for bringing the fixities into scope -rnLocalValBindsRHS :: NameSet -- names bound by the LHSes - -> HsValBindsLR GhcRn GhcPs - -> RnM (HsValBinds GhcRn, DefUses) -rnLocalValBindsRHS bound_names binds - = rnValBindsRHS (LocalBindCtxt bound_names) binds - --- for local binds --- wrapper that does both the left- and right-hand sides --- --- here there are no local fixity decls passed in; --- the local fixity decls come from the ValBinds sigs -rnLocalValBindsAndThen - :: HsValBinds GhcPs - -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) -rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside - = do { -- (A) Create the local fixity environment - new_fixities <- makeMiniFixityEnv [ L loc sig - | L loc (FixSig _ sig) <- sigs] - - -- (B) Rename the LHSes - ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds - - -- ...and bring them (and their fixities) into scope - ; bindLocalNamesFV bound_names $ - addLocalFixities new_fixities bound_names $ do - - { -- (C) Do the RHS and thing inside - (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs - ; (result, result_fvs) <- thing_inside binds' (allUses dus) - - -- Report unused bindings based on the (accurate) - -- findUses. E.g. - -- let x = x in 3 - -- should report 'x' unused - ; let real_uses = findUses dus result_fvs - -- Insert fake uses for variables introduced implicitly by - -- wildcards (#4404) - rec_uses = hsValBindsImplicits binds' - implicit_uses = mkNameSet $ concatMap snd - $ rec_uses - ; mapM_ (\(loc, ns) -> - checkUnusedRecordWildcard loc real_uses (Just ns)) - rec_uses - ; warnUnusedLocalBinds bound_names - (real_uses `unionNameSet` implicit_uses) - - ; let - -- The variables "used" in the val binds are: - -- (1) the uses of the binds (allUses) - -- (2) the FVs of the thing-inside - all_uses = allUses dus `plusFV` result_fvs - -- Note [Unused binding hack] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Note that *in contrast* to the above reporting of - -- unused bindings, (1) above uses duUses to return *all* - -- the uses, even if the binding is unused. Otherwise consider: - -- x = 3 - -- y = let p = x in 'x' -- NB: p not used - -- If we don't "see" the dependency of 'y' on 'x', we may put the - -- bindings in the wrong order, and the type checker will complain - -- that x isn't in scope - -- - -- But note that this means we won't report 'x' as unused, - -- whereas we would if we had { x = 3; p = x; y = 'x' } - - ; return (result, all_uses) }} - -- The bound names are pruned out of all_uses - -- by the bindLocalNamesFV call above - -rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) - - ---------------------- - --- renaming a single bind - -rnBindLHS :: NameMaker - -> SDoc - -> HsBind GhcPs - -- returns the renamed left-hand side, - -- and the FreeVars *of the LHS* - -- (i.e., any free variables of the pattern) - -> RnM (HsBindLR GhcRn GhcPs) - -rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat }) - = do - -- we don't actually use the FV processing of rnPatsAndThen here - (pat',pat'_fvs) <- rnBindPat name_maker pat - return (bind { pat_lhs = pat', pat_ext = pat'_fvs }) - -- We temporarily store the pat's FVs in bind_fvs; - -- gets updated to the FVs of the whole bind - -- when doing the RHS below - -rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name }) - = do { name <- applyNameMaker name_maker rdr_name - ; return (bind { fun_id = name - , fun_ext = noExtField }) } - -rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname }) - | isTopRecNameMaker name_maker - = do { addLocM checkConName rdrname - ; name <- lookupLocatedTopBndrRn rdrname -- Should be in scope already - ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) } - - | otherwise -- Pattern synonym, not at top level - = do { addErr localPatternSynonymErr -- Complain, but make up a fake - -- name so that we can carry on - ; name <- applyNameMaker name_maker rdrname - ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) } - where - localPatternSynonymErr :: SDoc - localPatternSynonymErr - = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) - 2 (text "Pattern synonym declarations are only valid at top level") - -rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) - -rnLBind :: (Name -> [Name]) -- Signature tyvar function - -> LHsBindLR GhcRn GhcPs - -> RnM (LHsBind GhcRn, [Name], Uses) -rnLBind sig_fn (L loc bind) - = setSrcSpan loc $ - do { (bind', bndrs, dus) <- rnBind sig_fn bind - ; return (L loc bind', bndrs, dus) } - --- assumes the left-hands-side vars are in scope -rnBind :: (Name -> [Name]) -- Signature tyvar function - -> HsBindLR GhcRn GhcPs - -> RnM (HsBind GhcRn, [Name], Uses) -rnBind _ bind@(PatBind { pat_lhs = pat - , pat_rhs = grhss - -- pat fvs were stored in bind_fvs - -- after processing the LHS - , pat_ext = pat_fvs }) - = do { mod <- getModule - ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss - - -- No scoped type variables for pattern bindings - ; let all_fvs = pat_fvs `plusFV` rhs_fvs - fvs' = filterNameSet (nameIsLocalOrFrom mod) all_fvs - -- Keep locally-defined Names - -- As well as dependency analysis, we need these for the - -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan - bndrs = collectPatBinders pat - bind' = bind { pat_rhs = grhss' - , pat_ext = fvs' } - - ok_nobind_pat - = -- See Note [Pattern bindings that bind no variables] - case unLoc pat of - WildPat {} -> True - BangPat {} -> True -- #9127, #13646 - SplicePat {} -> True - _ -> False - - -- Warn if the pattern binds no variables - -- See Note [Pattern bindings that bind no variables] - ; whenWOptM Opt_WarnUnusedPatternBinds $ - when (null bndrs && not ok_nobind_pat) $ - addWarn (Reason Opt_WarnUnusedPatternBinds) $ - unusedPatBindWarn bind' - - ; fvs' `seq` -- See Note [Free-variable space leak] - return (bind', bndrs, all_fvs) } - -rnBind sig_fn bind@(FunBind { fun_id = name - , fun_matches = matches }) - -- invariant: no free vars here when it's a FunBind - = do { let plain_name = unLoc name - - ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ - -- bindSigTyVars tests for LangExt.ScopedTyVars - rnMatchGroup (mkPrefixFunRhs name) - rnLExpr matches - ; let is_infix = isInfixFunBind bind - ; when is_infix $ checkPrecMatch plain_name matches' - - ; mod <- getModule - ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs - -- Keep locally-defined Names - -- As well as dependency analysis, we need these for the - -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan - - ; fvs' `seq` -- See Note [Free-variable space leak] - return (bind { fun_matches = matches' - , fun_ext = fvs' }, - [plain_name], rhs_fvs) - } - -rnBind sig_fn (PatSynBind x bind) - = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind - ; return (PatSynBind x bind', name, fvs) } - -rnBind _ b = pprPanic "rnBind" (ppr b) - -{- Note [Pattern bindings that bind no variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally, we want to warn about pattern bindings like - Just _ = e -because they don't do anything! But we have three exceptions: - -* A wildcard pattern - _ = rhs - which (a) is not that different from _v = rhs - (b) is sometimes used to give a type sig for, - or an occurrence of, a variable on the RHS - -* A strict pattern binding; that is, one with an outermost bang - !Just _ = e - This can fail, so unlike the lazy variant, it is not a no-op. - Moreover, #13646 argues that even for single constructor - types, you might want to write the constructor. See also #9127. - -* A splice pattern - $(th-lhs) = rhs - It is impossible to determine whether or not th-lhs really - binds any variable. We should disable the warning for any pattern - which contain splices, but that is a more expensive check. - -Note [Free-variable space leak] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have - fvs' = trim fvs -and we seq fvs' before turning it as part of a record. - -The reason is that trim is sometimes something like - \xs -> intersectNameSet (mkNameSet bound_names) xs -and we don't want to retain the list bound_names. This showed up in -trac ticket #1136. --} - -{- ********************************************************************* -* * - Dependency analysis and other support functions -* * -********************************************************************* -} - -depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses) - -> ([(RecFlag, LHsBinds GhcRn)], DefUses) --- Dependency analysis; this is important so that --- unused-binding reporting is accurate -depAnalBinds binds_w_dus - = (map get_binds sccs, toOL $ map get_du sccs) - where - sccs = depAnal (\(_, defs, _) -> defs) - (\(_, _, uses) -> nonDetEltsUniqSet uses) - -- It's OK to use nonDetEltsUniqSet here as explained in - -- Note [depAnal determinism] in GHC.Types.Name.Env. - (bagToList binds_w_dus) - - get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind) - get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus]) - - get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses) - get_du (CyclicSCC binds_w_dus) = (Just defs, uses) - where - defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs] - uses = unionNameSets [u | (_,_,u) <- binds_w_dus] - ---------------------- --- Bind the top-level forall'd type variables in the sigs. --- E.g f :: forall a. a -> a --- f = rhs --- The 'a' scopes over the rhs --- --- NB: there'll usually be just one (for a function binding) --- but if there are many, one may shadow the rest; too bad! --- e.g x :: forall a. [a] -> [a] --- y :: forall a. [(a,a)] -> a --- (x,y) = e --- In e, 'a' will be in scope, and it'll be the one from 'y'! - -mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name]) --- Return a lookup function that maps an Id Name to the names --- of the type variables that should scope over its body. -mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` [] - where - env = mkHsSigEnv get_scoped_tvs sigs - - get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name]) - -- Returns (binders, scoped tvs for those binders) - get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty)) - = Just (names, hsScopedTvs sig_ty) - get_scoped_tvs (L _ (TypeSig _ names sig_ty)) - = Just (names, hsWcScopedTvs sig_ty) - get_scoped_tvs (L _ (PatSynSig _ names sig_ty)) - = Just (names, hsScopedTvs sig_ty) - get_scoped_tvs _ = Nothing - --- Process the fixity declarations, making a FastString -> (Located Fixity) map --- (We keep the location around for reporting duplicate fixity declarations.) --- --- Checks for duplicates, but not that only locally defined things are fixed. --- Note: for local fixity declarations, duplicates would also be checked in --- check_sigs below. But we also use this function at the top level. - -makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv - -makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls - where - add_one_sig env (L loc (FixitySig _ names fixity)) = - foldlM add_one env [ (loc,name_loc,name,fixity) - | L name_loc name <- names ] - add_one_sig _ (L _ (XFixitySig nec)) = noExtCon nec - - add_one env (loc, name_loc, name,fixity) = do - { -- this fixity decl is a duplicate iff - -- the ReaderName's OccName's FastString is already in the env - -- (we only need to check the local fix_env because - -- definitions of non-local will be caught elsewhere) - let { fs = occNameFS (rdrNameOcc name) - ; fix_item = L loc fixity }; - - case lookupFsEnv env fs of - Nothing -> return $ extendFsEnv env fs fix_item - Just (L loc' _) -> do - { setSrcSpan loc $ - addErrAt name_loc (dupFixityDecl loc' name) - ; return env} - } - -dupFixityDecl :: SrcSpan -> RdrName -> SDoc -dupFixityDecl loc rdr_name - = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), - text "also at " <+> ppr loc] - - -{- ********************************************************************* -* * - Pattern synonym bindings -* * -********************************************************************* -} - -rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function - -> PatSynBind GhcRn GhcPs - -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses) -rnPatSynBind sig_fn bind@(PSB { psb_id = L l name - , psb_args = details - , psb_def = pat - , 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) - ; let scoped_tvs = sig_fn name - - ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $ - rnPat PatSyn pat $ \pat' -> - -- We check the 'RdrName's instead of the 'Name's - -- so that the binding locations are reported - -- from the left-hand side - case details of - PrefixCon vars -> - do { checkDupRdrNames vars - ; names <- mapM lookupPatSynBndr vars - ; return ( (pat', PrefixCon names) - , mkFVs (map unLoc names)) } - InfixCon var1 var2 -> - do { checkDupRdrNames [var1, var2] - ; name1 <- lookupPatSynBndr var1 - ; name2 <- lookupPatSynBndr var2 - -- ; checkPrecMatch -- TODO - ; return ( (pat', InfixCon name1 name2) - , mkFVs (map unLoc [name1, name2])) } - RecCon vars -> - do { checkDupRdrNames (map recordPatSynSelectorId vars) - ; let rnRecordPatSynField - (RecordPatSynField { recordPatSynSelectorId = visible - , recordPatSynPatVar = hidden }) - = do { visible' <- lookupLocatedTopBndrRn visible - ; hidden' <- lookupPatSynBndr hidden - ; return $ RecordPatSynField { recordPatSynSelectorId = visible' - , recordPatSynPatVar = hidden' } } - ; names <- mapM rnRecordPatSynField vars - ; return ( (pat', RecCon names) - , mkFVs (map (unLoc . recordPatSynPatVar) names)) } - - ; (dir', fvs2) <- case dir of - Unidirectional -> return (Unidirectional, emptyFVs) - ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs) - ExplicitBidirectional mg -> - do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $ - rnMatchGroup (mkPrefixFunRhs (L l name)) - rnLExpr mg - ; return (ExplicitBidirectional mg', fvs) } - - ; mod <- getModule - ; let fvs = fvs1 `plusFV` fvs2 - fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs - -- Keep locally-defined Names - -- As well as dependency analysis, we need these for the - -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan - - bind' = bind{ psb_args = details' - , psb_def = pat' - , psb_dir = dir' - , psb_ext = fvs' } - selector_names = case details' of - RecCon names -> - map (unLoc . recordPatSynSelectorId) names - _ -> [] - - ; fvs' `seq` -- See Note [Free-variable space leak] - return (bind', name : selector_names , fvs1) - -- Why fvs1? See Note [Pattern synonym builders don't yield dependencies] - } - where - -- See Note [Renaming pattern synonym variables] - lookupPatSynBndr = wrapLocM lookupLocalOccRn - - patternSynonymErr :: SDoc - patternSynonymErr - = hang (text "Illegal pattern synonym declaration") - 2 (text "Use -XPatternSynonyms to enable this extension") - -rnPatSynBind _ (XPatSynBind nec) = noExtCon nec - -{- -Note [Renaming pattern synonym variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We rename pattern synonym declaractions backwards to normal to reuse -the logic already implemented for renaming patterns. - -We first rename the RHS of a declaration which brings into -scope the variables bound by the pattern (as they would be -in normal function definitions). We then lookup the variables -which we want to bind in this local environment. - -It is crucial that we then only lookup in the *local* environment which -only contains the variables brought into scope by the pattern and nothing -else. Amazingly no-one encountered this bug for 3 GHC versions but -it was possible to define a pattern synonym which referenced global -identifiers and worked correctly. - -``` -x = 5 - -pattern P :: Int -> () -pattern P x <- _ - -f (P x) = x - -> f () = 5 -``` - -See #13470 for the original report. - -Note [Pattern synonym builders don't yield dependencies] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When renaming a pattern synonym that has an explicit builder, -references in the builder definition should not be used when -calculating dependencies. For example, consider the following pattern -synonym definition: - -pattern P x <- C1 x where - P x = f (C1 x) - -f (P x) = C2 x - -In this case, 'P' needs to be typechecked in two passes: - -1. Typecheck the pattern definition of 'P', which fully determines the - type of 'P'. This step doesn't require knowing anything about 'f', - since the builder definition is not looked at. - -2. Typecheck the builder definition, which needs the typechecked - definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind - in TcBinds.tcValBinds. - -This behaviour is implemented in 'tcValBinds', but it crucially -depends on 'P' not being put in a recursive group with 'f' (which -would make it look like a recursive pattern synonym a la 'pattern P = -P' which is unsound and rejected). - -So: - * We do not include builder fvs in the Uses returned by rnPatSynBind - (which is then used for dependency analysis) - * But we /do/ include them in the psb_fvs for the PatSynBind - * In rnValBinds we record these builder uses, to avoid bogus - unused-variable warnings (#12548) --} - -{- ********************************************************************* -* * - Class/instance method bindings -* * -********************************************************************* -} - -{- @rnMethodBinds@ is used for the method bindings of a class and an instance -declaration. Like @rnBinds@ but without dependency analysis. - -NOTA BENE: we record each {\em binder} of a method-bind group as a free variable. -That's crucial when dealing with an instance decl: -\begin{verbatim} - instance Foo (T a) where - op x = ... -\end{verbatim} -This might be the {\em sole} occurrence of @op@ for an imported class @Foo@, -and unless @op@ occurs we won't treat the type signature of @op@ in the class -decl for @Foo@ as a source of instance-decl gates. But we should! Indeed, -in many ways the @op@ in an instance decl is just like an occurrence, not -a binder. --} - -rnMethodBinds :: Bool -- True <=> is a class declaration - -> Name -- Class name - -> [Name] -- Type variables from the class/instance header - -> LHsBinds GhcPs -- Binds - -> [LSig GhcPs] -- and signatures/pragmas - -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars) --- Used for --- * 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 { checkDupRdrNames (collectMethodBinders binds) - -- Check that the same method is not given twice in the - -- same instance decl instance C T where - -- f x = ... - -- g y = ... - -- f x = ... - -- We must use checkDupRdrNames because the Name of the - -- method is the Name of the class selector, whose SrcSpan - -- points to the class declaration; and we use rnMethodBinds - -- for instance decls too - - -- Rename the bindings LHSs - ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) emptyBag binds - - -- Rename the pragmas and signatures - -- Annoyingly the type variables /are/ in scope for signatures, but - -- /are not/ in scope in the SPECIALISE instance pramas; e.g. - -- instance Eq a => Eq (T a) where - -- (==) :: a -> a -> a - -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} - ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs - bound_nms = mkNameSet (collectHsBindsBinders binds') - sig_ctxt | is_cls_decl = ClsDeclCtxt cls - | otherwise = InstDeclCtxt bound_nms - ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags - ; (other_sigs', sig_fvs) <- extendTyVarEnvFVRn ktv_names $ - renameSigs sig_ctxt other_sigs - - -- Rename the bindings RHSs. Again there's an issue about whether the - -- type variables from the class/instance head are in scope. - -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables - ; scoped_tvs <- xoptM LangExt.ScopedTypeVariables - ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $ - do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds' - ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2) - emptyFVs binds_w_dus - ; return (mapBag fstOf3 binds_w_dus, bind_fvs) } - - ; return ( binds'', spec_inst_prags' ++ other_sigs' - , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) } - where - -- For the method bindings in class and instance decls, we extend - -- the type variable environment iff -XScopedTypeVariables - maybe_extend_tyvar_env scoped_tvs thing_inside - | scoped_tvs = extendTyVarEnvFVRn ktv_names thing_inside - | otherwise = thing_inside - -rnMethodBindLHS :: Bool -> Name - -> LHsBindLR GhcPs GhcPs - -> LHsBindsLR GhcRn GhcPs - -> RnM (LHsBindsLR GhcRn GhcPs) -rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest - = setSrcSpan loc $ do - do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name - -- We use the selector name as the binder - ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField } - ; return (L loc bind' `consBag` rest ) } - --- 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 loc $ - vcat [ what <+> text "not allowed in" <+> decl_sort - , nest 2 (ppr 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) - -{- -************************************************************************ -* * -\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} -* * -************************************************************************ - -@renameSigs@ checks for: -\begin{enumerate} -\item more than one sig for one thing; -\item signatures given for things not bound here; -\end{enumerate} - -At the moment we don't gather free-var info from the types in -signatures. We'd only need this if we wanted to report unused tyvars. --} - -renameSigs :: HsSigCtxt - -> [LSig GhcPs] - -> RnM ([LSig GhcRn], FreeVars) --- Renames the signatures and performs error checks -renameSigs ctxt sigs - = do { mapM_ dupSigDeclErr (findDupSigs sigs) - - ; checkDupMinimalSigs sigs - - ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs - - ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs' - ; mapM_ misplacedSigErr bad_sigs -- Misplaced - - ; return (good_sigs, sig_fvs) } - ----------------------- --- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory --- because this won't work for: --- instance Foo T where --- {-# INLINE op #-} --- Baz.op = ... --- We'll just rename the INLINE prag to refer to whatever other 'op' --- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) --- Doesn't seem worth much trouble to sort this. - -renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) -renameSig _ (IdSig _ x) - = return (IdSig noExtField x, emptyFVs) -- Actually this never occurs - -renameSig ctxt sig@(TypeSig _ vs ty) - = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; let doc = TypeSigCtx (ppr_sig_bndrs vs) - ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty - ; return (TypeSig noExtField new_vs new_ty, fvs) } - -renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) - = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures - ; when (is_deflt && not defaultSigs_on) $ - addErr (defaultSigErr sig) - ; new_v <- mapM (lookupSigOccRn ctxt sig) vs - ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty - ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) } - where - (v1:_) = vs - ty_ctxt = GenericCtx (text "a class method signature for" - <+> quotes (ppr v1)) - -renameSig _ (SpecInstSig _ src ty) - = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel ty - ; return (SpecInstSig noExtField src new_ty,fvs) } - --- {-# SPECIALISE #-} pragmas can refer to imported Ids --- so, in the top-level case (when mb_names is Nothing) --- we use lookupOccRn. If there's both an imported and a local 'f' --- then the SPECIALISE pragma is ambiguous, unlike all other signatures -renameSig ctxt sig@(SpecSig _ v tys inl) - = do { new_v <- case ctxt of - TopSigCtxt {} -> lookupLocatedOccRn v - _ -> lookupSigOccRn ctxt sig v - ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys - ; return (SpecSig noExtField new_v new_ty inl, fvs) } - where - ty_ctxt = GenericCtx (text "a SPECIALISE signature for" - <+> quotes (ppr v)) - do_one (tys,fvs) ty - = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty - ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } - -renameSig ctxt sig@(InlineSig _ v s) - = do { new_v <- lookupSigOccRn ctxt sig v - ; return (InlineSig noExtField new_v s, emptyFVs) } - -renameSig ctxt (FixSig _ fsig) - = do { new_fsig <- rnSrcFixityDecl ctxt fsig - ; return (FixSig noExtField new_fsig, emptyFVs) } - -renameSig ctxt sig@(MinimalSig _ s (L l bf)) - = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf - return (MinimalSig noExtField s (L l new_bf), emptyFVs) - -renameSig ctxt sig@(PatSynSig _ vs ty) - = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty - ; return (PatSynSig noExtField new_vs ty', fvs) } - where - ty_ctxt = GenericCtx (text "a pattern synonym signature for" - <+> ppr_sig_bndrs vs) - -renameSig ctxt sig@(SCCFunSig _ st v s) - = do { new_v <- lookupSigOccRn ctxt sig v - ; return (SCCFunSig noExtField st new_v s, emptyFVs) } - --- COMPLETE Sigs can refer to imported IDs which is why we use --- lookupLocatedOccRn rather than lookupSigOccRn -renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty) - = do new_bf <- traverse lookupLocatedOccRn bf - new_mty <- traverse lookupLocatedOccRn mty - - this_mod <- fmap tcg_mod getGblEnv - unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do - -- Why 'any'? See Note [Orphan COMPLETE pragmas] - addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError - - return (CompleteMatchSig noExtField s (L l new_bf) new_mty, emptyFVs) - where - orphanError :: SDoc - orphanError = - 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." - -renameSig _ (XSig nec) = noExtCon nec - -{- -Note [Orphan COMPLETE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We define a COMPLETE pragma to be a non-orphan if it includes at least -one conlike defined in the current module. Why is this sufficient? -Well if you have a pattern match - - case expr of - P1 -> ... - P2 -> ... - P3 -> ... - -any COMPLETE pragma which mentions a conlike other than P1, P2 or P3 -will not be of any use in verifying that the pattern match is -exhaustive. So as we have certainly read the interface files that -define P1, P2 and P3, we will have loaded all non-orphan COMPLETE -pragmas that could be relevant to this pattern match. - -For now we simply disallow orphan COMPLETE pragmas, as the added -complexity of supporting them properly doesn't seem worthwhile. --} - -ppr_sig_bndrs :: [Located RdrName] -> SDoc -ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) - -okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool -okHsSig ctxt (L _ sig) - = case (sig, ctxt) of - (ClassOpSig {}, ClsDeclCtxt {}) -> True - (ClassOpSig {}, InstDeclCtxt {}) -> True - (ClassOpSig {}, _) -> False - - (TypeSig {}, ClsDeclCtxt {}) -> False - (TypeSig {}, InstDeclCtxt {}) -> False - (TypeSig {}, _) -> True - - (PatSynSig {}, TopSigCtxt{}) -> True - (PatSynSig {}, _) -> False - - (FixSig {}, InstDeclCtxt {}) -> False - (FixSig {}, _) -> True - - (IdSig {}, TopSigCtxt {}) -> True - (IdSig {}, InstDeclCtxt {}) -> True - (IdSig {}, _) -> False - - (InlineSig {}, HsBootCtxt {}) -> False - (InlineSig {}, _) -> True - - (SpecSig {}, TopSigCtxt {}) -> True - (SpecSig {}, LocalBindCtxt {}) -> True - (SpecSig {}, InstDeclCtxt {}) -> True - (SpecSig {}, _) -> False - - (SpecInstSig {}, InstDeclCtxt {}) -> True - (SpecInstSig {}, _) -> False - - (MinimalSig {}, ClsDeclCtxt {}) -> True - (MinimalSig {}, _) -> False - - (SCCFunSig {}, HsBootCtxt {}) -> False - (SCCFunSig {}, _) -> True - - (CompleteMatchSig {}, TopSigCtxt {} ) -> True - (CompleteMatchSig {}, _) -> False - - (XSig nec, _) -> noExtCon nec - -------------------- -findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)] --- Check for duplicates on RdrName version, --- because renamed version has unboundName for --- not-in-scope binders, which gives bogus dup-sig errors --- NB: in a class decl, a 'generic' sig is not considered --- equal to an ordinary sig, so we allow, say --- class C a where --- op :: a -> a --- default op :: Eq a => a -> a -findDupSigs sigs - = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) - where - expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig) - expand_sig sig@(InlineSig _ n _) = [(n,sig)] - expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns] - expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns] - expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns] - expand_sig sig@(SCCFunSig _ _ n _) = [(n,sig)] - expand_sig _ = [] - - matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 - mtch (FixSig {}) (FixSig {}) = True - mtch (InlineSig {}) (InlineSig {}) = True - mtch (TypeSig {}) (TypeSig {}) = True - mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2 - mtch (PatSynSig _ _ _) (PatSynSig _ _ _) = True - mtch (SCCFunSig{}) (SCCFunSig{}) = True - mtch _ _ = False - --- Warn about multiple MINIMAL signatures -checkDupMinimalSigs :: [LSig GhcPs] -> RnM () -checkDupMinimalSigs sigs - = case filter isMinimalLSig sigs of - minSigs@(_:_:_) -> dupMinimalSigErr minSigs - _ -> return () - -{- -************************************************************************ -* * -\subsection{Match} -* * -************************************************************************ --} - -rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> MatchGroup GhcPs (Located (body GhcPs)) - -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars) -rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin }) - = do { empty_case_ok <- xoptM LangExt.EmptyCase - ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) - ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms - ; return (mkMatchGroup origin new_ms, ms_fvs) } -rnMatchGroup _ _ (XMatchGroup nec) = noExtCon nec - -rnMatch :: Outputable (body GhcPs) => HsMatchContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> LMatch GhcPs (Located (body GhcPs)) - -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars) -rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) - -rnMatch' :: Outputable (body GhcPs) => HsMatchContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> Match GhcPs (Located (body GhcPs)) - -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars) -rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) - = do { -- Note that there are no local fixity decls for matches - ; rnPats ctxt pats $ \ pats' -> do - { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss - ; let mf' = case (ctxt, mf) of - (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ }) - -> mf { mc_fun = L lf funid } - _ -> ctxt - ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = pats' - , m_grhss = grhss'}, grhss_fvs ) }} -rnMatch' _ _ (XMatch nec) = noExtCon nec - -emptyCaseErr :: HsMatchContext GhcRn -> SDoc -emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) - 2 (text "Use EmptyCase to allow this") - where - pp_ctxt = case ctxt of - CaseAlt -> text "case expression" - LambdaExpr -> text "\\case expression" - _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt - -{- -************************************************************************ -* * -\subsubsection{Guarded right-hand sides (GRHSs)} -* * -************************************************************************ --} - -rnGRHSs :: HsMatchContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> GRHSs GhcPs (Located (body GhcPs)) - -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars) -rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds)) - = rnLocalBindsAndThen binds $ \ binds' _ -> do - (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss - return (GRHSs noExtField grhss' (L l binds'), fvGRHSs) -rnGRHSs _ _ (XGRHSs nec) = noExtCon nec - -rnGRHS :: HsMatchContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> LGRHS GhcPs (Located (body GhcPs)) - -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars) -rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) - -rnGRHS' :: HsMatchContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> GRHS GhcPs (Located (body GhcPs)) - -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars) -rnGRHS' ctxt rnBody (GRHS _ guards rhs) - = do { pattern_guards_allowed <- xoptM LangExt.PatternGuards - ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> - rnBody rhs - - ; unless (pattern_guards_allowed || is_standard_guard guards') - (addWarn NoReason (nonStdGuardErr guards')) - - ; return (GRHS noExtField guards' rhs', fvs) } - where - -- Standard Haskell 1.4 guards are just a single boolean - -- expression, rather than a list of qualifiers as in the - -- Glasgow extension - is_standard_guard [] = True - is_standard_guard [L _ (BodyStmt {})] = True - is_standard_guard _ = False -rnGRHS' _ _ (XGRHS nec) = noExtCon nec - -{- -********************************************************* -* * - Source-code fixity declarations -* * -********************************************************* --} - -rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn) --- Rename a fixity decl, so we can put --- the renamed decl in the renamed syntax tree --- Errors if the thing being fixed is not defined locally. -rnSrcFixityDecl sig_ctxt = rn_decl - where - rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn) - -- GHC extension: look up both the tycon and data con - -- for con-like things; hence returning a list - -- If neither are in scope, report an error; otherwise - -- return a fixity sig for each (slightly odd) - rn_decl (FixitySig _ fnames fixity) - = do names <- concatMapM lookup_one fnames - return (FixitySig noExtField names fixity) - rn_decl (XFixitySig nec) = noExtCon nec - - lookup_one :: Located RdrName -> RnM [Located Name] - lookup_one (L name_loc rdr_name) - = setSrcSpan name_loc $ - -- This lookup will fail if the name is not defined in the - -- same binding group as this fixity declaration. - do names <- lookupLocalTcNames sig_ctxt what rdr_name - return [ L name_loc name | (_, name) <- names ] - what = text "fixity signature" - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM () -dupSigDeclErr pairs@((L loc name, sig) :| _) - = addErrAt loc $ - vcat [ text "Duplicate" <+> what_it_is - <> text "s for" <+> quotes (ppr name) - , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest - $ map (getLoc . fst) - $ toList pairs) - ] - where - what_it_is = hsSigDoc sig - -misplacedSigErr :: LSig GhcRn -> RnM () -misplacedSigErr (L loc sig) - = addErrAt loc $ - sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] - -defaultSigErr :: Sig GhcPs -> SDoc -defaultSigErr sig = vcat [ hang (text "Unexpected default signature:") - 2 (ppr sig) - , text "Use DefaultSignatures to enable default signatures" ] - -bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc -bindsInHsBootFile mbinds - = hang (text "Bindings in hs-boot files are not allowed") - 2 (ppr mbinds) - -nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc -nonStdGuardErr guards - = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)") - 4 (interpp'SP guards) - -unusedPatBindWarn :: HsBind GhcRn -> SDoc -unusedPatBindWarn bind - = hang (text "This pattern-binding binds no variables:") - 2 (ppr bind) - -dupMinimalSigErr :: [LSig GhcPs] -> RnM () -dupMinimalSigErr sigs@(L loc _ : _) - = addErrAt loc $ - vcat [ text "Multiple minimal complete definitions" - , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLoc sigs) - , text "Combine alternative minimal complete definitions with `|'" ] -dupMinimalSigErr [] = panic "dupMinimalSigErr" 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 @@ -2,9 +2,9 @@ module GHC.Rename.Doc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where -import GhcPrelude +import GHC.Prelude -import TcRnTypes +import GHC.Tc.Types import GHC.Hs import GHC.Types.SrcLoc 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 @@ -44,37 +44,37 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Iface.Load ( loadInterfaceForName, loadSrcInterface_maybe ) import GHC.Iface.Env import GHC.Hs import GHC.Types.Name.Reader import GHC.Driver.Types -import TcEnv -import TcRnMonad -import RdrHsSyn ( filterCTuple, setRdrNameSpace ) -import TysWiredIn +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Parser.PostProcess ( filterCTuple, 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.Module +import GHC.Unit.Module import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon -import ErrUtils ( MsgDoc ) -import PrelNames ( rOOT_MAIN ) +import GHC.Utils.Error ( MsgDoc ) +import GHC.Builtin.Names( rOOT_MAIN ) import GHC.Types.Basic ( pprWarningTxtForMsg, TopLevelFlag(..), TupleSort(..) ) import GHC.Types.SrcLoc as SrcLoc -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Types.Unique.Set ( uniqSetAny ) -import Util -import Maybes +import GHC.Utils.Misc +import GHC.Data.Maybe import GHC.Driver.Session -import FastString +import GHC.Data.FastString import Control.Monad -import ListSetOps ( minusList ) +import GHC.Data.List.SetOps ( minusList ) import qualified GHC.LanguageExtensions as LangExt import GHC.Rename.Unbound import GHC.Rename.Utils @@ -180,7 +180,7 @@ -- -- 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 RdrHsSyn.tyConToDataCon + -- 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. @@ -400,7 +400,7 @@ -> RnM (Located 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.Binds.rnMethodBind +lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f GHC.Rename.Bind.rnMethodBind = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* = lookupLocatedOccRn tc_rdr @@ -912,7 +912,7 @@ Nothing -> reportUnboundName rdr_name } -- Only used in one place, to rename pattern synonym binders. --- See Note [Renaming pattern synonym variables] in GHC.Rename.Binds +-- See Note [Renaming pattern synonym variables] in GHC.Rename.Bind lookupLocalOccRn :: RdrName -> RnM Name lookupLocalOccRn rdr_name = do { mb_name <- lookupLocalOccRn_maybe rdr_name @@ -1633,7 +1633,7 @@ * NegApp * NPlusKPat * HsDo -respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName, +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. 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 @@ -12,6 +12,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -25,14 +26,14 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import GHC.Rename.Binds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS +import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS , rnMatchGroup, rnGRHS, makeMiniFixityEnv) import GHC.Hs -import TcEnv ( isBrackStage ) -import TcRnMonad -import GHC.Types.Module ( getModule ) +import GHC.Tc.Utils.Env ( isBrackStage ) +import GHC.Tc.Utils.Monad +import GHC.Unit.Module ( getModule ) import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames @@ -42,10 +43,10 @@ , checkUnusedRecordWildcard ) import GHC.Rename.Unbound ( reportUnboundName ) import GHC.Rename.Splice ( rnBracket, rnSpliceExpr, checkThLocalName ) -import GHC.Rename.Types +import GHC.Rename.HsType import GHC.Rename.Pat import GHC.Driver.Session -import PrelNames +import GHC.Builtin.Names import GHC.Types.Basic import GHC.Types.Name @@ -53,14 +54,14 @@ import GHC.Types.Name.Reader import GHC.Types.Unique.Set import Data.List -import Util -import ListSetOps ( removeDups ) -import ErrUtils -import Outputable +import GHC.Utils.Misc +import GHC.Data.List.SetOps ( removeDups ) +import GHC.Utils.Error +import GHC.Utils.Outputable as Outputable import GHC.Types.SrcLoc -import FastString +import GHC.Data.FastString import Control.Monad -import TysWiredIn ( nilDataConName ) +import GHC.Builtin.Types ( nilDataConName ) import qualified GHC.LanguageExtensions as LangExt import Data.Ord @@ -189,7 +190,7 @@ -- Deal with fixity -- When renaming code synthesised from "deriving" declarations -- we used to avoid fixity stuff, but we can't easily tell any - -- more, so I've removed the test. Adding HsPars in TcGenDeriv + -- more, so I've removed the test. Adding HsPars in GHC.Tc.Deriv.Generate -- should prevent bad things happening. ; fixity <- case op' of L _ (HsVar _ (L _ n)) -> lookupFixityRn n @@ -214,7 +215,7 @@ --------------------------------------------- -- Sections --- See Note [Parsing sections] in Parser.y +-- See Note [Parsing sections] in GHC.Parser rnExpr (HsPar x (L loc (section@(SectionL {})))) = do { (section', fvs) <- rnSection section ; return (HsPar x (L loc section'), fvs) } @@ -241,7 +242,6 @@ rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann rn_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl rn_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo - rn_prag (XHsPragE x) = noExtCon x rnExpr (HsLam x matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches @@ -289,7 +289,6 @@ ; return (L l (Present x e'), fvs) } rnTupArg (L l (Missing _)) = return (L l (Missing noExtField) , emptyFVs) - rnTupArg (L _ (XTupArg nec)) = noExtCon nec rnExpr (ExplicitSum x alt arity expr) = do { (expr', fvs) <- rnLExpr expr @@ -354,7 +353,7 @@ For the static form we check that it is not used in splices. We also collect the free variables of the term which come from -this module. See Note [Grand plan for static forms] in StaticPtrTable. +this module. See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. -} rnExpr e@(HsStatic _ expr) = do @@ -398,7 +397,7 @@ -- HsWrap ---------------------- --- See Note [Parsing sections] in Parser.y +-- See Note [Parsing sections] in GHC.Parser rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnSection section@(SectionR x op expr) = do { (op', fvs_op) <- rnLExpr op @@ -441,7 +440,6 @@ ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd', fvCmd `plusFV` cmd_fvs) } - rnCmdTop' (XCmdTop nec) = noExtCon nec rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) rnLCmd = wrapLocFstM rnCmd @@ -457,7 +455,7 @@ select_arrow_scope tc = case ho of HsHigherOrderApp -> tc HsFirstOrderApp -> escapeArrowScope tc - -- See Note [Escaping the arrow scope] in TcRnTypes + -- See Note [Escaping the arrow scope] in GHC.Tc.Types -- Before renaming 'arrow', use the environment of the enclosing -- proc for the (-<) case. -- Local bindings, inside the enclosing proc, are not in scope @@ -497,6 +495,10 @@ ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } +rnCmd (HsCmdLamCase x matches) + = do { (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches + ; return (HsCmdLamCase x new_matches, ms_fvs) } + rnCmd (HsCmdIf x _ p b1 b2) = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLCmd b1 @@ -514,8 +516,6 @@ rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) ; return ( HsCmdDo x (L l stmts'), fvs ) } -rnCmd (XCmd nec) = noExtCon nec - --------------------------------------------------- type CmdNeeds = FreeVars -- Only inhabitants are -- appAName, choiceAName, loopAName @@ -544,8 +544,8 @@ methodNamesCmd (HsCmdCase _ _ matches) = methodNamesMatch matches `addOneFV` choiceAName - -methodNamesCmd (XCmd nec) = noExtCon nec +methodNamesCmd (HsCmdLamCase _ matches) + = methodNamesMatch matches `addOneFV` choiceAName --methodNamesCmd _ = emptyFVs -- Other forms can't occur in commands, but it's not convenient @@ -558,20 +558,16 @@ = plusFVs (map do_one ms) where do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss - do_one (L _ (XMatch nec)) = noExtCon nec -methodNamesMatch (XMatchGroup nec) = noExtCon nec ------------------------------------------------- -- gaw 2004 methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss) -methodNamesGRHSs (XGRHSs nec) = noExtCon nec ------------------------------------------------- methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs -methodNamesGRHS (L _ (XGRHS nec)) = noExtCon nec --------------------------------------------------- methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars @@ -584,7 +580,7 @@ methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesStmt (LastStmt _ cmd _ _) = methodNamesLCmd cmd methodNamesStmt (BodyStmt _ cmd _ _) = methodNamesLCmd cmd -methodNamesStmt (BindStmt _ _ cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (BindStmt _ _ cmd) = methodNamesLCmd cmd methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName methodNamesStmt (LetStmt {}) = emptyFVs @@ -593,7 +589,6 @@ methodNamesStmt ApplicativeStmt{} = emptyFVs -- ParStmt and TransStmt can't occur in commands, but it's not -- convenient to error here so we just do what's convenient -methodNamesStmt (XStmtLR nec) = noExtCon nec {- ************************************************************************ @@ -772,8 +767,11 @@ statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an exhaustive list). How we deal with pattern match failure is context-dependent. - * In the case of list comprehensions and pattern guards we don't need any 'fail' - function; the desugarer ignores the fail function field of 'BindStmt' entirely. + * In the case of list comprehensions and pattern guards we don't need any + 'fail' function; the desugarer ignores the fail function of 'BindStmt' + entirely. So, for list comprehensions, the fail function is set to 'Nothing' + for clarity. + * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo expressions) we want pattern match failure to be desugared to the appropriate 'fail' function (either that of Monad or MonadFail, depending on whether @@ -824,7 +822,7 @@ ; return ( ([(L loc (BodyStmt noExtField body' then_op guard_op), fv_expr)] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } -rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside +rnStmt ctxt rnBody (L loc (BindStmt _ pat body)) thing_inside = do { (body', fv_expr) <- rnBody body -- The binders do not scope over the expression ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName @@ -833,8 +831,8 @@ ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside (collectPatBinders pat') - ; return (( [( L loc (BindStmt noExtField pat' body' bind_op fail_op) - , fv_expr )] + ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op } + ; return (( [( L loc (BindStmt xbsrn pat' body'), fv_expr )] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} -- fv_expr shouldn't really be filtered by the rnPatsAndThen @@ -923,9 +921,6 @@ rnStmt _ _ (L _ ApplicativeStmt{}) _ = panic "rnStmt: ApplicativeStmt" -rnStmt _ _ (L _ (XStmtLR nec)) _ = - noExtCon nec - rnParallelStmts :: forall thing. HsStmtContext GhcRn -> SyntaxExpr GhcRn -> [ParStmtBlock GhcPs GhcPs] @@ -955,7 +950,6 @@ ; let seg' = ParStmtBlock x stmts' used_bndrs return_op ; return ((seg':segs', thing), fvs) } - rn_segs _ _ (XParStmtBlock nec:_) = noExtCon nec cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" @@ -1093,11 +1087,11 @@ rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a)) = return [(L loc (LastStmt noExtField body noret a), emptyFVs)] -rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b)) +rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body)) = do -- should the ctxt be MDo instead? (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat - return [(L loc (BindStmt noExtField pat' body a b), fv_pat)] + return [(L loc (BindStmt noExtField pat' body), fv_pat)] rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {})))) = failWith (badIpBinds (text "an mdo expression") binds) @@ -1124,10 +1118,6 @@ rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _)))) = panic "rn_rec_stmt LetStmt EmptyLocalBinds" -rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec)))) - = noExtCon nec -rn_rec_stmt_lhs _ (L _ (XStmtLR nec)) - = noExtCon nec rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv -> [LStmt GhcPs body] @@ -1164,7 +1154,7 @@ ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] } -rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat) +rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body), fv_pat) = do { (body', fv_expr) <- rnBody body ; (bind_op, fvs1) <- lookupSyntax bindMName @@ -1172,8 +1162,9 @@ ; let bndrs = mkNameSet (collectPatBinders pat') fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 + ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op } ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, - L loc (BindStmt noExtField pat' body' bind_op fail_op))] } + L loc (BindStmt xbsrn pat' body'))] } rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _) = failWith (badIpBinds (text "an mdo expression") binds) @@ -1195,18 +1186,12 @@ rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) -rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))), _) - = noExtCon nec - rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _) = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _) = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) -rn_rec_stmt _ _ (L _ (XStmtLR nec), _) - = noExtCon nec - rn_rec_stmts :: Outputable (body GhcPs) => (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> [Name] @@ -1507,7 +1492,7 @@ other form of expression. The only crux is that the typechecker has to be aware of the special ApplicativeDo statements in the do-notation, and typecheck them appropriately. - Relevant module: TcMatches + Relevant module: GHC.Tc.Gen.Match * Desugarer: Any do-block which contains applicative statements is desugared as outlined above, to use the Applicative combinators. @@ -1671,27 +1656,27 @@ -- In the spec, but we do it here rather than in the desugarer, -- because we need the typechecker to typecheck the <$> form rather than -- the bind form, which would give rise to a Monad constraint. -stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op), _)) +stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt xbs pat rhs), _)) tail _tail_fvs | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail -- See Note [ApplicativeDo and strict patterns] = mkApplicativeStmt ctxt [ApplicativeArgOne - { xarg_app_arg_one = noExtField + { xarg_app_arg_one = xbsrn_failOp xbs , app_arg_pattern = pat , arg_expr = rhs , is_body_stmt = False - , fail_operator = fail_op}] + }] False tail' stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_)) tail _tail_fvs | (False,tail') <- needJoin monad_names tail = mkApplicativeStmt ctxt [ApplicativeArgOne - { xarg_app_arg_one = noExtField + { xarg_app_arg_one = Nothing , app_arg_pattern = nlWildPatName , arg_expr = rhs , is_body_stmt = True - , fail_operator = noSyntaxExpr}] False tail' + }] False tail' stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs = return (s : tail, emptyNameSet) @@ -1714,21 +1699,19 @@ (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail' return (stmts, unionNameSets (fvs:fvss)) where - stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _)) + stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt xbs pat exp), _)) = return (ApplicativeArgOne - { xarg_app_arg_one = noExtField + { xarg_app_arg_one = xbsrn_failOp xbs , app_arg_pattern = pat , arg_expr = exp , is_body_stmt = False - , fail_operator = fail_op }, emptyFVs) stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) = return (ApplicativeArgOne - { xarg_app_arg_one = noExtField + { xarg_app_arg_one = Nothing , app_arg_pattern = nlWildPatName , arg_expr = exp , is_body_stmt = True - , fail_operator = noSyntaxExpr }, emptyFVs) stmtTreeArg ctxt tail_fvs tree = do let stmts = flattenStmtTree tree @@ -1805,7 +1788,7 @@ pvars = mkNameSet (collectStmtBinders (unLoc stmt)) isStrictPatternBind :: ExprLStmt GhcRn -> Bool - isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat + isStrictPatternBind (L _ (BindStmt _ pat _)) = isStrictPattern pat isStrictPatternBind _ = False {- @@ -1847,14 +1830,12 @@ ListPat{} -> True TuplePat{} -> True SumPat{} -> True - ConPatIn{} -> True - ConPatOut{} -> True + ConPat{} -> True LitPat{} -> True NPat{} -> True NPlusKPat{} -> True SplicePat{} -> True - CoPat{} -> panic "isStrictPattern: CoPat" - XPat nec -> noExtCon nec + XPat{} -> panic "isStrictPattern: XPat" {- Note [ApplicativeDo and refutable patterns] @@ -1907,9 +1888,9 @@ -- strict patterns though; splitSegments expects that if we return Just -- then we have actually done some splitting. Otherwise it will go into -- an infinite loop (#14163). - go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest) + go lets indep bndrs ((L loc (BindStmt xbs pat body), fvs): rest) | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat) - = go lets ((L loc (BindStmt noExtField pat body bind_op fail_op), fvs) : indep) + = go lets ((L loc (BindStmt xbs pat body), fvs) : indep) bndrs' rest where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat) -- If we encounter a LetStmt that doesn't depend on a BindStmt in this @@ -2065,7 +2046,6 @@ pprStmtCat (RecStmt {}) = text "rec" pprStmtCat (ParStmt {}) = text "parallel" pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt" -pprStmtCat (XStmtLR nec) = noExtCon nec ------------ emptyInvalid :: Validity -- Payload is the empty document @@ -2131,7 +2111,6 @@ RecStmt {} -> emptyInvalid LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) ApplicativeStmt {} -> emptyInvalid - XStmtLR nec -> noExtCon nec --------- checkTupleSection :: [LHsTupArg GhcPs] -> RnM () @@ -2156,16 +2135,16 @@ monadFailOp :: LPat GhcPs -> HsStmtContext GhcRn - -> RnM (SyntaxExpr GhcRn, FreeVars) + -> RnM (FailOperator GhcRn, FreeVars) monadFailOp pat ctxt -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.) -- we should not need to fail. - | isIrrefutableHsPat pat = return (noSyntaxExpr, emptyFVs) + | isIrrefutableHsPat pat = return (Nothing, emptyFVs) -- For non-monadic contexts (e.g. guard patterns, list - -- comprehensions, etc.) we should not need to fail. See Note - -- [Failing pattern matches in Stmts] - | not (isMonadFailStmtContext ctxt) = return (noSyntaxExpr, emptyFVs) + -- comprehensions, etc.) we should not need to fail, or failure is handled in + -- a different way. See Note [Failing pattern matches in Stmts]. + | not (isMonadFailStmtContext ctxt) = return (Nothing, emptyFVs) | otherwise = getMonadFailOp @@ -2193,11 +2172,12 @@ (rather than plain 'fail') for the 'fail' operation. This is done in 'getMonadFailOp'. -} -getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op +getMonadFailOp :: RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op getMonadFailOp = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags - ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings + ; (fail, fvs) <- reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings + ; return (Just fail, fvs) } where reallyGetMonadFailOp rebindableSyntax overloadedStrings diff --git a/compiler/GHC/Rename/Expr.hs-boot b/compiler/GHC/Rename/Expr.hs-boot --- a/compiler/GHC/Rename/Expr.hs-boot +++ b/compiler/GHC/Rename/Expr.hs-boot @@ -2,9 +2,9 @@ import GHC.Types.Name import GHC.Hs import GHC.Types.Name.Set ( FreeVars ) -import TcRnTypes +import GHC.Tc.Types import GHC.Types.SrcLoc ( Located ) -import Outputable ( Outputable ) +import GHC.Utils.Outputable ( Outputable ) rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars) 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 @@ -16,21 +16,21 @@ ) where -import GhcPrelude +import GHC.Prelude import GHC.Iface.Load import GHC.Hs import GHC.Types.Name.Reader import GHC.Driver.Types -import TcRnMonad +import GHC.Tc.Utils.Monad import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Types.Module +import GHC.Unit.Module import GHC.Types.Basic ( Fixity(..), FixityDirection(..), minPrecedence, defaultFixity, SourceText(..) ) import GHC.Types.SrcLoc -import Outputable -import Maybes +import GHC.Utils.Outputable +import GHC.Data.Maybe import Data.List import Data.Function ( on ) import GHC.Rename.Unbound @@ -216,4 +216,3 @@ format_ambig (elt, fix) = hang (ppr fix) 2 (pprNameProvenance elt) -lookupFieldFixityRn (XAmbiguousFieldOcc nec) = noExtCon nec diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Rename/HsType.hs @@ -0,0 +1,1771 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Rename.HsType ( + -- Type related stuff + rnHsType, rnLHsType, rnLHsTypes, rnContext, + rnHsKind, rnLHsKind, rnLHsTypeArgs, + rnHsSigType, rnHsWcType, + HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped, + newTyVarNameRn, + rnConDeclFields, + rnLTyVar, + + -- Precence related stuff + mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, + checkPrecMatch, checkSectionPrec, + + -- Binding related stuff + bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs, + bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames, + extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars, + extractHsTysRdrTyVarsDups, + extractRdrKindSigVars, extractDataDefnKindVars, + extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup, + nubL, elemRdr + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType ) + +import GHC.Driver.Session +import GHC.Hs +import GHC.Rename.Doc ( rnLHsDoc, rnMbLHsDoc ) +import GHC.Rename.Env +import GHC.Rename.Utils ( HsDocContext(..), withHsDocContext, mapFvRn + , pprHsDocContext, bindLocalNamesFV, typeAppErr + , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames ) +import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn + , lookupTyFixityRn ) +import GHC.Tc.Utils.Monad +import GHC.Types.Name.Reader +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim ( funTyConName ) +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Types.Name.Set +import GHC.Types.FieldLabel + +import GHC.Utils.Misc +import GHC.Data.List.SetOps ( deleteBys ) +import GHC.Types.Basic ( compareFixity, funTyFixity, negateFixity + , Fixity(..), FixityDirection(..), LexicalFixity(..) + , TypeOrKind(..) ) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Maybe +import qualified GHC.LanguageExtensions as LangExt + +import Data.List ( nubBy, partition, (\\) ) +import Control.Monad ( unless, when ) + +#include "HsVersions.h" + +{- +These type renamers are in a separate module, rather than in (say) GHC.Rename.Module, +to break several loop. + +********************************************************* +* * + HsSigWcType (i.e with wildcards) +* * +********************************************************* +-} + +data HsSigWcTypeScoping = AlwaysBind + -- ^ Always bind any free tyvars of the given type, + -- regardless of whether we have a forall at the top + | BindUnlessForall + -- ^ Unless there's forall at the top, do the same + -- thing as 'AlwaysBind' + | NeverBind + -- ^ Never bind any free tyvars + +rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs + -> RnM (LHsSigWcType GhcRn, FreeVars) +rnHsSigWcType scoping doc sig_ty + = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' -> + return (sig_ty', emptyFVs) + +rnHsSigWcTypeScoped :: HsSigWcTypeScoping + -- AlwaysBind: for pattern type sigs and rules we /do/ want + -- to bring those type variables into scope, even + -- if there's a forall at the top which usually + -- stops that happening + -- e.g \ (x :: forall a. a-> b) -> e + -- Here we do bring 'b' into scope + -> HsDocContext -> LHsSigWcType GhcPs + -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +-- Used for +-- - Signatures on binders in a RULE +-- - Pattern type signatures +-- Wildcards are allowed +-- type signatures on binders only allowed with ScopedTypeVariables +rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside + = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables + ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty) + ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside + } + +rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs + -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +-- rn_hs_sig_wc_type is used for source-language type signatures +rn_hs_sig_wc_type scoping ctxt + (HsWC { hswc_body = HsIB { hsib_body = hs_ty }}) + thing_inside + = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty + ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars + ; let nwc_rdrs = nubL nwc_rdrs' + bind_free_tvs = case scoping of + AlwaysBind -> True + BindUnlessForall -> not (isLHsForAllTy hs_ty) + NeverBind -> False + ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars -> + do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty + ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' } + ib_ty' = HsIB { hsib_ext = vars + , hsib_body = hs_ty' } + ; (res, fvs2) <- thing_inside sig_ty' + ; return (res, fvs1 `plusFV` fvs2) } } + +rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) +rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) + = do { free_vars <- extractFilteredRdrTyVars hs_ty + ; (nwc_rdrs, _) <- partition_nwcs free_vars + ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty + ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' } + ; return (sig_ty', fvs) } + +rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs + -> RnM ([Name], LHsType GhcRn, FreeVars) +rnWcBody ctxt nwc_rdrs hs_ty + = do { nwcs <- mapM newLocalBndrRn nwc_rdrs + ; let env = RTKE { rtke_level = TypeLevel + , rtke_what = RnTypeBody + , rtke_nwcs = mkNameSet nwcs + , rtke_ctxt = ctxt } + ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $ + rn_lty env hs_ty + ; return (nwcs, hs_ty', fvs) } + where + rn_lty env (L loc hs_ty) + = setSrcSpan loc $ + do { (hs_ty', fvs) <- rn_ty env hs_ty + ; return (L loc hs_ty', fvs) } + + rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) + -- A lot of faff just to allow the extra-constraints wildcard to appear + rn_ty env hs_ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs + , hst_body = hs_body }) + = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' -> + do { (hs_body', fvs) <- rn_lty env hs_body + ; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField + , hst_bndrs = tvs', hst_body = hs_body' } + , fvs) } + + rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt + , hst_body = hs_ty }) + | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt + , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last + = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 + ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1 + ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)] + ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty + ; return (HsQualTy { hst_xqual = noExtField + , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } + , fvs1 `plusFV` fvs2) } + + | otherwise + = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt + ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty + ; return (HsQualTy { hst_xqual = noExtField + , hst_ctxt = L cx hs_ctxt' + , hst_body = hs_ty' } + , fvs1 `plusFV` fvs2) } + + rn_ty env hs_ty = rnHsTyKi env hs_ty + + rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint }) + + +checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM () +-- Rename the extra-constraint spot in a type signature +-- (blah, _) => type +-- Check that extra-constraints are allowed at all, and +-- if so that it's an anonymous wildcard +checkExtraConstraintWildCard env hs_ctxt + = checkWildCard env mb_bad + where + mb_bad | not (extraConstraintWildCardsAllowed env) + = Just base_msg + -- Currently, we do not allow wildcards in their full glory in + -- standalone deriving declarations. We only allow a single + -- extra-constraints wildcard à la: + -- + -- deriving instance _ => Eq (Foo a) + -- + -- i.e., we don't support things like + -- + -- deriving instance (Eq a, _) => Eq (Foo a) + | DerivDeclCtx {} <- rtke_ctxt env + , not (null hs_ctxt) + = Just deriv_decl_msg + | otherwise + = Nothing + + base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard + <+> text "not allowed" + + deriv_decl_msg + = hang base_msg + 2 (vcat [ text "except as the sole constraint" + , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ]) + +extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool +extraConstraintWildCardsAllowed env + = case rtke_ctxt env of + TypeSigCtx {} -> True + ExprWithTySigCtx {} -> True + DerivDeclCtx {} -> True + StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls + _ -> False + +-- | Finds free type and kind variables in a type, +-- without duplicates, and +-- without variables that are already in scope in LocalRdrEnv +-- NB: this includes named wildcards, which look like perfectly +-- ordinary type variables at this point +extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups +extractFilteredRdrTyVars hs_ty = filterInScopeM (extractHsTyRdrTyVars hs_ty) + +-- | Finds free type and kind variables in a type, +-- with duplicates, but +-- without variables that are already in scope in LocalRdrEnv +-- NB: this includes named wildcards, which look like perfectly +-- ordinary type variables at this point +extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups +extractFilteredRdrTyVarsDups hs_ty = filterInScopeM (extractHsTyRdrTyVarsDups hs_ty) + +-- | When the NamedWildCards extension is enabled, partition_nwcs +-- removes type variables that start with an underscore from the +-- FreeKiTyVars in the argument and returns them in a separate list. +-- When the extension is disabled, the function returns the argument +-- and empty list. See Note [Renaming named wild cards] +partition_nwcs :: FreeKiTyVars -> RnM ([Located RdrName], FreeKiTyVars) +partition_nwcs free_vars + = do { wildcards_enabled <- xoptM LangExt.NamedWildCards + ; return $ + if wildcards_enabled + then partition is_wildcard free_vars + else ([], free_vars) } + where + is_wildcard :: Located RdrName -> Bool + is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr)) + +{- Note [Renaming named wild cards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Identifiers starting with an underscore are always parsed as type variables. +It is only here in the renamer that we give the special treatment. +See Note [The wildcard story for types] in GHC.Hs.Types. + +It's easy! When we collect the implicitly bound type variables, ready +to bring them into scope, and NamedWildCards is on, we partition the +variables into the ones that start with an underscore (the named +wildcards) and the rest. Then we just add them to the hswc_wcs field +of the HsWildCardBndrs structure, and we are done. + + +********************************************************* +* * + HsSigtype (i.e. no wildcards) +* * +****************************************************** -} + +rnHsSigType :: HsDocContext + -> TypeOrKind + -> LHsSigType GhcPs + -> RnM (LHsSigType GhcRn, FreeVars) +-- Used for source-language type signatures +-- that cannot have wildcards +rnHsSigType ctx level (HsIB { hsib_body = hs_ty }) + = do { traceRn "rnHsSigType" (ppr hs_ty) + ; vars <- extractFilteredRdrTyVarsDups hs_ty + ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars -> + do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty + + ; return ( HsIB { hsib_ext = vars + , hsib_body = body' } + , fvs ) } } + +rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables + -- E.g. f :: forall a. a->b + -- we do not want to bring 'b' into scope, hence False + -- But f :: a -> b + -- we want to bring both 'a' and 'b' into scope + -> FreeKiTyVarsWithDups + -- Free vars of hs_ty (excluding wildcards) + -- May have duplicates, which is + -- checked here + -> ([Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnImplicitBndrs bind_free_tvs + fvs_with_dups + thing_inside + = do { let fvs = nubL fvs_with_dups + real_fvs | bind_free_tvs = fvs + | otherwise = [] + + ; traceRn "rnImplicitBndrs" $ + vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ] + + ; loc <- getSrcSpanM + ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_fvs + + ; bindLocalNamesFV vars $ + thing_inside vars } + +{- ****************************************************** +* * + LHsType and HsType +* * +****************************************************** -} + +{- +rnHsType is here because we call it from loadInstDecl, and I didn't +want a gratuitous knot. + +Note [QualTy in kinds] +~~~~~~~~~~~~~~~~~~~~~~ +I was wondering whether QualTy 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 QualTy must all be +equalities; or at least, any kinds with a class constraint are +uninhabited. +-} + +data RnTyKiEnv + = RTKE { rtke_ctxt :: HsDocContext + , rtke_level :: TypeOrKind -- Am I renaming a type or a kind? + , rtke_what :: RnTyKiWhat -- And within that what am I renaming? + , rtke_nwcs :: NameSet -- These are the in-scope named wildcards + } + +data RnTyKiWhat = RnTypeBody + | RnTopConstraint -- Top-level context of HsSigWcTypes + | RnConstraint -- All other constraints + +instance Outputable RnTyKiEnv where + ppr (RTKE { rtke_level = lev, rtke_what = what + , rtke_nwcs = wcs, rtke_ctxt = ctxt }) + = text "RTKE" + <+> braces (sep [ ppr lev, ppr what, ppr wcs + , pprHsDocContext ctxt ]) + +instance Outputable RnTyKiWhat where + ppr RnTypeBody = text "RnTypeBody" + ppr RnTopConstraint = text "RnTopConstraint" + ppr RnConstraint = text "RnConstraint" + +mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv +mkTyKiEnv cxt level what + = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet + , rtke_what = what, rtke_ctxt = cxt } + +isRnKindLevel :: RnTyKiEnv -> Bool +isRnKindLevel (RTKE { rtke_level = KindLevel }) = True +isRnKindLevel _ = False + +-------------- +rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) +rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty + +rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars) +rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys + +rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) +rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty + +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) +rnLHsTypeArg ctxt (HsValArg ty) + = do { (tys_rn, fvs) <- rnLHsType ctxt ty + ; return (HsValArg tys_rn, fvs) } +rnLHsTypeArg ctxt (HsTypeArg l ki) + = do { (kis_rn, fvs) <- rnLHsKind ctxt ki + ; return (HsTypeArg l kis_rn, fvs) } +rnLHsTypeArg _ (HsArgPar sp) + = return (HsArgPar sp, emptyFVs) + +rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs] + -> RnM ([LHsTypeArg GhcRn], FreeVars) +rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args + +-------------- +rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs + -> RnM (LHsContext GhcRn, FreeVars) +rnTyKiContext env (L loc cxt) + = do { traceRn "rncontext" (ppr cxt) + ; let env' = env { rtke_what = RnConstraint } + ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt + ; return (L loc cxt', fvs) } + +rnContext :: HsDocContext -> LHsContext GhcPs + -> RnM (LHsContext GhcRn, FreeVars) +rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta + +-------------- +rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) +rnLHsTyKi env (L loc ty) + = setSrcSpan loc $ + do { (ty', fvs) <- rnHsTyKi env ty + ; return (L loc ty', fvs) } + +rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) + +rnHsTyKi env ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars + , hst_body = tau }) + = do { checkPolyKinds env ty + ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty) + Nothing tyvars $ \ tyvars' -> + do { (tau', fvs) <- rnLHsTyKi env tau + ; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField + , hst_bndrs = tyvars' , hst_body = tau' } + , fvs) } } + +rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) + = do { checkPolyKinds env ty -- See Note [QualTy in kinds] + ; (ctxt', fvs1) <- rnTyKiContext env lctxt + ; (tau', fvs2) <- rnLHsTyKi env tau + ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt' + , hst_body = tau' } + , fvs1 `plusFV` fvs2) } + +rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) + = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ + unlessXOptM LangExt.PolyKinds $ addErr $ + withHsDocContext (rtke_ctxt env) $ + vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name) + , text "Perhaps you intended to use PolyKinds" ] + -- Any type variable at the kind level is illegal without the use + -- of PolyKinds (see #14710) + ; name <- rnTyVar env rdr_name + ; return (HsTyVar noExtField ip (L loc name), unitFV name) } + +rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) + = setSrcSpan (getLoc l_op) $ + do { (l_op', fvs1) <- rnHsTyOp env ty l_op + ; fix <- lookupTyFixityRn l_op' + ; (ty1', fvs2) <- rnLHsTyKi env ty1 + ; (ty2', fvs3) <- rnLHsTyKi env ty2 + ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExtField t1 l_op' t2) + (unLoc l_op') fix ty1' ty2' + ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } + +rnHsTyKi env (HsParTy _ ty) + = do { (ty', fvs) <- rnLHsTyKi env ty + ; return (HsParTy noExtField ty', fvs) } + +rnHsTyKi env (HsBangTy _ b ty) + = do { (ty', fvs) <- rnLHsTyKi env ty + ; return (HsBangTy noExtField b ty', fvs) } + +rnHsTyKi env ty@(HsRecTy _ flds) + = do { let ctxt = rtke_ctxt env + ; fls <- get_fields ctxt + ; (flds', fvs) <- rnConDeclFields ctxt fls flds + ; return (HsRecTy noExtField flds', fvs) } + where + get_fields (ConDeclCtx names) + = concatMapM (lookupConstructorFields . unLoc) names + get_fields _ + = do { addErr (hang (text "Record syntax is illegal here:") + 2 (ppr ty)) + ; return [] } + +rnHsTyKi env (HsFunTy _ ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi env ty1 + -- Might find a for-all as the arg of a function type + ; (ty2', fvs2) <- rnLHsTyKi env ty2 + -- Or as the result. This happens when reading Prelude.hi + -- when we find return :: forall m. Monad m -> forall a. a -> m a + + -- Check for fixity rearrangements + ; res_ty <- mkHsOpTyRn (HsFunTy noExtField) funTyConName funTyFixity ty1' ty2' + ; return (res_ty, fvs1 `plusFV` fvs2) } + +rnHsTyKi env listTy@(HsListTy _ ty) + = do { data_kinds <- xoptM LangExt.DataKinds + ; when (not data_kinds && isRnKindLevel env) + (addErr (dataKindsErr env listTy)) + ; (ty', fvs) <- rnLHsTyKi env ty + ; return (HsListTy noExtField ty', fvs) } + +rnHsTyKi env t@(HsKindSig _ ty k) + = do { checkPolyKinds env t + ; 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 + ; return (HsKindSig noExtField ty' k', lhs_fvs `plusFV` sig_fvs) } + +-- Unboxed tuples are allowed to have poly-typed arguments. These +-- sometimes crop up as a result of CPR worker-wrappering dictionaries. +rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys) + = do { data_kinds <- xoptM LangExt.DataKinds + ; when (not data_kinds && isRnKindLevel env) + (addErr (dataKindsErr env tupleTy)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsTupleTy noExtField tup_con tys', fvs) } + +rnHsTyKi env sumTy@(HsSumTy _ tys) + = do { data_kinds <- xoptM LangExt.DataKinds + ; when (not data_kinds && isRnKindLevel env) + (addErr (dataKindsErr env sumTy)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsSumTy noExtField tys', fvs) } + +-- Ensure that a type-level integer is nonnegative (#8306, #8412) +rnHsTyKi env tyLit@(HsTyLit _ t) + = do { data_kinds <- xoptM LangExt.DataKinds + ; unless data_kinds (addErr (dataKindsErr env tyLit)) + ; when (negLit t) (addErr negLitErr) + ; checkPolyKinds env tyLit + ; return (HsTyLit noExtField t, emptyFVs) } + where + negLit (HsStrTy _ _) = False + negLit (HsNumTy _ i) = i < 0 + negLitErr = 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) + = do { kind_app <- xoptM LangExt.TypeApplications + ; unless kind_app (addErr (typeAppErr "kind" k)) + ; (ty', fvs1) <- rnLHsTyKi env ty + ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k + ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) } + +rnHsTyKi env t@(HsIParamTy _ n ty) + = do { notInKinds env t + ; (ty', fvs) <- rnLHsTyKi env ty + ; return (HsIParamTy noExtField n ty', fvs) } + +rnHsTyKi _ (HsStarTy _ isUni) + = return (HsStarTy noExtField isUni, emptyFVs) + +rnHsTyKi _ (HsSpliceTy _ sp) + = rnSpliceType sp + +rnHsTyKi env (HsDocTy _ ty haddock_doc) + = do { (ty', fvs) <- rnLHsTyKi env ty + ; haddock_doc' <- rnLHsDoc haddock_doc + ; return (HsDocTy noExtField ty' haddock_doc', fvs) } + +rnHsTyKi _ (XHsType (NHsCoreTy ty)) + = return (XHsType (NHsCoreTy ty), emptyFVs) + -- The emptyFVs probably isn't quite right + -- but I don't think it matters + +rnHsTyKi env ty@(HsExplicitListTy _ ip tys) + = do { checkPolyKinds env ty + ; data_kinds <- xoptM LangExt.DataKinds + ; unless data_kinds (addErr (dataKindsErr env ty)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsExplicitListTy noExtField ip tys', fvs) } + +rnHsTyKi env ty@(HsExplicitTupleTy _ tys) + = do { checkPolyKinds env ty + ; data_kinds <- xoptM LangExt.DataKinds + ; unless data_kinds (addErr (dataKindsErr env ty)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsExplicitTupleTy noExtField tys', fvs) } + +rnHsTyKi env (HsWildCardTy _) + = do { checkAnonWildCard env + ; return (HsWildCardTy noExtField, emptyFVs) } + +-------------- +rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name +rnTyVar env rdr_name + = do { name <- lookupTypeOccRn rdr_name + ; checkNamedWildCard env name + ; return name } + +rnLTyVar :: Located RdrName -> RnM (Located Name) +-- Called externally; does not deal with wildcards +rnLTyVar (L loc rdr_name) + = do { tyvar <- lookupTypeOccRn rdr_name + ; return (L loc tyvar) } + +-------------- +rnHsTyOp :: Outputable a + => RnTyKiEnv -> a -> Located RdrName + -> RnM (Located Name, FreeVars) +rnHsTyOp env overall_ty (L loc op) + = do { ops_ok <- xoptM LangExt.TypeOperators + ; op' <- rnTyVar env op + ; unless (ops_ok || op' `hasKey` eqTyConKey) $ + addErr (opTyErr op overall_ty) + ; let l_op' = L loc op' + ; return (l_op', unitFV op') } + +-------------- +notAllowed :: SDoc -> SDoc +notAllowed doc + = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed") + +checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM () +checkWildCard env (Just doc) + = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))] +checkWildCard _ Nothing + = return () + +checkAnonWildCard :: RnTyKiEnv -> RnM () +-- Report an error if an anonymous wildcard is illegal here +checkAnonWildCard env + = checkWildCard env mb_bad + where + mb_bad :: Maybe SDoc + mb_bad | not (wildCardsAllowed env) + = Just (notAllowed pprAnonWildCard) + | otherwise + = case rtke_what env of + RnTypeBody -> Nothing + RnTopConstraint -> Just constraint_msg + RnConstraint -> Just constraint_msg + + constraint_msg = hang + (notAllowed pprAnonWildCard <+> text "in a constraint") + 2 hint_msg + hint_msg = vcat [ text "except as the last top-level constraint of a type signature" + , nest 2 (text "e.g f :: (Eq a, _) => blah") ] + +checkNamedWildCard :: RnTyKiEnv -> Name -> RnM () +-- Report an error if a named wildcard is illegal here +checkNamedWildCard env name + = checkWildCard env mb_bad + where + mb_bad | not (name `elemNameSet` rtke_nwcs env) + = Nothing -- Not a wildcard + | not (wildCardsAllowed env) + = Just (notAllowed (ppr name)) + | otherwise + = case rtke_what env of + RnTypeBody -> Nothing -- Allowed + RnTopConstraint -> Nothing -- Allowed; e.g. + -- f :: (Eq _a) => _a -> Int + -- g :: (_a, _b) => T _a _b -> Int + -- The named tyvars get filled in from elsewhere + RnConstraint -> Just constraint_msg + constraint_msg = notAllowed (ppr name) <+> text "in a constraint" + +wildCardsAllowed :: RnTyKiEnv -> Bool +-- ^ In what contexts are wildcards permitted +wildCardsAllowed env + = case rtke_ctxt env of + TypeSigCtx {} -> True + TypBrCtx {} -> True -- Template Haskell quoted type + SpliceTypeCtx {} -> True -- Result of a Template Haskell splice + ExprWithTySigCtx {} -> True + PatCtx {} -> True + RuleCtx {} -> True + FamPatCtx {} -> True -- Not named wildcards though + GHCiCtx {} -> True + HsTypeCtx {} -> True + StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls + _ -> False + + + +--------------- +-- | Ensures either that we're in a type or that -XPolyKinds is set +checkPolyKinds :: Outputable ty + => RnTyKiEnv + -> ty -- ^ type + -> RnM () +checkPolyKinds env ty + | isRnKindLevel env + = do { polykinds <- xoptM LangExt.PolyKinds + ; unless polykinds $ + addErr (text "Illegal kind:" <+> ppr ty $$ + text "Did you mean to enable PolyKinds?") } +checkPolyKinds _ _ = return () + +notInKinds :: Outputable ty + => RnTyKiEnv + -> ty + -> RnM () +notInKinds env ty + | isRnKindLevel env + = addErr (text "Illegal kind:" <+> ppr ty) +notInKinds _ _ = return () + +{- ***************************************************** +* * + Binding type variables +* * +***************************************************** -} + +bindSigTyVarsFV :: [Name] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +-- Used just before renaming the defn of a function +-- with a separate type signature, to bring its tyvars into scope +-- With no -XScopedTypeVariables, this is a no-op +bindSigTyVarsFV tvs thing_inside + = do { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside + else + bindLocalNamesFV tvs thing_inside } + +-- | Simply bring a bunch of RdrNames into scope. No checking for +-- validity, at all. The binding location is taken from the location +-- on each name. +bindLRdrNames :: [Located RdrName] + -> ([Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindLRdrNames rdrs thing_inside + = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs + ; bindLocalNamesFV var_names $ + thing_inside var_names } + +--------------- +bindHsQTyVars :: forall a b. + HsDocContext + -> Maybe SDoc -- Just d => check for unused tvs + -- d is a phrase like "in the type ..." + -> Maybe a -- Just _ => an associated type decl + -> [Located RdrName] -- Kind variables from scope, no dups + -> (LHsQTyVars GhcPs) + -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars)) + -- The Bool is True <=> 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 + -> RnM (b, FreeVars) + +-- See Note [bindHsQTyVars examples] +-- (a) Bring kind variables into scope +-- both (i) passed in body_kv_occs +-- and (ii) mentioned in the kinds of hsq_bndrs +-- (b) Bring type variables into scope +-- +bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside + = do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs + bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs + + ; let -- See Note [bindHsQTyVars examples] for what + -- all these various things are doing + bndrs, kv_occs, implicit_kvs :: [Located RdrName] + bndrs = map hsLTyVarLocName hs_tv_bndrs + kv_occs = nubL (bndr_kv_occs ++ body_kv_occs) + -- Make sure to list the binder kvs before the + -- body kvs, as mandated by + -- Note [Ordering of implicit variables] + implicit_kvs = filter_occs bndrs kv_occs + del = deleteBys eqLocated + all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs) + + ; traceRn "checkMixedVars3" $ + vcat [ text "kv_occs" <+> ppr kv_occs + , text "bndrs" <+> ppr hs_tv_bndrs + , text "bndr_kv_occs" <+> ppr bndr_kv_occs + , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs) + ] + + ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs + + ; bindLocalNamesFV implicit_kv_nms $ + bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs -> + do { 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 } } + + where + filter_occs :: [Located RdrName] -- Bound here + -> [Located RdrName] -- Potential implicit binders + -> [Located RdrName] -- Final implicit binders + -- Filter out any potential implicit binders that are either + -- already in scope, or are explicitly bound in the same HsQTyVars + filter_occs bndrs occs + = filterOut is_in_scope occs + where + is_in_scope locc = locc `elemRdr` bndrs + +{- Note [bindHsQTyVars examples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + data T k (a::k1) (b::k) :: k2 -> k1 -> * + +Then: + hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables + bndrs = [k,a,b] + + bndr_kv_occs = [k,k1], kind variables free in kind signatures + of hs_tv_bndrs + + body_kv_occs = [k2,k1], kind variables free in the + result kind signature + + implicit_kvs = [k1,k2], kind variables free in kind signatures + of hs_tv_bndrs, and not bound by bndrs + +* We want to quantify add implicit bindings for implicit_kvs + +* If implicit_body_kvs is non-empty, then there is a kind variable + mentioned in the kind signature that is not bound "on the left". + That's one of the rules for a CUSK, so we pass that info on + as the second argument to thing_inside. + +* Order is not important in these lists. All we are doing is + bring Names into scope. + +Finally, you may wonder why filter_occs removes in-scope variables +from bndr/body_kv_occs. How can anything be in scope? Answer: +HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax +ConDecls + data T a = forall (b::k). MkT a b +The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire +ConDecl. Hence the local RdrEnv may be non-empty and we must filter +out 'a' from the free vars. (Mind you, in this situation all the +implicit kind variables are bound at the data type level, so there +are none to bind in the ConDecl, so there are no implicitly bound +variables at all. + +Note [Kind variable scoping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + data T (a :: k) k = ... +we report "k is out of scope" for (a::k). Reason: k is not brought +into scope until the explicit k-binding that follows. It would be +terribly confusing to bring into scope an /implicit/ k for a's kind +and a distinct, shadowing explicit k that follows, something like + data T {k1} (a :: k1) k = ... + +So the rule is: + + the implicit binders never include any + of the explicit binders in the group + +Note that in the denerate case + data T (a :: a) = blah +we get a complaint the second 'a' is not in scope. + +That applies to foralls too: e.g. + forall (a :: k) k . blah + +But if the foralls are split, we treat the two groups separately: + forall (a :: k). forall k. blah +Here we bring into scope an implicit k, which is later shadowed +by the explicit k. + +In implementation terms + +* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete + the binders {a,k}, and so end with no implicit binders. Then we + rename the binders left-to-right, and hence see that 'k' is out of + scope in the kind of 'a'. + +* Similarly in extract_hs_tv_bndrs + +Note [Variables used as both types and kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We bind the type variables tvs, and kvs is the set of free variables of the +kinds in the scope of the binding. Here is one typical example: + + forall a b. a -> (b::k) -> (c::a) + +Here, tvs will be {a,b}, and kvs {k,a}. + +We must make sure that kvs includes all of variables in the kinds of type +variable bindings. For instance: + + forall k (a :: k). Proxy a + +If we only look in the body of the `forall` type, we will mistakenly conclude +that kvs is {}. But in fact, the type variable `k` is also used as a kind +variable in (a :: k), later in the binding. (This mistake lead to #14710.) +So tvs is {k,a} and kvs is {k}. + +NB: we do this only at the binding site of 'tvs'. +-} + +bindLHsTyVarBndrs :: HsDocContext + -> Maybe SDoc -- Just d => check for unused tvs + -- d is a phrase like "in the type ..." + -> Maybe a -- Just _ => an associated type decl + -> [LHsTyVarBndr GhcPs] -- User-written tyvars + -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside + = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) + ; checkDupRdrNames tv_names_w_loc + ; go tv_bndrs thing_inside } + where + tv_names_w_loc = map hsLTyVarLocName tv_bndrs + + go [] thing_inside = thing_inside [] + go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' -> + do { (res, fvs) <- go bs $ \ bs' -> + thing_inside (b' : bs') + ; warn_unused b' fvs + ; return (res, fvs) } + + warn_unused tv_bndr fvs = case mb_in_doc of + Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs + Nothing -> return () + +bindLHsTyVarBndr :: HsDocContext + -> Maybe a -- associated class + -> LHsTyVarBndr GhcPs + -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindLHsTyVarBndr _doc mb_assoc (L loc + (UserTyVar x + lrdr@(L lv _))) thing_inside + = do { nm <- newTyVarNameRn mb_assoc lrdr + ; bindLocalNamesFV [nm] $ + thing_inside (L loc (UserTyVar x (L lv nm))) } + +bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind)) + thing_inside + = do { sig_ok <- xoptM LangExt.KindSignatures + ; unless sig_ok (badKindSigErr doc kind) + ; (kind', fvs1) <- rnLHsKind doc kind + ; tv_nm <- newTyVarNameRn mb_assoc lrdr + ; (b, fvs2) <- bindLocalNamesFV [tv_nm] + $ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind')) + ; return (b, fvs1 `plusFV` fvs2) } + +newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name +newTyVarNameRn mb_assoc (L loc 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 + + _ -> newLocalBndrRn (L loc rdr) } +{- +********************************************************* +* * + ConDeclField +* * +********************************************************* + +When renaming a ConDeclField, we have to find the FieldLabel +associated with each field. But we already have all the FieldLabels +available (since they were brought into scope by +GHC.Rename.Names.getLocalNonValBinders), so we just take the list as an +argument, build a map and look them up. +-} + +rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs] + -> RnM ([LConDeclField GhcRn], FreeVars) +-- Also called from GHC.Rename.Module +-- No wildcards can appear in record fields +rnConDeclFields ctxt fls fields + = mapFvRn (rnField fl_env env) fields + where + env = mkTyKiEnv ctxt TypeLevel RnTypeBody + fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ] + +rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs + -> RnM (LConDeclField GhcRn, FreeVars) +rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) + = do { let new_names = map (fmap lookupField) names + ; (new_ty, fvs) <- rnLHsTyKi env ty + ; new_haddock_doc <- rnMbLHsDoc haddock_doc + ; return (L l (ConDeclField noExtField new_names new_ty new_haddock_doc) + , fvs) } + where + lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn + lookupField (FieldOcc _ (L lr rdr)) = + FieldOcc (flSelector fl) (L lr rdr) + where + lbl = occNameFS $ rdrNameOcc rdr + fl = expectJust "rnField" $ lookupFsEnv fl_env lbl + +{- +************************************************************************ +* * + Fixities and precedence parsing +* * +************************************************************************ + +@mkOpAppRn@ deals with operator fixities. The argument expressions +are assumed to be already correctly arranged. It needs the fixities +recorded in the OpApp nodes, because fixity info applies to the things +the programmer actually wrote, so you can't find it out from the Name. + +Furthermore, the second argument is guaranteed not to be another +operator application. Why? Because the parser parses all +operator applications left-associatively, EXCEPT negation, which +we need to handle specially. +Infix types are read in a *right-associative* way, so that + a `op` b `op` c +is always read in as + a `op` (b `op` c) + +mkHsOpTyRn rearranges where necessary. The two arguments +have already been renamed and rearranged. It's made rather tiresome +by the presence of ->, which is a separate syntactic construct. +-} + +--------------- +-- Building (ty1 `op1` (ty21 `op2` ty22)) +mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn + -> RnM (HsType GhcRn) + +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExtField ty21 op2 ty22)) + = do { fix2 <- lookupTyFixityRn op2 + ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 + (\t1 t2 -> HsOpTy noExtField t1 op2 t2) + (unLoc op2) fix2 ty21 ty22 loc2 } + +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22)) + = mk_hs_op_ty mk1 pp_op1 fix1 ty1 + (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2 + +mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment + = return (mk1 ty1 ty2) + +--------------- +mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn + -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan + -> RnM (HsType GhcRn) +mk_hs_op_ty mk1 op1 fix1 ty1 + mk2 op2 fix2 ty21 ty22 loc2 + | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2) + ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } + | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) + | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) + new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 + ; return (mk2 (noLoc new_ty) ty22) } + where + (nofix_error, associate_right) = compareFixity fix1 fix2 + + +--------------------------- +mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged + -> LHsExpr GhcRn -> Fixity -- Operator and fixity + -> LHsExpr GhcRn -- Right operand (not an OpApp, but might + -- be a NegApp) + -> RnM (HsExpr GhcRn) + +-- (e11 `op1` e12) `op2` e2 +mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 + | nofix_error + = do precParseErr (get_op op1,fix1) (get_op op2,fix2) + return (OpApp fix2 e1 op2 e2) + + | associate_right = do + new_e <- mkOpAppRn e12 op2 fix2 e2 + return (OpApp fix1 e11 op1 (L loc' new_e)) + where + loc'= combineLocs e12 e2 + (nofix_error, associate_right) = compareFixity fix1 fix2 + +--------------------------- +-- (- neg_arg) `op` e2 +mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 + | nofix_error + = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) + return (OpApp fix2 e1 op2 e2) + + | associate_right + = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 + return (NegApp noExtField (L loc' new_e) neg_name) + where + loc' = combineLocs neg_arg e2 + (nofix_error, associate_right) = compareFixity negateFixity fix2 + +--------------------------- +-- e1 `op` - neg_arg +mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right + | not associate_right -- We *want* right association + = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) + return (OpApp fix1 e1 op1 e2) + where + (_, associate_right) = compareFixity fix1 negateFixity + +--------------------------- +-- Default case +mkOpAppRn e1 op fix e2 -- Default case, no rearrangment + = ASSERT2( right_op_ok fix (unLoc e2), + ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 + ) + return (OpApp fix e1 op e2) + +---------------------------- + +-- | Name of an operator in an operator application or section +data OpName = NormalOp Name -- ^ A normal identifier + | NegateOp -- ^ Prefix negation + | UnboundOp OccName -- ^ An unbound indentifier + | RecFldOp (AmbiguousFieldOcc GhcRn) + -- ^ A (possibly ambiguous) 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 +get_op (L _ (HsVar _ n)) = NormalOp (unLoc n) +get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv +get_op (L _ (HsRecFld _ fld)) = RecFldOp fld +get_op other = pprPanic "get_op" (ppr other) + +-- Parser left-associates everything, but +-- derived instances may have correctly-associated things to +-- in the right operand. So we just check that the right operand is OK +right_op_ok :: Fixity -> HsExpr GhcRn -> Bool +right_op_ok fix1 (OpApp fix2 _ _ _) + = not error_please && associate_right + where + (error_please, associate_right) = compareFixity fix1 fix2 +right_op_ok _ _ + = True + +-- Parser initially makes negation bind more tightly than any other operator +-- And "deriving" code should respect this (use HsPar if not) +mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id) + -> RnM (HsExpr (GhcPass id)) +mkNegAppRn neg_arg neg_name + = ASSERT( not_op_app (unLoc neg_arg) ) + return (NegApp noExtField neg_arg neg_name) + +not_op_app :: HsExpr id -> Bool +not_op_app (OpApp {}) = False +not_op_app _ = True + +--------------------------- +mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged + -> LHsExpr GhcRn -> Fixity -- Operator and fixity + -> LHsCmdTop GhcRn -- Right operand (not an infix) + -> RnM (HsCmd GhcRn) + +-- (e11 `op1` e12) `op2` e2 +mkOpFormRn a1@(L loc + (HsCmdTop _ + (L _ (HsCmdArrForm x op1 f (Just fix1) + [a11,a12])))) + op2 fix2 a2 + | nofix_error + = do precParseErr (get_op op1,fix1) (get_op op2,fix2) + return (HsCmdArrForm x op2 f (Just fix2) [a1, a2]) + + | associate_right + = do new_c <- mkOpFormRn a12 op2 fix2 a2 + return (HsCmdArrForm noExtField op1 f (Just fix1) + [a11, L loc (HsCmdTop [] (L loc new_c))]) + -- TODO: locs are wrong + where + (nofix_error, associate_right) = compareFixity fix1 fix2 + +-- Default case +mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment + = return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2]) + + +-------------------------------------- +mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn + -> RnM (Pat GhcRn) + +mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p11 p12))) p2 + = do { fix1 <- lookupFixityRn (unLoc op1) + ; let (nofix_error, associate_right) = compareFixity fix1 fix2 + + ; if nofix_error then do + { precParseErr (NormalOp (unLoc op1),fix1) + (NormalOp (unLoc op2),fix2) + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = op2 + , pat_args = InfixCon p1 p2 + } + } + + else if associate_right then do + { new_p <- mkConOpPatRn op2 fix2 p12 p2 + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = op1 + , pat_args = InfixCon p11 (L loc new_p) + } + } + -- XXX loc right? + else return $ ConPat + { pat_con_ext = noExtField + , pat_con = op2 + , pat_args = InfixCon p1 p2 + } + } + +mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment + = ASSERT( not_op_pat (unLoc p2) ) + return $ ConPat + { pat_con_ext = noExtField + , pat_con = op + , pat_args = InfixCon p1 p2 + } + +not_op_pat :: Pat GhcRn -> Bool +not_op_pat (ConPat NoExtField _ (InfixCon _ _)) = False +not_op_pat _ = True + +-------------------------------------- +checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM () + -- Check precedence of a function binding written infix + -- eg a `op` b `C` c = ... + -- See comments with rnExpr (OpApp ...) about "deriving" + +checkPrecMatch op (MG { mg_alts = (L _ ms) }) + = mapM_ check ms + where + check (L _ (Match { m_pats = (L l1 p1) + : (L l2 p2) + : _ })) + = setSrcSpan (combineSrcSpans l1 l2) $ + do checkPrec op p1 False + checkPrec op p2 True + + check _ = return () + -- This can happen. Consider + -- a `op` True = ... + -- op = ... + -- The infix flag comes from the first binding of the group + -- but the second eqn has no args (an error, but not discovered + -- until the type checker). So we don't want to crash on the + -- second eqn. + +checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () +checkPrec op (ConPat NoExtField op1 (InfixCon _ _)) right = do + op_fix@(Fixity _ op_prec op_dir) <- lookupFixityRn op + op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1) + let + inf_ok = op1_prec > op_prec || + (op1_prec == op_prec && + (op1_dir == InfixR && op_dir == InfixR && right || + op1_dir == InfixL && op_dir == InfixL && not right)) + + info = (NormalOp op, op_fix) + info1 = (NormalOp (unLoc op1), op1_fix) + (infol, infor) = if right then (info, info1) else (info1, info) + unless inf_ok (precParseErr infol infor) + +checkPrec _ _ _ + = return () + +-- Check precedence of (arg op) or (op arg) respectively +-- If arg is itself an operator application, then either +-- (a) its precedence must be higher than that of op +-- (b) its precedency & associativity must be the same as that of op +checkSectionPrec :: FixityDirection -> HsExpr GhcPs + -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM () +checkSectionPrec direction section op arg + = case unLoc arg of + OpApp fix _ op' _ -> go_for_it (get_op op') fix + NegApp _ _ _ -> go_for_it NegateOp negateFixity + _ -> return () + where + op_name = get_op op + go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do + op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name + unless (op_prec < arg_prec + || (op_prec == arg_prec && direction == assoc)) + (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 (possibly ambiguous) record fields +-- (see #13132). +lookupFixityOp :: OpName -> RnM Fixity +lookupFixityOp (NormalOp n) = lookupFixityRn n +lookupFixityOp NegateOp = lookupFixityRn negateName +lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName u) +lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f + + +-- Precedence-related error messages + +precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM () +precParseErr op1@(n1,_) op2@(n2,_) + | is_unbound n1 || is_unbound n2 + = return () -- Avoid error cascade + | otherwise + = addErr $ hang (text "Precedence parsing error") + 4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"), + ppr_opfix op2, + text "in the same infix expression"]) + +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 $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "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))] + +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 +* * +***************************************************** -} + +unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc +unexpectedTypeSigErr ty + = hang (text "Illegal type signature:" <+> quotes (ppr ty)) + 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") + +badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () +badKindSigErr doc (L loc ty) + = setSrcSpan loc $ addErr $ + withHsDocContext doc $ + hang (text "Illegal kind signature:" <+> quotes (ppr ty)) + 2 (text "Perhaps you intended to use KindSignatures") + +dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc +dataKindsErr env thing + = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) + 2 (text "Perhaps you intended to use DataKinds") + where + pp_what | isRnKindLevel env = text "kind" + | otherwise = text "type" + +inTypeDoc :: HsType GhcPs -> SDoc +inTypeDoc ty = text "In the type" <+> quotes (ppr ty) + +warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM () +warnUnusedForAll in_doc (L loc tv) used_names + = whenWOptM Opt_WarnUnusedForalls $ + unless (hsTyVarName tv `elemNameSet` used_names) $ + addWarnAt (Reason Opt_WarnUnusedForalls) loc $ + vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) + , in_doc ] + +opTyErr :: Outputable a => RdrName -> a -> SDoc +opTyErr op overall_ty + = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty)) + 2 (text "Use TypeOperators to allow operators in types") + +{- +************************************************************************ +* * + Finding the free type variables of a (HsType RdrName) +* * +************************************************************************ + + +Note [Kind and type-variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type signature we may implicitly bind type/kind variables. For example: + * f :: a -> a + f = ... + Here we need to find the free type variables of (a -> a), + so that we know what to quantify + + * class C (a :: k) where ... + This binds 'k' in ..., as well as 'a' + + * f (x :: a -> [a]) = .... + Here we bind 'a' in .... + + * f (x :: T a -> T (b :: k)) = ... + Here we bind both 'a' and the kind variable 'k' + + * type instance F (T (a :: Maybe k)) = ...a...k... + Here we want to constrain the kind of 'a', and bind 'k'. + +To do that, we need to walk over a type and find its free type/kind variables. +We preserve the left-to-right order of each variable occurrence. +See Note [Ordering of implicit variables]. + +Clients of this code can remove duplicates with nubL. + +Note [Ordering of implicit variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the advent of -XTypeApplications, GHC makes promises about the ordering +of implicit variable quantification. Specifically, we offer that implicitly +quantified variables (such as those in const :: a -> b -> a, without a `forall`) +will occur in left-to-right order of first occurrence. Here are a few examples: + + const :: a -> b -> a -- forall a b. ... + f :: Eq a => b -> a -> a -- forall a b. ... contexts are included + + type a <-< b = b -> a + g :: a <-< b -- forall a b. ... type synonyms matter + + class Functor f where + fmap :: (a -> b) -> f a -> f b -- forall f a b. ... + -- The f is quantified by the class, so only a and b are considered in fmap + +This simple story is complicated by the possibility of dependency: all variables +must come after any variables mentioned in their kinds. + + typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ... + +The k comes first because a depends on k, even though the k appears later than +the a in the code. Thus, GHC does ScopedSort on the variables. +See Note [ScopedSort] in GHC.Core.Type. + +Implicitly bound variables are collected by any function which returns a +FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably +includes the `extract-` family of functions (extractHsTysRdrTyVarsDups, +extractHsTyVarBndrsKVs, etc.). +These functions thus promise to keep left-to-right ordering. + +Note [Implicit quantification in type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We typically bind type/kind variables implicitly when they are in a kind +annotation on the LHS, for example: + + data Proxy (a :: k) = Proxy + type KindOf (a :: k) = k + +Here 'k' is in the kind annotation of a type variable binding, KindedTyVar, and +we want to implicitly quantify over it. This is easy: just extract all free +variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs + +By contrast, on the RHS we can't simply collect *all* free variables. Which of +the following are allowed? + + type TySyn1 = a :: Type + type TySyn2 = 'Nothing :: Maybe a + type TySyn3 = 'Just ('Nothing :: Maybe a) + type TySyn4 = 'Left a :: Either Type a + +After some design deliberations (see non-taken alternatives below), the answer +is to reject TySyn1 and TySyn3, but allow TySyn2 and TySyn4, at least for now. +We implicitly quantify over free variables of the outermost kind signature, if +one exists: + + * In TySyn1, the outermost kind signature is (:: Type), and it does not have + any free variables. + * In TySyn2, the outermost kind signature is (:: Maybe a), it contains a + free variable 'a', which we implicitly quantify over. + * In TySyn3, there is no outermost kind signature. The (:: Maybe a) signature + is hidden inside 'Just. + * In TySyn4, the outermost kind signature is (:: Either Type a), it contains + 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. + +This is something of a stopgap solution until we can explicitly bind invisible +type/kind variables: + + type TySyn3 :: forall a. Maybe a + type TySyn3 @a = 'Just ('Nothing :: Maybe a) + +Note [Implicit quantification in type synonyms: non-taken alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Alternative I: No quantification +-------------------------------- +We could offer no implicit quantification on the RHS, accepting none of the +TySyn examples. The user would have to bind the variables explicitly: + + type TySyn1 a = a :: Type + type TySyn2 a = 'Nothing :: Maybe a + type TySyn3 a = 'Just ('Nothing :: Maybe a) + type TySyn4 a = 'Left a :: Either Type a + +However, this would mean that one would have to specify 'a' at call sites every +time, which could be undesired. + +Alternative II: Indiscriminate quantification +--------------------------------------------- +We could implicitly quantify over all free variables on the RHS just like we do +on the LHS. Then we would infer the following kinds: + + TySyn1 :: forall {a}. Type + TySyn2 :: forall {a}. Maybe a + TySyn3 :: forall {a}. Maybe (Maybe a) + TySyn4 :: forall {a}. Either Type a + +This would work fine for TySyn<2,3,4>, but TySyn1 is clearly bogus: the variable +is free-floating, not fixed by anything. + +Alternative III: reportFloatingKvs +---------------------------------- +We could augment Alternative II by hunting down free-floating variables during +type checking. While viable, this would mean we'd end up accepting this: + + data Prox k (a :: k) + type T = Prox k + +-} + +-- See Note [Kind and type-variable binders] +-- These lists are guaranteed to preserve left-to-right ordering of +-- the types the variables were extracted from. See also +-- Note [Ordering of implicit variables]. +type FreeKiTyVars = [Located RdrName] + +-- | A 'FreeKiTyVars' list that is allowed to have duplicate variables. +type FreeKiTyVarsWithDups = FreeKiTyVars + +-- | A 'FreeKiTyVars' list that contains no duplicate variables. +type FreeKiTyVarsNoDups = FreeKiTyVars + +filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars +filterInScope rdr_env = filterOut (inScope rdr_env . unLoc) + +filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars +filterInScopeM vars + = do { rdr_env <- getLocalRdrEnv + ; return (filterInScope rdr_env vars) } + +inScope :: LocalRdrEnv -> RdrName -> Bool +inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env + +extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups +extract_tyarg (HsValArg ty) acc = extract_lty ty acc +extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc +extract_tyarg (HsArgPar _) acc = acc + +extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups +extract_tyargs args acc = foldr extract_tyarg acc args + +extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups +extractHsTyArgRdrKiTyVarsDup args + = extract_tyargs args [] + +-- | 'extractHsTyRdrTyVars' finds the type/kind variables +-- of a HsType/HsKind. +-- It's used when making the @forall@s explicit. +-- When the same name occurs multiple times in the types, only the first +-- occurrence is returned. +-- See Note [Kind and type-variable binders] +extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups +extractHsTyRdrTyVars ty + = nubL (extractHsTyRdrTyVarsDups ty) + +-- | 'extractHsTyRdrTyVarsDups' finds the type/kind variables +-- of a HsType/HsKind. +-- It's used when making the @forall@s explicit. +-- When the same name occurs multiple times in the types, all occurrences +-- are returned. +extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups +extractHsTyRdrTyVarsDups ty + = extract_lty ty [] + +-- | Extracts the free type/kind variables from the kind signature of a HsType. +-- This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@. +-- When the same name occurs multiple times in the type, only the first +-- occurrence is returned, and the left-to-right order of variables is +-- preserved. +-- See Note [Kind and type-variable binders] and +-- Note [Ordering of implicit variables] and +-- Note [Implicit quantification in type synonyms]. +extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVarsNoDups +extractHsTyRdrTyVarsKindVars (unLoc -> ty) = + case ty of + HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty + HsKindSig _ _ ki -> extractHsTyRdrTyVars ki + _ -> [] + +-- | Extracts free type and kind variables from types in a list. +-- When the same name occurs multiple times in the types, all occurrences +-- are returned. +extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups +extractHsTysRdrTyVarsDups tys + = extract_ltys tys [] + +-- Returns the free kind variables of any explicitly-kinded binders, returning +-- variable occurrences in left-to-right order. +-- See Note [Ordering of implicit variables]. +-- NB: Does /not/ delete the binders themselves. +-- However duplicates are removed +-- E.g. given [k1, a:k1, b:k2] +-- the function returns [k1,k2], even though k1 is bound here +extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsNoDups +extractHsTyVarBndrsKVs tv_bndrs + = nubL (extract_hs_tv_bndrs_kvs tv_bndrs) + +-- Returns the free kind variables in a type family result signature, returning +-- variable occurrences in left-to-right order. +-- See Note [Ordering of implicit variables]. +extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName] +extractRdrKindSigVars (L _ resultSig) + | KindSig _ k <- resultSig = extractHsTyRdrTyVars k + | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k + | otherwise = [] + +-- Get type/kind variables mentioned in the kind signature, preserving +-- left-to-right order and without duplicates: +-- +-- * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type -- result: [k2,k1] +-- * data T a (b :: k1) -- result: [] +-- +-- See Note [Ordering of implicit variables]. +extractDataDefnKindVars :: HsDataDefn GhcPs -> FreeKiTyVarsNoDups +extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig }) + = maybe [] extractHsTyRdrTyVars ksig + +extract_lctxt :: LHsContext GhcPs + -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups +extract_lctxt ctxt = extract_ltys (unLoc ctxt) + +extract_ltys :: [LHsType GhcPs] + -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups +extract_ltys tys acc = foldr extract_lty acc tys + +extract_lty :: LHsType GhcPs + -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups +extract_lty (L _ ty) acc + = case ty of + HsTyVar _ _ ltv -> extract_tv ltv acc + HsBangTy _ _ ty -> extract_lty ty acc + HsRecTy _ flds -> foldr (extract_lty + . cd_fld_type . unLoc) acc + flds + HsAppTy _ ty1 ty2 -> extract_lty ty1 $ + extract_lty ty2 acc + HsAppKindTy _ ty k -> extract_lty ty $ + extract_lty k acc + HsListTy _ ty -> extract_lty ty acc + HsTupleTy _ _ tys -> extract_ltys tys acc + HsSumTy _ tys -> extract_ltys tys acc + HsFunTy _ ty1 ty2 -> extract_lty ty1 $ + extract_lty ty2 acc + HsIParamTy _ _ ty -> extract_lty ty acc + HsOpTy _ ty1 tv ty2 -> extract_tv tv $ + extract_lty ty1 $ + extract_lty ty2 acc + HsParTy _ ty -> extract_lty ty acc + HsSpliceTy {} -> acc -- Type splices mention no tvs + HsDocTy _ ty _ -> extract_lty ty acc + HsExplicitListTy _ _ tys -> extract_ltys tys acc + HsExplicitTupleTy _ tys -> extract_ltys tys acc + HsTyLit _ _ -> acc + HsStarTy _ _ -> acc + HsKindSig _ ty ki -> extract_lty ty $ + extract_lty ki acc + HsForAllTy { hst_bndrs = tvs, hst_body = ty } + -> extract_hs_tv_bndrs tvs acc $ + extract_lty ty [] + HsQualTy { hst_ctxt = ctxt, hst_body = ty } + -> extract_lctxt ctxt $ + extract_lty ty acc + XHsType {} -> acc + -- We deal with these separately in rnLHsTypeWithWildCards + HsWildCardTy {} -> acc + +extractHsTvBndrs :: [LHsTyVarBndr GhcPs] + -> FreeKiTyVarsWithDups -- Free in body + -> FreeKiTyVarsWithDups -- Free in result +extractHsTvBndrs tv_bndrs body_fvs + = extract_hs_tv_bndrs tv_bndrs [] body_fvs + +extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] + -> FreeKiTyVarsWithDups -- Accumulator + -> FreeKiTyVarsWithDups -- Free in body + -> FreeKiTyVarsWithDups +-- In (forall (a :: Maybe e). a -> b) we have +-- 'a' is bound by the forall +-- 'b' is a free type variable +-- 'e' is a free kind variable +extract_hs_tv_bndrs tv_bndrs acc_vars body_vars + | null tv_bndrs = body_vars ++ acc_vars + | otherwise = filterOut (`elemRdr` tv_bndr_rdrs) (bndr_vars ++ body_vars) ++ acc_vars + -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars. + -- See Note [Kind variable scoping] + where + bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs + tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs + +extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName] +-- Returns the free kind variables of any explicitly-kinded binders, returning +-- variable occurrences in left-to-right order. +-- See Note [Ordering of implicit variables]. +-- NB: Does /not/ delete the binders themselves. +-- Duplicates are /not/ removed +-- E.g. given [k1, a:k1, b:k2] +-- the function returns [k1,k2], even though k1 is bound here +extract_hs_tv_bndrs_kvs tv_bndrs = + foldr extract_lty [] + [k | L _ (KindedTyVar _ _ k) <- tv_bndrs] + +extract_tv :: Located RdrName + -> [Located RdrName] -> [Located RdrName] +extract_tv tv acc = + if isRdrTyVar (unLoc tv) then tv:acc else acc + +-- Deletes duplicates in a list of Located things. +-- +-- Importantly, this function is stable with respect to the original ordering +-- of things in the list. This is important, as it is a property that GHC +-- relies on to maintain the left-to-right ordering of implicitly quantified +-- type variables. +-- See Note [Ordering of implicit variables]. +nubL :: Eq a => [Located a] -> [Located a] +nubL = nubBy eqLocated + +elemRdr :: Located RdrName -> [Located RdrName] -> Bool +elemRdr x = any (eqLocated x) diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Rename/Module.hs @@ -0,0 +1,2374 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Main pass of renamer +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Rename.Module ( + rnSrcDecls, addTcgDUs, findSplice + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) +import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) + +import GHC.Hs +import GHC.Types.FieldLabel +import GHC.Types.Name.Reader +import GHC.Rename.HsType +import GHC.Rename.Bind +import GHC.Rename.Env +import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames + , checkDupRdrNames, inHsDocContext, bindLocalNamesFV + , checkShadowedRdrNames, warnUnusedTypePatterns + , extendTyVarEnvFVRn, newLocalBndrsRn + , withHsDocContext ) +import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr ) +import GHC.Rename.Names +import GHC.Rename.Doc ( rnHsDoc, rnMbLHsDoc ) +import GHC.Tc.Gen.Annotation ( annCtxt ) +import GHC.Tc.Utils.Monad + +import GHC.Types.ForeignCall ( CCallTarget(..) ) +import GHC.Unit.Module +import GHC.Driver.Types ( Warnings(..), plusWarns ) +import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName + , monadClassName, returnMName, thenMName + , semigroupClassName, sappendName + , monoidClassName, mappendName + ) +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.Data.FastString +import GHC.Types.SrcLoc as SrcLoc +import GHC.Driver.Session +import GHC.Utils.Misc ( debugIsOn, filterOut, lengthExceeds, partitionWith ) +import GHC.Driver.Types ( HscEnv, hsc_dflags ) +import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses ) +import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) + , stronglyConnCompFromEdgedVerticesUniq ) +import GHC.Types.Unique.Set +import GHC.Data.OrdList +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Control.Arrow ( first ) +import Data.List ( mapAccumL ) +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) +import qualified Data.Set as Set ( difference, fromList, toList, null ) +import Data.Function ( on ) + +{- | @rnSourceDecl@ "renames" declarations. +It simultaneously performs dependency analysis and precedence parsing. +It also does the following error checks: + +* Checks that tyvars are used properly. This includes checking + for undefined tyvars, and tyvars in contexts that are ambiguous. + (Some of this checking has now been moved to module @TcMonoType@, + since we don't have functional dependency information at this point.) + +* Checks that all variable occurrences are defined. + +* Checks the @(..)@ etc constraints in the export list. + +Brings the binders of the group into scope in the appropriate places; +does NOT assume that anything is in scope already +-} +rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn) +-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files +rnSrcDecls group@(HsGroup { hs_valds = val_decls, + hs_splcds = splice_decls, + hs_tyclds = tycl_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_warnds = warn_decls, + hs_annds = ann_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_docs = docs }) + = do { + -- (A) Process the top-level fixity declarations, creating a mapping from + -- FastStrings to FixItems. Also checks for duplicates. + -- See Note [Top-level fixity signatures in an HsGroup] in GHC.Hs.Decls + local_fix_env <- makeMiniFixityEnv $ hsGroupTopLevelFixitySigs group ; + + -- (B) Bring top level binders (and their fixities) into scope, + -- *except* for the value bindings, which get done in step (D) + -- with collectHsIdBinders. However *do* include + -- + -- * Class ops, data constructors, and record fields, + -- because they do not have value declarations. + -- + -- * For hs-boot files, include the value signatures + -- Again, they have no value declarations + -- + (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; + + + setEnvs tc_envs $ do { + + failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations + + -- (D1) Bring pattern synonyms into scope. + -- Need to do this before (D2) because rnTopBindsLHS + -- looks up those pattern synonyms (#9889) + + extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do { + + -- (D2) Rename the left-hand sides of the value bindings. + -- This depends on everything from (B) being in scope. + -- It uses the fixity env from (A) to bind fixities for view patterns. + new_lhs <- rnTopBindsLHS local_fix_env val_decls ; + + -- Bind the LHSes (and their fixities) in the global rdr environment + let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders + -- They are already in scope + traceRn "rnSrcDecls" (ppr id_bndrs) ; + tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ; + setEnvs tc_envs $ do { + + -- Now everything is in scope, as the remaining renaming assumes. + + -- (E) Rename type and class decls + -- (note that value LHSes need to be in scope for default methods) + -- + -- You might think that we could build proper def/use information + -- for type and class declarations, but they can be involved + -- in mutual recursion across modules, and we only do the SCC + -- analysis for them in the type checker. + -- So we content ourselves with gathering uses only; that + -- means we'll only report a declaration as unused if it isn't + -- mentioned at all. Ah well. + traceRn "Start rnTyClDecls" (ppr tycl_decls) ; + (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ; + + -- (F) Rename Value declarations right-hand sides + traceRn "Start rnmono" empty ; + let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ; + is_boot <- tcIsHsBootOrSig ; + (rn_val_decls, bind_dus) <- if is_boot + -- For an hs-boot, use tc_bndrs (which collects how we're renamed + -- signatures), since val_bndr_set is empty (there are no x = ... + -- bindings in an hs-boot.) + then rnTopBindsBoot tc_bndrs new_lhs + else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ; + traceRn "finish rnmono" (ppr rn_val_decls) ; + + -- (G) Rename Fixity and deprecations + + -- 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 } ; + 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 ; + + -- (H) Rename Everything else + + (rn_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $ + rnList rnHsRuleDecls rule_decls ; + -- Inside RULES, scoped type variables are on + (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ; + (rn_ann_decls, src_fvs4) <- rnList rnAnnDecl ann_decls ; + (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; + (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; + (rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ; + -- Haddock docs; no free vars + rn_docs <- mapM (wrapLocM rnDocDecl) docs ; + + last_tcg_env <- getGblEnv ; + -- (I) Compute the results and return + let {rn_group = HsGroup { hs_ext = noExtField, + hs_valds = rn_val_decls, + hs_splcds = rn_splice_decls, + hs_tyclds = rn_tycl_decls, + hs_derivds = rn_deriv_decls, + hs_fixds = rn_fix_decls, + hs_warnds = [], -- warns are returned in the tcg_env + -- (see below) not in the HsGroup + hs_fords = rn_foreign_decls, + hs_annds = rn_ann_decls, + hs_defds = rn_default_decls, + hs_ruleds = rn_rule_decls, + hs_docs = rn_docs } ; + + tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ; + other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ; + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, + src_fvs5, src_fvs6, src_fvs7] ; + -- It is tiresome to gather the binders from type and class decls + + src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ; + -- Instance decls may have occurrences of things bound in bind_dus + -- so we must put other_fvs last + + 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 }; + } ; + traceRn "finish rnSrc" (ppr rn_group) ; + traceRn "finish Dus" (ppr src_dus ) ; + return (final_tcg_env, rn_group) + }}}} + +addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv +-- This function could be defined lower down in the module hierarchy, +-- but there doesn't seem anywhere very logical to put it. +addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } + +rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars) +rnList f xs = mapFvRn (wrapLocFstM f) xs + +{- +********************************************************* +* * + HsDoc stuff +* * +********************************************************* +-} + +rnDocDecl :: DocDecl -> RnM DocDecl +rnDocDecl (DocCommentNext doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentNext rn_doc) +rnDocDecl (DocCommentPrev doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentPrev rn_doc) +rnDocDecl (DocCommentNamed str doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentNamed str rn_doc) +rnDocDecl (DocGroup lev doc) = do + rn_doc <- rnHsDoc doc + return (DocGroup lev rn_doc) + +{- +********************************************************* +* * + Source-code deprecations declarations +* * +********************************************************* + +Check that the deprecated names are defined, are defined locally, and +that there are no duplicate deprecations. + +It's only imported deprecations, dealt with in RnIfaces, that we +gather them together. +-} + +-- checks that the deprecations are defined locally, and that there are no duplicates +rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings +rnSrcWarnDecls _ [] + = return NoWarnings + +rnSrcWarnDecls bndr_set decls' + = do { -- check for duplicates + ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups + in addErrAt loc (dupWarnDecl lrdr' rdr)) + warn_rdr_dups + ; pairs_s <- mapM (addLocM rn_deprec) decls + ; return (WarnSome ((concat pairs_s))) } + where + decls = concatMap (wd_warnings . unLoc) decls' + + sig_ctxt = TopSigCtxt bndr_set + + rn_deprec (Warning _ rdr_names txt) + -- ensures that the names are defined locally + = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) + rdr_names + ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] } + + what = text "deprecation" + + warn_rdr_dups = findDupRdrNames + $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls + +findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)] +findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) + +-- look for duplicates among the OccNames; +-- we check that the names are defined above +-- invt: the lists returned by findDupsEq always have at least two elements + +dupWarnDecl :: Located RdrName -> RdrName -> SDoc +-- Located RdrName -> DeprecDecl RdrName -> SDoc +dupWarnDecl d rdr_name + = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), + text "also at " <+> ppr (getLoc d)] + +{- +********************************************************* +* * +\subsection{Annotation declarations} +* * +********************************************************* +-} + +rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) +rnAnnDecl ann@(HsAnnotation _ s provenance expr) + = addErrCtxt (annCtxt ann) $ + do { (provenance', provenance_fvs) <- rnAnnProvenance provenance + ; (expr', expr_fvs) <- setStage (Splice Untyped) $ + rnLExpr expr + ; return (HsAnnotation noExtField s provenance' expr', + provenance_fvs `plusFV` expr_fvs) } + +rnAnnProvenance :: AnnProvenance RdrName + -> RnM (AnnProvenance Name, FreeVars) +rnAnnProvenance provenance = do + provenance' <- traverse lookupTopBndrRn provenance + return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) + +{- +********************************************************* +* * +\subsection{Default declarations} +* * +********************************************************* +-} + +rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) +rnDefaultDecl (DefaultDecl _ tys) + = do { (tys', fvs) <- rnLHsTypes doc_str tys + ; return (DefaultDecl noExtField tys', fvs) } + where + doc_str = DefaultDeclCtx + +{- +********************************************************* +* * +\subsection{Foreign declarations} +* * +********************************************************* +-} + +rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) +rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) + = do { topEnv :: HscEnv <- getTopEnv + ; name' <- lookupLocatedTopBndrRn name + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty + + -- Mark any PackageTarget style imports as coming from the current package + ; let unitId = thisPackage $ hsc_dflags topEnv + spec' = patchForeignImport unitId spec + + ; return (ForeignImport { fd_i_ext = noExtField + , fd_name = name', fd_sig_ty = ty' + , fd_fi = spec' }, fvs) } + +rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) + = do { name' <- lookupLocatedOccRn name + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty + ; return (ForeignExport { fd_e_ext = noExtField + , fd_name = name', fd_sig_ty = ty' + , fd_fe = spec } + , fvs `addOneFV` unLoc name') } + -- NB: a foreign export is an *occurrence site* for name, so + -- we add it to the free-variable list. It might, for example, + -- be imported from another module + +-- | For Windows DLLs we need to know what packages imported symbols are from +-- to generate correct calls. Imported symbols are tagged with the current +-- package, so if they get inlined across a package boundary we'll still +-- know where they're from. +-- +patchForeignImport :: Unit -> ForeignImport -> ForeignImport +patchForeignImport unit (CImport cconv safety fs spec src) + = CImport cconv safety fs (patchCImportSpec unit spec) src + +patchCImportSpec :: Unit -> CImportSpec -> CImportSpec +patchCImportSpec unit spec + = case spec of + CFunction callTarget -> CFunction $ patchCCallTarget unit callTarget + _ -> spec + +patchCCallTarget :: Unit -> CCallTarget -> CCallTarget +patchCCallTarget unit callTarget = + case callTarget of + StaticTarget src label Nothing isFun + -> StaticTarget src label (Just unit) isFun + _ -> callTarget + +{- +********************************************************* +* * +\subsection{Instance declarations} +* * +********************************************************* +-} + +rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) +rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) + = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi + ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) } + +rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) + = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi + ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) } + +rnSrcInstDecl (ClsInstD { cid_inst = cid }) + = do { traceRn "rnSrcIstDecl {" (ppr cid) + ; (cid', fvs) <- rnClsInstDecl cid + ; traceRn "rnSrcIstDecl end }" empty + ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) } + +-- | Warn about non-canonical typeclass instance declarations +-- +-- A "non-canonical" instance definition can occur for instances of a +-- class which redundantly defines an operation its superclass +-- provides as well (c.f. `return`/`pure`). In such cases, a canonical +-- instance is one where the subclass inherits its method +-- implementation from its superclass instance (usually the subclass +-- has a default method implementation to that effect). Consequently, +-- a non-canonical instance occurs when this is not the case. +-- +-- See also descriptions of 'checkCanonicalMonadInstances' and +-- 'checkCanonicalMonoidInstances' +checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () +checkCanonicalInstances cls poly_ty mbinds = do + whenWOptM Opt_WarnNonCanonicalMonadInstances + checkCanonicalMonadInstances + + whenWOptM Opt_WarnNonCanonicalMonoidInstances + checkCanonicalMonoidInstances + + where + -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance + -- declarations. Specifically, the following conditions are verified: + -- + -- In 'Monad' instances declarations: + -- + -- * If 'return' is overridden it must be canonical (i.e. @return = pure@) + -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@) + -- + -- In 'Applicative' instance declarations: + -- + -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). + -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). + -- + checkCanonicalMonadInstances + | cls == applicativeClassName = do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == pureAName, isAliasMG mg == Just returnMName + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonadInstances "pure" "return" + + | name == thenAName, isAliasMG mg == Just thenMName + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)" + + _ -> return () + + | cls == monadClassName = do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == returnMName, isAliasMG mg /= Just pureAName + -> addWarnNonCanonicalMethod2 + Opt_WarnNonCanonicalMonadInstances "return" "pure" + + | name == thenMName, isAliasMG mg /= Just thenAName + -> addWarnNonCanonicalMethod2 + Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)" + + _ -> return () + + | otherwise = return () + + -- | Check whether Monoid(mappend) is defined in terms of + -- Semigroup((<>)) (and not the other way round). Specifically, + -- the following conditions are verified: + -- + -- In 'Monoid' instances declarations: + -- + -- * If 'mappend' is overridden it must be canonical + -- (i.e. @mappend = (<>)@) + -- + -- In 'Semigroup' instance declarations: + -- + -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). + -- + checkCanonicalMonoidInstances + | cls == semigroupClassName = do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == sappendName, isAliasMG mg == Just mappendName + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" + + _ -> return () + + | cls == monoidClassName = do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == mappendName, isAliasMG mg /= Just sappendName + -> addWarnNonCanonicalMethod2NoDefault + Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)" + + _ -> return () + + | otherwise = return () + + -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\" + -- binding, and return @Just rhsName@ if this is the case + isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name + isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = [] + , m_grhss = grhss })])} + | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss + , EmptyLocalBinds _ <- unLoc lbinds + , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) + isAliasMG _ = Nothing + + -- got "lhs = rhs" but expected something different + addWarnNonCanonicalMethod1 flag lhs rhs = do + addWarn (Reason flag) $ 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) + ] + + -- expected "lhs = rhs" but got something else + addWarnNonCanonicalMethod2 flag lhs rhs = do + addWarn (Reason flag) $ vcat + [ text "Noncanonical" <+> + quotes (text lhs) <+> + text "definition detected" + , instDeclCtxt1 poly_ty + , text "Either remove definition for" <+> + quotes (text lhs) <+> text "or define as" <+> + quotes (text (lhs ++ " = " ++ rhs)) + ] + + -- like above, but method has no default impl + addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do + addWarn (Reason flag) $ vcat + [ text "Noncanonical" <+> + quotes (text lhs) <+> + text "definition detected" + , instDeclCtxt1 poly_ty + , text "Define as" <+> + quotes (text (lhs ++ " = " ++ rhs)) + ] + + -- stolen from GHC.Tc.TyCl.Instance + instDeclCtxt1 :: LHsSigType GhcRn -> SDoc + instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + + inst_decl_ctxt :: SDoc -> SDoc + inst_decl_ctxt doc = hang (text "in the instance declaration for") + 2 (quotes doc <> text ".") + + +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 { (inst_ty', inst_fvs) + <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inst_ty + ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' + ; cls <- + case hsTyGetAppHead_maybe head_ty' of + Just (L _ cls) -> pure cls + Nothing -> do + -- The instance is malformed. We'd still like + -- to make *some* progress (rather than failing outright), so + -- we report an error and continue for as long as we can. + -- Importantly, this error should be thrown before we reach the + -- typechecker, lest we encounter different errors that are + -- hopelessly confusing (such as the one in #16114). + addErrAt (getLoc (hsSigType inst_ty)) $ + hang (text "Illegal class instance:" <+> quotes (ppr inst_ty)) + 2 (vcat [ text "Class instances must be of the form" + , nest 2 $ text "context => C ty_1 ... ty_n" + , text "where" <+> quotes (char 'C') + <+> text "is a class" + ]) + pure $ mkUnboundName (mkTcOccFS (fsLit "")) + + -- Rename the bindings + -- The typechecker (not the renamer) checks that all + -- the bindings are for the right class + -- (Slightly strangely) when scoped type variables are on, the + -- forall-d tyvars scope over the method bindings too + ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags + + ; checkCanonicalInstances cls inst_ty' mbinds' + + -- Rename the associated types, and type signatures + -- Both need to have the instance type variables in scope + ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names) + ; ((ats', adts'), more_fvs) + <- extendTyVarEnvFVRn ktv_names $ + do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats + ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts + ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) } + + ; let all_fvs = meth_fvs `plusFV` more_fvs + `plusFV` inst_fvs + ; return (ClsInstDecl { cid_ext = noExtField + , cid_poly_ty = inst_ty', cid_binds = mbinds' + , cid_sigs = uprags', cid_tyfam_insts = ats' + , cid_overlap_mode = oflag + , cid_datafam_insts = adts' }, + all_fvs) } + -- We return the renamed associated data type declarations so + -- that they can be entered into the list of type declarations + -- for the binding group, but we also keep a copy in the instance. + -- The latter is needed for well-formedness checks in the type + -- checker (eg, to ensure that all ATs of the instance actually + -- receive a declaration). + -- NB: Even the copies in the instance declaration carry copies of + -- the instance context after renaming. This is a bit + -- strange, but should not matter (and it would be more work + -- to remove the context). + +rnFamInstEqn :: HsDocContext + -> AssocTyFamInfo + -> [Located RdrName] -- Kind variables from the equation's RHS + -> FamInstEqn GhcPs rhs + -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) + -> RnM (FamInstEqn GhcRn rhs', FreeVars) +rnFamInstEqn doc atfi rhs_kvars + (HsIB { hsib_body = FamEqn { feqn_tycon = tycon + , feqn_bndrs = mb_bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = payload }}) rn_payload + = do { let mb_cls = case atfi of + NonAssocTyFamEqn -> Nothing + AssocTyFamDeflt cls -> Just cls + AssocTyFamInst cls _ -> Just cls + ; tycon' <- lookupFamInstName mb_cls tycon + ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats + -- Use the "...Dups" form because it's needed + -- below to report unused binder on the LHS + + -- Implicitly bound variables, empty if we have an explicit 'forall' according + -- to the "forall-or-nothing" rule. + ; let imp_vars | isNothing mb_bndrs = nubL pat_kity_vars_with_dups + | otherwise = [] + ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars + + ; let bndrs = fromMaybe [] mb_bndrs + bnd_vars = map hsLTyVarLocName bndrs + payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars + -- Make sure to filter out the kind variables that were explicitly + -- bound in the type patterns. + ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars + + -- all names not bound in an explicit forall + ; let all_imp_var_names = imp_var_names ++ payload_kvar_names + + -- All the free vars of the family patterns + -- with a sensible binding location + ; ((bndrs', pats', payload'), fvs) + <- bindLocalNamesFV all_imp_var_names $ + bindLHsTyVarBndrs doc (Just $ inHsDocContext doc) + Nothing bndrs $ \bndrs' -> + -- Note: If we pass mb_cls instead of Nothing here, + -- bindLHsTyVarBndrs will use class variables for any names + -- the user meant to bring in scope here. This is an explicit + -- forall, so we want fresh names, not class variables. + -- Thus: always pass Nothing + do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats + ; (payload', rhs_fvs) <- rn_payload doc payload + + -- Report unused binders on the LHS + -- See Note [Unused type variables in family instances] + ; let groups :: [NonEmpty (Located RdrName)] + groups = equivClasses cmpLocated $ + pat_kity_vars_with_dups + ; nms_dups <- mapM (lookupOccRn . unLoc) $ + [ tv | (tv :| (_:_)) <- groups ] + -- Add to the used variables + -- a) any variables that appear *more than once* on the LHS + -- e.g. F a Int a = Bool + -- b) for associated instances, the variables + -- of the instance decl. See + -- Note [Unused type variables in family instances] + ; let nms_used = extendNameSetList rhs_fvs $ + inst_tvs ++ nms_dups + inst_tvs = case atfi of + NonAssocTyFamEqn -> [] + AssocTyFamDeflt _ -> [] + AssocTyFamInst _ inst_tvs -> inst_tvs + all_nms = all_imp_var_names ++ hsLTyVarNames bndrs' + ; warnUnusedTypePatterns all_nms nms_used + + ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) } + + ; let all_fvs = fvs `addOneFV` unLoc tycon' + -- type instance => use, hence addOneFV + + ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances] + , hsib_body + = FamEqn { feqn_ext = noExtField + , feqn_tycon = tycon' + , feqn_bndrs = bndrs' <$ mb_bndrs + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = payload' } }, + all_fvs) } + +rnTyFamInstDecl :: AssocTyFamInfo + -> TyFamInstDecl GhcPs + -> RnM (TyFamInstDecl GhcRn, FreeVars) +rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn }) + = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn + ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) } + +-- | Tracks whether we are renaming: +-- +-- 1. A type family equation that is not associated +-- with a parent type class ('NonAssocTyFamEqn') +-- +-- 2. An associated type family default declaration ('AssocTyFamDeflt') +-- +-- 3. An associated type family instance declaration ('AssocTyFamInst') +data AssocTyFamInfo + = NonAssocTyFamEqn + | AssocTyFamDeflt Name -- Name of the parent class + | AssocTyFamInst Name -- Name of the parent class + [Name] -- Names of the tyvars of the parent instance decl + +-- | Tracks whether we are renaming an equation in a closed type family +-- equation ('ClosedTyFam') or not ('NotClosedTyFam'). +data ClosedTyFamInfo + = NotClosedTyFam + | ClosedTyFam (Located RdrName) Name + -- The names (RdrName and Name) of the closed type family + +rnTyFamInstEqn :: AssocTyFamInfo + -> ClosedTyFamInfo + -> TyFamInstEqn GhcPs + -> RnM (TyFamInstEqn GhcRn, FreeVars) +rnTyFamInstEqn atfi ctf_info + eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon + , feqn_rhs = rhs }}) + = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs + ; (eqn'@(HsIB { hsib_body = + FamEqn { feqn_tycon = L _ tycon' }}), fvs) + <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn + ; case ctf_info of + NotClosedTyFam -> pure () + ClosedTyFam fam_rdr_name fam_name -> + checkTc (fam_name == tycon') $ + withHsDocContext (TyFamilyCtx fam_rdr_name) $ + wrongTyFamName fam_name tycon' + ; pure (eqn', fvs) } + +rnTyFamDefltDecl :: Name + -> TyFamDefltDecl GhcPs + -> RnM (TyFamDefltDecl GhcRn, FreeVars) +rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls) + +rnDataFamInstDecl :: AssocTyFamInfo + -> DataFamInstDecl GhcPs + -> RnM (DataFamInstDecl GhcRn, FreeVars) +rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body = + FamEqn { feqn_tycon = tycon + , feqn_rhs = rhs }})}) + = do { let rhs_kvs = extractDataDefnKindVars rhs + ; (eqn', fvs) <- + rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn + ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) } + +-- Renaming of the associated types in instances. + +-- Rename associated type family decl in class +rnATDecls :: Name -- Class + -> [LFamilyDecl GhcPs] + -> RnM ([LFamilyDecl GhcRn], FreeVars) +rnATDecls cls at_decls + = rnList (rnFamDecl (Just cls)) at_decls + +rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames + decl GhcPs -> -- an instance. rnTyFamInstDecl + RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl + -> Name -- Class + -> [Name] + -> [Located (decl GhcPs)] + -> RnM ([Located (decl GhcRn)], FreeVars) +-- Used for data and type family defaults in a class decl +-- and the family instance declarations in an instance +-- +-- NB: We allow duplicate associated-type decls; +-- See Note [Associated type instances] in GHC.Tc.TyCl.Instance +rnATInstDecls rnFun cls tv_ns at_insts + = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts + -- See Note [Renaming associated types] + +{- Note [Wildcards in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Wild cards can be used in type/data family instance declarations to indicate +that the name of a type variable doesn't matter. Each wild card will be +replaced with a new unique type variable. For instance: + + type family F a b :: * + type instance F Int _ = Int + +is the same as + + type family F a b :: * + type instance F Int b = Int + +This is implemented as follows: Unnamed wildcards remain unchanged after +the renamer, and then given fresh meta-variables during typechecking, and +it is handled pretty much the same way as the ones in partial type signatures. +We however don't want to emit hole constraints on wildcards in family +instances, so we turn on PartialTypeSignatures and turn off warning flag to +let typechecker know this. +See related Note [Wildcards in visible kind application] in GHC.Tc.Gen.HsType + +Note [Unused type variables in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the flag -fwarn-unused-type-patterns is on, the compiler reports +warnings about unused type variables in type-family instances. A +tpye variable is considered used (i.e. cannot be turned into a wildcard) +when + + * it occurs on the RHS of the family instance + e.g. type instance F a b = a -- a is used on the RHS + + * it occurs multiple times in the patterns on the LHS + e.g. type instance F a a = Int -- a appears more than once on LHS + + * it is one of the instance-decl variables, for associated types + e.g. instance C (a,b) where + type T (a,b) = a + Here the type pattern in the type instance must be the same as that + for the class instance, so + type T (a,_) = a + would be rejected. So we should not complain about an unused variable b + +As usual, the warnings are not reported for type variables with names +beginning with an underscore. + +Extra-constraints wild cards are not supported in type/data family +instance declarations. + +Relevant tickets: #3699, #10586, #10982 and #11451. + +Note [Renaming associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check that the RHS of the decl mentions only type variables that are explicitly +bound on the LHS. For example, this is not ok + class C a b where + type F a x :: * + instance C (p,q) r where + type F (p,q) x = (x, r) -- BAD: mentions 'r' +c.f. #5515 + +Kind variables, on the other hand, are allowed to be implicitly or explicitly +bound. As examples, this (#9574) is acceptable: + class Funct f where + type Codomain f :: * + instance Funct ('KProxy :: KProxy o) where + -- o is implicitly bound by the kind signature + -- of the LHS type pattern ('KProxy) + type Codomain 'KProxy = NatTr (Proxy :: o -> *) +And this (#14131) is also acceptable: + data family Nat :: k -> k -> * + -- k is implicitly bound by an invisible kind pattern + newtype instance Nat :: (k -> *) -> (k -> *) -> * where + Nat :: (forall xx. f xx -> g xx) -> Nat f g +We could choose to disallow this, but then associated type families would not +be able to be as expressive as top-level type synonyms. For example, this type +synonym definition is allowed: + type T = (Nothing :: Maybe a) +So for parity with type synonyms, we also allow: + type family T :: Maybe a + type instance T = (Nothing :: Maybe a) + +All this applies only for *instance* declarations. In *class* +declarations there is no RHS to worry about, and the class variables +can all be in scope (#5862): + class Category (x :: k -> k -> *) where + type Ob x :: k -> Constraint + id :: Ob x a => x a a + (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c +Here 'k' is in scope in the kind signature, just like 'x'. + +Although type family equations can bind type variables with explicit foralls, +it need not be the case that all variables that appear on the RHS must be bound +by a forall. For instance, the following is acceptable: + + class C a where + type T a b + instance C (Maybe a) where + type forall b. T (Maybe a) b = Either a b + +Even though `a` is not bound by the forall, this is still accepted because `a` +was previously bound by the `instance C (Maybe a)` part. (see #16116). + +In each case, the function which detects improperly bound variables on the RHS +is GHC.Tc.Validity.checkValidFamPats. +-} + + +{- +********************************************************* +* * +\subsection{Stand-alone deriving declarations} +* * +********************************************************* +-} + +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) + ; (mds', ty', fvs) + <- rnLDerivStrategy DerivDeclCtx mds $ + rnHsSigWcType BindUnlessForall DerivDeclCtx ty + ; warnNoDerivStrat mds' loc + ; return (DerivDecl noExtField ty' mds' overlap, fvs) } + where + loc = getLoc $ hsib_body $ hswc_body ty + +standaloneDerivErr :: SDoc +standaloneDerivErr + = hang (text "Illegal standalone deriving declaration") + 2 (text "Use StandaloneDeriving to enable this extension") + +{- +********************************************************* +* * +\subsection{Rules} +* * +********************************************************* +-} + +rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars) +rnHsRuleDecls (HsRules { rds_src = src + , rds_rules = rules }) + = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules + ; return (HsRules { rds_ext = noExtField + , rds_src = src + , rds_rules = rn_rules }, fvs) } + +rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) +rnHsRuleDecl (HsRule { rd_name = rule_name + , rd_act = act + , rd_tyvs = tyvs + , rd_tmvs = tmvs + , rd_lhs = lhs + , rd_rhs = rhs }) + = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs + ; checkDupRdrNames rdr_names_w_loc + ; checkShadowedRdrNames rdr_names_w_loc + ; names <- newLocalBndrsRn rdr_names_w_loc + ; let doc = RuleCtx (snd $ unLoc rule_name) + ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' -> + bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' -> + do { (lhs', fv_lhs') <- rnLExpr lhs + ; (rhs', fv_rhs') <- rnLExpr rhs + ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs' + ; return (HsRule { rd_ext = HsRuleRn fv_lhs' fv_rhs' + , rd_name = rule_name + , rd_act = act + , rd_tyvs = tyvs' + , rd_tmvs = tmvs' + , rd_lhs = lhs' + , rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } } + where + get_var :: RuleBndr GhcPs -> Located RdrName + get_var (RuleBndrSig _ v _) = v + get_var (RuleBndr _ v) = v + in_rule = text "in the rule" <+> pprFullRuleName rule_name + +bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs + -> [LRuleBndr GhcPs] -> [Name] + -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindRuleTmVars doc tyvs vars names thing_inside + = go vars names $ \ vars' -> + bindLocalNamesFV names (thing_inside vars') + where + go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside + = go vars ns $ \ vars' -> + thing_inside (L l (RuleBndr noExtField (L loc n)) : vars') + + go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) + (n : ns) thing_inside + = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' -> + go vars ns $ \ vars' -> + thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars') + + go [] [] thing_inside = thing_inside [] + go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) + + bind_free_tvs = case tyvs of Nothing -> AlwaysBind + Just _ -> NeverBind + +bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs] + -> (Maybe [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindRuleTyVars doc in_doc (Just bndrs) thing_inside + = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just) +bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing + +{- +Note [Rule LHS validity checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check the shape of a transformation rule LHS. Currently we only allow +LHSs of the form @(f e1 .. en)@, where @f@ is not one of the +@forall@'d variables. + +We used restrict the form of the 'ei' to prevent you writing rules +with LHSs with a complicated desugaring (and hence unlikely to match); +(e.g. a case expression is not allowed: too elaborate.) + +But there are legitimate non-trivial args ei, like sections and +lambdas. So it seems simmpler not to check at all, and that is why +check_e is commented out. +-} + +checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM () +checkValidRule rule_name ids lhs' fv_lhs' + = do { -- Check for the form of the LHS + case (validRuleLhs ids lhs') of + Nothing -> return () + Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad) + + -- 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 } + +validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn) +-- Nothing => OK +-- Just e => Not ok, and e is the offending sub-expression +validRuleLhs foralls lhs + = checkl lhs + where + checkl = check . unLoc + + check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1 + `mplus` checkl_e e2 + check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2 + check (HsAppType _ e _) = checkl e + check (HsVar _ lv) + | (unLoc lv) `notElem` foralls = Nothing + check other = Just other -- Failure + + -- Check an argument + checkl_e _ = Nothing + -- Was (check_e e); see Note [Rule LHS validity checking] + +{- Commented out; see Note [Rule LHS validity checking] above + check_e (HsVar v) = Nothing + check_e (HsPar e) = checkl_e e + check_e (HsLit e) = Nothing + check_e (HsOverLit e) = Nothing + + check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2 + check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 + check_e (NegApp e _) = checkl_e e + check_e (ExplicitList _ es) = checkl_es es + check_e other = Just other -- Fails + + checkl_es es = foldr (mplus . checkl_e) Nothing es +-} + +badRuleVar :: FastString -> Name -> SDoc +badRuleVar name var + = 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 -> SDoc +badRuleLhsErr name lhs bad_e + = 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" + where + err = case bad_e of + HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual uv) + _ -> text "Illegal expression:" <+> ppr bad_e + +{- ************************************************************** + * * + Renaming type, class, instance and role declarations +* * +***************************************************************** + +@rnTyDecl@ uses the `global name function' to create a new type +declaration in which local names have been replaced by their original +names, reporting any unknown names. + +Renaming type variables is a pain. Because they now contain uniques, +it is necessary to pass in an association list which maps a parsed +tyvar to its @Name@ representation. +In some cases (type signatures of values), +it is even necessary to go over the type first +in order to get the set of tyvars used by it, make an assoc list, +and then go over it again to rename the tyvars! +However, we can also do some scoping checks at the same time. + +Note [Dependency analysis of type, class, and instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A TyClGroup represents a strongly connected components of +type/class/instance decls, together with the role annotations for the +type/class declarations. The renamer uses strongly connected +comoponent analysis to build these groups. We do this for a number of +reasons: + +* Improve kind error messages. Consider + + data T f a = MkT f a + data S f a = MkS f (T f a) + + This has a kind error, but the error message is better if you + check T first, (fixing its kind) and *then* S. If you do kind + inference together, you might get an error reported in S, which + is jolly confusing. See #4875 + + +* Increase kind polymorphism. See GHC.Tc.TyCl + Note [Grouping of type and class declarations] + +Why do the instance declarations participate? At least two reasons + +* Consider (#11348) + + type family F a + type instance F Int = Bool + + data R = MkR (F Int) + + type Foo = 'MkR 'True + + For Foo to kind-check we need to know that (F Int) ~ Bool. But we won't + know that unless we've looked at the type instance declaration for F + before kind-checking Foo. + +* Another example is this (#3990). + + data family Complex a + data instance Complex Double = CD {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + + data T = T {-# UNPACK #-} !(Complex Double) + + Here, to generate the right kind of unpacked implementation for T, + we must have access to the 'data instance' declaration. + +* Things become more complicated when we introduce transitive + dependencies through imported definitions, like in this scenario: + + A.hs + type family Closed (t :: Type) :: Type where + Closed t = Open t + + type family Open (t :: Type) :: Type + + B.hs + data Q where + Q :: Closed Bool -> Q + + type instance Open Int = Bool + + type S = 'Q 'True + + Somehow, we must ensure that the instance Open Int = Bool is checked before + the type synonym S. While we know that S depends upon 'Q depends upon Closed, + we have no idea that Closed depends upon Open! + + To accommodate for these situations, we ensure that an instance is checked + before every @TyClDecl@ on which it does not depend. That's to say, instances + are checked as early as possible in @tcTyAndClassDecls@. + +------------------------------------ +So much for WHY. What about HOW? It's pretty easy: + +(1) Rename the type/class, instance, and role declarations + individually + +(2) Do strongly-connected component analysis of the type/class decls, + We'll make a TyClGroup for each SCC + + In this step we treat a reference to a (promoted) data constructor + K as a dependency on its parent type. Thus + data T = K1 | K2 + data S = MkS (Proxy 'K1) + Here S depends on 'K1 and hence on its parent T. + + In this step we ignore instances; see + Note [No dependencies on data instances] + +(3) Attach roles to the appropriate SCC + +(4) Attach instances to the appropriate SCC. + We add an instance decl to SCC when: + all its free types/classes are bound in this SCC or earlier ones + +(5) We make an initial TyClGroup, with empty group_tyclds, for any + (orphan) instances that affect only imported types/classes + +Steps (3) and (4) are done by the (mapAccumL mk_group) call. + +Note [No dependencies on data instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + data family D a + data instance D Int = D1 + data S = MkS (Proxy 'D1) + +Here the declaration of S depends on the /data instance/ declaration +for 'D Int'. That makes things a lot more complicated, especially +if the data instance is an associated type of an enclosing class instance. +(And the class instance might have several associated type instances +with different dependency structure!) + +Ugh. For now we simply don't allow promotion of data constructors for +data instances. See Note [AFamDataCon: not promoting data family +constructors] in GHC.Tc.Utils.Env +-} + + +rnTyClDecls :: [TyClGroup GhcPs] + -> RnM ([TyClGroup GhcRn], FreeVars) +-- Rename the declarations and do dependency analysis on them +rnTyClDecls tycl_ds + = do { -- Rename the type/class, instance, and role declaraations + ; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds) + ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs) + ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds) + ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds) + ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds) + + -- Do SCC analysis on the type/class decls + ; rdr_env <- getGlobalRdrEnv + ; 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 + + inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs + (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map + + first_group + | null init_inst_ds = [] + | otherwise = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [] + , group_instds = init_inst_ds }] + + (final_inst_ds, groups) + = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs + + all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV` + foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV` + foldr (plusFV . snd) emptyFVs kisigs_w_fvs + + all_groups = first_group ++ groups + + ; MASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map + $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds ) + + ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups) + ; return (all_groups, all_fvs) } + where + mk_group :: RoleAnnotEnv + -> KindSigEnv + -> InstDeclFreeVarsMap + -> SCC (LTyClDecl GhcRn) + -> (InstDeclFreeVarsMap, TyClGroup GhcRn) + mk_group role_env kisig_env inst_map scc + = (inst_map', group) + where + tycl_ds = flattenSCC scc + bndrs = map (tcdName . unLoc) tycl_ds + roles = getRoleAnnots bndrs role_env + kisigs = getKindSigs bndrs kisig_env + (inst_ds, inst_map') = getInsts bndrs inst_map + group = TyClGroup { group_ext = noExtField + , group_tyclds = tycl_ds + , group_kisigs = kisigs + , group_roles = roles + , group_instds = inst_ds } + +-- | Free variables of standalone kind signatures. +newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars) + +lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars +lookupKindSig_FV_Env (KindSig_FV_Env e) name + = fromMaybe emptyFVs (lookupNameEnv e name) + +-- | Standalone kind signatures. +type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn) + +mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env) +mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env) + where + kisig_env = mapNameEnv fst compound_env + kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env) + compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars) + = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs + +getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn] +getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs + +rnStandaloneKindSignatures + :: NameSet -- names of types and classes in the current TyClGroup + -> [LStandaloneKindSig GhcPs] + -> RnM [(LStandaloneKindSig GhcRn, FreeVars)] +rnStandaloneKindSignatures tc_names kisigs + = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs + get_name = standaloneKindSigName . unLoc + ; mapM_ dupKindSig_Err dup_kisigs + ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups + } + +rnStandaloneKindSignature + :: NameSet -- names of types and classes in the current TyClGroup + -> StandaloneKindSig GhcPs + -> 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 <- 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 :: SDoc + standaloneKiSigErr = + hang (text "Illegal standalone kind signature") + 2 (text "Did you mean to enable StandaloneKindSignatures?") + +depAnalTyClDecls :: GlobalRdrEnv + -> KindSig_FV_Env + -> [(LTyClDecl GhcRn, FreeVars)] + -> [SCC (LTyClDecl GhcRn)] +-- See Note [Dependency analysis of type, class, and instance decls] +depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs + = stronglyConnCompFromEdgedVerticesUniq edges + where + edges :: [ Node Name (LTyClDecl GhcRn) ] + edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps)) + | (d, fvs) <- ds_w_fvs, + let { name = tcdName (unLoc d) + ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name + ; deps = fvs `plusFV` kisig_fvs + } + ] + -- 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. + +toParents :: GlobalRdrEnv -> NameSet -> NameSet +toParents rdr_env ns + = nonDetFoldUniqSet add emptyNameSet ns + -- It's OK to use nonDetFoldUFM because we immediately forget the + -- ordering by creating a set + where + add n s = extendNameSet s (getParent rdr_env n) + +getParent :: GlobalRdrEnv -> Name -> Name +getParent rdr_env n + = case lookupGRE_Name rdr_env n of + Just gre -> case gre_par gre of + ParentIs { par_is = p } -> p + FldParent { par_is = p } -> p + _ -> n + Nothing -> n + + +{- ****************************************************** +* * + Role annotations +* * +****************************************************** -} + +-- | Renames role annotations, returning them as the values in a NameEnv +-- and checks for duplicate role annotations. +-- It is quite convenient to do both of these in the same place. +-- See also Note [Role annotations in the renamer] +rnRoleAnnots :: NameSet + -> [LRoleAnnotDecl GhcPs] + -> RnM [LRoleAnnotDecl GhcRn] +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 + get_name = roleAnnotDeclName . unLoc + ; mapM_ dupRoleAnnotErr dup_annots + ; mapM (wrapLocM rn_role_annot1) no_dups } + where + 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' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) + (text "role annotation") + tycon + ; return $ RoleAnnotDecl noExtField tycon' roles } + +dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () +dupRoleAnnotErr list + = addErrAt loc $ + 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 loc) + + cmp_loc = SrcLoc.leftmost_smallest `on` getLoc + +dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () +dupKindSig_Err list + = addErrAt loc $ + 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 loc) + + cmp_loc = SrcLoc.leftmost_smallest `on` getLoc + +{- Note [Role annotations in the renamer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must ensure that a type's role annotation is put in the same group as the +proper type declaration. This is because role annotations are needed during +type-checking when creating the type's TyCon. So, rnRoleAnnots builds a +NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that +type, if any. Then, this map can be used to add the role annotations to the +groups after dependency analysis. + +This process checks for duplicate role annotations, where we must be careful +to do the check *before* renaming to avoid calling all unbound names duplicates +of one another. + +The renaming process, as usual, might identify and report errors for unbound +names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using +lookupGlobalOccRn led to #8485). +-} + + +{- ****************************************************** +* * + Dependency info for instances +* * +****************************************************** -} + +---------------------------------------------------------- +-- | 'InstDeclFreeVarsMap is an association of an +-- @InstDecl@ with @FreeVars@. The @FreeVars@ are +-- the tycon names that are both +-- a) free in the instance declaration +-- b) bound by this group of type/class/instance decls +type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)] + +-- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the +-- @FreeVars@ which are *not* the binders of a @TyClDecl@. +mkInstDeclFreeVarsMap :: GlobalRdrEnv + -> NameSet + -> [(LInstDecl GhcRn, FreeVars)] + -> InstDeclFreeVarsMap +mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs + = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs) + | (inst_decl, fvs) <- inst_ds_fvs ] + +-- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the +-- @InstDeclFreeVarsMap@ with these entries removed. +-- We call (getInsts tcs instd_map) when we've completed the declarations +-- for 'tcs'. The call returns (inst_decls, instd_map'), where +-- inst_decls are the instance declarations all of +-- whose free vars are now defined +-- instd_map' is the inst-decl map with 'tcs' removed from +-- the free-var set +getInsts :: [Name] -> InstDeclFreeVarsMap + -> ([LInstDecl GhcRn], InstDeclFreeVarsMap) +getInsts bndrs inst_decl_map + = partitionWith pick_me inst_decl_map + where + pick_me :: (LInstDecl GhcRn, FreeVars) + -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars) + pick_me (decl, fvs) + | isEmptyNameSet depleted_fvs = Left decl + | otherwise = Right (decl, depleted_fvs) + where + depleted_fvs = delFVs bndrs fvs + +{- ****************************************************** +* * + Renaming a type or class declaration +* * +****************************************************** -} + +rnTyClDecl :: TyClDecl GhcPs + -> RnM (TyClDecl GhcRn, FreeVars) + +-- All flavours of top-level type family declarations ("type family", "newtype +-- family", and "data family") +rnTyClDecl (FamDecl { tcdFam = fam }) + = do { (fam', fvs) <- rnFamDecl Nothing fam + ; return (FamDecl noExtField fam', fvs) } + +rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, + tcdFixity = fixity, tcdRhs = rhs }) + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; let kvs = extractHsTyRdrTyVarsKindVars rhs + doc = TySynCtx tycon + ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs) + ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> + do { (rhs', fvs) <- rnTySyn doc rhs + ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' + , tcdFixity = fixity + , tcdRhs = rhs', tcdSExt = fvs }, fvs) } } + +-- "data", "newtype" declarations +rnTyClDecl (DataDecl + { tcdLName = tycon, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data + , dd_kindSig = kind_sig} }) + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; let kvs = extractDataDefnKindVars defn + doc = TyDataCtx tycon + ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs) + ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs -> + do { (defn', fvs) <- rnDataDefn doc defn + ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig + ; let rn_info = DataDeclRn { tcdDataCusk = cusk + , tcdFVs = fvs } + ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs) + ; return (DataDecl { tcdLName = tycon' + , tcdTyVars = tyvars' + , tcdFixity = fixity + , tcdDataDefn = defn' + , tcdDExt = rn_info }, fvs) } } + +rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, + tcdTyVars = tyvars, tcdFixity = fixity, + tcdFDs = fds, tcdSigs = sigs, + tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = docs}) + = do { lcls' <- lookupLocatedTopBndrRn lcls + ; let cls' = unLoc lcls' + kvs = [] -- No scoped kind vars except those in + -- kind signatures on the tyvars + + -- Tyvars scope over superclass context and method signatures + ; ((tyvars', context', fds', ats'), stuff_fvs) + <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do + -- Checks for distinct tyvars + { (context', cxt_fvs) <- rnContext cls_doc context + ; fds' <- rnFds fds + -- The fundeps have no free variables + ; (ats', fv_ats) <- rnATDecls cls' ats + ; let fvs = cxt_fvs `plusFV` + fv_ats + ; return ((tyvars', context', fds', ats'), fvs) } + + ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs + + -- No need to check for duplicate associated type decls + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + + -- Check the signatures + -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). + ; let sig_rdr_names_w_locs = + [op | L _ (ClassOpSig _ False ops _) <- sigs + , op <- ops] + ; 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 + -- for instance decls. + + -- The newLocals call is tiresome: given a generic class decl + -- class C a where + -- op :: a -> a + -- op {| x+y |} (Inl a) = ... + -- op {| x+y |} (Inr b) = ... + -- op {| a*b |} (a*b) = ... + -- we want to name both "x" tyvars with the same unique, so that they are + -- easy to group together in the typechecker. + ; (mbinds', sigs', meth_fvs) + <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs + -- No need to check for duplicate method signatures + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + -- and the methods are already in scope + + -- Haddock docs + ; docs' <- mapM (wrapLocM rnDocDecl) docs + + ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs + ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', + tcdTyVars = tyvars', tcdFixity = fixity, + tcdFDs = fds', tcdSigs = sigs', + tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', + tcdDocs = docs', tcdCExt = all_fvs }, + all_fvs ) } + where + cls_doc = ClassDeclCtx lcls + +-- Does the data type declaration include a CUSK? +data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool +data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do + { -- See Note [Unlifted Newtypes and CUSKs], and for a broader + -- picture, see Note [Implementation of UnliftedNewtypes]. + ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes + ; let non_cusk_newtype + | NewType <- new_or_data = + unlifted_newtypes && isNothing kind_sig + | otherwise = False + -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls + ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype + } + +{- Note [Unlifted Newtypes and CUSKs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When unlifted newtypes are enabled, a newtype must have a kind signature +in order to be considered have a CUSK. This is because the flow of +kind inference works differently. Consider: + + newtype Foo = FooC Int + +When UnliftedNewtypes is disabled, we decide that Foo has kind +`TYPE 'LiftedRep` without looking inside the data constructor. So, we +can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled, +we fill in the kind of Foo as a metavar that gets solved by unification +with the kind of the field inside FooC (that is, Int, whose kind is +`TYPE 'LiftedRep`). But since we have to look inside the data constructors +to figure out the kind signature of Foo, it does not have a CUSK. + +See Note [Implementation of UnliftedNewtypes] for where this fits in to +the broader picture of UnliftedNewtypes. +-} + +-- "type" and "type instance" declarations +rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) +rnTySyn doc rhs = rnLHsType doc rhs + +rnDataDefn :: HsDocContext -> HsDataDefn GhcPs + -> RnM (HsDataDefn GhcRn, FreeVars) +rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = context, dd_cons = condecls + , dd_kindSig = m_sig, dd_derivs = derivs }) + = do { checkTc (h98_style || null (unLoc context)) + (badGadtStupidTheta doc) + + ; (m_sig', sig_fvs) <- case m_sig of + Just sig -> first Just <$> rnLHsKind doc sig + Nothing -> return (Nothing, emptyFVs) + ; (context', fvs1) <- rnContext doc context + ; (derivs', fvs3) <- rn_derivs derivs + + -- For the constructor declarations, drop the LocalRdrEnv + -- in the GADT case, where the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } + ; let { zap_lcl_env | h98_style = \ thing -> thing + | otherwise = setLocalRdrEnv emptyLocalRdrEnv } + ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls + -- No need to check for duplicate constructor decls + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + + ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` + con_fvs `plusFV` sig_fvs + ; return ( HsDataDefn { dd_ext = noExtField + , dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = context', dd_kindSig = m_sig' + , dd_cons = condecls' + , dd_derivs = derivs' } + , all_fvs ) + } + where + h98_style = case condecls of -- Note [Stupid theta] + (L _ (ConDeclGADT {})) : _ -> False + _ -> True + + rn_derivs (L loc ds) + = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies + ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) + multipleDerivClausesErr + ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds + ; return (L loc ds', fvs) } + +warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) + -> SrcSpan + -> RnM () +warnNoDerivStrat mds loc + = do { dyn_flags <- getDynFlags + ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $ + case mds of + Nothing -> addWarnAt + (Reason Opt_WarnMissingDerivingStrategies) + loc + (if xopt LangExt.DerivingStrategies dyn_flags + then no_strat_warning + else no_strat_warning $+$ deriv_strat_nenabled + ) + _ -> 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) +rnLHsDerivingClause doc + (L loc (HsDerivingClause + { deriv_clause_ext = noExtField + , deriv_clause_strategy = dcs + , deriv_clause_tys = L loc' dct })) + = do { (dcs', dct', fvs) + <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct + ; warnNoDerivStrat dcs' loc + ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField + , deriv_clause_strategy = dcs' + , deriv_clause_tys = L loc' dct' }) + , fvs ) } + +rnLDerivStrategy :: forall a. + HsDocContext + -> Maybe (LDerivStrategy GhcPs) + -> RnM (a, FreeVars) + -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars) +rnLDerivStrategy doc mds thing_inside + = case mds of + Nothing -> boring_case Nothing + Just (L loc ds) -> + setSrcSpan loc $ do + (ds', thing, fvs) <- rn_deriv_strat ds + pure (Just (L loc ds'), thing, fvs) + where + rn_deriv_strat :: DerivStrategy GhcPs + -> RnM (DerivStrategy GhcRn, a, FreeVars) + rn_deriv_strat ds = do + let extNeeded :: LangExt.Extension + extNeeded + | ViaStrategy{} <- ds + = LangExt.DerivingVia + | otherwise + = LangExt.DerivingStrategies + + unlessXOptM extNeeded $ + failWith $ illegalDerivStrategyErr ds + + case ds of + StockStrategy -> boring_case StockStrategy + AnyclassStrategy -> boring_case AnyclassStrategy + NewtypeStrategy -> boring_case NewtypeStrategy + ViaStrategy via_ty -> + do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty + let HsIB { hsib_ext = via_imp_tvs + , hsib_body = via_body } = via_ty' + (via_exp_tv_bndrs, _, _) = splitLHsSigmaTyInvis via_body + via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs + via_tvs = via_imp_tvs ++ via_exp_tvs + (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside + pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) + + boring_case :: ds -> RnM (ds, a, FreeVars) + boring_case ds = do + (thing, fvs) <- thing_inside + pure (ds, thing, fvs) + +badGadtStupidTheta :: HsDocContext -> SDoc +badGadtStupidTheta _ + = 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 -> SDoc +illegalDerivStrategyErr ds + = 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 :: SDoc +multipleDerivClausesErr + = 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 + -> FamilyDecl GhcPs + -> RnM (FamilyDecl GhcRn, FreeVars) +rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars + , fdFixity = fixity + , fdInfo = info, fdResultSig = res_sig + , fdInjectivityAnn = injectivity }) + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; ((tyvars', res_sig', injectivity'), fv1) <- + bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ -> + do { let rn_sig = rnFamResultSig doc + ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig + ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') + injectivity + ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } + ; (info', fv2) <- rn_info tycon' info + ; return (FamilyDecl { fdExt = noExtField + , fdLName = tycon', fdTyVars = tyvars' + , fdFixity = fixity + , fdInfo = info', fdResultSig = res_sig' + , fdInjectivityAnn = injectivity' } + , fv1 `plusFV` fv2) } + where + doc = TyFamilyCtx tycon + kvs = extractRdrKindSigVars res_sig + + ---------------------- + rn_info :: Located Name + -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars) + rn_info (L _ fam_name) (ClosedTypeFamily (Just eqns)) + = do { (eqns', fvs) + <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name)) + -- no class context + eqns + ; return (ClosedTypeFamily (Just eqns'), fvs) } + rn_info _ (ClosedTypeFamily Nothing) + = return (ClosedTypeFamily Nothing, emptyFVs) + rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs) + rn_info _ DataFamily = return (DataFamily, emptyFVs) + +rnFamResultSig :: HsDocContext + -> FamilyResultSig GhcPs + -> RnM (FamilyResultSig GhcRn, FreeVars) +rnFamResultSig _ (NoSig _) + = return (NoSig noExtField, emptyFVs) +rnFamResultSig doc (KindSig _ kind) + = do { (rndKind, ftvs) <- rnLHsKind doc kind + ; return (KindSig noExtField rndKind, ftvs) } +rnFamResultSig doc (TyVarSig _ tvbndr) + = do { -- `TyVarSig` tells us that user named the result of a type family by + -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to + -- be sure that the supplied result name is not identical to an + -- already in-scope type variable from an enclosing class. + -- + -- Example of disallowed declaration: + -- class C a b where + -- type F b = a | a -> b + rdr_env <- getLocalRdrEnv + ; let resName = hsLTyVarName tvbndr + ; when (resName `elemLocalRdrEnv` rdr_env) $ + addErrAt (getLoc tvbndr) $ + (hsep [ text "Type variable", quotes (ppr resName) <> comma + , text "naming a type family result," + ] $$ + text "shadows an already bound type variable") + + ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for + -- scoping checks that are irrelevant here + tvbndr $ \ tvbndr' -> + return (TyVarSig noExtField tvbndr', unitFV (hsLTyVarName tvbndr')) } + +-- Note [Renaming injectivity annotation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- During renaming of injectivity annotation we have to make several checks to +-- make sure that it is well-formed. At the moment injectivity annotation +-- consists of a single injectivity condition, so the terms "injectivity +-- annotation" and "injectivity condition" might be used interchangeably. See +-- Note [Injectivity annotation] for a detailed discussion of currently allowed +-- injectivity annotations. +-- +-- Checking LHS is simple because the only type variable allowed on the LHS of +-- injectivity condition is the variable naming the result in type family head. +-- Example of disallowed annotation: +-- +-- type family Foo a b = r | b -> a +-- +-- Verifying RHS of injectivity consists of checking that: +-- +-- 1. only variables defined in type family head appear on the RHS (kind +-- variables are also allowed). Example of disallowed annotation: +-- +-- type family Foo a = r | r -> b +-- +-- 2. for associated types the result variable does not shadow any of type +-- class variables. Example of disallowed annotation: +-- +-- class Foo a b where +-- type F a = b | b -> a +-- +-- Breaking any of these assumptions results in an error. + +-- | Rename injectivity annotation. Note that injectivity annotation is just the +-- part after the "|". Everything that appears before it is renamed in +-- rnFamDecl. +rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in + -- type family head + -> LFamilyResultSig GhcRn -- ^ Result signature + -> LInjectivityAnn GhcPs -- ^ Injectivity annotation + -> RnM (LInjectivityAnn GhcRn) +rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) + (L srcSpan (InjectivityAnn injFrom injTo)) + = do + { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors) + <- askNoErrs $ + bindLocalNames [hsLTyVarName resTv] $ + -- The return type variable scopes over the injectivity annotation + -- e.g. type family F a = (r::*) | r -> a + do { injFrom' <- rnLTyVar injFrom + ; injTo' <- mapM rnLTyVar injTo + ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } + + ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs + resName = hsLTyVarName resTv + -- See Note [Renaming injectivity annotation] + lhsValid = EQ == (stableNameCmp resName (unLoc injFrom')) + rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames + + -- if renaming of type variables ended with errors (eg. there were + -- not-in-scope variables) don't check the validity of injectivity + -- annotation. This gives better error messages. + ; when (noRnErrors && not lhsValid) $ + addErrAt (getLoc injFrom) + ( vcat [ text $ "Incorrect type variable on the LHS of " + ++ "injectivity condition" + , nest 5 + ( vcat [ text "Expected :" <+> ppr resName + , text "Actual :" <+> ppr injFrom ])]) + + ; when (noRnErrors && not (Set.null rhsValid)) $ + do { let errorVars = Set.toList rhsValid + ; addErrAt srcSpan $ ( hsep + [ text "Unknown type variable" <> plural errorVars + , text "on the RHS of injectivity condition:" + , interpp'SP errorVars ] ) } + + ; return injDecl' } + +-- We can only hit this case when the user writes injectivity annotation without +-- naming the result: +-- +-- type family F a | result -> a +-- type family F a :: * | result -> a +-- +-- So we rename injectivity annotation like we normally would except that +-- this time we expect "result" to be reported not in scope by rnLTyVar. +rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) = + setSrcSpan srcSpan $ do + (injDecl', _) <- askNoErrs $ do + injFrom' <- rnLTyVar injFrom + injTo' <- mapM rnLTyVar injTo + return $ L srcSpan (InjectivityAnn injFrom' injTo') + return $ injDecl' + +{- +Note [Stupid theta] +~~~~~~~~~~~~~~~~~~~ +#3850 complains about a regression wrt 6.10 for + data Show a => T a +There is no reason not to allow the stupid theta if there are no data +constructors. It's still stupid, but does no harm, and I don't want +to cause programs to break unnecessarily (notably HList). So if there +are no data constructors we allow h98_style = True +-} + + +{- ***************************************************** +* * + Support code for type/data declarations +* * +***************************************************** -} + +--------------- +wrongTyFamName :: Name -> Name -> SDoc +wrongTyFamName fam_tc_name eqn_tc_name + = hang (text "Mismatched type name in type family instance.") + 2 (vcat [ text "Expected:" <+> ppr fam_tc_name + , text " Actual:" <+> ppr eqn_tc_name ]) + +----------------- +rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars) +rnConDecls = mapFvRn (wrapLocFstM rnConDecl) + +rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) +rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt, con_args = args + , con_doc = mb_doc }) + = do { _ <- addLocM checkConName name + ; new_name <- lookupLocatedTopBndrRn name + ; mb_doc' <- rnMbLHsDoc mb_doc + + -- We bind no implicit binders here; this is just like + -- a nested HsForAllTy. E.g. consider + -- data T a = forall (b::k). MkT (...) + -- The 'k' will already be in scope from the bindHsQTyVars + -- for the data decl itself. So we'll get + -- data T {k} a = ... + -- And indeed we may later discover (a::k). But that's the + -- scoping we get. So no implicit binders at the existential forall + + ; let ctxt = ConDeclCtx [new_name] + ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt)) + Nothing ex_tvs $ \ new_ex_tvs -> + do { (new_context, fvs1) <- rnMbContext ctxt mcxt + ; (new_args, fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args + ; let all_fvs = fvs1 `plusFV` fvs2 + ; traceRn "rnConDecl" (ppr name <+> vcat + [ text "ex_tvs:" <+> ppr ex_tvs + , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) + + ; return (decl { con_ext = noExtField + , con_name = new_name, con_ex_tvs = new_ex_tvs + , con_mb_cxt = new_context, con_args = new_args + , con_doc = mb_doc' }, + all_fvs) }} + +rnConDecl decl@(ConDeclGADT { con_names = names + , con_forall = L _ explicit_forall + , con_qvars = qtvs + , con_mb_cxt = mcxt + , con_args = args + , con_res_ty = res_ty + , con_doc = mb_doc }) + = do { mapM_ (addLocM checkConName) names + ; new_names <- mapM lookupLocatedTopBndrRn names + ; mb_doc' <- rnMbLHsDoc mb_doc + + ; let explicit_tkvs = hsQTvExplicit qtvs + theta = hsConDeclTheta mcxt + arg_tys = hsConDeclArgTys args + + -- We must ensure that we extract the free tkvs in left-to-right + -- order of their appearance in the constructor type. + -- That order governs the order the implicitly-quantified type + -- variable, and hence the order needed for visible type application + -- See #14808. + free_tkvs = extractHsTvBndrs explicit_tkvs $ + extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty]) + + ctxt = ConDeclCtx new_names + mb_ctxt = Just (inHsDocContext ctxt) + + ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall ) + ; rnImplicitBndrs (not explicit_forall) free_tkvs $ \ implicit_tkvs -> + bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs -> + do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt + ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args + ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty + + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + (args', res_ty') + = case args of + InfixCon {} -> pprPanic "rnConDecl" (ppr names) + RecCon {} -> (new_args, new_res_ty) + PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty + -> ASSERT( null as ) + -- See Note [GADT abstract syntax] in GHC.Hs.Decls + (PrefixCon arg_tys, final_res_ty) + + new_qtvs = HsQTvs { hsq_ext = implicit_tkvs + , hsq_explicit = explicit_tkvs } + + ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) + ; return (decl { con_g_ext = noExtField, con_names = new_names + , con_qvars = new_qtvs, con_mb_cxt = new_cxt + , con_args = args', con_res_ty = res_ty' + , con_doc = mb_doc' }, + all_fvs) } } + + +rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) + -> RnM (Maybe (LHsContext GhcRn), FreeVars) +rnMbContext _ Nothing = return (Nothing, emptyFVs) +rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt + ; return (Just ctx',fvs) } + +rnConDeclDetails + :: Name + -> HsDocContext + -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs]) + -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]), + FreeVars) +rnConDeclDetails _ doc (PrefixCon tys) + = do { (new_tys, fvs) <- rnLHsTypes doc tys + ; return (PrefixCon new_tys, fvs) } + +rnConDeclDetails _ doc (InfixCon ty1 ty2) + = do { (new_ty1, fvs1) <- rnLHsType doc ty1 + ; (new_ty2, fvs2) <- rnLHsType doc ty2 + ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } + +rnConDeclDetails con doc (RecCon (L l fields)) + = do { fls <- lookupConstructorFields con + ; (new_fields, fvs) <- rnConDeclFields doc fls fields + -- No need to check for duplicate fields + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + ; return (RecCon (L l new_fields), fvs) } + +------------------------------------------------- + +-- | Brings pattern synonym names and also pattern synonym selectors +-- from record pattern synonyms into scope. +extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv + -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a +extendPatSynEnv 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 pat_syn_bndrs + ; (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' } + ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } + where + new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] + new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds + new_ps _ = panic "new_ps" + + new_ps' :: LHsBindLR GhcPs GhcPs + -> [(Name, [FieldLabel])] + -> TcM [(Name, [FieldLabel])] + new_ps' bind names + | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n + , psb_args = RecCon as }))) <- bind + = do + bnd_name <- newTopSrcBinder (L bind_loc n) + let rnames = map recordPatSynSelectorId as + mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs + mkFieldOcc (L l name) = L l (FieldOcc noExtField (L l name)) + field_occs = map mkFieldOcc rnames + flds <- mapM (newRecordSelector False [bnd_name]) field_occs + return ((bnd_name, flds): names) + | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind + = do + bnd_name <- newTopSrcBinder (L bind_loc n) + return ((bnd_name, []): names) + | otherwise + = return names + +{- +********************************************************* +* * +\subsection{Support code to rename types} +* * +********************************************************* +-} + +rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn] +rnFds fds + = mapM (wrapLocM rn_fds) fds + where + rn_fds (tys1, tys2) + = do { tys1' <- rnHsTyVars tys1 + ; tys2' <- rnHsTyVars tys2 + ; return (tys1', tys2') } + +rnHsTyVars :: [Located RdrName] -> RnM [Located Name] +rnHsTyVars tvs = mapM rnHsTyVar tvs + +rnHsTyVar :: Located RdrName -> RnM (Located Name) +rnHsTyVar (L l tyvar) = do + tyvar' <- lookupOccRn tyvar + return (L l tyvar') + +{- +********************************************************* +* * + findSplice +* * +********************************************************* + +This code marches down the declarations, looking for the first +Template Haskell splice. As it does so it + a) groups the declarations into a HsGroup + b) runs any top-level quasi-quotes +-} + +findSplice :: [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) +findSplice ds = addl emptyRdrGroup ds + +addl :: HsGroup GhcPs -> [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) +-- This stuff reverses the declarations (again) but it doesn't matter +addl gp [] = return (gp, Nothing) +addl gp (L l d : ds) = add gp l d ds + + +add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) + +-- #10047: Declaration QuasiQuoters are expanded immediately, without +-- causing a group split +add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds + = do { (ds', _) <- rnTopSpliceDecls qq + ; addl gp (ds' ++ ds) + } + +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) + case flag of + ExplicitSplice -> return () + ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell + ; unless th_on $ setSrcSpan loc $ + failWith badImplicitSplice } + + ; return (gp, Just (splice, ds)) } + where + badImplicitSplice = 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. + +-- Class declarations: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (TyClD _ d) ds + = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds + +-- Signatures: fixity sigs go a different place than all others +add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds + = addl (gp {hs_fixds = L l f : ts}) ds + +-- Standalone kind signatures: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds + = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds + +add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds + = addl (gp {hs_valds = add_sig (L l d) ts}) ds + +-- Value declarations: use add_bind +add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds + = addl (gp { hs_valds = add_bind (L l d) ts }) ds + +-- Role annotations: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds + = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds + +-- NB instance declarations go into TyClGroups. We throw them into the first +-- group, just as we do for the TyClD case. The renamer will go on to group +-- and order them later. +add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds + = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds + +-- The rest are routine +add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds + = addl (gp { hs_derivds = L l d : ts }) ds +add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds + = addl (gp { hs_defds = L l d : ts }) ds +add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds + = addl (gp { hs_fords = L l d : ts }) ds +add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds + = addl (gp { hs_warnds = L l d : ts }) ds +add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds + = addl (gp { hs_annds = L l d : ts }) ds +add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds + = addl (gp { hs_ruleds = L l d : ts }) ds +add gp l (DocD _ d) ds + = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds + +add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)] + -> [TyClGroup (GhcPass p)] +add_tycld d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [d] + , group_kisigs = [] + , group_roles = [] + , group_instds = [] + } + ] +add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss) + = ds { group_tyclds = d : tyclds } : dss + +add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)] + -> [TyClGroup (GhcPass p)] +add_instd d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [] + , group_instds = [d] + } + ] +add_instd d (ds@(TyClGroup { group_instds = instds }):dss) + = ds { group_instds = d : instds } : dss + +add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)] + -> [TyClGroup (GhcPass p)] +add_role_annot d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [d] + , group_instds = [] + } + ] +add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) + = tycls { group_roles = d : roles } : rest + +add_kisig :: LStandaloneKindSig (GhcPass p) + -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)] +add_kisig d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [d] + , group_roles = [] + , group_instds = [] + } + ] +add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest) + = tycls { group_kisigs = d : kisigs } : rest + +add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a +add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs +add_bind _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_bind" + +add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) +add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs) +add_sig _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_sig" 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 @@ -32,19 +32,19 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Core.TyCo.Ppr import GHC.Hs -import TcEnv +import GHC.Tc.Utils.Env import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv ) import GHC.Iface.Load ( loadSrcInterface ) -import TcRnMonad -import PrelNames -import GHC.Types.Module +import GHC.Tc.Utils.Monad +import GHC.Builtin.Names +import GHC.Unit.Module import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -52,14 +52,14 @@ import GHC.Types.FieldLabel import GHC.Driver.Types import GHC.Types.Name.Reader -import RdrHsSyn ( setRdrNameSpace ) -import Outputable -import Maybes +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import GHC.Utils.Outputable as Outputable +import GHC.Data.Maybe import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Basic ( TopLevelFlag(..), StringLiteral(..) ) -import Util -import FastString -import FastStringEnv +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Data.FastString.Env import GHC.Types.Id import GHC.Core.Type import GHC.Core.PatSyn @@ -306,7 +306,7 @@ -- c.f. GHC.findModule, and #9997 Nothing -> True Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" || - fsToUnitId pkg_fs == moduleUnitId this_mod)) + fsToUnit pkg_fs == moduleUnit this_mod)) (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name)) -- Check for a missing import list (Opt_WarnMissingImportList also @@ -388,7 +388,6 @@ , ideclHiding = new_imp_details }) return (new_imp_decl, gbl_env, imports, mi_hpc iface) -rnImportDecl _ (L _ (XImportDecl nec)) = noExtCon nec -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. @@ -441,8 +440,8 @@ imp_sem_mod : dep_finsts deps | otherwise = dep_finsts deps - pkg = moduleUnitId (mi_module iface) - ipkg = toInstalledUnitId pkg + 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] @@ -765,7 +764,6 @@ = expectJust "getLocalNonValBinders/find_con_decl_fld" $ find (\ fl -> flLabel fl == lbl) flds where lbl = occNameFS (rdrNameOcc rdr) - find_con_decl_fld (L _ (XFieldOcc nec)) = noExtCon nec new_assoc :: Bool -> LInstDecl GhcPs -> RnM ([AvailInfo], [(Name, [FieldLabel])]) @@ -801,8 +799,6 @@ (avails, fldss) <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts pure (avails, concat fldss) - new_assoc _ (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec - new_assoc _ (L _ (XInstDecl nec)) = noExtCon nec new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) @@ -816,16 +812,13 @@ -- main_name is not bound here! fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds' ; return (avail, fld_env) } - new_di _ _ (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d -getLocalNonValBinders _ (XHsGroup nec) = noExtCon nec newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" -newRecordSelector _ _ (L _ (XFieldOcc nec)) = noExtCon nec newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld))) = do { selName <- newTopSrcBinder $ L loc $ field ; return $ qualFieldLbl { flSelector = selName } } @@ -1438,7 +1431,6 @@ -- 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. - unused_decl (L _ (XImportDecl nec)) = noExtCon nec {- Note [The ImportMap] 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 @@ -44,7 +44,7 @@ -- ENH: thin imports to only what is necessary for patterns -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat ) @@ -52,8 +52,8 @@ #include "HsVersions.h" import GHC.Hs -import TcRnMonad -import TcHsSyn ( hsOverLitName ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Zonk ( hsOverLitName ) import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames @@ -61,18 +61,18 @@ , checkUnusedRecordWildcard , checkDupNames, checkDupAndShadowedNames , checkTupSize , unknownSubordinateErr ) -import GHC.Rename.Types -import PrelNames +import GHC.Rename.HsType +import GHC.Builtin.Names import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.Basic -import Util -import ListSetOps ( removeDups ) -import Outputable +import GHC.Utils.Misc +import GHC.Data.List.SetOps( removeDups ) +import GHC.Utils.Outputable import GHC.Types.SrcLoc import GHC.Types.Literal ( inCharRange ) -import TysWiredIn ( nilDataCon ) +import GHC.Builtin.Types ( nilDataCon ) import GHC.Core.DataCon import qualified GHC.LanguageExtensions as LangExt @@ -249,7 +249,7 @@ -- however, this binding seems to work, and it only exists for -- the duration of the patterns and the continuation; -- then the top-level name is added to the global env - -- before going on to the RHSes (see GHC.Rename.Source). + -- before going on to the RHSes (see GHC.Rename.Module). {- Note [View pattern usage] @@ -468,14 +468,14 @@ -- ; return (ViewPat expr' pat' ty) } ; return (ViewPat x expr' pat') } -rnPatAndThen mk (ConPatIn con stuff) +rnPatAndThen mk (ConPat NoExtField con args) -- rnConPatAndThen takes care of reconstructing the pattern -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. = case unLoc con == nameRdrName (dataConName nilDataCon) of True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists ; if ol_flag then rnPatAndThen mk (ListPat noExtField []) - else rnConPatAndThen mk con stuff} - False -> rnConPatAndThen mk con stuff + else rnConPatAndThen mk con args} + False -> rnConPatAndThen mk con args rnPatAndThen mk (ListPat _ pats) = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists @@ -505,9 +505,6 @@ Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed Right already_renamed -> return already_renamed } -rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat) - - -------------------- rnConPatAndThen :: NameMaker -> Located RdrName -- the constructor @@ -517,7 +514,12 @@ rnConPatAndThen mk con (PrefixCon pats) = do { con' <- lookupConCps con ; pats' <- rnLPatsAndThen mk pats - ; return (ConPatIn con' (PrefixCon pats')) } + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = con' + , pat_args = PrefixCon pats' + } + } rnConPatAndThen mk con (InfixCon pat1 pat2) = do { con' <- lookupConCps con @@ -529,7 +531,12 @@ rnConPatAndThen mk con (RecCon rpats) = do { con' <- lookupConCps con ; rpats' <- rnHsRecPatsAndThen mk con' rpats - ; return (ConPatIn con' (RecCon rpats')) } + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = con' + , pat_args = RecCon rpats' + } + } checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn () checkUnusedRecordWildcardCps loc dotdot_names = @@ -638,8 +645,6 @@ sel (L ll lbl))) , hsRecFieldArg = arg' , hsRecPun = pun })) } - rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) - = panic "rnHsRecFields" rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat @@ -732,7 +737,7 @@ = do { let lbl = rdrNameAmbiguousFieldOcc f ; sel <- setSrcSpan loc $ -- Defer renaming of overloaded fields to the typechecker - -- See Note [Disambiguating record fields] in TcExpr + -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Expr if overload_ok then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl diff --git a/compiler/GHC/Rename/Source.hs b/compiler/GHC/Rename/Source.hs deleted file mode 100644 --- a/compiler/GHC/Rename/Source.hs +++ /dev/null @@ -1,2413 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -Main pass of renamer --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module GHC.Rename.Source ( - rnSrcDecls, addTcgDUs, findSplice - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) -import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) - -import GHC.Hs -import GHC.Types.FieldLabel -import GHC.Types.Name.Reader -import GHC.Rename.Types -import GHC.Rename.Binds -import GHC.Rename.Env -import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames - , checkDupRdrNames, inHsDocContext, bindLocalNamesFV - , checkShadowedRdrNames, warnUnusedTypePatterns - , extendTyVarEnvFVRn, newLocalBndrsRn - , withHsDocContext ) -import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr ) -import GHC.Rename.Names -import GHC.Rename.Doc ( rnHsDoc, rnMbLHsDoc ) -import TcAnnotations ( annCtxt ) -import TcRnMonad - -import GHC.Types.ForeignCall ( CCallTarget(..) ) -import GHC.Types.Module -import GHC.Driver.Types ( Warnings(..), plusWarns ) -import PrelNames ( applicativeClassName, pureAName, thenAName - , monadClassName, returnMName, thenMName - , semigroupClassName, sappendName - , monoidClassName, mappendName - ) -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.Name.Env -import GHC.Types.Avail -import Outputable -import Bag -import GHC.Types.Basic ( pprRuleName, TypeOrKind(..) ) -import FastString -import GHC.Types.SrcLoc as SrcLoc -import GHC.Driver.Session -import Util ( debugIsOn, filterOut, lengthExceeds, partitionWith ) -import GHC.Driver.Types ( HscEnv, hsc_dflags ) -import ListSetOps ( findDupsEq, removeDups, equivClasses ) -import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..) - , stronglyConnCompFromEdgedVerticesUniq ) -import GHC.Types.Unique.Set -import OrdList -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Control.Arrow ( first ) -import Data.List ( mapAccumL ) -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty ( NonEmpty(..) ) -import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) -import qualified Data.Set as Set ( difference, fromList, toList, null ) -import Data.Function ( on ) - -{- | @rnSourceDecl@ "renames" declarations. -It simultaneously performs dependency analysis and precedence parsing. -It also does the following error checks: - -* Checks that tyvars are used properly. This includes checking - for undefined tyvars, and tyvars in contexts that are ambiguous. - (Some of this checking has now been moved to module @TcMonoType@, - since we don't have functional dependency information at this point.) - -* Checks that all variable occurrences are defined. - -* Checks the @(..)@ etc constraints in the export list. - -Brings the binders of the group into scope in the appropriate places; -does NOT assume that anything is in scope already --} -rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn) --- Rename a top-level HsGroup; used for normal source files *and* hs-boot files -rnSrcDecls group@(HsGroup { hs_valds = val_decls, - hs_splcds = splice_decls, - hs_tyclds = tycl_decls, - hs_derivds = deriv_decls, - hs_fixds = fix_decls, - hs_warnds = warn_decls, - hs_annds = ann_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_docs = docs }) - = do { - -- (A) Process the top-level fixity declarations, creating a mapping from - -- FastStrings to FixItems. Also checks for duplicates. - -- See Note [Top-level fixity signatures in an HsGroup] in GHC.Hs.Decls - local_fix_env <- makeMiniFixityEnv $ hsGroupTopLevelFixitySigs group ; - - -- (B) Bring top level binders (and their fixities) into scope, - -- *except* for the value bindings, which get done in step (D) - -- with collectHsIdBinders. However *do* include - -- - -- * Class ops, data constructors, and record fields, - -- because they do not have value declarations. - -- - -- * For hs-boot files, include the value signatures - -- Again, they have no value declarations - -- - (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; - - - setEnvs tc_envs $ do { - - failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations - - -- (D1) Bring pattern synonyms into scope. - -- Need to do this before (D2) because rnTopBindsLHS - -- looks up those pattern synonyms (#9889) - - extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do { - - -- (D2) Rename the left-hand sides of the value bindings. - -- This depends on everything from (B) being in scope. - -- It uses the fixity env from (A) to bind fixities for view patterns. - new_lhs <- rnTopBindsLHS local_fix_env val_decls ; - - -- Bind the LHSes (and their fixities) in the global rdr environment - let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders - -- They are already in scope - traceRn "rnSrcDecls" (ppr id_bndrs) ; - tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ; - setEnvs tc_envs $ do { - - -- Now everything is in scope, as the remaining renaming assumes. - - -- (E) Rename type and class decls - -- (note that value LHSes need to be in scope for default methods) - -- - -- You might think that we could build proper def/use information - -- for type and class declarations, but they can be involved - -- in mutual recursion across modules, and we only do the SCC - -- analysis for them in the type checker. - -- So we content ourselves with gathering uses only; that - -- means we'll only report a declaration as unused if it isn't - -- mentioned at all. Ah well. - traceRn "Start rnTyClDecls" (ppr tycl_decls) ; - (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ; - - -- (F) Rename Value declarations right-hand sides - traceRn "Start rnmono" empty ; - let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ; - is_boot <- tcIsHsBootOrSig ; - (rn_val_decls, bind_dus) <- if is_boot - -- For an hs-boot, use tc_bndrs (which collects how we're renamed - -- signatures), since val_bndr_set is empty (there are no x = ... - -- bindings in an hs-boot.) - then rnTopBindsBoot tc_bndrs new_lhs - else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ; - traceRn "finish rnmono" (ppr rn_val_decls) ; - - -- (G) Rename Fixity and deprecations - - -- 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 } ; - 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 ; - - -- (H) Rename Everything else - - (rn_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $ - rnList rnHsRuleDecls rule_decls ; - -- Inside RULES, scoped type variables are on - (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ; - (rn_ann_decls, src_fvs4) <- rnList rnAnnDecl ann_decls ; - (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; - (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; - (rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ; - -- Haddock docs; no free vars - rn_docs <- mapM (wrapLocM rnDocDecl) docs ; - - last_tcg_env <- getGblEnv ; - -- (I) Compute the results and return - let {rn_group = HsGroup { hs_ext = noExtField, - hs_valds = rn_val_decls, - hs_splcds = rn_splice_decls, - hs_tyclds = rn_tycl_decls, - hs_derivds = rn_deriv_decls, - hs_fixds = rn_fix_decls, - hs_warnds = [], -- warns are returned in the tcg_env - -- (see below) not in the HsGroup - hs_fords = rn_foreign_decls, - hs_annds = rn_ann_decls, - hs_defds = rn_default_decls, - hs_ruleds = rn_rule_decls, - hs_docs = rn_docs } ; - - tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ; - other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ; - other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, - src_fvs5, src_fvs6, src_fvs7] ; - -- It is tiresome to gather the binders from type and class decls - - src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ; - -- Instance decls may have occurrences of things bound in bind_dus - -- so we must put other_fvs last - - 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 }; - } ; - traceRn "finish rnSrc" (ppr rn_group) ; - traceRn "finish Dus" (ppr src_dus ) ; - return (final_tcg_env, rn_group) - }}}} -rnSrcDecls (XHsGroup nec) = noExtCon nec - -addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv --- This function could be defined lower down in the module hierarchy, --- but there doesn't seem anywhere very logical to put it. -addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } - -rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars) -rnList f xs = mapFvRn (wrapLocFstM f) xs - -{- -********************************************************* -* * - HsDoc stuff -* * -********************************************************* --} - -rnDocDecl :: DocDecl -> RnM DocDecl -rnDocDecl (DocCommentNext doc) = do - rn_doc <- rnHsDoc doc - return (DocCommentNext rn_doc) -rnDocDecl (DocCommentPrev doc) = do - rn_doc <- rnHsDoc doc - return (DocCommentPrev rn_doc) -rnDocDecl (DocCommentNamed str doc) = do - rn_doc <- rnHsDoc doc - return (DocCommentNamed str rn_doc) -rnDocDecl (DocGroup lev doc) = do - rn_doc <- rnHsDoc doc - return (DocGroup lev rn_doc) - -{- -********************************************************* -* * - Source-code deprecations declarations -* * -********************************************************* - -Check that the deprecated names are defined, are defined locally, and -that there are no duplicate deprecations. - -It's only imported deprecations, dealt with in RnIfaces, that we -gather them together. --} - --- checks that the deprecations are defined locally, and that there are no duplicates -rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings -rnSrcWarnDecls _ [] - = return NoWarnings - -rnSrcWarnDecls bndr_set decls' - = do { -- check for duplicates - ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups - in addErrAt loc (dupWarnDecl lrdr' rdr)) - warn_rdr_dups - ; pairs_s <- mapM (addLocM rn_deprec) decls - ; return (WarnSome ((concat pairs_s))) } - where - decls = concatMap (wd_warnings . unLoc) decls' - - sig_ctxt = TopSigCtxt bndr_set - - rn_deprec (Warning _ rdr_names txt) - -- ensures that the names are defined locally - = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) - rdr_names - ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] } - rn_deprec (XWarnDecl nec) = noExtCon nec - - what = text "deprecation" - - warn_rdr_dups = findDupRdrNames - $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls - -findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)] -findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) - --- look for duplicates among the OccNames; --- we check that the names are defined above --- invt: the lists returned by findDupsEq always have at least two elements - -dupWarnDecl :: Located RdrName -> RdrName -> SDoc --- Located RdrName -> DeprecDecl RdrName -> SDoc -dupWarnDecl d rdr_name - = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), - text "also at " <+> ppr (getLoc d)] - -{- -********************************************************* -* * -\subsection{Annotation declarations} -* * -********************************************************* --} - -rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) -rnAnnDecl ann@(HsAnnotation _ s provenance expr) - = addErrCtxt (annCtxt ann) $ - do { (provenance', provenance_fvs) <- rnAnnProvenance provenance - ; (expr', expr_fvs) <- setStage (Splice Untyped) $ - rnLExpr expr - ; return (HsAnnotation noExtField s provenance' expr', - provenance_fvs `plusFV` expr_fvs) } -rnAnnDecl (XAnnDecl nec) = noExtCon nec - -rnAnnProvenance :: AnnProvenance RdrName - -> RnM (AnnProvenance Name, FreeVars) -rnAnnProvenance provenance = do - provenance' <- traverse lookupTopBndrRn provenance - return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) - -{- -********************************************************* -* * -\subsection{Default declarations} -* * -********************************************************* --} - -rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) -rnDefaultDecl (DefaultDecl _ tys) - = do { (tys', fvs) <- rnLHsTypes doc_str tys - ; return (DefaultDecl noExtField tys', fvs) } - where - doc_str = DefaultDeclCtx -rnDefaultDecl (XDefaultDecl nec) = noExtCon nec - -{- -********************************************************* -* * -\subsection{Foreign declarations} -* * -********************************************************* --} - -rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) -rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) - = do { topEnv :: HscEnv <- getTopEnv - ; name' <- lookupLocatedTopBndrRn name - ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty - - -- Mark any PackageTarget style imports as coming from the current package - ; let unitId = thisPackage $ hsc_dflags topEnv - spec' = patchForeignImport unitId spec - - ; return (ForeignImport { fd_i_ext = noExtField - , fd_name = name', fd_sig_ty = ty' - , fd_fi = spec' }, fvs) } - -rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) - = do { name' <- lookupLocatedOccRn name - ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty - ; return (ForeignExport { fd_e_ext = noExtField - , fd_name = name', fd_sig_ty = ty' - , fd_fe = spec } - , fvs `addOneFV` unLoc name') } - -- NB: a foreign export is an *occurrence site* for name, so - -- we add it to the free-variable list. It might, for example, - -- be imported from another module - -rnHsForeignDecl (XForeignDecl nec) = noExtCon nec - --- | For Windows DLLs we need to know what packages imported symbols are from --- to generate correct calls. Imported symbols are tagged with the current --- package, so if they get inlined across a package boundary we'll still --- know where they're from. --- -patchForeignImport :: UnitId -> ForeignImport -> ForeignImport -patchForeignImport unitId (CImport cconv safety fs spec src) - = CImport cconv safety fs (patchCImportSpec unitId spec) src - -patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec -patchCImportSpec unitId spec - = case spec of - CFunction callTarget -> CFunction $ patchCCallTarget unitId callTarget - _ -> spec - -patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget -patchCCallTarget unitId callTarget = - case callTarget of - StaticTarget src label Nothing isFun - -> StaticTarget src label (Just unitId) isFun - _ -> callTarget - -{- -********************************************************* -* * -\subsection{Instance declarations} -* * -********************************************************* --} - -rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) -rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) - = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi - ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) } - -rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) - = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi - ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) } - -rnSrcInstDecl (ClsInstD { cid_inst = cid }) - = do { traceRn "rnSrcIstDecl {" (ppr cid) - ; (cid', fvs) <- rnClsInstDecl cid - ; traceRn "rnSrcIstDecl end }" empty - ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) } - -rnSrcInstDecl (XInstDecl nec) = noExtCon nec - --- | Warn about non-canonical typeclass instance declarations --- --- A "non-canonical" instance definition can occur for instances of a --- class which redundantly defines an operation its superclass --- provides as well (c.f. `return`/`pure`). In such cases, a canonical --- instance is one where the subclass inherits its method --- implementation from its superclass instance (usually the subclass --- has a default method implementation to that effect). Consequently, --- a non-canonical instance occurs when this is not the case. --- --- See also descriptions of 'checkCanonicalMonadInstances' and --- 'checkCanonicalMonoidInstances' -checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () -checkCanonicalInstances cls poly_ty mbinds = do - whenWOptM Opt_WarnNonCanonicalMonadInstances - checkCanonicalMonadInstances - - whenWOptM Opt_WarnNonCanonicalMonoidInstances - checkCanonicalMonoidInstances - - where - -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance - -- declarations. Specifically, the following conditions are verified: - -- - -- In 'Monad' instances declarations: - -- - -- * If 'return' is overridden it must be canonical (i.e. @return = pure@) - -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@) - -- - -- In 'Applicative' instance declarations: - -- - -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). - -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). - -- - checkCanonicalMonadInstances - | cls == applicativeClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do - case mbind of - FunBind { fun_id = L _ name - , fun_matches = mg } - | name == pureAName, isAliasMG mg == Just returnMName - -> addWarnNonCanonicalMethod1 - Opt_WarnNonCanonicalMonadInstances "pure" "return" - - | name == thenAName, isAliasMG mg == Just thenMName - -> addWarnNonCanonicalMethod1 - Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)" - - _ -> return () - - | cls == monadClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do - case mbind of - FunBind { fun_id = L _ name - , fun_matches = mg } - | name == returnMName, isAliasMG mg /= Just pureAName - -> addWarnNonCanonicalMethod2 - Opt_WarnNonCanonicalMonadInstances "return" "pure" - - | name == thenMName, isAliasMG mg /= Just thenAName - -> addWarnNonCanonicalMethod2 - Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)" - - _ -> return () - - | otherwise = return () - - -- | Check whether Monoid(mappend) is defined in terms of - -- Semigroup((<>)) (and not the other way round). Specifically, - -- the following conditions are verified: - -- - -- In 'Monoid' instances declarations: - -- - -- * If 'mappend' is overridden it must be canonical - -- (i.e. @mappend = (<>)@) - -- - -- In 'Semigroup' instance declarations: - -- - -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). - -- - checkCanonicalMonoidInstances - | cls == semigroupClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do - case mbind of - FunBind { fun_id = L _ name - , fun_matches = mg } - | name == sappendName, isAliasMG mg == Just mappendName - -> addWarnNonCanonicalMethod1 - Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" - - _ -> return () - - | cls == monoidClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do - case mbind of - FunBind { fun_id = L _ name - , fun_matches = mg } - | name == mappendName, isAliasMG mg /= Just sappendName - -> addWarnNonCanonicalMethod2NoDefault - Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)" - - _ -> return () - - | otherwise = return () - - -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\" - -- binding, and return @Just rhsName@ if this is the case - isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name - isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = [] - , m_grhss = grhss })])} - | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss - , EmptyLocalBinds _ <- unLoc lbinds - , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) - isAliasMG _ = Nothing - - -- got "lhs = rhs" but expected something different - addWarnNonCanonicalMethod1 flag lhs rhs = do - addWarn (Reason flag) $ 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) - ] - - -- expected "lhs = rhs" but got something else - addWarnNonCanonicalMethod2 flag lhs rhs = do - addWarn (Reason flag) $ vcat - [ text "Noncanonical" <+> - quotes (text lhs) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , text "Either remove definition for" <+> - quotes (text lhs) <+> text "or define as" <+> - quotes (text (lhs ++ " = " ++ rhs)) - ] - - -- like above, but method has no default impl - addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do - addWarn (Reason flag) $ vcat - [ text "Noncanonical" <+> - quotes (text lhs) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , text "Define as" <+> - quotes (text (lhs ++ " = " ++ rhs)) - ] - - -- stolen from TcInstDcls - instDeclCtxt1 :: LHsSigType GhcRn -> SDoc - instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) - - inst_decl_ctxt :: SDoc -> SDoc - inst_decl_ctxt doc = hang (text "in the instance declaration for") - 2 (quotes doc <> text ".") - - -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 { (inst_ty', inst_fvs) - <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inst_ty - ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' - ; cls <- - case hsTyGetAppHead_maybe head_ty' of - Just (L _ cls) -> pure cls - Nothing -> do - -- The instance is malformed. We'd still like - -- to make *some* progress (rather than failing outright), so - -- we report an error and continue for as long as we can. - -- Importantly, this error should be thrown before we reach the - -- typechecker, lest we encounter different errors that are - -- hopelessly confusing (such as the one in #16114). - addErrAt (getLoc (hsSigType inst_ty)) $ - hang (text "Illegal class instance:" <+> quotes (ppr inst_ty)) - 2 (vcat [ text "Class instances must be of the form" - , nest 2 $ text "context => C ty_1 ... ty_n" - , text "where" <+> quotes (char 'C') - <+> text "is a class" - ]) - pure $ mkUnboundName (mkTcOccFS (fsLit "")) - - -- Rename the bindings - -- The typechecker (not the renamer) checks that all - -- the bindings are for the right class - -- (Slightly strangely) when scoped type variables are on, the - -- forall-d tyvars scope over the method bindings too - ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags - - ; checkCanonicalInstances cls inst_ty' mbinds' - - -- Rename the associated types, and type signatures - -- Both need to have the instance type variables in scope - ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names) - ; ((ats', adts'), more_fvs) - <- extendTyVarEnvFVRn ktv_names $ - do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats - ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts - ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) } - - ; let all_fvs = meth_fvs `plusFV` more_fvs - `plusFV` inst_fvs - ; return (ClsInstDecl { cid_ext = noExtField - , cid_poly_ty = inst_ty', cid_binds = mbinds' - , cid_sigs = uprags', cid_tyfam_insts = ats' - , cid_overlap_mode = oflag - , cid_datafam_insts = adts' }, - all_fvs) } - -- We return the renamed associated data type declarations so - -- that they can be entered into the list of type declarations - -- for the binding group, but we also keep a copy in the instance. - -- The latter is needed for well-formedness checks in the type - -- checker (eg, to ensure that all ATs of the instance actually - -- receive a declaration). - -- NB: Even the copies in the instance declaration carry copies of - -- the instance context after renaming. This is a bit - -- strange, but should not matter (and it would be more work - -- to remove the context). -rnClsInstDecl (XClsInstDecl nec) = noExtCon nec - -rnFamInstEqn :: HsDocContext - -> AssocTyFamInfo - -> [Located RdrName] -- Kind variables from the equation's RHS - -> FamInstEqn GhcPs rhs - -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) - -> RnM (FamInstEqn GhcRn rhs', FreeVars) -rnFamInstEqn doc atfi rhs_kvars - (HsIB { hsib_body = FamEqn { feqn_tycon = tycon - , feqn_bndrs = mb_bndrs - , feqn_pats = pats - , feqn_fixity = fixity - , feqn_rhs = payload }}) rn_payload - = do { let mb_cls = case atfi of - NonAssocTyFamEqn -> Nothing - AssocTyFamDeflt cls -> Just cls - AssocTyFamInst cls _ -> Just cls - ; tycon' <- lookupFamInstName mb_cls tycon - ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats - -- Use the "...Dups" form because it's needed - -- below to report unused binder on the LHS - - -- Implicitly bound variables, empty if we have an explicit 'forall' according - -- to the "forall-or-nothing" rule. - ; let imp_vars | isNothing mb_bndrs = nubL pat_kity_vars_with_dups - | otherwise = [] - ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars - - ; let bndrs = fromMaybe [] mb_bndrs - bnd_vars = map hsLTyVarLocName bndrs - payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars - -- Make sure to filter out the kind variables that were explicitly - -- bound in the type patterns. - ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars - - -- all names not bound in an explicit forall - ; let all_imp_var_names = imp_var_names ++ payload_kvar_names - - -- All the free vars of the family patterns - -- with a sensible binding location - ; ((bndrs', pats', payload'), fvs) - <- bindLocalNamesFV all_imp_var_names $ - bindLHsTyVarBndrs doc (Just $ inHsDocContext doc) - Nothing bndrs $ \bndrs' -> - -- Note: If we pass mb_cls instead of Nothing here, - -- bindLHsTyVarBndrs will use class variables for any names - -- the user meant to bring in scope here. This is an explicit - -- forall, so we want fresh names, not class variables. - -- Thus: always pass Nothing - do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats - ; (payload', rhs_fvs) <- rn_payload doc payload - - -- Report unused binders on the LHS - -- See Note [Unused type variables in family instances] - ; let groups :: [NonEmpty (Located RdrName)] - groups = equivClasses cmpLocated $ - pat_kity_vars_with_dups - ; nms_dups <- mapM (lookupOccRn . unLoc) $ - [ tv | (tv :| (_:_)) <- groups ] - -- Add to the used variables - -- a) any variables that appear *more than once* on the LHS - -- e.g. F a Int a = Bool - -- b) for associated instances, the variables - -- of the instance decl. See - -- Note [Unused type variables in family instances] - ; let nms_used = extendNameSetList rhs_fvs $ - inst_tvs ++ nms_dups - inst_tvs = case atfi of - NonAssocTyFamEqn -> [] - AssocTyFamDeflt _ -> [] - AssocTyFamInst _ inst_tvs -> inst_tvs - all_nms = all_imp_var_names ++ hsLTyVarNames bndrs' - ; warnUnusedTypePatterns all_nms nms_used - - ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) } - - ; let all_fvs = fvs `addOneFV` unLoc tycon' - -- type instance => use, hence addOneFV - - ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances] - , hsib_body - = FamEqn { feqn_ext = noExtField - , feqn_tycon = tycon' - , feqn_bndrs = bndrs' <$ mb_bndrs - , feqn_pats = pats' - , feqn_fixity = fixity - , feqn_rhs = payload' } }, - all_fvs) } -rnFamInstEqn _ _ _ (HsIB _ (XFamEqn nec)) _ = noExtCon nec -rnFamInstEqn _ _ _ (XHsImplicitBndrs nec) _ = noExtCon nec - -rnTyFamInstDecl :: AssocTyFamInfo - -> TyFamInstDecl GhcPs - -> RnM (TyFamInstDecl GhcRn, FreeVars) -rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn }) - = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn - ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) } - --- | Tracks whether we are renaming: --- --- 1. A type family equation that is not associated --- with a parent type class ('NonAssocTyFamEqn') --- --- 2. An associated type family default declaration ('AssocTyFamDeflt') --- --- 3. An associated type family instance declaration ('AssocTyFamInst') -data AssocTyFamInfo - = NonAssocTyFamEqn - | AssocTyFamDeflt Name -- Name of the parent class - | AssocTyFamInst Name -- Name of the parent class - [Name] -- Names of the tyvars of the parent instance decl - --- | Tracks whether we are renaming an equation in a closed type family --- equation ('ClosedTyFam') or not ('NotClosedTyFam'). -data ClosedTyFamInfo - = NotClosedTyFam - | ClosedTyFam (Located RdrName) Name - -- The names (RdrName and Name) of the closed type family - -rnTyFamInstEqn :: AssocTyFamInfo - -> ClosedTyFamInfo - -> TyFamInstEqn GhcPs - -> RnM (TyFamInstEqn GhcRn, FreeVars) -rnTyFamInstEqn atfi ctf_info - eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon - , feqn_rhs = rhs }}) - = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs - ; (eqn'@(HsIB { hsib_body = - FamEqn { feqn_tycon = L _ tycon' }}), fvs) - <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn - ; case ctf_info of - NotClosedTyFam -> pure () - ClosedTyFam fam_rdr_name fam_name -> - checkTc (fam_name == tycon') $ - withHsDocContext (TyFamilyCtx fam_rdr_name) $ - wrongTyFamName fam_name tycon' - ; pure (eqn', fvs) } -rnTyFamInstEqn _ _ (HsIB _ (XFamEqn nec)) = noExtCon nec -rnTyFamInstEqn _ _ (XHsImplicitBndrs nec) = noExtCon nec - -rnTyFamDefltDecl :: Name - -> TyFamDefltDecl GhcPs - -> RnM (TyFamDefltDecl GhcRn, FreeVars) -rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls) - -rnDataFamInstDecl :: AssocTyFamInfo - -> DataFamInstDecl GhcPs - -> RnM (DataFamInstDecl GhcRn, FreeVars) -rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body = - FamEqn { feqn_tycon = tycon - , feqn_rhs = rhs }})}) - = do { let rhs_kvs = extractDataDefnKindVars rhs - ; (eqn', fvs) <- - rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn - ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) } -rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn nec))) - = noExtCon nec -rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs nec)) - = noExtCon nec - --- Renaming of the associated types in instances. - --- Rename associated type family decl in class -rnATDecls :: Name -- Class - -> [LFamilyDecl GhcPs] - -> RnM ([LFamilyDecl GhcRn], FreeVars) -rnATDecls cls at_decls - = rnList (rnFamDecl (Just cls)) at_decls - -rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames - decl GhcPs -> -- an instance. rnTyFamInstDecl - RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl - -> Name -- Class - -> [Name] - -> [Located (decl GhcPs)] - -> RnM ([Located (decl GhcRn)], FreeVars) --- Used for data and type family defaults in a class decl --- and the family instance declarations in an instance --- --- NB: We allow duplicate associated-type decls; --- See Note [Associated type instances] in TcInstDcls -rnATInstDecls rnFun cls tv_ns at_insts - = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts - -- See Note [Renaming associated types] - -{- Note [Wildcards in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Wild cards can be used in type/data family instance declarations to indicate -that the name of a type variable doesn't matter. Each wild card will be -replaced with a new unique type variable. For instance: - - type family F a b :: * - type instance F Int _ = Int - -is the same as - - type family F a b :: * - type instance F Int b = Int - -This is implemented as follows: Unnamed wildcards remain unchanged after -the renamer, and then given fresh meta-variables during typechecking, and -it is handled pretty much the same way as the ones in partial type signatures. -We however don't want to emit hole constraints on wildcards in family -instances, so we turn on PartialTypeSignatures and turn off warning flag to -let typechecker know this. -See related Note [Wildcards in visible kind application] in TcHsType.hs - -Note [Unused type variables in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the flag -fwarn-unused-type-patterns is on, the compiler reports -warnings about unused type variables in type-family instances. A -tpye variable is considered used (i.e. cannot be turned into a wildcard) -when - - * it occurs on the RHS of the family instance - e.g. type instance F a b = a -- a is used on the RHS - - * it occurs multiple times in the patterns on the LHS - e.g. type instance F a a = Int -- a appears more than once on LHS - - * it is one of the instance-decl variables, for associated types - e.g. instance C (a,b) where - type T (a,b) = a - Here the type pattern in the type instance must be the same as that - for the class instance, so - type T (a,_) = a - would be rejected. So we should not complain about an unused variable b - -As usual, the warnings are not reported for type variables with names -beginning with an underscore. - -Extra-constraints wild cards are not supported in type/data family -instance declarations. - -Relevant tickets: #3699, #10586, #10982 and #11451. - -Note [Renaming associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Check that the RHS of the decl mentions only type variables that are explicitly -bound on the LHS. For example, this is not ok - class C a b where - type F a x :: * - instance C (p,q) r where - type F (p,q) x = (x, r) -- BAD: mentions 'r' -c.f. #5515 - -Kind variables, on the other hand, are allowed to be implicitly or explicitly -bound. As examples, this (#9574) is acceptable: - class Funct f where - type Codomain f :: * - instance Funct ('KProxy :: KProxy o) where - -- o is implicitly bound by the kind signature - -- of the LHS type pattern ('KProxy) - type Codomain 'KProxy = NatTr (Proxy :: o -> *) -And this (#14131) is also acceptable: - data family Nat :: k -> k -> * - -- k is implicitly bound by an invisible kind pattern - newtype instance Nat :: (k -> *) -> (k -> *) -> * where - Nat :: (forall xx. f xx -> g xx) -> Nat f g -We could choose to disallow this, but then associated type families would not -be able to be as expressive as top-level type synonyms. For example, this type -synonym definition is allowed: - type T = (Nothing :: Maybe a) -So for parity with type synonyms, we also allow: - type family T :: Maybe a - type instance T = (Nothing :: Maybe a) - -All this applies only for *instance* declarations. In *class* -declarations there is no RHS to worry about, and the class variables -can all be in scope (#5862): - class Category (x :: k -> k -> *) where - type Ob x :: k -> Constraint - id :: Ob x a => x a a - (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c -Here 'k' is in scope in the kind signature, just like 'x'. - -Although type family equations can bind type variables with explicit foralls, -it need not be the case that all variables that appear on the RHS must be bound -by a forall. For instance, the following is acceptable: - - class C a where - type T a b - instance C (Maybe a) where - type forall b. T (Maybe a) b = Either a b - -Even though `a` is not bound by the forall, this is still accepted because `a` -was previously bound by the `instance C (Maybe a)` part. (see #16116). - -In each case, the function which detects improperly bound variables on the RHS -is TcValidity.checkValidFamPats. --} - - -{- -********************************************************* -* * -\subsection{Stand-alone deriving declarations} -* * -********************************************************* --} - -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) - ; (mds', ty', fvs) - <- rnLDerivStrategy DerivDeclCtx mds $ - rnHsSigWcType BindUnlessForall DerivDeclCtx ty - ; warnNoDerivStrat mds' loc - ; return (DerivDecl noExtField ty' mds' overlap, fvs) } - where - loc = getLoc $ hsib_body $ hswc_body ty -rnSrcDerivDecl (XDerivDecl nec) = noExtCon nec - -standaloneDerivErr :: SDoc -standaloneDerivErr - = hang (text "Illegal standalone deriving declaration") - 2 (text "Use StandaloneDeriving to enable this extension") - -{- -********************************************************* -* * -\subsection{Rules} -* * -********************************************************* --} - -rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars) -rnHsRuleDecls (HsRules { rds_src = src - , rds_rules = rules }) - = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules - ; return (HsRules { rds_ext = noExtField - , rds_src = src - , rds_rules = rn_rules }, fvs) } -rnHsRuleDecls (XRuleDecls nec) = noExtCon nec - -rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) -rnHsRuleDecl (HsRule { rd_name = rule_name - , rd_act = act - , rd_tyvs = tyvs - , rd_tmvs = tmvs - , rd_lhs = lhs - , rd_rhs = rhs }) - = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs - ; checkDupRdrNames rdr_names_w_loc - ; checkShadowedRdrNames rdr_names_w_loc - ; names <- newLocalBndrsRn rdr_names_w_loc - ; let doc = RuleCtx (snd $ unLoc rule_name) - ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' -> - bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' -> - do { (lhs', fv_lhs') <- rnLExpr lhs - ; (rhs', fv_rhs') <- rnLExpr rhs - ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs' - ; return (HsRule { rd_ext = HsRuleRn fv_lhs' fv_rhs' - , rd_name = rule_name - , rd_act = act - , rd_tyvs = tyvs' - , rd_tmvs = tmvs' - , rd_lhs = lhs' - , rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } } - where - get_var (RuleBndrSig _ v _) = v - get_var (RuleBndr _ v) = v - get_var (XRuleBndr nec) = noExtCon nec - in_rule = text "in the rule" <+> pprFullRuleName rule_name -rnHsRuleDecl (XRuleDecl nec) = noExtCon nec - -bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs - -> [LRuleBndr GhcPs] -> [Name] - -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -bindRuleTmVars doc tyvs vars names thing_inside - = go vars names $ \ vars' -> - bindLocalNamesFV names (thing_inside vars') - where - go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside - = go vars ns $ \ vars' -> - thing_inside (L l (RuleBndr noExtField (L loc n)) : vars') - - go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) - (n : ns) thing_inside - = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' -> - go vars ns $ \ vars' -> - thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars') - - go [] [] thing_inside = thing_inside [] - go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) - - bind_free_tvs = case tyvs of Nothing -> AlwaysBind - Just _ -> NeverBind - -bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs] - -> (Maybe [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) - -> RnM (b, FreeVars) -bindRuleTyVars doc in_doc (Just bndrs) thing_inside - = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just) -bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing - -{- -Note [Rule LHS validity checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Check the shape of a transformation rule LHS. Currently we only allow -LHSs of the form @(f e1 .. en)@, where @f@ is not one of the -@forall@'d variables. - -We used restrict the form of the 'ei' to prevent you writing rules -with LHSs with a complicated desugaring (and hence unlikely to match); -(e.g. a case expression is not allowed: too elaborate.) - -But there are legitimate non-trivial args ei, like sections and -lambdas. So it seems simmpler not to check at all, and that is why -check_e is commented out. --} - -checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM () -checkValidRule rule_name ids lhs' fv_lhs' - = do { -- Check for the form of the LHS - case (validRuleLhs ids lhs') of - Nothing -> return () - Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad) - - -- 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 } - -validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn) --- Nothing => OK --- Just e => Not ok, and e is the offending sub-expression -validRuleLhs foralls lhs - = checkl lhs - where - checkl = check . unLoc - - check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1 - `mplus` checkl_e e2 - check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2 - check (HsAppType _ e _) = checkl e - check (HsVar _ lv) - | (unLoc lv) `notElem` foralls = Nothing - check other = Just other -- Failure - - -- Check an argument - checkl_e _ = Nothing - -- Was (check_e e); see Note [Rule LHS validity checking] - -{- Commented out; see Note [Rule LHS validity checking] above - check_e (HsVar v) = Nothing - check_e (HsPar e) = checkl_e e - check_e (HsLit e) = Nothing - check_e (HsOverLit e) = Nothing - - check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2 - check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 - check_e (NegApp e _) = checkl_e e - check_e (ExplicitList _ es) = checkl_es es - check_e other = Just other -- Fails - - checkl_es es = foldr (mplus . checkl_e) Nothing es --} - -badRuleVar :: FastString -> Name -> SDoc -badRuleVar name var - = 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 -> SDoc -badRuleLhsErr name lhs bad_e - = 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" - where - err = case bad_e of - HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual uv) - _ -> text "Illegal expression:" <+> ppr bad_e - -{- ************************************************************** - * * - Renaming type, class, instance and role declarations -* * -***************************************************************** - -@rnTyDecl@ uses the `global name function' to create a new type -declaration in which local names have been replaced by their original -names, reporting any unknown names. - -Renaming type variables is a pain. Because they now contain uniques, -it is necessary to pass in an association list which maps a parsed -tyvar to its @Name@ representation. -In some cases (type signatures of values), -it is even necessary to go over the type first -in order to get the set of tyvars used by it, make an assoc list, -and then go over it again to rename the tyvars! -However, we can also do some scoping checks at the same time. - -Note [Dependency analysis of type, class, and instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A TyClGroup represents a strongly connected components of -type/class/instance decls, together with the role annotations for the -type/class declarations. The renamer uses strongly connected -comoponent analysis to build these groups. We do this for a number of -reasons: - -* Improve kind error messages. Consider - - data T f a = MkT f a - data S f a = MkS f (T f a) - - This has a kind error, but the error message is better if you - check T first, (fixing its kind) and *then* S. If you do kind - inference together, you might get an error reported in S, which - is jolly confusing. See #4875 - - -* Increase kind polymorphism. See TcTyClsDecls - Note [Grouping of type and class declarations] - -Why do the instance declarations participate? At least two reasons - -* Consider (#11348) - - type family F a - type instance F Int = Bool - - data R = MkR (F Int) - - type Foo = 'MkR 'True - - For Foo to kind-check we need to know that (F Int) ~ Bool. But we won't - know that unless we've looked at the type instance declaration for F - before kind-checking Foo. - -* Another example is this (#3990). - - data family Complex a - data instance Complex Double = CD {-# UNPACK #-} !Double - {-# UNPACK #-} !Double - - data T = T {-# UNPACK #-} !(Complex Double) - - Here, to generate the right kind of unpacked implementation for T, - we must have access to the 'data instance' declaration. - -* Things become more complicated when we introduce transitive - dependencies through imported definitions, like in this scenario: - - A.hs - type family Closed (t :: Type) :: Type where - Closed t = Open t - - type family Open (t :: Type) :: Type - - B.hs - data Q where - Q :: Closed Bool -> Q - - type instance Open Int = Bool - - type S = 'Q 'True - - Somehow, we must ensure that the instance Open Int = Bool is checked before - the type synonym S. While we know that S depends upon 'Q depends upon Closed, - we have no idea that Closed depends upon Open! - - To accommodate for these situations, we ensure that an instance is checked - before every @TyClDecl@ on which it does not depend. That's to say, instances - are checked as early as possible in @tcTyAndClassDecls@. - ------------------------------------- -So much for WHY. What about HOW? It's pretty easy: - -(1) Rename the type/class, instance, and role declarations - individually - -(2) Do strongly-connected component analysis of the type/class decls, - We'll make a TyClGroup for each SCC - - In this step we treat a reference to a (promoted) data constructor - K as a dependency on its parent type. Thus - data T = K1 | K2 - data S = MkS (Proxy 'K1) - Here S depends on 'K1 and hence on its parent T. - - In this step we ignore instances; see - Note [No dependencies on data instances] - -(3) Attach roles to the appropriate SCC - -(4) Attach instances to the appropriate SCC. - We add an instance decl to SCC when: - all its free types/classes are bound in this SCC or earlier ones - -(5) We make an initial TyClGroup, with empty group_tyclds, for any - (orphan) instances that affect only imported types/classes - -Steps (3) and (4) are done by the (mapAccumL mk_group) call. - -Note [No dependencies on data instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - data family D a - data instance D Int = D1 - data S = MkS (Proxy 'D1) - -Here the declaration of S depends on the /data instance/ declaration -for 'D Int'. That makes things a lot more complicated, especially -if the data instance is an associated type of an enclosing class instance. -(And the class instance might have several associated type instances -with different dependency structure!) - -Ugh. For now we simply don't allow promotion of data constructors for -data instances. See Note [AFamDataCon: not promoting data family -constructors] in TcEnv --} - - -rnTyClDecls :: [TyClGroup GhcPs] - -> RnM ([TyClGroup GhcRn], FreeVars) --- Rename the declarations and do dependency analysis on them -rnTyClDecls tycl_ds - = do { -- Rename the type/class, instance, and role declaraations - ; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds) - ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs) - ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds) - ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds) - ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds) - - -- Do SCC analysis on the type/class decls - ; rdr_env <- getGlobalRdrEnv - ; 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 - - inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs - (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map - - first_group - | null init_inst_ds = [] - | otherwise = [TyClGroup { group_ext = noExtField - , group_tyclds = [] - , group_kisigs = [] - , group_roles = [] - , group_instds = init_inst_ds }] - - (final_inst_ds, groups) - = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs - - all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV` - foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV` - foldr (plusFV . snd) emptyFVs kisigs_w_fvs - - all_groups = first_group ++ groups - - ; MASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map - $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds ) - - ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups) - ; return (all_groups, all_fvs) } - where - mk_group :: RoleAnnotEnv - -> KindSigEnv - -> InstDeclFreeVarsMap - -> SCC (LTyClDecl GhcRn) - -> (InstDeclFreeVarsMap, TyClGroup GhcRn) - mk_group role_env kisig_env inst_map scc - = (inst_map', group) - where - tycl_ds = flattenSCC scc - bndrs = map (tcdName . unLoc) tycl_ds - roles = getRoleAnnots bndrs role_env - kisigs = getKindSigs bndrs kisig_env - (inst_ds, inst_map') = getInsts bndrs inst_map - group = TyClGroup { group_ext = noExtField - , group_tyclds = tycl_ds - , group_kisigs = kisigs - , group_roles = roles - , group_instds = inst_ds } - --- | Free variables of standalone kind signatures. -newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars) - -lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars -lookupKindSig_FV_Env (KindSig_FV_Env e) name - = fromMaybe emptyFVs (lookupNameEnv e name) - --- | Standalone kind signatures. -type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn) - -mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env) -mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env) - where - kisig_env = mapNameEnv fst compound_env - kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env) - compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars) - = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs - -getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn] -getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs - -rnStandaloneKindSignatures - :: NameSet -- names of types and classes in the current TyClGroup - -> [LStandaloneKindSig GhcPs] - -> RnM [(LStandaloneKindSig GhcRn, FreeVars)] -rnStandaloneKindSignatures tc_names kisigs - = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs - get_name = standaloneKindSigName . unLoc - ; mapM_ dupKindSig_Err dup_kisigs - ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups - } - -rnStandaloneKindSignature - :: NameSet -- names of types and classes in the current TyClGroup - -> StandaloneKindSig GhcPs - -> 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 <- 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 :: SDoc - standaloneKiSigErr = - hang (text "Illegal standalone kind signature") - 2 (text "Did you mean to enable StandaloneKindSignatures?") -rnStandaloneKindSignature _ (XStandaloneKindSig nec) = noExtCon nec - -depAnalTyClDecls :: GlobalRdrEnv - -> KindSig_FV_Env - -> [(LTyClDecl GhcRn, FreeVars)] - -> [SCC (LTyClDecl GhcRn)] --- See Note [Dependency analysis of type, class, and instance decls] -depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs - = stronglyConnCompFromEdgedVerticesUniq edges - where - edges :: [ Node Name (LTyClDecl GhcRn) ] - edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps)) - | (d, fvs) <- ds_w_fvs, - let { name = tcdName (unLoc d) - ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name - ; deps = fvs `plusFV` kisig_fvs - } - ] - -- 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 Digraph. - -toParents :: GlobalRdrEnv -> NameSet -> NameSet -toParents rdr_env ns - = nonDetFoldUniqSet add emptyNameSet ns - -- It's OK to use nonDetFoldUFM because we immediately forget the - -- ordering by creating a set - where - add n s = extendNameSet s (getParent rdr_env n) - -getParent :: GlobalRdrEnv -> Name -> Name -getParent rdr_env n - = case lookupGRE_Name rdr_env n of - Just gre -> case gre_par gre of - ParentIs { par_is = p } -> p - FldParent { par_is = p } -> p - _ -> n - Nothing -> n - - -{- ****************************************************** -* * - Role annotations -* * -****************************************************** -} - --- | Renames role annotations, returning them as the values in a NameEnv --- and checks for duplicate role annotations. --- It is quite convenient to do both of these in the same place. --- See also Note [Role annotations in the renamer] -rnRoleAnnots :: NameSet - -> [LRoleAnnotDecl GhcPs] - -> RnM [LRoleAnnotDecl GhcRn] -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 - get_name = roleAnnotDeclName . unLoc - ; mapM_ dupRoleAnnotErr dup_annots - ; mapM (wrapLocM rn_role_annot1) no_dups } - where - 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' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) - (text "role annotation") - tycon - ; return $ RoleAnnotDecl noExtField tycon' roles } - rn_role_annot1 (XRoleAnnotDecl nec) = noExtCon nec - -dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () -dupRoleAnnotErr list - = addErrAt loc $ - 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 loc) - - cmp_loc = SrcLoc.leftmost_smallest `on` getLoc - -dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () -dupKindSig_Err list - = addErrAt loc $ - 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 loc) - - cmp_loc = SrcLoc.leftmost_smallest `on` getLoc - -{- Note [Role annotations in the renamer] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must ensure that a type's role annotation is put in the same group as the -proper type declaration. This is because role annotations are needed during -type-checking when creating the type's TyCon. So, rnRoleAnnots builds a -NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that -type, if any. Then, this map can be used to add the role annotations to the -groups after dependency analysis. - -This process checks for duplicate role annotations, where we must be careful -to do the check *before* renaming to avoid calling all unbound names duplicates -of one another. - -The renaming process, as usual, might identify and report errors for unbound -names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using -lookupGlobalOccRn led to #8485). --} - - -{- ****************************************************** -* * - Dependency info for instances -* * -****************************************************** -} - ----------------------------------------------------------- --- | 'InstDeclFreeVarsMap is an association of an --- @InstDecl@ with @FreeVars@. The @FreeVars@ are --- the tycon names that are both --- a) free in the instance declaration --- b) bound by this group of type/class/instance decls -type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)] - --- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the --- @FreeVars@ which are *not* the binders of a @TyClDecl@. -mkInstDeclFreeVarsMap :: GlobalRdrEnv - -> NameSet - -> [(LInstDecl GhcRn, FreeVars)] - -> InstDeclFreeVarsMap -mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs - = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs) - | (inst_decl, fvs) <- inst_ds_fvs ] - --- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the --- @InstDeclFreeVarsMap@ with these entries removed. --- We call (getInsts tcs instd_map) when we've completed the declarations --- for 'tcs'. The call returns (inst_decls, instd_map'), where --- inst_decls are the instance declarations all of --- whose free vars are now defined --- instd_map' is the inst-decl map with 'tcs' removed from --- the free-var set -getInsts :: [Name] -> InstDeclFreeVarsMap - -> ([LInstDecl GhcRn], InstDeclFreeVarsMap) -getInsts bndrs inst_decl_map - = partitionWith pick_me inst_decl_map - where - pick_me :: (LInstDecl GhcRn, FreeVars) - -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars) - pick_me (decl, fvs) - | isEmptyNameSet depleted_fvs = Left decl - | otherwise = Right (decl, depleted_fvs) - where - depleted_fvs = delFVs bndrs fvs - -{- ****************************************************** -* * - Renaming a type or class declaration -* * -****************************************************** -} - -rnTyClDecl :: TyClDecl GhcPs - -> RnM (TyClDecl GhcRn, FreeVars) - --- All flavours of top-level type family declarations ("type family", "newtype --- family", and "data family") -rnTyClDecl (FamDecl { tcdFam = fam }) - = do { (fam', fvs) <- rnFamDecl Nothing fam - ; return (FamDecl noExtField fam', fvs) } - -rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, - tcdFixity = fixity, tcdRhs = rhs }) - = do { tycon' <- lookupLocatedTopBndrRn tycon - ; let kvs = extractHsTyRdrTyVarsKindVars rhs - doc = TySynCtx tycon - ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs) - ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> - do { (rhs', fvs) <- rnTySyn doc rhs - ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' - , tcdFixity = fixity - , tcdRhs = rhs', tcdSExt = fvs }, fvs) } } - --- "data", "newtype" declarations -rnTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec -rnTyClDecl (DataDecl - { tcdLName = tycon, tcdTyVars = tyvars, - tcdFixity = fixity, - tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data - , dd_kindSig = kind_sig} }) - = do { tycon' <- lookupLocatedTopBndrRn tycon - ; let kvs = extractDataDefnKindVars defn - doc = TyDataCtx tycon - ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs) - ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs -> - do { (defn', fvs) <- rnDataDefn doc defn - ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig - ; let rn_info = DataDeclRn { tcdDataCusk = cusk - , tcdFVs = fvs } - ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs) - ; return (DataDecl { tcdLName = tycon' - , tcdTyVars = tyvars' - , tcdFixity = fixity - , tcdDataDefn = defn' - , tcdDExt = rn_info }, fvs) } } - -rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, - tcdTyVars = tyvars, tcdFixity = fixity, - tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, - tcdDocs = docs}) - = do { lcls' <- lookupLocatedTopBndrRn lcls - ; let cls' = unLoc lcls' - kvs = [] -- No scoped kind vars except those in - -- kind signatures on the tyvars - - -- Tyvars scope over superclass context and method signatures - ; ((tyvars', context', fds', ats'), stuff_fvs) - <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do - -- Checks for distinct tyvars - { (context', cxt_fvs) <- rnContext cls_doc context - ; fds' <- rnFds fds - -- The fundeps have no free variables - ; (ats', fv_ats) <- rnATDecls cls' ats - ; let fvs = cxt_fvs `plusFV` - fv_ats - ; return ((tyvars', context', fds', ats'), fvs) } - - ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs - - -- No need to check for duplicate associated type decls - -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn - - -- Check the signatures - -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). - ; let sig_rdr_names_w_locs = - [op | L _ (ClassOpSig _ False ops _) <- sigs - , op <- ops] - ; 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 - -- for instance decls. - - -- The newLocals call is tiresome: given a generic class decl - -- class C a where - -- op :: a -> a - -- op {| x+y |} (Inl a) = ... - -- op {| x+y |} (Inr b) = ... - -- op {| a*b |} (a*b) = ... - -- we want to name both "x" tyvars with the same unique, so that they are - -- easy to group together in the typechecker. - ; (mbinds', sigs', meth_fvs) - <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs - -- No need to check for duplicate method signatures - -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn - -- and the methods are already in scope - - -- Haddock docs - ; docs' <- mapM (wrapLocM rnDocDecl) docs - - ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs - ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', - tcdTyVars = tyvars', tcdFixity = fixity, - tcdFDs = fds', tcdSigs = sigs', - tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', - tcdDocs = docs', tcdCExt = all_fvs }, - all_fvs ) } - where - cls_doc = ClassDeclCtx lcls - -rnTyClDecl (XTyClDecl nec) = noExtCon nec - --- Does the data type declaration include a CUSK? -data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool -data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do - { -- See Note [Unlifted Newtypes and CUSKs], and for a broader - -- picture, see Note [Implementation of UnliftedNewtypes]. - ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - ; let non_cusk_newtype - | NewType <- new_or_data = - unlifted_newtypes && isNothing kind_sig - | otherwise = False - -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls - ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype - } - -{- Note [Unlifted Newtypes and CUSKs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When unlifted newtypes are enabled, a newtype must have a kind signature -in order to be considered have a CUSK. This is because the flow of -kind inference works differently. Consider: - - newtype Foo = FooC Int - -When UnliftedNewtypes is disabled, we decide that Foo has kind -`TYPE 'LiftedRep` without looking inside the data constructor. So, we -can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled, -we fill in the kind of Foo as a metavar that gets solved by unification -with the kind of the field inside FooC (that is, Int, whose kind is -`TYPE 'LiftedRep`). But since we have to look inside the data constructors -to figure out the kind signature of Foo, it does not have a CUSK. - -See Note [Implementation of UnliftedNewtypes] for where this fits in to -the broader picture of UnliftedNewtypes. --} - --- "type" and "type instance" declarations -rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) -rnTySyn doc rhs = rnLHsType doc rhs - -rnDataDefn :: HsDocContext -> HsDataDefn GhcPs - -> RnM (HsDataDefn GhcRn, FreeVars) -rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = context, dd_cons = condecls - , dd_kindSig = m_sig, dd_derivs = derivs }) - = do { checkTc (h98_style || null (unLoc context)) - (badGadtStupidTheta doc) - - ; (m_sig', sig_fvs) <- case m_sig of - Just sig -> first Just <$> rnLHsKind doc sig - Nothing -> return (Nothing, emptyFVs) - ; (context', fvs1) <- rnContext doc context - ; (derivs', fvs3) <- rn_derivs derivs - - -- For the constructor declarations, drop the LocalRdrEnv - -- in the GADT case, where the type variables in the declaration - -- do not scope over the constructor signatures - -- data T a where { T1 :: forall b. b-> b } - ; let { zap_lcl_env | h98_style = \ thing -> thing - | otherwise = setLocalRdrEnv emptyLocalRdrEnv } - ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls - -- No need to check for duplicate constructor decls - -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn - - ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` - con_fvs `plusFV` sig_fvs - ; return ( HsDataDefn { dd_ext = noExtField - , dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = context', dd_kindSig = m_sig' - , dd_cons = condecls' - , dd_derivs = derivs' } - , all_fvs ) - } - where - h98_style = case condecls of -- Note [Stupid theta] - (L _ (ConDeclGADT {})) : _ -> False - _ -> True - - rn_derivs (L loc ds) - = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies - ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) - multipleDerivClausesErr - ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds - ; return (L loc ds', fvs) } -rnDataDefn _ (XHsDataDefn nec) = noExtCon nec - -warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) - -> SrcSpan - -> RnM () -warnNoDerivStrat mds loc - = do { dyn_flags <- getDynFlags - ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $ - case mds of - Nothing -> addWarnAt - (Reason Opt_WarnMissingDerivingStrategies) - loc - (if xopt LangExt.DerivingStrategies dyn_flags - then no_strat_warning - else no_strat_warning $+$ deriv_strat_nenabled - ) - _ -> 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) -rnLHsDerivingClause doc - (L loc (HsDerivingClause - { deriv_clause_ext = noExtField - , deriv_clause_strategy = dcs - , deriv_clause_tys = L loc' dct })) - = do { (dcs', dct', fvs) - <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct - ; warnNoDerivStrat dcs' loc - ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField - , deriv_clause_strategy = dcs' - , deriv_clause_tys = L loc' dct' }) - , fvs ) } -rnLHsDerivingClause _ (L _ (XHsDerivingClause nec)) - = noExtCon nec - -rnLDerivStrategy :: forall a. - HsDocContext - -> Maybe (LDerivStrategy GhcPs) - -> RnM (a, FreeVars) - -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars) -rnLDerivStrategy doc mds thing_inside - = case mds of - Nothing -> boring_case Nothing - Just (L loc ds) -> - setSrcSpan loc $ do - (ds', thing, fvs) <- rn_deriv_strat ds - pure (Just (L loc ds'), thing, fvs) - where - rn_deriv_strat :: DerivStrategy GhcPs - -> RnM (DerivStrategy GhcRn, a, FreeVars) - rn_deriv_strat ds = do - let extNeeded :: LangExt.Extension - extNeeded - | ViaStrategy{} <- ds - = LangExt.DerivingVia - | otherwise - = LangExt.DerivingStrategies - - unlessXOptM extNeeded $ - failWith $ illegalDerivStrategyErr ds - - case ds of - StockStrategy -> boring_case StockStrategy - AnyclassStrategy -> boring_case AnyclassStrategy - NewtypeStrategy -> boring_case NewtypeStrategy - ViaStrategy via_ty -> - do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty - let HsIB { hsib_ext = via_imp_tvs - , hsib_body = via_body } = via_ty' - (via_exp_tv_bndrs, _, _) = splitLHsSigmaTyInvis via_body - via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs - via_tvs = via_imp_tvs ++ via_exp_tvs - (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside - pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) - - boring_case :: ds -> RnM (ds, a, FreeVars) - boring_case ds = do - (thing, fvs) <- thing_inside - pure (ds, thing, fvs) - -badGadtStupidTheta :: HsDocContext -> SDoc -badGadtStupidTheta _ - = 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 -> SDoc -illegalDerivStrategyErr ds - = 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 :: SDoc -multipleDerivClausesErr - = 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 - -> FamilyDecl GhcPs - -> RnM (FamilyDecl GhcRn, FreeVars) -rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars - , fdFixity = fixity - , fdInfo = info, fdResultSig = res_sig - , fdInjectivityAnn = injectivity }) - = do { tycon' <- lookupLocatedTopBndrRn tycon - ; ((tyvars', res_sig', injectivity'), fv1) <- - bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ -> - do { let rn_sig = rnFamResultSig doc - ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig - ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') - injectivity - ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } - ; (info', fv2) <- rn_info tycon' info - ; return (FamilyDecl { fdExt = noExtField - , fdLName = tycon', fdTyVars = tyvars' - , fdFixity = fixity - , fdInfo = info', fdResultSig = res_sig' - , fdInjectivityAnn = injectivity' } - , fv1 `plusFV` fv2) } - where - doc = TyFamilyCtx tycon - kvs = extractRdrKindSigVars res_sig - - ---------------------- - rn_info :: Located Name - -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars) - rn_info (L _ fam_name) (ClosedTypeFamily (Just eqns)) - = do { (eqns', fvs) - <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name)) - -- no class context - eqns - ; return (ClosedTypeFamily (Just eqns'), fvs) } - rn_info _ (ClosedTypeFamily Nothing) - = return (ClosedTypeFamily Nothing, emptyFVs) - rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs) - rn_info _ DataFamily = return (DataFamily, emptyFVs) -rnFamDecl _ (XFamilyDecl nec) = noExtCon nec - -rnFamResultSig :: HsDocContext - -> FamilyResultSig GhcPs - -> RnM (FamilyResultSig GhcRn, FreeVars) -rnFamResultSig _ (NoSig _) - = return (NoSig noExtField, emptyFVs) -rnFamResultSig doc (KindSig _ kind) - = do { (rndKind, ftvs) <- rnLHsKind doc kind - ; return (KindSig noExtField rndKind, ftvs) } -rnFamResultSig doc (TyVarSig _ tvbndr) - = do { -- `TyVarSig` tells us that user named the result of a type family by - -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to - -- be sure that the supplied result name is not identical to an - -- already in-scope type variable from an enclosing class. - -- - -- Example of disallowed declaration: - -- class C a b where - -- type F b = a | a -> b - rdr_env <- getLocalRdrEnv - ; let resName = hsLTyVarName tvbndr - ; when (resName `elemLocalRdrEnv` rdr_env) $ - addErrAt (getLoc tvbndr) $ - (hsep [ text "Type variable", quotes (ppr resName) <> comma - , text "naming a type family result," - ] $$ - text "shadows an already bound type variable") - - ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for - -- scoping checks that are irrelevant here - tvbndr $ \ tvbndr' -> - return (TyVarSig noExtField tvbndr', unitFV (hsLTyVarName tvbndr')) } -rnFamResultSig _ (XFamilyResultSig nec) = noExtCon nec - --- Note [Renaming injectivity annotation] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- During renaming of injectivity annotation we have to make several checks to --- make sure that it is well-formed. At the moment injectivity annotation --- consists of a single injectivity condition, so the terms "injectivity --- annotation" and "injectivity condition" might be used interchangeably. See --- Note [Injectivity annotation] for a detailed discussion of currently allowed --- injectivity annotations. --- --- Checking LHS is simple because the only type variable allowed on the LHS of --- injectivity condition is the variable naming the result in type family head. --- Example of disallowed annotation: --- --- type family Foo a b = r | b -> a --- --- Verifying RHS of injectivity consists of checking that: --- --- 1. only variables defined in type family head appear on the RHS (kind --- variables are also allowed). Example of disallowed annotation: --- --- type family Foo a = r | r -> b --- --- 2. for associated types the result variable does not shadow any of type --- class variables. Example of disallowed annotation: --- --- class Foo a b where --- type F a = b | b -> a --- --- Breaking any of these assumptions results in an error. - --- | Rename injectivity annotation. Note that injectivity annotation is just the --- part after the "|". Everything that appears before it is renamed in --- rnFamDecl. -rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in - -- type family head - -> LFamilyResultSig GhcRn -- ^ Result signature - -> LInjectivityAnn GhcPs -- ^ Injectivity annotation - -> RnM (LInjectivityAnn GhcRn) -rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) - (L srcSpan (InjectivityAnn injFrom injTo)) - = do - { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors) - <- askNoErrs $ - bindLocalNames [hsLTyVarName resTv] $ - -- The return type variable scopes over the injectivity annotation - -- e.g. type family F a = (r::*) | r -> a - do { injFrom' <- rnLTyVar injFrom - ; injTo' <- mapM rnLTyVar injTo - ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } - - ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs - resName = hsLTyVarName resTv - -- See Note [Renaming injectivity annotation] - lhsValid = EQ == (stableNameCmp resName (unLoc injFrom')) - rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames - - -- if renaming of type variables ended with errors (eg. there were - -- not-in-scope variables) don't check the validity of injectivity - -- annotation. This gives better error messages. - ; when (noRnErrors && not lhsValid) $ - addErrAt (getLoc injFrom) - ( vcat [ text $ "Incorrect type variable on the LHS of " - ++ "injectivity condition" - , nest 5 - ( vcat [ text "Expected :" <+> ppr resName - , text "Actual :" <+> ppr injFrom ])]) - - ; when (noRnErrors && not (Set.null rhsValid)) $ - do { let errorVars = Set.toList rhsValid - ; addErrAt srcSpan $ ( hsep - [ text "Unknown type variable" <> plural errorVars - , text "on the RHS of injectivity condition:" - , interpp'SP errorVars ] ) } - - ; return injDecl' } - --- We can only hit this case when the user writes injectivity annotation without --- naming the result: --- --- type family F a | result -> a --- type family F a :: * | result -> a --- --- So we rename injectivity annotation like we normally would except that --- this time we expect "result" to be reported not in scope by rnLTyVar. -rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) = - setSrcSpan srcSpan $ do - (injDecl', _) <- askNoErrs $ do - injFrom' <- rnLTyVar injFrom - injTo' <- mapM rnLTyVar injTo - return $ L srcSpan (InjectivityAnn injFrom' injTo') - return $ injDecl' - -{- -Note [Stupid theta] -~~~~~~~~~~~~~~~~~~~ -#3850 complains about a regression wrt 6.10 for - data Show a => T a -There is no reason not to allow the stupid theta if there are no data -constructors. It's still stupid, but does no harm, and I don't want -to cause programs to break unnecessarily (notably HList). So if there -are no data constructors we allow h98_style = True --} - - -{- ***************************************************** -* * - Support code for type/data declarations -* * -***************************************************** -} - ---------------- -wrongTyFamName :: Name -> Name -> SDoc -wrongTyFamName fam_tc_name eqn_tc_name - = hang (text "Mismatched type name in type family instance.") - 2 (vcat [ text "Expected:" <+> ppr fam_tc_name - , text " Actual:" <+> ppr eqn_tc_name ]) - ------------------ -rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars) -rnConDecls = mapFvRn (wrapLocFstM rnConDecl) - -rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) -rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs - , con_mb_cxt = mcxt, con_args = args - , con_doc = mb_doc }) - = do { _ <- addLocM checkConName name - ; new_name <- lookupLocatedTopBndrRn name - ; mb_doc' <- rnMbLHsDoc mb_doc - - -- We bind no implicit binders here; this is just like - -- a nested HsForAllTy. E.g. consider - -- data T a = forall (b::k). MkT (...) - -- The 'k' will already be in scope from the bindHsQTyVars - -- for the data decl itself. So we'll get - -- data T {k} a = ... - -- And indeed we may later discover (a::k). But that's the - -- scoping we get. So no implicit binders at the existential forall - - ; let ctxt = ConDeclCtx [new_name] - ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt)) - Nothing ex_tvs $ \ new_ex_tvs -> - do { (new_context, fvs1) <- rnMbContext ctxt mcxt - ; (new_args, fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args - ; let all_fvs = fvs1 `plusFV` fvs2 - ; traceRn "rnConDecl" (ppr name <+> vcat - [ text "ex_tvs:" <+> ppr ex_tvs - , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) - - ; return (decl { con_ext = noExtField - , con_name = new_name, con_ex_tvs = new_ex_tvs - , con_mb_cxt = new_context, con_args = new_args - , con_doc = mb_doc' }, - all_fvs) }} - -rnConDecl decl@(ConDeclGADT { con_names = names - , con_forall = L _ explicit_forall - , con_qvars = qtvs - , con_mb_cxt = mcxt - , con_args = args - , con_res_ty = res_ty - , con_doc = mb_doc }) - = do { mapM_ (addLocM checkConName) names - ; new_names <- mapM lookupLocatedTopBndrRn names - ; mb_doc' <- rnMbLHsDoc mb_doc - - ; let explicit_tkvs = hsQTvExplicit qtvs - theta = hsConDeclTheta mcxt - arg_tys = hsConDeclArgTys args - - -- We must ensure that we extract the free tkvs in left-to-right - -- order of their appearance in the constructor type. - -- That order governs the order the implicitly-quantified type - -- variable, and hence the order needed for visible type application - -- See #14808. - free_tkvs = extractHsTvBndrs explicit_tkvs $ - extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty]) - - ctxt = ConDeclCtx new_names - mb_ctxt = Just (inHsDocContext ctxt) - - ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall ) - ; rnImplicitBndrs (not explicit_forall) free_tkvs $ \ implicit_tkvs -> - bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs -> - do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt - ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args - ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty - - ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 - (args', res_ty') - = case args of - InfixCon {} -> pprPanic "rnConDecl" (ppr names) - RecCon {} -> (new_args, new_res_ty) - PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty - -> ASSERT( null as ) - -- See Note [GADT abstract syntax] in GHC.Hs.Decls - (PrefixCon arg_tys, final_res_ty) - - new_qtvs = HsQTvs { hsq_ext = implicit_tkvs - , hsq_explicit = explicit_tkvs } - - ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) - ; return (decl { con_g_ext = noExtField, con_names = new_names - , con_qvars = new_qtvs, con_mb_cxt = new_cxt - , con_args = args', con_res_ty = res_ty' - , con_doc = mb_doc' }, - all_fvs) } } - -rnConDecl (XConDecl nec) = noExtCon nec - - -rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) - -> RnM (Maybe (LHsContext GhcRn), FreeVars) -rnMbContext _ Nothing = return (Nothing, emptyFVs) -rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt - ; return (Just ctx',fvs) } - -rnConDeclDetails - :: Name - -> HsDocContext - -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs]) - -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]), - FreeVars) -rnConDeclDetails _ doc (PrefixCon tys) - = do { (new_tys, fvs) <- rnLHsTypes doc tys - ; return (PrefixCon new_tys, fvs) } - -rnConDeclDetails _ doc (InfixCon ty1 ty2) - = do { (new_ty1, fvs1) <- rnLHsType doc ty1 - ; (new_ty2, fvs2) <- rnLHsType doc ty2 - ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } - -rnConDeclDetails con doc (RecCon (L l fields)) - = do { fls <- lookupConstructorFields con - ; (new_fields, fvs) <- rnConDeclFields doc fls fields - -- No need to check for duplicate fields - -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn - ; return (RecCon (L l new_fields), fvs) } - -------------------------------------------------- - --- | Brings pattern synonym names and also pattern synonym selectors --- from record pattern synonyms into scope. -extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv - -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a -extendPatSynEnv 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 pat_syn_bndrs - ; (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' } - ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } - where - new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] - new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds - new_ps _ = panic "new_ps" - - new_ps' :: LHsBindLR GhcPs GhcPs - -> [(Name, [FieldLabel])] - -> TcM [(Name, [FieldLabel])] - new_ps' bind names - | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n - , psb_args = RecCon as }))) <- bind - = do - bnd_name <- newTopSrcBinder (L bind_loc n) - let rnames = map recordPatSynSelectorId as - mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs - mkFieldOcc (L l name) = L l (FieldOcc noExtField (L l name)) - field_occs = map mkFieldOcc rnames - flds <- mapM (newRecordSelector False [bnd_name]) field_occs - return ((bnd_name, flds): names) - | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind - = do - bnd_name <- newTopSrcBinder (L bind_loc n) - return ((bnd_name, []): names) - | otherwise - = return names - -{- -********************************************************* -* * -\subsection{Support code to rename types} -* * -********************************************************* --} - -rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn] -rnFds fds - = mapM (wrapLocM rn_fds) fds - where - rn_fds (tys1, tys2) - = do { tys1' <- rnHsTyVars tys1 - ; tys2' <- rnHsTyVars tys2 - ; return (tys1', tys2') } - -rnHsTyVars :: [Located RdrName] -> RnM [Located Name] -rnHsTyVars tvs = mapM rnHsTyVar tvs - -rnHsTyVar :: Located RdrName -> RnM (Located Name) -rnHsTyVar (L l tyvar) = do - tyvar' <- lookupOccRn tyvar - return (L l tyvar') - -{- -********************************************************* -* * - findSplice -* * -********************************************************* - -This code marches down the declarations, looking for the first -Template Haskell splice. As it does so it - a) groups the declarations into a HsGroup - b) runs any top-level quasi-quotes --} - -findSplice :: [LHsDecl GhcPs] - -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) -findSplice ds = addl emptyRdrGroup ds - -addl :: HsGroup GhcPs -> [LHsDecl GhcPs] - -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) --- This stuff reverses the declarations (again) but it doesn't matter -addl gp [] = return (gp, Nothing) -addl gp (L l d : ds) = add gp l d ds - - -add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] - -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) - --- #10047: Declaration QuasiQuoters are expanded immediately, without --- causing a group split -add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds - = do { (ds', _) <- rnTopSpliceDecls qq - ; addl gp (ds' ++ ds) - } - -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) - case flag of - ExplicitSplice -> return () - ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell - ; unless th_on $ setSrcSpan loc $ - failWith badImplicitSplice } - - ; return (gp, Just (splice, ds)) } - where - badImplicitSplice = 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. - --- Class declarations: added to the TyClGroup -add gp@(HsGroup {hs_tyclds = ts}) l (TyClD _ d) ds - = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds - --- Signatures: fixity sigs go a different place than all others -add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds - = addl (gp {hs_fixds = L l f : ts}) ds - --- Standalone kind signatures: added to the TyClGroup -add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds - = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds - -add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds - = addl (gp {hs_valds = add_sig (L l d) ts}) ds - --- Value declarations: use add_bind -add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds - = addl (gp { hs_valds = add_bind (L l d) ts }) ds - --- Role annotations: added to the TyClGroup -add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds - = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds - --- NB instance declarations go into TyClGroups. We throw them into the first --- group, just as we do for the TyClD case. The renamer will go on to group --- and order them later. -add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds - = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds - --- The rest are routine -add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds - = addl (gp { hs_derivds = L l d : ts }) ds -add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds - = addl (gp { hs_defds = L l d : ts }) ds -add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds - = addl (gp { hs_fords = L l d : ts }) ds -add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds - = addl (gp { hs_warnds = L l d : ts }) ds -add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds - = addl (gp { hs_annds = L l d : ts }) ds -add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds - = addl (gp { hs_ruleds = L l d : ts }) ds -add gp l (DocD _ d) ds - = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds -add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec -add (HsGroup {}) _ (XHsDecl nec) _ = noExtCon nec -add (XHsGroup nec) _ _ _ = noExtCon nec - -add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)] - -> [TyClGroup (GhcPass p)] -add_tycld d [] = [TyClGroup { group_ext = noExtField - , group_tyclds = [d] - , group_kisigs = [] - , group_roles = [] - , group_instds = [] - } - ] -add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss) - = ds { group_tyclds = d : tyclds } : dss -add_tycld _ (XTyClGroup nec: _) = noExtCon nec - -add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)] - -> [TyClGroup (GhcPass p)] -add_instd d [] = [TyClGroup { group_ext = noExtField - , group_tyclds = [] - , group_kisigs = [] - , group_roles = [] - , group_instds = [d] - } - ] -add_instd d (ds@(TyClGroup { group_instds = instds }):dss) - = ds { group_instds = d : instds } : dss -add_instd _ (XTyClGroup nec: _) = noExtCon nec - -add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)] - -> [TyClGroup (GhcPass p)] -add_role_annot d [] = [TyClGroup { group_ext = noExtField - , group_tyclds = [] - , group_kisigs = [] - , group_roles = [d] - , group_instds = [] - } - ] -add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) - = tycls { group_roles = d : roles } : rest -add_role_annot _ (XTyClGroup nec: _) = noExtCon nec - -add_kisig :: LStandaloneKindSig (GhcPass p) - -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)] -add_kisig d [] = [TyClGroup { group_ext = noExtField - , group_tyclds = [] - , group_kisigs = [d] - , group_roles = [] - , group_instds = [] - } - ] -add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest) - = tycls { group_kisigs = d : kisigs } : rest -add_kisig _ (XTyClGroup nec : _) = noExtCon nec - -add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a -add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs -add_bind _ (XValBindsLR {}) = panic "RdrHsSyn:add_bind" - -add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) -add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs) -add_sig _ (XValBindsLR {}) = panic "RdrHsSyn:add_sig" 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 @@ -14,42 +14,42 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Name import GHC.Types.Name.Set import GHC.Hs import GHC.Types.Name.Reader -import TcRnMonad +import GHC.Tc.Utils.Monad import GHC.Rename.Env import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn ) import GHC.Rename.Unbound ( isUnboundName ) -import GHC.Rename.Source ( rnSrcDecls, findSplice ) +import GHC.Rename.Module ( rnSrcDecls, findSplice ) import GHC.Rename.Pat ( rnPat ) import GHC.Types.Basic ( TopLevelFlag, isTopLevel, SourceText(..) ) -import Outputable -import GHC.Types.Module +import GHC.Utils.Outputable +import GHC.Unit.Module import GHC.Types.SrcLoc -import GHC.Rename.Types ( rnLHsType ) +import GHC.Rename.HsType ( rnLHsType ) import Control.Monad ( unless, when ) import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) -import TcEnv ( checkWellStaged ) -import THNames ( liftName ) +import GHC.Tc.Utils.Env ( checkWellStaged ) +import GHC.Builtin.Names.TH ( liftName ) import GHC.Driver.Session -import FastString -import ErrUtils ( dumpIfSet_dyn_printer, DumpFormat (..) ) -import TcEnv ( tcMetaTy ) +import GHC.Data.FastString +import GHC.Utils.Error ( dumpIfSet_dyn_printer, DumpFormat (..) ) +import GHC.Tc.Utils.Env ( tcMetaTy ) import GHC.Driver.Hooks -import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName - , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) +import GHC.Builtin.Names.TH ( quoteExpName, quotePatName, quoteDecName, quoteTypeName + , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) -import {-# SOURCE #-} TcExpr ( tcPolyExpr ) -import {-# SOURCE #-} TcSplice +import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckExpr ) +import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runMetaD , runMetaE , runMetaP @@ -57,7 +57,7 @@ , tcTopSpliceExpr ) -import TcHsSyn +import GHC.Tc.Utils.Zonk import GHCi.RemoteTypes ( ForeignRef ) import qualified Language.Haskell.TH as TH (Q) @@ -91,7 +91,7 @@ ; Splice Untyped -> checkTc (not (isTypedBracket br_body)) illegalTypedBracket ; RunSplice _ -> - -- See Note [RunSplice ThLevel] in "TcRnTypes". + -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnBracket: Renaming bracket when running a splice" (ppr e) ; Comp -> return () @@ -182,8 +182,6 @@ rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e ; return (TExpBr x e', fvs) } -rn_bracket _ (XBracket nec) = noExtCon nec - quotationCtxtDoc :: HsBracket GhcPs -> SDoc quotationCtxtDoc br_body = hang (text "In the Template Haskell quotation") @@ -300,7 +298,6 @@ spliceExtension (HsTypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell) spliceExtension (HsUntypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell) spliceExtension s@(HsSpliced {}) = pprPanic "spliceExtension" (ppr s) - spliceExtension (XSplice nec) = noExtCon nec ------------------ @@ -322,13 +319,12 @@ HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) - XSplice nec -> noExtCon nec -- Typecheck the expression ; meta_exp_ty <- tcMetaTy meta_ty_name ; zonked_q_expr <- zonkTopLExpr =<< tcTopSpliceExpr Untyped - (tcPolyExpr the_expr meta_exp_ty) + (tcCheckExpr the_expr meta_exp_ty) -- Run the expression ; mod_finalizers_ref <- newTcRef [] @@ -369,8 +365,6 @@ = pprPanic "makePending" (ppr splice) makePending _ splice@(HsSpliced {}) = pprPanic "makePending" (ppr splice) -makePending _ (XSplice nec) - = noExtCon nec ------------------ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString @@ -420,7 +414,6 @@ , unitFV quoter') } rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) -rnSplice (XSplice nec) = noExtCon nec --------------------- rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) @@ -540,10 +533,10 @@ [1] https://gitlab.haskell.org/ghc/ghc/wikis/template-haskell/reify [2] 'rnSpliceExpr' -[3] 'TcSplice.qAddModFinalizer' -[4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...)) -[5] 'TcHsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...)) -[6] 'TcPat.tc_pat' ('SplicePat' ('HsSpliced' ...)) +[3] 'GHC.Tc.Gen.Splice.qAddModFinalizer' +[4] 'GHC.Tc.Gen.Expr.tcExpr' ('HsSpliceE' ('HsSpliced' ...)) +[5] 'GHC.Tc.Gen.HsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...)) +[6] 'GHC.Tc.Gen.Pat.tc_pat' ('SplicePat' ('HsSpliced' ...)) -} @@ -600,7 +593,7 @@ renaming. The names generated for anonymous wild cards in TH type splices will thus be collected as well. -For more details about renaming wild cards, see GHC.Rename.Types.rnHsSigWcType +For more details about renaming wild cards, see GHC.Rename.HsType.rnHsSigWcType Note that partial type signatures are fully supported in TH declaration splices, e.g.: @@ -653,7 +646,6 @@ , SpliceDecl noExtField (L loc rn_splice) flg) run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) -rnSpliceDecl (XSpliceDecl nec) = noExtCon nec rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) -- Declaration splice at the very top level of the module @@ -731,7 +723,6 @@ HsTypedSplice {} -> text "typed splice:" HsQuasiQuote {} -> text "quasi-quotation:" HsSpliced {} -> text "spliced expression:" - XSplice nec -> noExtCon nec -- | The splice data to be logged data SpliceInfo @@ -769,7 +760,7 @@ spliceDebugDoc loc = let code = case mb_src of Nothing -> ending - Just e -> nest 2 (ppr (stripParensHsExpr e)) : ending + Just e -> nest 2 (ppr (stripParensLHsExpr e)) : ending ending = [ text "======>", nest 2 gen ] in hang (ppr loc <> colon <+> text "Splicing" <+> text sd) 2 (sep code) @@ -812,7 +803,7 @@ -- Examples \x -> [| x |] -- [| map |] -- --- This code is similar to checkCrossStageLifting in TcExpr, but +-- This code is similar to checkCrossStageLifting in GHC.Tc.Gen.Expr, but -- this is only run on *untyped* brackets. checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name @@ -891,7 +882,7 @@ Note [Quoting names] ~~~~~~~~~~~~~~~~~~~~ A quoted name 'n is a bit like a quoted expression [| n |], except that we -have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing +have no cross-stage lifting (c.f. GHC.Tc.Gen.Expr.thBrackId). So, after incrementing the use-level to account for the brackets, the cases are: bind > use Error diff --git a/compiler/GHC/Rename/Splice.hs-boot b/compiler/GHC/Rename/Splice.hs-boot --- a/compiler/GHC/Rename/Splice.hs-boot +++ b/compiler/GHC/Rename/Splice.hs-boot @@ -1,8 +1,8 @@ module GHC.Rename.Splice where -import GhcPrelude +import GHC.Prelude import GHC.Hs -import TcRnMonad +import GHC.Tc.Utils.Monad import GHC.Types.Name.Set diff --git a/compiler/GHC/Rename/Types.hs b/compiler/GHC/Rename/Types.hs deleted file mode 100644 --- a/compiler/GHC/Rename/Types.hs +++ /dev/null @@ -1,1764 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - --} - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} - -module GHC.Rename.Types ( - -- Type related stuff - rnHsType, rnLHsType, rnLHsTypes, rnContext, - rnHsKind, rnLHsKind, rnLHsTypeArgs, - rnHsSigType, rnHsWcType, - HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped, - newTyVarNameRn, - rnConDeclFields, - rnLTyVar, - - -- Precence related stuff - mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, - checkPrecMatch, checkSectionPrec, - - -- Binding related stuff - bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs, - bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames, - extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars, - extractHsTysRdrTyVarsDups, - extractRdrKindSigVars, extractDataDefnKindVars, - extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup, - nubL, elemRdr - ) where - -import GhcPrelude - -import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType ) - -import GHC.Driver.Session -import GHC.Hs -import GHC.Rename.Doc ( rnLHsDoc, rnMbLHsDoc ) -import GHC.Rename.Env -import GHC.Rename.Utils ( HsDocContext(..), withHsDocContext, mapFvRn - , pprHsDocContext, bindLocalNamesFV, typeAppErr - , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames ) -import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn - , lookupTyFixityRn ) -import TcRnMonad -import GHC.Types.Name.Reader -import PrelNames -import TysPrim ( funTyConName ) -import GHC.Types.Name -import GHC.Types.SrcLoc -import GHC.Types.Name.Set -import GHC.Types.FieldLabel - -import Util -import ListSetOps ( deleteBys ) -import GHC.Types.Basic ( compareFixity, funTyFixity, negateFixity - , Fixity(..), FixityDirection(..), LexicalFixity(..) - , TypeOrKind(..) ) -import Outputable -import FastString -import Maybes -import qualified GHC.LanguageExtensions as LangExt - -import Data.List ( nubBy, partition, (\\) ) -import Control.Monad ( unless, when ) - -#include "HsVersions.h" - -{- -These type renamers are in a separate module, rather than in (say) GHC.Rename.Source, -to break several loop. - -********************************************************* -* * - HsSigWcType (i.e with wildcards) -* * -********************************************************* --} - -data HsSigWcTypeScoping = AlwaysBind - -- ^ Always bind any free tyvars of the given type, - -- regardless of whether we have a forall at the top - | BindUnlessForall - -- ^ Unless there's forall at the top, do the same - -- thing as 'AlwaysBind' - | NeverBind - -- ^ Never bind any free tyvars - -rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs - -> RnM (LHsSigWcType GhcRn, FreeVars) -rnHsSigWcType scoping doc sig_ty - = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' -> - return (sig_ty', emptyFVs) - -rnHsSigWcTypeScoped :: HsSigWcTypeScoping - -- AlwaysBind: for pattern type sigs and rules we /do/ want - -- to bring those type variables into scope, even - -- if there's a forall at the top which usually - -- stops that happening - -- e.g \ (x :: forall a. a-> b) -> e - -- Here we do bring 'b' into scope - -> HsDocContext -> LHsSigWcType GhcPs - -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) --- Used for --- - Signatures on binders in a RULE --- - Pattern type signatures --- Wildcards are allowed --- type signatures on binders only allowed with ScopedTypeVariables -rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside - = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables - ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty) - ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside - } - -rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs - -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) --- rn_hs_sig_wc_type is used for source-language type signatures -rn_hs_sig_wc_type scoping ctxt - (HsWC { hswc_body = HsIB { hsib_body = hs_ty }}) - thing_inside - = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty - ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars - ; let nwc_rdrs = nubL nwc_rdrs' - bind_free_tvs = case scoping of - AlwaysBind -> True - BindUnlessForall -> not (isLHsForAllTy hs_ty) - NeverBind -> False - ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars -> - do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty - ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' } - ib_ty' = HsIB { hsib_ext = vars - , hsib_body = hs_ty' } - ; (res, fvs2) <- thing_inside sig_ty' - ; return (res, fvs1 `plusFV` fvs2) } } -rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs nec)) _ - = noExtCon nec -rn_hs_sig_wc_type _ _ (XHsWildCardBndrs nec) _ - = noExtCon nec - -rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) -rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) - = do { free_vars <- extractFilteredRdrTyVars hs_ty - ; (nwc_rdrs, _) <- partition_nwcs free_vars - ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty - ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' } - ; return (sig_ty', fvs) } -rnHsWcType _ (XHsWildCardBndrs nec) = noExtCon nec - -rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs - -> RnM ([Name], LHsType GhcRn, FreeVars) -rnWcBody ctxt nwc_rdrs hs_ty - = do { nwcs <- mapM newLocalBndrRn nwc_rdrs - ; let env = RTKE { rtke_level = TypeLevel - , rtke_what = RnTypeBody - , rtke_nwcs = mkNameSet nwcs - , rtke_ctxt = ctxt } - ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $ - rn_lty env hs_ty - ; return (nwcs, hs_ty', fvs) } - where - rn_lty env (L loc hs_ty) - = setSrcSpan loc $ - do { (hs_ty', fvs) <- rn_ty env hs_ty - ; return (L loc hs_ty', fvs) } - - rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) - -- A lot of faff just to allow the extra-constraints wildcard to appear - rn_ty env hs_ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs - , hst_body = hs_body }) - = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' -> - do { (hs_body', fvs) <- rn_lty env hs_body - ; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tvs', hst_body = hs_body' } - , fvs) } - - rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt - , hst_body = hs_ty }) - | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt - , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last - = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 - ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1 - ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)] - ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty - ; return (HsQualTy { hst_xqual = noExtField - , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } - , fvs1 `plusFV` fvs2) } - - | otherwise - = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt - ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty - ; return (HsQualTy { hst_xqual = noExtField - , hst_ctxt = L cx hs_ctxt' - , hst_body = hs_ty' } - , fvs1 `plusFV` fvs2) } - - rn_ty env hs_ty = rnHsTyKi env hs_ty - - rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint }) - - -checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM () --- Rename the extra-constraint spot in a type signature --- (blah, _) => type --- Check that extra-constraints are allowed at all, and --- if so that it's an anonymous wildcard -checkExtraConstraintWildCard env hs_ctxt - = checkWildCard env mb_bad - where - mb_bad | not (extraConstraintWildCardsAllowed env) - = Just base_msg - -- Currently, we do not allow wildcards in their full glory in - -- standalone deriving declarations. We only allow a single - -- extra-constraints wildcard à la: - -- - -- deriving instance _ => Eq (Foo a) - -- - -- i.e., we don't support things like - -- - -- deriving instance (Eq a, _) => Eq (Foo a) - | DerivDeclCtx {} <- rtke_ctxt env - , not (null hs_ctxt) - = Just deriv_decl_msg - | otherwise - = Nothing - - base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard - <+> text "not allowed" - - deriv_decl_msg - = hang base_msg - 2 (vcat [ text "except as the sole constraint" - , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ]) - -extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool -extraConstraintWildCardsAllowed env - = case rtke_ctxt env of - TypeSigCtx {} -> True - ExprWithTySigCtx {} -> True - DerivDeclCtx {} -> True - StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls - _ -> False - --- | Finds free type and kind variables in a type, --- without duplicates, and --- without variables that are already in scope in LocalRdrEnv --- NB: this includes named wildcards, which look like perfectly --- ordinary type variables at this point -extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups -extractFilteredRdrTyVars hs_ty = filterInScopeM (extractHsTyRdrTyVars hs_ty) - --- | Finds free type and kind variables in a type, --- with duplicates, but --- without variables that are already in scope in LocalRdrEnv --- NB: this includes named wildcards, which look like perfectly --- ordinary type variables at this point -extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups -extractFilteredRdrTyVarsDups hs_ty = filterInScopeM (extractHsTyRdrTyVarsDups hs_ty) - --- | When the NamedWildCards extension is enabled, partition_nwcs --- removes type variables that start with an underscore from the --- FreeKiTyVars in the argument and returns them in a separate list. --- When the extension is disabled, the function returns the argument --- and empty list. See Note [Renaming named wild cards] -partition_nwcs :: FreeKiTyVars -> RnM ([Located RdrName], FreeKiTyVars) -partition_nwcs free_vars - = do { wildcards_enabled <- xoptM LangExt.NamedWildCards - ; return $ - if wildcards_enabled - then partition is_wildcard free_vars - else ([], free_vars) } - where - is_wildcard :: Located RdrName -> Bool - is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr)) - -{- Note [Renaming named wild cards] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Identifiers starting with an underscore are always parsed as type variables. -It is only here in the renamer that we give the special treatment. -See Note [The wildcard story for types] in GHC.Hs.Types. - -It's easy! When we collect the implicitly bound type variables, ready -to bring them into scope, and NamedWildCards is on, we partition the -variables into the ones that start with an underscore (the named -wildcards) and the rest. Then we just add them to the hswc_wcs field -of the HsWildCardBndrs structure, and we are done. - - -********************************************************* -* * - HsSigtype (i.e. no wildcards) -* * -****************************************************** -} - -rnHsSigType :: HsDocContext - -> TypeOrKind - -> LHsSigType GhcPs - -> RnM (LHsSigType GhcRn, FreeVars) --- Used for source-language type signatures --- that cannot have wildcards -rnHsSigType ctx level (HsIB { hsib_body = hs_ty }) - = do { traceRn "rnHsSigType" (ppr hs_ty) - ; vars <- extractFilteredRdrTyVarsDups hs_ty - ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars -> - do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty - - ; return ( HsIB { hsib_ext = vars - , hsib_body = body' } - , fvs ) } } -rnHsSigType _ _ (XHsImplicitBndrs nec) = noExtCon nec - -rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables - -- E.g. f :: forall a. a->b - -- we do not want to bring 'b' into scope, hence False - -- But f :: a -> b - -- we want to bring both 'a' and 'b' into scope - -> FreeKiTyVarsWithDups - -- Free vars of hs_ty (excluding wildcards) - -- May have duplicates, which is - -- checked here - -> ([Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -rnImplicitBndrs bind_free_tvs - fvs_with_dups - thing_inside - = do { let fvs = nubL fvs_with_dups - real_fvs | bind_free_tvs = fvs - | otherwise = [] - - ; traceRn "rnImplicitBndrs" $ - vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ] - - ; loc <- getSrcSpanM - ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_fvs - - ; bindLocalNamesFV vars $ - thing_inside vars } - -{- ****************************************************** -* * - LHsType and HsType -* * -****************************************************** -} - -{- -rnHsType is here because we call it from loadInstDecl, and I didn't -want a gratuitous knot. - -Note [QualTy in kinds] -~~~~~~~~~~~~~~~~~~~~~~ -I was wondering whether QualTy 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 QualTy must all be -equalities; or at least, any kinds with a class constraint are -uninhabited. --} - -data RnTyKiEnv - = RTKE { rtke_ctxt :: HsDocContext - , rtke_level :: TypeOrKind -- Am I renaming a type or a kind? - , rtke_what :: RnTyKiWhat -- And within that what am I renaming? - , rtke_nwcs :: NameSet -- These are the in-scope named wildcards - } - -data RnTyKiWhat = RnTypeBody - | RnTopConstraint -- Top-level context of HsSigWcTypes - | RnConstraint -- All other constraints - -instance Outputable RnTyKiEnv where - ppr (RTKE { rtke_level = lev, rtke_what = what - , rtke_nwcs = wcs, rtke_ctxt = ctxt }) - = text "RTKE" - <+> braces (sep [ ppr lev, ppr what, ppr wcs - , pprHsDocContext ctxt ]) - -instance Outputable RnTyKiWhat where - ppr RnTypeBody = text "RnTypeBody" - ppr RnTopConstraint = text "RnTopConstraint" - ppr RnConstraint = text "RnConstraint" - -mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv -mkTyKiEnv cxt level what - = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet - , rtke_what = what, rtke_ctxt = cxt } - -isRnKindLevel :: RnTyKiEnv -> Bool -isRnKindLevel (RTKE { rtke_level = KindLevel }) = True -isRnKindLevel _ = False - --------------- -rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) -rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty - -rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars) -rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys - -rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty - -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) -rnLHsTypeArg ctxt (HsValArg ty) - = do { (tys_rn, fvs) <- rnLHsType ctxt ty - ; return (HsValArg tys_rn, fvs) } -rnLHsTypeArg ctxt (HsTypeArg l ki) - = do { (kis_rn, fvs) <- rnLHsKind ctxt ki - ; return (HsTypeArg l kis_rn, fvs) } -rnLHsTypeArg _ (HsArgPar sp) - = return (HsArgPar sp, emptyFVs) - -rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs] - -> RnM ([LHsTypeArg GhcRn], FreeVars) -rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args - --------------- -rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs - -> RnM (LHsContext GhcRn, FreeVars) -rnTyKiContext env (L loc cxt) - = do { traceRn "rncontext" (ppr cxt) - ; let env' = env { rtke_what = RnConstraint } - ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt - ; return (L loc cxt', fvs) } - -rnContext :: HsDocContext -> LHsContext GhcPs - -> RnM (LHsContext GhcRn, FreeVars) -rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta - --------------- -rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) -rnLHsTyKi env (L loc ty) - = setSrcSpan loc $ - do { (ty', fvs) <- rnHsTyKi env ty - ; return (L loc ty', fvs) } - -rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) - -rnHsTyKi env ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars - , hst_body = tau }) - = do { checkPolyKinds env ty - ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty) - Nothing tyvars $ \ tyvars' -> - do { (tau', fvs) <- rnLHsTyKi env tau - ; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tyvars' , hst_body = tau' } - , fvs) } } - -rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) - = do { checkPolyKinds env ty -- See Note [QualTy in kinds] - ; (ctxt', fvs1) <- rnTyKiContext env lctxt - ; (tau', fvs2) <- rnLHsTyKi env tau - ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt' - , hst_body = tau' } - , fvs1 `plusFV` fvs2) } - -rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) - = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ - unlessXOptM LangExt.PolyKinds $ addErr $ - withHsDocContext (rtke_ctxt env) $ - vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name) - , text "Perhaps you intended to use PolyKinds" ] - -- Any type variable at the kind level is illegal without the use - -- of PolyKinds (see #14710) - ; name <- rnTyVar env rdr_name - ; return (HsTyVar noExtField ip (L loc name), unitFV name) } - -rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) - = setSrcSpan (getLoc l_op) $ - do { (l_op', fvs1) <- rnHsTyOp env ty l_op - ; fix <- lookupTyFixityRn l_op' - ; (ty1', fvs2) <- rnLHsTyKi env ty1 - ; (ty2', fvs3) <- rnLHsTyKi env ty2 - ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExtField t1 l_op' t2) - (unLoc l_op') fix ty1' ty2' - ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } - -rnHsTyKi env (HsParTy _ ty) - = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsParTy noExtField ty', fvs) } - -rnHsTyKi env (HsBangTy _ b ty) - = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsBangTy noExtField b ty', fvs) } - -rnHsTyKi env ty@(HsRecTy _ flds) - = do { let ctxt = rtke_ctxt env - ; fls <- get_fields ctxt - ; (flds', fvs) <- rnConDeclFields ctxt fls flds - ; return (HsRecTy noExtField flds', fvs) } - where - get_fields (ConDeclCtx names) - = concatMapM (lookupConstructorFields . unLoc) names - get_fields _ - = do { addErr (hang (text "Record syntax is illegal here:") - 2 (ppr ty)) - ; return [] } - -rnHsTyKi env (HsFunTy _ ty1 ty2) - = do { (ty1', fvs1) <- rnLHsTyKi env ty1 - -- Might find a for-all as the arg of a function type - ; (ty2', fvs2) <- rnLHsTyKi env ty2 - -- Or as the result. This happens when reading Prelude.hi - -- when we find return :: forall m. Monad m -> forall a. a -> m a - - -- Check for fixity rearrangements - ; res_ty <- mkHsOpTyRn (HsFunTy noExtField) funTyConName funTyFixity ty1' ty2' - ; return (res_ty, fvs1 `plusFV` fvs2) } - -rnHsTyKi env listTy@(HsListTy _ ty) - = do { data_kinds <- xoptM LangExt.DataKinds - ; when (not data_kinds && isRnKindLevel env) - (addErr (dataKindsErr env listTy)) - ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsListTy noExtField ty', fvs) } - -rnHsTyKi env t@(HsKindSig _ ty k) - = do { checkPolyKinds env t - ; 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 - ; return (HsKindSig noExtField ty' k', lhs_fvs `plusFV` sig_fvs) } - --- Unboxed tuples are allowed to have poly-typed arguments. These --- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys) - = do { data_kinds <- xoptM LangExt.DataKinds - ; when (not data_kinds && isRnKindLevel env) - (addErr (dataKindsErr env tupleTy)) - ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsTupleTy noExtField tup_con tys', fvs) } - -rnHsTyKi env sumTy@(HsSumTy _ tys) - = do { data_kinds <- xoptM LangExt.DataKinds - ; when (not data_kinds && isRnKindLevel env) - (addErr (dataKindsErr env sumTy)) - ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsSumTy noExtField tys', fvs) } - --- Ensure that a type-level integer is nonnegative (#8306, #8412) -rnHsTyKi env tyLit@(HsTyLit _ t) - = do { data_kinds <- xoptM LangExt.DataKinds - ; unless data_kinds (addErr (dataKindsErr env tyLit)) - ; when (negLit t) (addErr negLitErr) - ; checkPolyKinds env tyLit - ; return (HsTyLit noExtField t, emptyFVs) } - where - negLit (HsStrTy _ _) = False - negLit (HsNumTy _ i) = i < 0 - negLitErr = 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) - = do { kind_app <- xoptM LangExt.TypeApplications - ; unless kind_app (addErr (typeAppErr "kind" k)) - ; (ty', fvs1) <- rnLHsTyKi env ty - ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k - ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) } - -rnHsTyKi env t@(HsIParamTy _ n ty) - = do { notInKinds env t - ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsIParamTy noExtField n ty', fvs) } - -rnHsTyKi _ (HsStarTy _ isUni) - = return (HsStarTy noExtField isUni, emptyFVs) - -rnHsTyKi _ (HsSpliceTy _ sp) - = rnSpliceType sp - -rnHsTyKi env (HsDocTy _ ty haddock_doc) - = do { (ty', fvs) <- rnLHsTyKi env ty - ; haddock_doc' <- rnLHsDoc haddock_doc - ; return (HsDocTy noExtField ty' haddock_doc', fvs) } - -rnHsTyKi _ (XHsType (NHsCoreTy ty)) - = return (XHsType (NHsCoreTy ty), emptyFVs) - -- The emptyFVs probably isn't quite right - -- but I don't think it matters - -rnHsTyKi env ty@(HsExplicitListTy _ ip tys) - = do { checkPolyKinds env ty - ; data_kinds <- xoptM LangExt.DataKinds - ; unless data_kinds (addErr (dataKindsErr env ty)) - ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsExplicitListTy noExtField ip tys', fvs) } - -rnHsTyKi env ty@(HsExplicitTupleTy _ tys) - = do { checkPolyKinds env ty - ; data_kinds <- xoptM LangExt.DataKinds - ; unless data_kinds (addErr (dataKindsErr env ty)) - ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsExplicitTupleTy noExtField tys', fvs) } - -rnHsTyKi env (HsWildCardTy _) - = do { checkAnonWildCard env - ; return (HsWildCardTy noExtField, emptyFVs) } - --------------- -rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name -rnTyVar env rdr_name - = do { name <- lookupTypeOccRn rdr_name - ; checkNamedWildCard env name - ; return name } - -rnLTyVar :: Located RdrName -> RnM (Located Name) --- Called externally; does not deal with wildcards -rnLTyVar (L loc rdr_name) - = do { tyvar <- lookupTypeOccRn rdr_name - ; return (L loc tyvar) } - --------------- -rnHsTyOp :: Outputable a - => RnTyKiEnv -> a -> Located RdrName - -> RnM (Located Name, FreeVars) -rnHsTyOp env overall_ty (L loc op) - = do { ops_ok <- xoptM LangExt.TypeOperators - ; op' <- rnTyVar env op - ; unless (ops_ok || op' `hasKey` eqTyConKey) $ - addErr (opTyErr op overall_ty) - ; let l_op' = L loc op' - ; return (l_op', unitFV op') } - --------------- -notAllowed :: SDoc -> SDoc -notAllowed doc - = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed") - -checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM () -checkWildCard env (Just doc) - = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))] -checkWildCard _ Nothing - = return () - -checkAnonWildCard :: RnTyKiEnv -> RnM () --- Report an error if an anonymous wildcard is illegal here -checkAnonWildCard env - = checkWildCard env mb_bad - where - mb_bad :: Maybe SDoc - mb_bad | not (wildCardsAllowed env) - = Just (notAllowed pprAnonWildCard) - | otherwise - = case rtke_what env of - RnTypeBody -> Nothing - RnTopConstraint -> Just constraint_msg - RnConstraint -> Just constraint_msg - - constraint_msg = hang - (notAllowed pprAnonWildCard <+> text "in a constraint") - 2 hint_msg - hint_msg = vcat [ text "except as the last top-level constraint of a type signature" - , nest 2 (text "e.g f :: (Eq a, _) => blah") ] - -checkNamedWildCard :: RnTyKiEnv -> Name -> RnM () --- Report an error if a named wildcard is illegal here -checkNamedWildCard env name - = checkWildCard env mb_bad - where - mb_bad | not (name `elemNameSet` rtke_nwcs env) - = Nothing -- Not a wildcard - | not (wildCardsAllowed env) - = Just (notAllowed (ppr name)) - | otherwise - = case rtke_what env of - RnTypeBody -> Nothing -- Allowed - RnTopConstraint -> Nothing -- Allowed; e.g. - -- f :: (Eq _a) => _a -> Int - -- g :: (_a, _b) => T _a _b -> Int - -- The named tyvars get filled in from elsewhere - RnConstraint -> Just constraint_msg - constraint_msg = notAllowed (ppr name) <+> text "in a constraint" - -wildCardsAllowed :: RnTyKiEnv -> Bool --- ^ In what contexts are wildcards permitted -wildCardsAllowed env - = case rtke_ctxt env of - TypeSigCtx {} -> True - TypBrCtx {} -> True -- Template Haskell quoted type - SpliceTypeCtx {} -> True -- Result of a Template Haskell splice - ExprWithTySigCtx {} -> True - PatCtx {} -> True - RuleCtx {} -> True - FamPatCtx {} -> True -- Not named wildcards though - GHCiCtx {} -> True - HsTypeCtx {} -> True - StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls - _ -> False - - - ---------------- --- | Ensures either that we're in a type or that -XPolyKinds is set -checkPolyKinds :: Outputable ty - => RnTyKiEnv - -> ty -- ^ type - -> RnM () -checkPolyKinds env ty - | isRnKindLevel env - = do { polykinds <- xoptM LangExt.PolyKinds - ; unless polykinds $ - addErr (text "Illegal kind:" <+> ppr ty $$ - text "Did you mean to enable PolyKinds?") } -checkPolyKinds _ _ = return () - -notInKinds :: Outputable ty - => RnTyKiEnv - -> ty - -> RnM () -notInKinds env ty - | isRnKindLevel env - = addErr (text "Illegal kind:" <+> ppr ty) -notInKinds _ _ = return () - -{- ***************************************************** -* * - Binding type variables -* * -***************************************************** -} - -bindSigTyVarsFV :: [Name] - -> RnM (a, FreeVars) - -> RnM (a, FreeVars) --- Used just before renaming the defn of a function --- with a separate type signature, to bring its tyvars into scope --- With no -XScopedTypeVariables, this is a no-op -bindSigTyVarsFV tvs thing_inside - = do { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables - ; if not scoped_tyvars then - thing_inside - else - bindLocalNamesFV tvs thing_inside } - --- | Simply bring a bunch of RdrNames into scope. No checking for --- validity, at all. The binding location is taken from the location --- on each name. -bindLRdrNames :: [Located RdrName] - -> ([Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -bindLRdrNames rdrs thing_inside - = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs - ; bindLocalNamesFV var_names $ - thing_inside var_names } - ---------------- -bindHsQTyVars :: forall a b. - HsDocContext - -> Maybe SDoc -- Just d => check for unused tvs - -- d is a phrase like "in the type ..." - -> Maybe a -- Just _ => an associated type decl - -> [Located RdrName] -- Kind variables from scope, no dups - -> (LHsQTyVars GhcPs) - -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars)) - -- The Bool is True <=> 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 - -> RnM (b, FreeVars) - --- See Note [bindHsQTyVars examples] --- (a) Bring kind variables into scope --- both (i) passed in body_kv_occs --- and (ii) mentioned in the kinds of hsq_bndrs --- (b) Bring type variables into scope --- -bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside - = do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs - bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs - - ; let -- See Note [bindHsQTyVars examples] for what - -- all these various things are doing - bndrs, kv_occs, implicit_kvs :: [Located RdrName] - bndrs = map hsLTyVarLocName hs_tv_bndrs - kv_occs = nubL (bndr_kv_occs ++ body_kv_occs) - -- Make sure to list the binder kvs before the - -- body kvs, as mandated by - -- Note [Ordering of implicit variables] - implicit_kvs = filter_occs bndrs kv_occs - del = deleteBys eqLocated - all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs) - - ; traceRn "checkMixedVars3" $ - vcat [ text "kv_occs" <+> ppr kv_occs - , text "bndrs" <+> ppr hs_tv_bndrs - , text "bndr_kv_occs" <+> ppr bndr_kv_occs - , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs) - ] - - ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs - - ; bindLocalNamesFV implicit_kv_nms $ - bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs -> - do { 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 } } - - where - filter_occs :: [Located RdrName] -- Bound here - -> [Located RdrName] -- Potential implicit binders - -> [Located RdrName] -- Final implicit binders - -- Filter out any potential implicit binders that are either - -- already in scope, or are explicitly bound in the same HsQTyVars - filter_occs bndrs occs - = filterOut is_in_scope occs - where - is_in_scope locc = locc `elemRdr` bndrs - -{- Note [bindHsQTyVars examples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - data T k (a::k1) (b::k) :: k2 -> k1 -> * - -Then: - hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables - bndrs = [k,a,b] - - bndr_kv_occs = [k,k1], kind variables free in kind signatures - of hs_tv_bndrs - - body_kv_occs = [k2,k1], kind variables free in the - result kind signature - - implicit_kvs = [k1,k2], kind variables free in kind signatures - of hs_tv_bndrs, and not bound by bndrs - -* We want to quantify add implicit bindings for implicit_kvs - -* If implicit_body_kvs is non-empty, then there is a kind variable - mentioned in the kind signature that is not bound "on the left". - That's one of the rules for a CUSK, so we pass that info on - as the second argument to thing_inside. - -* Order is not important in these lists. All we are doing is - bring Names into scope. - -Finally, you may wonder why filter_occs removes in-scope variables -from bndr/body_kv_occs. How can anything be in scope? Answer: -HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax -ConDecls - data T a = forall (b::k). MkT a b -The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire -ConDecl. Hence the local RdrEnv may be non-empty and we must filter -out 'a' from the free vars. (Mind you, in this situation all the -implicit kind variables are bound at the data type level, so there -are none to bind in the ConDecl, so there are no implicitly bound -variables at all. - -Note [Kind variable scoping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - data T (a :: k) k = ... -we report "k is out of scope" for (a::k). Reason: k is not brought -into scope until the explicit k-binding that follows. It would be -terribly confusing to bring into scope an /implicit/ k for a's kind -and a distinct, shadowing explicit k that follows, something like - data T {k1} (a :: k1) k = ... - -So the rule is: - - the implicit binders never include any - of the explicit binders in the group - -Note that in the denerate case - data T (a :: a) = blah -we get a complaint the second 'a' is not in scope. - -That applies to foralls too: e.g. - forall (a :: k) k . blah - -But if the foralls are split, we treat the two groups separately: - forall (a :: k). forall k. blah -Here we bring into scope an implicit k, which is later shadowed -by the explicit k. - -In implementation terms - -* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete - the binders {a,k}, and so end with no implicit binders. Then we - rename the binders left-to-right, and hence see that 'k' is out of - scope in the kind of 'a'. - -* Similarly in extract_hs_tv_bndrs - -Note [Variables used as both types and kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We bind the type variables tvs, and kvs is the set of free variables of the -kinds in the scope of the binding. Here is one typical example: - - forall a b. a -> (b::k) -> (c::a) - -Here, tvs will be {a,b}, and kvs {k,a}. - -We must make sure that kvs includes all of variables in the kinds of type -variable bindings. For instance: - - forall k (a :: k). Proxy a - -If we only look in the body of the `forall` type, we will mistakenly conclude -that kvs is {}. But in fact, the type variable `k` is also used as a kind -variable in (a :: k), later in the binding. (This mistake lead to #14710.) -So tvs is {k,a} and kvs is {k}. - -NB: we do this only at the binding site of 'tvs'. --} - -bindLHsTyVarBndrs :: HsDocContext - -> Maybe SDoc -- Just d => check for unused tvs - -- d is a phrase like "in the type ..." - -> Maybe a -- Just _ => an associated type decl - -> [LHsTyVarBndr GhcPs] -- User-written tyvars - -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) - -> RnM (b, FreeVars) -bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside - = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) - ; checkDupRdrNames tv_names_w_loc - ; go tv_bndrs thing_inside } - where - tv_names_w_loc = map hsLTyVarLocName tv_bndrs - - go [] thing_inside = thing_inside [] - go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' -> - do { (res, fvs) <- go bs $ \ bs' -> - thing_inside (b' : bs') - ; warn_unused b' fvs - ; return (res, fvs) } - - warn_unused tv_bndr fvs = case mb_in_doc of - Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs - Nothing -> return () - -bindLHsTyVarBndr :: HsDocContext - -> Maybe a -- associated class - -> LHsTyVarBndr GhcPs - -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) - -> RnM (b, FreeVars) -bindLHsTyVarBndr _doc mb_assoc (L loc - (UserTyVar x - lrdr@(L lv _))) thing_inside - = do { nm <- newTyVarNameRn mb_assoc lrdr - ; bindLocalNamesFV [nm] $ - thing_inside (L loc (UserTyVar x (L lv nm))) } - -bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind)) - thing_inside - = do { sig_ok <- xoptM LangExt.KindSignatures - ; unless sig_ok (badKindSigErr doc kind) - ; (kind', fvs1) <- rnLHsKind doc kind - ; tv_nm <- newTyVarNameRn mb_assoc lrdr - ; (b, fvs2) <- bindLocalNamesFV [tv_nm] - $ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind')) - ; return (b, fvs1 `plusFV` fvs2) } - -bindLHsTyVarBndr _ _ (L _ (XTyVarBndr nec)) _ = noExtCon nec - -newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name -newTyVarNameRn mb_assoc (L loc 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 - - _ -> newLocalBndrRn (L loc rdr) } -{- -********************************************************* -* * - ConDeclField -* * -********************************************************* - -When renaming a ConDeclField, we have to find the FieldLabel -associated with each field. But we already have all the FieldLabels -available (since they were brought into scope by -GHC.Rename.Names.getLocalNonValBinders), so we just take the list as an -argument, build a map and look them up. --} - -rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs] - -> RnM ([LConDeclField GhcRn], FreeVars) --- Also called from GHC.Rename.Source --- No wildcards can appear in record fields -rnConDeclFields ctxt fls fields - = mapFvRn (rnField fl_env env) fields - where - env = mkTyKiEnv ctxt TypeLevel RnTypeBody - fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ] - -rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs - -> RnM (LConDeclField GhcRn, FreeVars) -rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) - = do { let new_names = map (fmap lookupField) names - ; (new_ty, fvs) <- rnLHsTyKi env ty - ; new_haddock_doc <- rnMbLHsDoc haddock_doc - ; return (L l (ConDeclField noExtField new_names new_ty new_haddock_doc) - , fvs) } - where - lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn - lookupField (FieldOcc _ (L lr rdr)) = - FieldOcc (flSelector fl) (L lr rdr) - where - lbl = occNameFS $ rdrNameOcc rdr - fl = expectJust "rnField" $ lookupFsEnv fl_env lbl - lookupField (XFieldOcc nec) = noExtCon nec -rnField _ _ (L _ (XConDeclField nec)) = noExtCon nec - -{- -************************************************************************ -* * - Fixities and precedence parsing -* * -************************************************************************ - -@mkOpAppRn@ deals with operator fixities. The argument expressions -are assumed to be already correctly arranged. It needs the fixities -recorded in the OpApp nodes, because fixity info applies to the things -the programmer actually wrote, so you can't find it out from the Name. - -Furthermore, the second argument is guaranteed not to be another -operator application. Why? Because the parser parses all -operator applications left-associatively, EXCEPT negation, which -we need to handle specially. -Infix types are read in a *right-associative* way, so that - a `op` b `op` c -is always read in as - a `op` (b `op` c) - -mkHsOpTyRn rearranges where necessary. The two arguments -have already been renamed and rearranged. It's made rather tiresome -by the presence of ->, which is a separate syntactic construct. --} - ---------------- --- Building (ty1 `op1` (ty21 `op2` ty22)) -mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) - -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn - -> RnM (HsType GhcRn) - -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExtField ty21 op2 ty22)) - = do { fix2 <- lookupTyFixityRn op2 - ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 - (\t1 t2 -> HsOpTy noExtField t1 op2 t2) - (unLoc op2) fix2 ty21 ty22 loc2 } - -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22)) - = mk_hs_op_ty mk1 pp_op1 fix1 ty1 - (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2 - -mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment - = return (mk1 ty1 ty2) - ---------------- -mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) - -> Name -> Fixity -> LHsType GhcRn - -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) - -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan - -> RnM (HsType GhcRn) -mk_hs_op_ty mk1 op1 fix1 ty1 - mk2 op2 fix2 ty21 ty22 loc2 - | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2) - ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } - | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) - | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) - new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 - ; return (mk2 (noLoc new_ty) ty22) } - where - (nofix_error, associate_right) = compareFixity fix1 fix2 - - ---------------------------- -mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged - -> LHsExpr GhcRn -> Fixity -- Operator and fixity - -> LHsExpr GhcRn -- Right operand (not an OpApp, but might - -- be a NegApp) - -> RnM (HsExpr GhcRn) - --- (e11 `op1` e12) `op2` e2 -mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 - | nofix_error - = do precParseErr (get_op op1,fix1) (get_op op2,fix2) - return (OpApp fix2 e1 op2 e2) - - | associate_right = do - new_e <- mkOpAppRn e12 op2 fix2 e2 - return (OpApp fix1 e11 op1 (L loc' new_e)) - where - loc'= combineLocs e12 e2 - (nofix_error, associate_right) = compareFixity fix1 fix2 - ---------------------------- --- (- neg_arg) `op` e2 -mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 - | nofix_error - = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) - return (OpApp fix2 e1 op2 e2) - - | associate_right - = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 - return (NegApp noExtField (L loc' new_e) neg_name) - where - loc' = combineLocs neg_arg e2 - (nofix_error, associate_right) = compareFixity negateFixity fix2 - ---------------------------- --- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right - | not associate_right -- We *want* right association - = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) - return (OpApp fix1 e1 op1 e2) - where - (_, associate_right) = compareFixity fix1 negateFixity - ---------------------------- --- Default case -mkOpAppRn e1 op fix e2 -- Default case, no rearrangment - = ASSERT2( right_op_ok fix (unLoc e2), - ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 - ) - return (OpApp fix e1 op e2) - ----------------------------- - --- | Name of an operator in an operator application or section -data OpName = NormalOp Name -- ^ A normal identifier - | NegateOp -- ^ Prefix negation - | UnboundOp OccName -- ^ An unbound indentifier - | RecFldOp (AmbiguousFieldOcc GhcRn) - -- ^ A (possibly ambiguous) 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 -get_op (L _ (HsVar _ n)) = NormalOp (unLoc n) -get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv -get_op (L _ (HsRecFld _ fld)) = RecFldOp fld -get_op other = pprPanic "get_op" (ppr other) - --- Parser left-associates everything, but --- derived instances may have correctly-associated things to --- in the right operand. So we just check that the right operand is OK -right_op_ok :: Fixity -> HsExpr GhcRn -> Bool -right_op_ok fix1 (OpApp fix2 _ _ _) - = not error_please && associate_right - where - (error_please, associate_right) = compareFixity fix1 fix2 -right_op_ok _ _ - = True - --- Parser initially makes negation bind more tightly than any other operator --- And "deriving" code should respect this (use HsPar if not) -mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id) - -> RnM (HsExpr (GhcPass id)) -mkNegAppRn neg_arg neg_name - = ASSERT( not_op_app (unLoc neg_arg) ) - return (NegApp noExtField neg_arg neg_name) - -not_op_app :: HsExpr id -> Bool -not_op_app (OpApp {}) = False -not_op_app _ = True - ---------------------------- -mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged - -> LHsExpr GhcRn -> Fixity -- Operator and fixity - -> LHsCmdTop GhcRn -- Right operand (not an infix) - -> RnM (HsCmd GhcRn) - --- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(L loc - (HsCmdTop _ - (L _ (HsCmdArrForm x op1 f (Just fix1) - [a11,a12])))) - op2 fix2 a2 - | nofix_error - = do precParseErr (get_op op1,fix1) (get_op op2,fix2) - return (HsCmdArrForm x op2 f (Just fix2) [a1, a2]) - - | associate_right - = do new_c <- mkOpFormRn a12 op2 fix2 a2 - return (HsCmdArrForm noExtField op1 f (Just fix1) - [a11, L loc (HsCmdTop [] (L loc new_c))]) - -- TODO: locs are wrong - where - (nofix_error, associate_right) = compareFixity fix1 fix2 - --- Default case -mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment - = return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2]) - - --------------------------------------- -mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn - -> RnM (Pat GhcRn) - -mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 - = do { fix1 <- lookupFixityRn (unLoc op1) - ; let (nofix_error, associate_right) = compareFixity fix1 fix2 - - ; if nofix_error then do - { precParseErr (NormalOp (unLoc op1),fix1) - (NormalOp (unLoc op2),fix2) - ; return (ConPatIn op2 (InfixCon p1 p2)) } - - else if associate_right then do - { new_p <- mkConOpPatRn op2 fix2 p12 p2 - ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } - -- XXX loc right? - else return (ConPatIn op2 (InfixCon p1 p2)) } - -mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment - = ASSERT( not_op_pat (unLoc p2) ) - return (ConPatIn op (InfixCon p1 p2)) - -not_op_pat :: Pat GhcRn -> Bool -not_op_pat (ConPatIn _ (InfixCon _ _)) = False -not_op_pat _ = True - --------------------------------------- -checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM () - -- Check precedence of a function binding written infix - -- eg a `op` b `C` c = ... - -- See comments with rnExpr (OpApp ...) about "deriving" - -checkPrecMatch op (MG { mg_alts = (L _ ms) }) - = mapM_ check ms - where - check (L _ (Match { m_pats = (L l1 p1) - : (L l2 p2) - : _ })) - = setSrcSpan (combineSrcSpans l1 l2) $ - do checkPrec op p1 False - checkPrec op p2 True - - check _ = return () - -- This can happen. Consider - -- a `op` True = ... - -- op = ... - -- The infix flag comes from the first binding of the group - -- but the second eqn has no args (an error, but not discovered - -- until the type checker). So we don't want to crash on the - -- second eqn. -checkPrecMatch _ (XMatchGroup nec) = noExtCon nec - -checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () -checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do - op_fix@(Fixity _ op_prec op_dir) <- lookupFixityRn op - op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1) - let - inf_ok = op1_prec > op_prec || - (op1_prec == op_prec && - (op1_dir == InfixR && op_dir == InfixR && right || - op1_dir == InfixL && op_dir == InfixL && not right)) - - info = (NormalOp op, op_fix) - info1 = (NormalOp (unLoc op1), op1_fix) - (infol, infor) = if right then (info, info1) else (info1, info) - unless inf_ok (precParseErr infol infor) - -checkPrec _ _ _ - = return () - --- Check precedence of (arg op) or (op arg) respectively --- If arg is itself an operator application, then either --- (a) its precedence must be higher than that of op --- (b) its precedency & associativity must be the same as that of op -checkSectionPrec :: FixityDirection -> HsExpr GhcPs - -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM () -checkSectionPrec direction section op arg - = case unLoc arg of - OpApp fix _ op' _ -> go_for_it (get_op op') fix - NegApp _ _ _ -> go_for_it NegateOp negateFixity - _ -> return () - where - op_name = get_op op - go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do - op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name - unless (op_prec < arg_prec - || (op_prec == arg_prec && direction == assoc)) - (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 (possibly ambiguous) record fields --- (see #13132). -lookupFixityOp :: OpName -> RnM Fixity -lookupFixityOp (NormalOp n) = lookupFixityRn n -lookupFixityOp NegateOp = lookupFixityRn negateName -lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName u) -lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f - - --- Precedence-related error messages - -precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM () -precParseErr op1@(n1,_) op2@(n2,_) - | is_unbound n1 || is_unbound n2 - = return () -- Avoid error cascade - | otherwise - = addErr $ hang (text "Precedence parsing error") - 4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"), - ppr_opfix op2, - text "in the same infix expression"]) - -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 $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "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))] - -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 -* * -***************************************************** -} - -unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc -unexpectedTypeSigErr ty - = hang (text "Illegal type signature:" <+> quotes (ppr ty)) - 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") - -badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () -badKindSigErr doc (L loc ty) - = setSrcSpan loc $ addErr $ - withHsDocContext doc $ - hang (text "Illegal kind signature:" <+> quotes (ppr ty)) - 2 (text "Perhaps you intended to use KindSignatures") - -dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc -dataKindsErr env thing - = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) - 2 (text "Perhaps you intended to use DataKinds") - where - pp_what | isRnKindLevel env = text "kind" - | otherwise = text "type" - -inTypeDoc :: HsType GhcPs -> SDoc -inTypeDoc ty = text "In the type" <+> quotes (ppr ty) - -warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM () -warnUnusedForAll in_doc (L loc tv) used_names - = whenWOptM Opt_WarnUnusedForalls $ - unless (hsTyVarName tv `elemNameSet` used_names) $ - addWarnAt (Reason Opt_WarnUnusedForalls) loc $ - vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) - , in_doc ] - -opTyErr :: Outputable a => RdrName -> a -> SDoc -opTyErr op overall_ty - = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty)) - 2 (text "Use TypeOperators to allow operators in types") - -{- -************************************************************************ -* * - Finding the free type variables of a (HsType RdrName) -* * -************************************************************************ - - -Note [Kind and type-variable binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a type signature we may implicitly bind type/kind variables. For example: - * f :: a -> a - f = ... - Here we need to find the free type variables of (a -> a), - so that we know what to quantify - - * class C (a :: k) where ... - This binds 'k' in ..., as well as 'a' - - * f (x :: a -> [a]) = .... - Here we bind 'a' in .... - - * f (x :: T a -> T (b :: k)) = ... - Here we bind both 'a' and the kind variable 'k' - - * type instance F (T (a :: Maybe k)) = ...a...k... - Here we want to constrain the kind of 'a', and bind 'k'. - -To do that, we need to walk over a type and find its free type/kind variables. -We preserve the left-to-right order of each variable occurrence. -See Note [Ordering of implicit variables]. - -Clients of this code can remove duplicates with nubL. - -Note [Ordering of implicit variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since the advent of -XTypeApplications, GHC makes promises about the ordering -of implicit variable quantification. Specifically, we offer that implicitly -quantified variables (such as those in const :: a -> b -> a, without a `forall`) -will occur in left-to-right order of first occurrence. Here are a few examples: - - const :: a -> b -> a -- forall a b. ... - f :: Eq a => b -> a -> a -- forall a b. ... contexts are included - - type a <-< b = b -> a - g :: a <-< b -- forall a b. ... type synonyms matter - - class Functor f where - fmap :: (a -> b) -> f a -> f b -- forall f a b. ... - -- The f is quantified by the class, so only a and b are considered in fmap - -This simple story is complicated by the possibility of dependency: all variables -must come after any variables mentioned in their kinds. - - typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ... - -The k comes first because a depends on k, even though the k appears later than -the a in the code. Thus, GHC does ScopedSort on the variables. -See Note [ScopedSort] in GHC.Core.Type. - -Implicitly bound variables are collected by any function which returns a -FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably -includes the `extract-` family of functions (extractHsTysRdrTyVarsDups, -extractHsTyVarBndrsKVs, etc.). -These functions thus promise to keep left-to-right ordering. - -Note [Implicit quantification in type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We typically bind type/kind variables implicitly when they are in a kind -annotation on the LHS, for example: - - data Proxy (a :: k) = Proxy - type KindOf (a :: k) = k - -Here 'k' is in the kind annotation of a type variable binding, KindedTyVar, and -we want to implicitly quantify over it. This is easy: just extract all free -variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs - -By contrast, on the RHS we can't simply collect *all* free variables. Which of -the following are allowed? - - type TySyn1 = a :: Type - type TySyn2 = 'Nothing :: Maybe a - type TySyn3 = 'Just ('Nothing :: Maybe a) - type TySyn4 = 'Left a :: Either Type a - -After some design deliberations (see non-taken alternatives below), the answer -is to reject TySyn1 and TySyn3, but allow TySyn2 and TySyn4, at least for now. -We implicitly quantify over free variables of the outermost kind signature, if -one exists: - - * In TySyn1, the outermost kind signature is (:: Type), and it does not have - any free variables. - * In TySyn2, the outermost kind signature is (:: Maybe a), it contains a - free variable 'a', which we implicitly quantify over. - * In TySyn3, there is no outermost kind signature. The (:: Maybe a) signature - is hidden inside 'Just. - * In TySyn4, the outermost kind signature is (:: Either Type a), it contains - 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. - -This is something of a stopgap solution until we can explicitly bind invisible -type/kind variables: - - type TySyn3 :: forall a. Maybe a - type TySyn3 @a = 'Just ('Nothing :: Maybe a) - -Note [Implicit quantification in type synonyms: non-taken alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Alternative I: No quantification --------------------------------- -We could offer no implicit quantification on the RHS, accepting none of the -TySyn examples. The user would have to bind the variables explicitly: - - type TySyn1 a = a :: Type - type TySyn2 a = 'Nothing :: Maybe a - type TySyn3 a = 'Just ('Nothing :: Maybe a) - type TySyn4 a = 'Left a :: Either Type a - -However, this would mean that one would have to specify 'a' at call sites every -time, which could be undesired. - -Alternative II: Indiscriminate quantification ---------------------------------------------- -We could implicitly quantify over all free variables on the RHS just like we do -on the LHS. Then we would infer the following kinds: - - TySyn1 :: forall {a}. Type - TySyn2 :: forall {a}. Maybe a - TySyn3 :: forall {a}. Maybe (Maybe a) - TySyn4 :: forall {a}. Either Type a - -This would work fine for TySyn<2,3,4>, but TySyn1 is clearly bogus: the variable -is free-floating, not fixed by anything. - -Alternative III: reportFloatingKvs ----------------------------------- -We could augment Alternative II by hunting down free-floating variables during -type checking. While viable, this would mean we'd end up accepting this: - - data Prox k (a :: k) - type T = Prox k - --} - --- See Note [Kind and type-variable binders] --- These lists are guaranteed to preserve left-to-right ordering of --- the types the variables were extracted from. See also --- Note [Ordering of implicit variables]. -type FreeKiTyVars = [Located RdrName] - --- | A 'FreeKiTyVars' list that is allowed to have duplicate variables. -type FreeKiTyVarsWithDups = FreeKiTyVars - --- | A 'FreeKiTyVars' list that contains no duplicate variables. -type FreeKiTyVarsNoDups = FreeKiTyVars - -filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars -filterInScope rdr_env = filterOut (inScope rdr_env . unLoc) - -filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars -filterInScopeM vars - = do { rdr_env <- getLocalRdrEnv - ; return (filterInScope rdr_env vars) } - -inScope :: LocalRdrEnv -> RdrName -> Bool -inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env - -extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_tyarg (HsValArg ty) acc = extract_lty ty acc -extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc -extract_tyarg (HsArgPar _) acc = acc - -extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_tyargs args acc = foldr extract_tyarg acc args - -extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -extractHsTyArgRdrKiTyVarsDup args - = extract_tyargs args [] - --- | 'extractHsTyRdrTyVars' finds the type/kind variables --- of a HsType/HsKind. --- It's used when making the @forall@s explicit. --- When the same name occurs multiple times in the types, only the first --- occurrence is returned. --- See Note [Kind and type-variable binders] -extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups -extractHsTyRdrTyVars ty - = nubL (extractHsTyRdrTyVarsDups ty) - --- | 'extractHsTyRdrTyVarsDups' finds the type/kind variables --- of a HsType/HsKind. --- It's used when making the @forall@s explicit. --- When the same name occurs multiple times in the types, all occurrences --- are returned. -extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups -extractHsTyRdrTyVarsDups ty - = extract_lty ty [] - --- | Extracts the free type/kind variables from the kind signature of a HsType. --- This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@. --- When the same name occurs multiple times in the type, only the first --- occurrence is returned, and the left-to-right order of variables is --- preserved. --- See Note [Kind and type-variable binders] and --- Note [Ordering of implicit variables] and --- Note [Implicit quantification in type synonyms]. -extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVarsNoDups -extractHsTyRdrTyVarsKindVars (unLoc -> ty) = - case ty of - HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty - HsKindSig _ _ ki -> extractHsTyRdrTyVars ki - _ -> [] - --- | Extracts free type and kind variables from types in a list. --- When the same name occurs multiple times in the types, all occurrences --- are returned. -extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups -extractHsTysRdrTyVarsDups tys - = extract_ltys tys [] - --- Returns the free kind variables of any explicitly-kinded binders, returning --- variable occurrences in left-to-right order. --- See Note [Ordering of implicit variables]. --- NB: Does /not/ delete the binders themselves. --- However duplicates are removed --- E.g. given [k1, a:k1, b:k2] --- the function returns [k1,k2], even though k1 is bound here -extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsNoDups -extractHsTyVarBndrsKVs tv_bndrs - = nubL (extract_hs_tv_bndrs_kvs tv_bndrs) - --- Returns the free kind variables in a type family result signature, returning --- variable occurrences in left-to-right order. --- See Note [Ordering of implicit variables]. -extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName] -extractRdrKindSigVars (L _ resultSig) - | KindSig _ k <- resultSig = extractHsTyRdrTyVars k - | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k - | otherwise = [] - --- Get type/kind variables mentioned in the kind signature, preserving --- left-to-right order and without duplicates: --- --- * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type -- result: [k2,k1] --- * data T a (b :: k1) -- result: [] --- --- See Note [Ordering of implicit variables]. -extractDataDefnKindVars :: HsDataDefn GhcPs -> FreeKiTyVarsNoDups -extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig }) - = maybe [] extractHsTyRdrTyVars ksig -extractDataDefnKindVars (XHsDataDefn nec) = noExtCon nec - -extract_lctxt :: LHsContext GhcPs - -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_lctxt ctxt = extract_ltys (unLoc ctxt) - -extract_ltys :: [LHsType GhcPs] - -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_ltys tys acc = foldr extract_lty acc tys - -extract_lty :: LHsType GhcPs - -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_lty (L _ ty) acc - = case ty of - HsTyVar _ _ ltv -> extract_tv ltv acc - HsBangTy _ _ ty -> extract_lty ty acc - HsRecTy _ flds -> foldr (extract_lty - . cd_fld_type . unLoc) acc - flds - HsAppTy _ ty1 ty2 -> extract_lty ty1 $ - extract_lty ty2 acc - HsAppKindTy _ ty k -> extract_lty ty $ - extract_lty k acc - HsListTy _ ty -> extract_lty ty acc - HsTupleTy _ _ tys -> extract_ltys tys acc - HsSumTy _ tys -> extract_ltys tys acc - HsFunTy _ ty1 ty2 -> extract_lty ty1 $ - extract_lty ty2 acc - HsIParamTy _ _ ty -> extract_lty ty acc - HsOpTy _ ty1 tv ty2 -> extract_tv tv $ - extract_lty ty1 $ - extract_lty ty2 acc - HsParTy _ ty -> extract_lty ty acc - HsSpliceTy {} -> acc -- Type splices mention no tvs - HsDocTy _ ty _ -> extract_lty ty acc - HsExplicitListTy _ _ tys -> extract_ltys tys acc - HsExplicitTupleTy _ tys -> extract_ltys tys acc - HsTyLit _ _ -> acc - HsStarTy _ _ -> acc - HsKindSig _ ty ki -> extract_lty ty $ - extract_lty ki acc - HsForAllTy { hst_bndrs = tvs, hst_body = ty } - -> extract_hs_tv_bndrs tvs acc $ - extract_lty ty [] - HsQualTy { hst_ctxt = ctxt, hst_body = ty } - -> extract_lctxt ctxt $ - extract_lty ty acc - XHsType {} -> acc - -- We deal with these separately in rnLHsTypeWithWildCards - HsWildCardTy {} -> acc - -extractHsTvBndrs :: [LHsTyVarBndr GhcPs] - -> FreeKiTyVarsWithDups -- Free in body - -> FreeKiTyVarsWithDups -- Free in result -extractHsTvBndrs tv_bndrs body_fvs - = extract_hs_tv_bndrs tv_bndrs [] body_fvs - -extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] - -> FreeKiTyVarsWithDups -- Accumulator - -> FreeKiTyVarsWithDups -- Free in body - -> FreeKiTyVarsWithDups --- In (forall (a :: Maybe e). a -> b) we have --- 'a' is bound by the forall --- 'b' is a free type variable --- 'e' is a free kind variable -extract_hs_tv_bndrs tv_bndrs acc_vars body_vars - | null tv_bndrs = body_vars ++ acc_vars - | otherwise = filterOut (`elemRdr` tv_bndr_rdrs) (bndr_vars ++ body_vars) ++ acc_vars - -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars. - -- See Note [Kind variable scoping] - where - bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs - tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs - -extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName] --- Returns the free kind variables of any explicitly-kinded binders, returning --- variable occurrences in left-to-right order. --- See Note [Ordering of implicit variables]. --- NB: Does /not/ delete the binders themselves. --- Duplicates are /not/ removed --- E.g. given [k1, a:k1, b:k2] --- the function returns [k1,k2], even though k1 is bound here -extract_hs_tv_bndrs_kvs tv_bndrs = - foldr extract_lty [] - [k | L _ (KindedTyVar _ _ k) <- tv_bndrs] - -extract_tv :: Located RdrName - -> [Located RdrName] -> [Located RdrName] -extract_tv tv acc = - if isRdrTyVar (unLoc tv) then tv:acc else acc - --- Deletes duplicates in a list of Located things. --- --- Importantly, this function is stable with respect to the original ordering --- of things in the list. This is important, as it is a property that GHC --- relies on to maintain the left-to-right ordering of implicitly quantified --- type variables. --- See Note [Ordering of implicit variables]. -nubL :: Eq a => [Located a] -> [Located a] -nubL = nubBy eqLocated - -elemRdr :: Located RdrName -> [Located RdrName] -> Bool -elemRdr x = any (eqLocated x) 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 @@ -17,20 +17,20 @@ ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Name.Reader import GHC.Driver.Types -import TcRnMonad +import GHC.Tc.Utils.Monad import GHC.Types.Name -import GHC.Types.Module +import GHC.Unit.Module import GHC.Types.SrcLoc as SrcLoc -import Outputable -import PrelNames ( mkUnboundName, isUnboundName, getUnique) -import Util -import Maybes +import GHC.Utils.Outputable as Outputable +import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique) +import GHC.Utils.Misc +import GHC.Data.Maybe import GHC.Driver.Session -import FastString +import GHC.Data.FastString import Data.List import Data.Function ( on ) import GHC.Types.Unique.DFM (udfmToList) @@ -90,7 +90,7 @@ -- Right ispec => imported as specified by ispec --- | Called from the typechecker (TcErrors) when we find an unbound variable +-- | Called from the typechecker (GHC.Tc.Errors) when we find an unbound variable unknownNameSuggestions :: DynFlags -> HomePackageTable -> Module -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails 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 @@ -33,27 +33,27 @@ where -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Types.Name.Reader import GHC.Driver.Types -import TcEnv -import TcRnMonad +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Core.DataCon import GHC.Types.SrcLoc as SrcLoc -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Types.Basic ( TopLevelFlag(..) ) -import ListSetOps ( removeDups ) +import GHC.Data.List.SetOps ( removeDups ) import GHC.Driver.Session -import FastString +import GHC.Data.FastString import Control.Monad import Data.List -import Constants ( mAX_TUPLE_SIZE ) +import GHC.Settings.Constants ( mAX_TUPLE_SIZE ) import qualified Data.List.NonEmpty as NE import qualified GHC.LanguageExtensions as LangExt @@ -506,7 +506,7 @@ pprHsDocContext HsTypeCtx = text "a type argument" pprHsDocContext GHCiCtx = text "GHCi input" pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) -pprHsDocContext ClassInstanceCtx = text "TcSplice.reifyInstances" +pprHsDocContext ClassInstanceCtx = text "GHC.Tc.Gen.Splice.reifyInstances" pprHsDocContext (ForeignDeclCtx name) = text "the foreign declaration for" <+> quotes (ppr name) diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -14,7 +14,7 @@ module GHC.Runtime.Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where -import GhcPrelude +import GHC.Prelude import GHC.Runtime.Linker import GHC.Runtime.Heap.Inspect @@ -32,12 +32,12 @@ import GHC.Types.Unique.Set import GHC.Core.Type import GHC -import Outputable +import GHC.Utils.Outputable import GHC.Core.Ppr.TyThing -import ErrUtils -import MonadUtils +import GHC.Utils.Error +import GHC.Utils.Monad import GHC.Driver.Session -import Exception +import GHC.Utils.Exception import Control.Monad import Data.List ( (\\) ) 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 @@ -46,7 +46,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Runtime.Eval.Types @@ -65,9 +65,9 @@ import GHC.Core.TyCon import GHC.Core.Type hiding( typeKind ) import GHC.Types.RepType -import TcType -import Constraint -import TcOrigin +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin import GHC.Core.Predicate import GHC.Types.Var import GHC.Types.Id as Id @@ -82,21 +82,22 @@ import GHC.LanguageExtensions import GHC.Types.Unique import GHC.Types.Unique.Supply -import MonadUtils -import GHC.Types.Module -import PrelNames ( toDynName, pretendNameIsInScope ) -import TysWiredIn ( isCTupleTyConName ) -import Panic -import Maybes -import ErrUtils +import GHC.Utils.Monad +import GHC.Unit.Module +import GHC.Builtin.Names ( toDynName, pretendNameIsInScope ) +import GHC.Builtin.Types ( isCTupleTyConName ) +import GHC.Utils.Panic +import GHC.Data.Maybe +import GHC.Utils.Error import GHC.Types.SrcLoc import GHC.Runtime.Heap.Inspect -import Outputable -import FastString -import Bag -import Util -import qualified Lexer (P (..), ParseResult(..), unP, mkPState) -import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Utils.Misc +import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, mkPStatePure) +import GHC.Parser.Lexer (ParserFlags) +import qualified GHC.Parser as Parser (parseStmt, parseModule, parseDeclaration, parseImport) import System.Directory import Data.Dynamic @@ -105,24 +106,24 @@ import Data.List (find,intercalate) import Data.Map (Map) import qualified Data.Map as Map -import StringBuffer (stringToStringBuffer) +import GHC.Data.StringBuffer (stringToStringBuffer) import Control.Monad import Data.Array -import Exception +import GHC.Utils.Exception import Unsafe.Coerce ( unsafeCoerce ) -import TcRnDriver ( runTcInteractive, tcRnType, loadUnqualIfaces ) -import TcHsSyn ( ZonkFlexi (SkolemiseFlexi) ) +import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces ) +import GHC.Tc.Utils.Zonk ( ZonkFlexi (SkolemiseFlexi) ) -import TcEnv (tcGetInstEnvs) +import GHC.Tc.Utils.Env (tcGetInstEnvs) -import Inst (instDFunType) -import TcSimplify (solveWanteds) -import TcRnMonad -import TcEvidence +import GHC.Tc.Utils.Instantiate (instDFunType) +import GHC.Tc.Solver (solveWanteds) +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Evidence import Data.Bifunctor (second) -import TcSMonad (runTcS) +import GHC.Tc.Solver.Monad (runTcS) -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -606,7 +607,7 @@ syncOccs mbVs ocs = unzip3 $ catMaybes $ joinOccs mbVs ocs where joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)] - joinOccs = zipWith joinOcc + joinOccs = zipWithEqual "bindLocalsAtBreakpoint" joinOcc joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc rttiEnvironment :: HscEnv -> IO HscEnv @@ -813,7 +814,7 @@ -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h -> - if moduleUnitId modl /= thisPackage (hsc_dflags h) + if moduleUnit modl /= thisPackage (hsc_dflags h) then return False else case lookupHpt (hsc_HPT h) (moduleName modl) of Just details -> return (isJust (mi_globals (hm_iface details))) @@ -879,44 +880,44 @@ ; hscTcRnLookupRdrName hsc_env lrdr_name } -- | Returns @True@ if passed string is a statement. -isStmt :: DynFlags -> String -> Bool -isStmt dflags stmt = - case parseThing Parser.parseStmt dflags stmt of +isStmt :: ParserFlags -> String -> Bool +isStmt pflags stmt = + case parseThing Parser.parseStmt pflags stmt of Lexer.POk _ _ -> True Lexer.PFailed _ -> False -- | Returns @True@ if passed string has an import declaration. -hasImport :: DynFlags -> String -> Bool -hasImport dflags stmt = - case parseThing Parser.parseModule dflags stmt of +hasImport :: ParserFlags -> String -> Bool +hasImport pflags stmt = + case parseThing Parser.parseModule pflags stmt of Lexer.POk _ thing -> hasImports thing Lexer.PFailed _ -> False where hasImports = not . null . hsmodImports . unLoc -- | Returns @True@ if passed string is an import declaration. -isImport :: DynFlags -> String -> Bool -isImport dflags stmt = - case parseThing Parser.parseImport dflags stmt of +isImport :: ParserFlags -> String -> Bool +isImport pflags stmt = + case parseThing Parser.parseImport pflags stmt of Lexer.POk _ _ -> True Lexer.PFailed _ -> False -- | Returns @True@ if passed string is a declaration but __/not a splice/__. -isDecl :: DynFlags -> String -> Bool -isDecl dflags stmt = do - case parseThing Parser.parseDeclaration dflags stmt of +isDecl :: ParserFlags -> String -> Bool +isDecl pflags stmt = do + case parseThing Parser.parseDeclaration pflags stmt of Lexer.POk _ thing -> case unLoc thing of SpliceD _ _ -> False _ -> True Lexer.PFailed _ -> False -parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing -parseThing parser dflags stmt = do +parseThing :: Lexer.P thing -> ParserFlags -> String -> Lexer.ParseResult thing +parseThing parser pflags stmt = do let buf = stringToStringBuffer stmt loc = mkRealSrcLoc (fsLit "") 1 1 - Lexer.unP parser (Lexer.mkPState dflags buf loc) + Lexer.unP parser (Lexer.mkPStatePure pflags buf loc) getDocs :: GhcMonad m => Name 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 @@ -25,7 +25,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Runtime.Interpreter as GHCi @@ -38,26 +38,26 @@ import GHC.Types.RepType import qualified GHC.Core.Unify as U import GHC.Types.Var -import TcRnMonad -import TcType -import TcMType -import TcHsSyn ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) ) -import TcUnify -import TcEnv +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.Utils.Unify +import GHC.Tc.Utils.Env import GHC.Core.TyCon import GHC.Types.Name import GHC.Types.Name.Occurrence as OccName -import GHC.Types.Module +import GHC.Unit.Module import GHC.Iface.Env -import Util +import GHC.Utils.Misc import GHC.Types.Var.Set import GHC.Types.Basic ( Boxity(..) ) -import TysPrim -import PrelNames -import TysWiredIn +import GHC.Builtin.Types.Prim +import GHC.Builtin.Names +import GHC.Builtin.Types import GHC.Driver.Session -import Outputable as Ppr +import GHC.Utils.Outputable as Ppr import GHC.Char import GHC.Exts.Heap import GHC.Runtime.Heap.Layout ( roundUpTo ) @@ -139,7 +139,7 @@ constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name) constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do let occName = mkOccName OccName.dataName occ - modName = mkModule (stringToUnitId pkg) (mkModuleName mod) + modName = mkModule (stringToUnit pkg) (mkModuleName mod) Right `fmap` lookupOrigIO hsc_env modName occName constrClosToName _hsc_env clos = return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos))) @@ -566,7 +566,7 @@ traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti --- Semantically different to recoverM in TcRnMonad +-- Semantically different to recoverM in GHC.Tc.Utils.Monad -- recoverM retains the errors in the first action, -- whereas recoverTc here does not recoverTR :: TR a -> TR a -> TR a @@ -865,10 +865,9 @@ -- This is a bit involved since we allow packing multiple fields -- within a single word. See also -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding - dflags <- getDynFlags - let platform = targetPlatform dflags - word_size = platformWordSizeInBytes platform - big_endian = wORDS_BIGENDIAN dflags + platform <- getPlatform + let word_size = platformWordSizeInBytes platform + endian = platformByteOrder platform size_b = primRepSizeB platform rep -- Align the start offset (eg, 2-byte value should be 2-byte -- aligned). But not more than to a word. The offset calculation @@ -877,7 +876,7 @@ !aligned_idx = roundUpTo arr_i (min word_size size_b) !new_arr_i = aligned_idx + size_b ws | size_b < word_size = - [index size_b aligned_idx word_size big_endian] + [index size_b aligned_idx word_size endian] | otherwise = let (q, r) = size_b `quotRem` word_size in ASSERT( r == 0 ) @@ -892,7 +891,7 @@ (error "unboxedTupleTerm: no HValue for unboxed tuple") terms -- Extract a sub-word sized field from a word - index item_size_b index_b word_size big_endian = + index item_size_b index_b word_size endian = (word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes where mask :: Word @@ -903,9 +902,9 @@ _ -> panic ("Weird byte-index: " ++ show index_b) (q,r) = index_b `quotRem` word_size word = array!!q - moveBytes = if big_endian - then word_size - (r + item_size_b) * 8 - else r * 8 + moveBytes = case endian of + BigEndian -> word_size - (r + item_size_b) * 8 + LittleEndian -> r * 8 -- | Fast, breadth-first Type reconstruction diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -53,27 +53,27 @@ , fromEvalResult ) where -import GhcPrelude +import GHC.Prelude import GHC.Runtime.Interpreter.Types import GHCi.Message import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray) -import Fingerprint +import GHC.Utils.Fingerprint import GHC.Driver.Types import GHC.Types.Unique.FM -import Panic +import GHC.Utils.Panic import GHC.Driver.Session -import Exception +import GHC.Utils.Exception import GHC.Types.Basic -import FastString -import Util +import GHC.Data.FastString +import GHC.Utils.Misc import GHC.Runtime.Eval.Types(BreakInfo(..)) -import Outputable(brackets, ppr, showSDocUnqual) +import GHC.Utils.Outputable(brackets, ppr, showSDocUnqual) import GHC.Types.SrcLoc -import Maybes -import GHC.Types.Module +import GHC.Data.Maybe +import GHC.Unit.Module import GHC.ByteCode.Types import GHC.Types.Unique diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -29,7 +29,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Runtime.Interpreter import GHC.Runtime.Interpreter.Types @@ -38,30 +38,30 @@ import GHC.ByteCode.Linker import GHC.ByteCode.Asm import GHC.ByteCode.Types -import TcRnMonad -import GHC.Driver.Packages as Packages +import GHC.Tc.Utils.Monad +import GHC.Unit.State as Packages import GHC.Driver.Phases import GHC.Driver.Finder import GHC.Driver.Types import GHC.Driver.Ways import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Types.Module -import ListSetOps +import GHC.Unit.Module +import GHC.Data.List.SetOps import GHC.Runtime.Linker.Types (DynLinker(..), LinkerUnitId, PersistentLinkerState(..)) import GHC.Driver.Session import GHC.Types.Basic -import Outputable -import Panic -import Util -import ErrUtils +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Error import GHC.Types.SrcLoc -import qualified Maybes +import qualified GHC.Data.Maybe as Maybes import GHC.Types.Unique.DSet -import FastString +import GHC.Data.FastString import GHC.Platform -import SysTools -import FileCleanup +import GHC.SysTools +import GHC.SysTools.FileCleanup -- Standard libraries import Control.Monad @@ -82,7 +82,7 @@ import System.Win32.Info (getSystemDirectory) #endif -import Exception +import GHC.Utils.Exception {- ********************************************************************** @@ -127,23 +127,23 @@ :: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO () modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f -emptyPLS :: DynFlags -> PersistentLinkerState -emptyPLS _ = PersistentLinkerState { - closure_env = emptyNameEnv, - itbl_env = emptyNameEnv, - pkgs_loaded = init_pkgs, - bcos_loaded = [], - objs_loaded = [], - temp_sos = [] } - +emptyPLS :: PersistentLinkerState +emptyPLS = PersistentLinkerState + { closure_env = emptyNameEnv + , itbl_env = emptyNameEnv + , pkgs_loaded = init_pkgs + , bcos_loaded = [] + , objs_loaded = [] + , temp_sos = [] + } -- Packages that don't need loading, because the compiler -- shares them with the interpreted program. -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. - where init_pkgs = map toInstalledUnitId [rtsUnitId] + where init_pkgs = map toUnitId [rtsUnitId] -extendLoadedPkgs :: DynLinker -> [InstalledUnitId] -> IO () +extendLoadedPkgs :: DynLinker -> [UnitId] -> IO () extendLoadedPkgs dl pkgs = modifyPLS_ dl $ \s -> return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } @@ -280,7 +280,7 @@ reallyInitDynLinker hsc_env = do -- Initialise the linker state let dflags = hsc_dflags hsc_env - pls0 = emptyPLS dflags + pls0 = emptyPLS -- (a) initialise the C dynamic linker initObjLinker hsc_env @@ -625,7 +625,7 @@ -> Maybe FilePath -- replace object suffices? -> SrcSpan -- for error messages -> [Module] -- If you need these - -> IO ([Linkable], [InstalledUnitId]) -- ... then link these first + -> IO ([Linkable], [UnitId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files getLinkDeps hsc_env hpt pls replace_osuf span mods @@ -663,8 +663,8 @@ -- tree recursively. See bug #936, testcase ghci/prog007. follow_deps :: [Module] -- modules to follow -> UniqDSet ModuleName -- accum. module dependencies - -> UniqDSet InstalledUnitId -- accum. package dependencies - -> IO ([ModuleName], [InstalledUnitId]) -- result + -> UniqDSet UnitId -- accum. package dependencies + -> IO ([ModuleName], [UnitId]) -- result follow_deps [] acc_mods acc_pkgs = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs @@ -678,7 +678,7 @@ when (mi_boot iface) $ link_boot_mod_error mod let - pkg = moduleUnitId mod + pkg = moduleUnit mod deps = mi_deps iface pkg_deps = dep_pkgs deps @@ -691,7 +691,7 @@ acc_pkgs' = addListToUniqDSet acc_pkgs $ map fst pkg_deps -- if pkg /= this_pkg - then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toInstalledUnitId pkg)) + then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) acc_mods' acc_pkgs' where @@ -1260,13 +1260,13 @@ | Just pkg_cfg <- lookupInstalledPackage pkgstate new_pkg = do { -- Link dependents first - pkgs' <- link pkgs (depends pkg_cfg) + pkgs' <- link pkgs (unitDepends pkg_cfg) -- Now link the package itself ; linkPackage hsc_env pkg_cfg ; return (new_pkg : pkgs') } | otherwise - = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg))) + = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) linkPackage :: HscEnv -> UnitInfo -> IO () @@ -1275,12 +1275,12 @@ let dflags = hsc_dflags hsc_env platform = targetPlatform dflags is_dyn = interpreterDynamic (hscInterp hsc_env) - dirs | is_dyn = Packages.libraryDynDirs pkg - | otherwise = Packages.libraryDirs pkg + dirs | is_dyn = Packages.unitLibraryDynDirs pkg + | otherwise = Packages.unitLibraryDirs pkg - let hs_libs = Packages.hsLibraries pkg + let hs_libs = Packages.unitLibraries pkg -- The FFI GHCi import lib isn't needed as - -- compiler/ghci/Linker.hs + rts/Linker.c link the + -- GHC.Runtime.Linker + rts/Linker.c link the -- interpreted references to FFI to the compiled FFI. -- We therefore filter it out so that we don't get -- duplicate symbol errors. @@ -1294,10 +1294,10 @@ -- package file provides an "extra-ghci-libraries" field then we use -- that instead of the "extra-libraries" field. extra_libs = - (if null (Packages.extraGHCiLibraries pkg) - then Packages.extraLibraries pkg - else Packages.extraGHCiLibraries pkg) - ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ] + (if null (Packages.unitExtDepLibsGhc pkg) + then Packages.unitExtDepLibsSys pkg + else Packages.unitExtDepLibsGhc pkg) + ++ [ lib | '-':'l':lib <- Packages.unitLinkerOptions pkg ] -- See Note [Fork/Exec Windows] gcc_paths <- getGCCPaths dflags (platformOS platform) dirs_env <- addEnvPaths "LIBRARY_PATH" dirs @@ -1322,10 +1322,10 @@ pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env maybePutStr dflags - ("Loading package " ++ sourcePackageIdString pkg ++ " ... ") + ("Loading package " ++ unitPackageIdString pkg ++ " ... ") -- See comments with partOfGHCi - when (packageName pkg `notElem` partOfGHCi) $ do + when (unitPackageName pkg `notElem` partOfGHCi) $ do loadFrameworks hsc_env platform pkg -- See Note [Crash early load_dyn and locateLib] -- Crash early if can't load any of `known_dlls` @@ -1352,7 +1352,7 @@ if succeeded ok then maybePutStrLn dflags "done." else let errmsg = "unable to load package `" - ++ sourcePackageIdString pkg ++ "'" + ++ unitPackageIdString pkg ++ "'" in throwGhcExceptionIO (InstallationError errmsg) {- @@ -1426,8 +1426,8 @@ loadFrameworks hsc_env platform pkg = when (platformUsesFrameworks platform) $ mapM_ load frameworks where - fw_dirs = Packages.frameworkDirs pkg - frameworks = Packages.frameworks pkg + fw_dirs = Packages.unitExtDepFrameworkDirs pkg + frameworks = Packages.unitExtDepFrameworks pkg load fw = do r <- loadFramework hsc_env fw_dirs fw case r of 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 @@ -20,7 +20,7 @@ lessUnsafeCoerce ) where -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Runtime.Linker ( linkModule, getHValue ) @@ -28,15 +28,15 @@ import GHC.Runtime.Interpreter.Types import GHC.Types.SrcLoc ( noSrcSpan ) import GHC.Driver.Finder ( findPluginModule, cannotFindModule ) -import TcRnMonad ( initTcInteractive, initIfaceTcRn ) +import GHC.Tc.Utils.Monad ( initTcInteractive, initIfaceTcRn ) import GHC.Iface.Load ( loadPluginInterface ) -import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..) +import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..) , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName , gre_name, mkRdrQual ) import GHC.Types.Name.Occurrence ( OccName, mkVarOcc ) import GHC.Rename.Names ( gresFromAvails ) import GHC.Driver.Plugins -import PrelNames ( pluginTyConName, frontendPluginTyConName ) +import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName ) import GHC.Driver.Types import GHCi.RemoteTypes ( HValue ) @@ -45,12 +45,12 @@ import GHC.Core.TyCon ( TyCon ) import GHC.Types.Name ( Name, nameModule_maybe ) import GHC.Types.Id ( idType ) -import GHC.Types.Module ( Module, ModuleName ) -import Panic -import FastString -import ErrUtils -import Outputable -import Exception +import GHC.Unit.Module ( Module, ModuleName ) +import GHC.Utils.Panic +import GHC.Data.FastString +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Exception import GHC.Driver.Hooks import Control.Monad ( unless ) diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Settings/IO.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.Settings.IO + ( SettingsError (..) + , initSettings + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Settings.Platform +import GHC.Settings.Utils + +import Config +import GHC.Utils.CliOption +import GHC.Utils.Fingerprint +import GHC.Platform +import GHC.Utils.Outputable +import GHC.Settings +import GHC.SysTools.BaseDir + +import Control.Monad.Trans.Except +import Control.Monad.IO.Class +import qualified Data.Map as Map +import System.FilePath +import System.Directory + +data SettingsError + = SettingsError_MissingData String + | SettingsError_BadData String + +initSettings + :: forall m + . MonadIO m + => String -- ^ TopDir path + -> ExceptT SettingsError m Settings +initSettings top_dir = do + -- see Note [topdir: How GHC finds its files] + -- NB: top_dir is assumed to be in standard Unix + -- format, '/' separated + mtool_dir <- liftIO $ findToolDir top_dir + -- see Note [tooldir: How GHC finds mingw on Windows] + + let installed :: FilePath -> FilePath + installed file = top_dir file + libexec :: FilePath -> FilePath + libexec file = top_dir "bin" file + settingsFile = installed "settings" + platformConstantsFile = installed "platformConstants" + + readFileSafe :: FilePath -> ExceptT SettingsError m String + readFileSafe path = liftIO (doesFileExist path) >>= \case + True -> liftIO $ readFile path + False -> throwE $ SettingsError_MissingData $ "Missing file: " ++ path + + settingsStr <- readFileSafe settingsFile + platformConstantsStr <- readFileSafe platformConstantsFile + settingsList <- case maybeReadFuzzy settingsStr of + Just s -> pure s + Nothing -> throwE $ SettingsError_BadData $ + "Can't parse " ++ show settingsFile + let mySettings = Map.fromList settingsList + platformConstants <- case maybeReadFuzzy platformConstantsStr of + Just s -> pure s + Nothing -> throwE $ SettingsError_BadData $ + "Can't parse " ++ show platformConstantsFile + -- See Note [Settings file] for a little more about this file. We're + -- 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 $ + getFilePathSetting0 top_dir settingsFile mySettings key + getToolSetting :: String -> ExceptT SettingsError m String + getToolSetting key = expandToolDir mtool_dir <$> getSetting key + getBooleanSetting :: String -> ExceptT SettingsError m Bool + getBooleanSetting key = either pgmError pure $ + getBooleanSetting0 settingsFile mySettings key + targetPlatformString <- getSetting "target platform string" + tablesNextToCode <- getBooleanSetting "Tables next to code" + myExtraGccViaCFlags <- getSetting "GCC extra via C opts" + -- On Windows, mingw is distributed with GHC, + -- so we look in TopDir/../mingw/bin, + -- as well as TopDir/../../mingw/bin for hadrian. + -- It would perhaps be nice to be able to override this + -- with the settings file, but it would be a little fiddly + -- to make that possible, so for now you can't. + cc_prog <- getToolSetting "C compiler command" + cc_args_str <- getSetting "C compiler flags" + cxx_args_str <- getSetting "C++ compiler flags" + gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" + cpp_prog <- getToolSetting "Haskell CPP command" + cpp_args_str <- getSetting "Haskell CPP flags" + + platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings + + let unreg_cc_args = if platformUnregisterised platform + then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] + else [] + cpp_args = map Option (words cpp_args_str) + cc_args = words cc_args_str ++ unreg_cc_args + cxx_args = words cxx_args_str + ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" + ldSupportsBuildId <- getBooleanSetting "ld supports build-id" + ldSupportsFilelist <- getBooleanSetting "ld supports filelist" + ldIsGnuLd <- getBooleanSetting "ld is GNU ld" + + let globalpkgdb_path = installed "package.conf.d" + ghc_usage_msg_path = installed "ghc-usage.txt" + ghci_usage_msg_path = installed "ghci-usage.txt" + + -- For all systems, unlit, split, mangle are GHC utilities + -- architecture-specific stuff is done when building Config.hs + unlit_path <- getToolSetting "unlit command" + + windres_path <- getToolSetting "windres command" + libtool_path <- getToolSetting "libtool command" + ar_path <- getToolSetting "ar command" + ranlib_path <- getToolSetting "ranlib command" + + -- TODO this side-effect doesn't belong here. Reading and parsing the settings + -- should be idempotent and accumulate no resources. + tmpdir <- liftIO $ getTemporaryDirectory + + touch_path <- getToolSetting "touch command" + + mkdll_prog <- getToolSetting "dllwrap command" + let mkdll_args = [] + + -- cpp is derived from gcc on all platforms + -- HACK, see setPgmP below. We keep 'words' here to remember to fix + -- Config.hs one day. + + + -- Other things being equal, as and ld are simply gcc + cc_link_args_str <- getSetting "C compiler link flags" + let as_prog = cc_prog + as_args = map Option cc_args + ld_prog = cc_prog + ld_args = map Option (cc_args ++ words cc_link_args_str) + + llvmTarget <- getSetting "LLVM target" + + -- We just assume on command line + lc_prog <- getSetting "LLVM llc command" + lo_prog <- getSetting "LLVM opt command" + lcc_prog <- getSetting "LLVM clang command" + + let iserv_prog = libexec "ghc-iserv" + + integerLibrary <- getSetting "integer library" + integerLibraryType <- case integerLibrary of + "integer-gmp" -> pure IntegerGMP + "integer-simple" -> pure IntegerSimple + _ -> pgmError $ unwords + [ "Entry for" + , show "integer library" + , "must be one of" + , show "integer-gmp" + , "or" + , show "integer-simple" + ] + + ghcWithInterpreter <- getBooleanSetting "Use interpreter" + ghcWithNativeCodeGen <- getBooleanSetting "Use native code generator" + ghcWithSMP <- getBooleanSetting "Support SMP" + ghcRTSWays <- getSetting "RTS ways" + leadingUnderscore <- getBooleanSetting "Leading underscore" + useLibFFI <- getBooleanSetting "Use LibFFI" + ghcThreaded <- getBooleanSetting "Use Threads" + ghcDebugged <- getBooleanSetting "Use Debugging" + ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw" + + return $ Settings + { sGhcNameVersion = GhcNameVersion + { ghcNameVersion_programName = "ghc" + , ghcNameVersion_projectVersion = cProjectVersion + } + + , sFileSettings = FileSettings + { fileSettings_tmpDir = normalise tmpdir + , fileSettings_ghcUsagePath = ghc_usage_msg_path + , fileSettings_ghciUsagePath = ghci_usage_msg_path + , fileSettings_toolDir = mtool_dir + , fileSettings_topDir = top_dir + , fileSettings_globalPackageDatabase = globalpkgdb_path + } + + , sToolSettings = ToolSettings + { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind + , toolSettings_ldSupportsBuildId = ldSupportsBuildId + , toolSettings_ldSupportsFilelist = ldSupportsFilelist + , toolSettings_ldIsGnuLd = ldIsGnuLd + , toolSettings_ccSupportsNoPie = gccSupportsNoPie + + , toolSettings_pgm_L = unlit_path + , toolSettings_pgm_P = (cpp_prog, cpp_args) + , toolSettings_pgm_F = "" + , toolSettings_pgm_c = cc_prog + , toolSettings_pgm_a = (as_prog, as_args) + , toolSettings_pgm_l = (ld_prog, ld_args) + , toolSettings_pgm_dll = (mkdll_prog,mkdll_args) + , toolSettings_pgm_T = touch_path + , toolSettings_pgm_windres = windres_path + , toolSettings_pgm_libtool = libtool_path + , toolSettings_pgm_ar = ar_path + , toolSettings_pgm_ranlib = ranlib_path + , toolSettings_pgm_lo = (lo_prog,[]) + , toolSettings_pgm_lc = (lc_prog,[]) + , toolSettings_pgm_lcc = (lcc_prog,[]) + , toolSettings_pgm_i = iserv_prog + , toolSettings_opt_L = [] + , toolSettings_opt_P = [] + , toolSettings_opt_P_fingerprint = fingerprint0 + , toolSettings_opt_F = [] + , toolSettings_opt_c = cc_args + , toolSettings_opt_cxx = cxx_args + , toolSettings_opt_a = [] + , toolSettings_opt_l = [] + , toolSettings_opt_windres = [] + , toolSettings_opt_lcc = [] + , toolSettings_opt_lo = [] + , toolSettings_opt_lc = [] + , toolSettings_opt_i = [] + + , toolSettings_extraGccViaCFlags = words myExtraGccViaCFlags + } + + , sTargetPlatform = platform + , sPlatformMisc = PlatformMisc + { platformMisc_targetPlatformString = targetPlatformString + , platformMisc_integerLibrary = integerLibrary + , platformMisc_integerLibraryType = integerLibraryType + , platformMisc_ghcWithInterpreter = ghcWithInterpreter + , platformMisc_ghcWithNativeCodeGen = ghcWithNativeCodeGen + , platformMisc_ghcWithSMP = ghcWithSMP + , platformMisc_ghcRTSWays = ghcRTSWays + , platformMisc_tablesNextToCode = tablesNextToCode + , platformMisc_leadingUnderscore = leadingUnderscore + , platformMisc_libFFI = useLibFFI + , platformMisc_ghcThreaded = ghcThreaded + , platformMisc_ghcDebugged = ghcDebugged + , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw + , platformMisc_llvmTarget = llvmTarget + } + + , sPlatformConstants = platformConstants + + , sRawSettings = settingsList + } 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 @@ -86,12 +86,13 @@ module GHC.Stg.CSE (stgCse) where -import GhcPrelude +import GHC.Prelude import GHC.Core.DataCon import GHC.Types.Id import GHC.Stg.Syntax -import Outputable +import GHC.Utils.Outputable +import GHC.Types.Basic (isWeakLoopBreaker) import GHC.Types.Var.Env import GHC.Core (AltCon(..)) import Data.List (mapAccumL) @@ -105,7 +106,7 @@ -------------- -- A lookup trie for data constructor applications, i.e. --- keys of type `(DataCon, [StgArg])`, following the patterns in TrieMap. +-- keys of type `(DataCon, [StgArg])`, following the patterns in GHC.Data.TrieMap. data StgArgMap a = SAM { sam_var :: DVarEnv a @@ -391,6 +392,7 @@ stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv) stgCseRhs env bndr (StgRhsCon ccs dataCon args) | Just other_bndr <- envLookup dataCon args' env + , not (isWeakLoopBreaker (idOccInfo bndr)) -- See Note [Care with loop breakers] = let env' = addSubst bndr other_bndr env in (Nothing, env') | otherwise @@ -399,6 +401,7 @@ pair = (bndr, StgRhsCon ccs dataCon args') in (Just pair, env') where args' = substArgs env args + stgCseRhs env bndr (StgRhsClosure ext ccs upd args body) = let (env1, args') = substBndrs env args env2 = forgetCse env1 -- See note [Free variables of an StgClosure] @@ -415,6 +418,21 @@ isBndr (_, _, StgApp f []) = f == bndr isBndr _ = False + +{- Note [Care with loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When doing CSE on a letrec we must be careful about loop +breakers. Consider + rec { y = K z + ; z = K z } +Now if, somehow (and wrongly)), y and z are both marked as +loop-breakers, we do *not* want to drop the (z = K z) binding +in favour of a substitution (z :-> y). + +I think this bug will only show up if the loop-breaker-ness is done +wrongly (itself a bug), but it still seems better to do the right +thing regardless. +-} -- Utilities diff --git a/compiler/GHC/Stg/DepAnal.hs b/compiler/GHC/Stg/DepAnal.hs --- a/compiler/GHC/Stg/DepAnal.hs +++ b/compiler/GHC/Stg/DepAnal.hs @@ -2,16 +2,16 @@ module GHC.Stg.DepAnal (depSortStgPgm) where -import GhcPrelude +import GHC.Prelude import GHC.Stg.Syntax import GHC.Types.Id import GHC.Types.Name (Name, nameIsLocalOrFrom) import GHC.Types.Name.Env -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique.Set (nonDetEltsUniqSet) import GHC.Types.Var.Set -import GHC.Types.Module (Module) +import GHC.Unit.Module (Module) import Data.Graph (SCC (..)) 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 @@ -42,14 +42,14 @@ annBindingFreeVars ) where -import GhcPrelude +import GHC.Prelude import GHC.Stg.Syntax import GHC.Types.Id import GHC.Types.Var.Set import GHC.Core ( Tickish(Breakpoint) ) -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import Data.Maybe ( mapMaybe ) 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 @@ -17,7 +17,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic import GHC.Driver.Session @@ -26,9 +26,9 @@ import GHC.Stg.Lift.Analysis import GHC.Stg.Lift.Monad import GHC.Stg.Syntax -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique.Supply -import Util +import GHC.Utils.Misc import GHC.Types.Var.Set import Control.Monad ( when ) import Data.Maybe ( isNothing ) 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 @@ -20,7 +20,7 @@ closureGrowth -- Exported just for the docs ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Types.Basic @@ -32,8 +32,8 @@ import qualified GHC.StgToCmm.ArgRep as StgToCmm.ArgRep import qualified GHC.StgToCmm.Closure as StgToCmm.Closure import qualified GHC.StgToCmm.Layout as StgToCmm.Layout -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Types.Var.Set import Data.Maybe ( mapMaybe ) 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 @@ -22,21 +22,21 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic import GHC.Types.CostCentre ( isCurrentCCS, dontCareCCS ) import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Types.Id import GHC.Types.Name -import Outputable -import OrdList +import GHC.Utils.Outputable +import GHC.Data.OrdList import GHC.Stg.Subst import GHC.Stg.Syntax import GHC.Core.Type import GHC.Types.Unique.Supply -import Util +import GHC.Utils.Misc import GHC.Types.Var.Env import GHC.Types.Var.Set 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 @@ -37,12 +37,12 @@ module GHC.Stg.Lint ( lintStgTopBindings ) where -import GhcPrelude +import GHC.Prelude import GHC.Stg.Syntax import GHC.Driver.Session -import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) +import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel ) import GHC.Types.CostCentre ( isCurrentCCS ) import GHC.Types.Id ( Id, idType, isJoinId, idName ) @@ -50,13 +50,13 @@ import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom ) -import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) +import GHC.Utils.Error ( MsgDoc, Severity(..), mkLocMessage ) import GHC.Core.Type import GHC.Types.RepType import GHC.Types.SrcLoc -import Outputable -import GHC.Types.Module ( Module ) -import qualified ErrUtils as Err +import GHC.Utils.Outputable +import GHC.Unit.Module ( Module ) +import qualified GHC.Utils.Error as Err import Control.Applicative ((<|>)) import Control.Monad 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 @@ -13,7 +13,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Stg.Syntax @@ -23,12 +23,12 @@ import GHC.Stg.Unarise ( unarise ) import GHC.Stg.CSE ( stgCse ) import GHC.Stg.Lift ( stgLiftLams ) -import GHC.Types.Module ( Module ) +import GHC.Unit.Module ( Module ) import GHC.Driver.Session -import ErrUtils +import GHC.Utils.Error import GHC.Types.Unique.Supply -import Outputable +import GHC.Utils.Outputable import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.State.Strict 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 @@ -27,12 +27,12 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Stg.Syntax import GHC.Types.Id (Id) -import Panic +import GHC.Utils.Panic import Data.Map (Map) import qualified Data.Map as Map diff --git a/compiler/GHC/Stg/Subst.hs b/compiler/GHC/Stg/Subst.hs --- a/compiler/GHC/Stg/Subst.hs +++ b/compiler/GHC/Stg/Subst.hs @@ -4,13 +4,13 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Id import GHC.Types.Var.Env import Control.Monad.Trans.State.Strict -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc -- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not -- maintaining pairs of substitutions. Like 'GHC.Core.Subst.Subst', but 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 @@ -200,25 +200,25 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic import GHC.Core import GHC.Core.DataCon -import FastString (FastString, mkFastString) +import GHC.Data.FastString (FastString, mkFastString) import GHC.Types.Id import GHC.Types.Literal import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID) import GHC.Types.Id.Make (voidPrimId, voidArgId) -import MonadUtils (mapAccumLM) -import Outputable +import GHC.Utils.Monad (mapAccumLM) +import GHC.Utils.Outputable import GHC.Types.RepType import GHC.Stg.Syntax import GHC.Core.Type -import TysPrim (intPrimTy,wordPrimTy,word64PrimTy) -import TysWiredIn +import GHC.Builtin.Types.Prim (intPrimTy,wordPrimTy,word64PrimTy) +import GHC.Builtin.Types import GHC.Types.Unique.Supply -import Util +import GHC.Utils.Misc import GHC.Types.Var.Env import Data.Bifunctor (second) diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -13,7 +13,7 @@ #include "HsVersions.h" -import GhcPrelude as Prelude +import GHC.Prelude as Prelude import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) import GHC.StgToCmm.Monad @@ -27,11 +27,12 @@ import GHC.StgToCmm.Ticky import GHC.Cmm +import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Stg.Syntax import GHC.Driver.Session -import ErrUtils +import GHC.Utils.Error import GHC.Driver.Types import GHC.Types.CostCentre @@ -40,18 +41,21 @@ import GHC.Types.RepType import GHC.Core.DataCon import GHC.Core.TyCon -import GHC.Types.Module -import Outputable -import Stream +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Data.Stream import GHC.Types.Basic import GHC.Types.Var.Set ( isEmptyDVarSet ) +import GHC.SysTools.FileCleanup -import OrdList +import GHC.Data.OrdList import GHC.Cmm.Graph import Data.IORef import Control.Monad (when,void) -import Util +import GHC.Utils.Misc +import System.IO.Unsafe +import qualified Data.ByteString as BS codeGen :: DynFlags -> Module @@ -133,13 +137,25 @@ ; sequence_ fcodes } -cgTopBinding dflags (StgTopStringLit id str) - = do { let label = mkBytesLabel (idName id) - ; let (lit, decl) = mkByteStringCLit label str - ; emitDecl decl - ; addBindC (litIdInfo dflags id mkLFStringLit lit) - } +cgTopBinding dflags (StgTopStringLit id str) = do + let label = mkBytesLabel (idName id) + -- emit either a CmmString literal or dump the string in a file and emit a + -- CmmFileEmbed literal. + -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr + let isNCG = platformMisc_ghcWithNativeCodeGen $ platformMisc dflags + isSmall = fromIntegral (BS.length str) <= binBlobThreshold dflags + asString = binBlobThreshold dflags == 0 || isSmall + (lit,decl) = if not isNCG || asString + then mkByteStringCLit label str + else mkFileEmbedLit label $ unsafePerformIO $ do + bFile <- newTempName dflags TFL_CurrentModule ".dat" + BS.writeFile bFile str + return bFile + emitDecl decl + addBindC (litIdInfo dflags id mkLFStringLit lit) + + cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ()) -- The Id is passed along for setting up a binding... @@ -177,7 +193,7 @@ cgEnumerationTyCon :: TyCon -> FCode () cgEnumerationTyCon tycon = do dflags <- getDynFlags - emitRawRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) + emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon dflags con) | con <- tyConDataCons tycon] 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 @@ -17,7 +17,7 @@ ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.StgToCmm.Closure ( idPrimRep ) @@ -25,10 +25,10 @@ import GHC.Types.Id ( Id ) import GHC.Core.TyCon ( PrimRep(..), primElemRepSizeB ) import GHC.Types.Basic ( RepArity ) -import Constants ( wORD64_SIZE, dOUBLE_SIZE ) +import GHC.Settings.Constants ( wORD64_SIZE, dOUBLE_SIZE ) -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString -- I extricated this code as this new module in order to avoid a -- cyclic dependency between GHC.StgToCmm.Layout and GHC.StgToCmm.Ticky. 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 @@ -13,7 +13,7 @@ pushUpdateFrame, emitUpdateFrame ) where -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) import GHC.Platform import GHC.StgToCmm.Expr @@ -42,13 +42,13 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name -import GHC.Types.Module -import ListSetOps -import Util +import GHC.Unit.Module +import GHC.Data.List.SetOps +import GHC.Utils.Misc import GHC.Types.Var.Set import GHC.Types.Basic -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Driver.Session import Control.Monad 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 @@ -16,7 +16,7 @@ get_GlobalReg_addr, ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform.Regs import GHC.Cmm @@ -25,7 +25,7 @@ import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Driver.Session -import Outputable +import GHC.Utils.Outputable -- ----------------------------------------------------------------------------- -- Information about global registers 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 @@ -64,7 +64,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Stg.Syntax import GHC.Runtime.Heap.Layout @@ -80,13 +80,13 @@ import GHC.Types.Name import GHC.Core.Type import GHC.Core.TyCo.Rep -import TcType +import GHC.Tc.Utils.TcType import GHC.Core.TyCon import GHC.Types.RepType import GHC.Types.Basic -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Session -import Util +import GHC.Utils.Misc import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 @@ -487,7 +487,7 @@ really does happen occasionally) let-floating may make a function f smaller so it can be inlined, so now (f True) may generate a local no-fv closure. This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind -in TcGenDeriv.) -} +in GHC.Tc.Deriv.Generate.) -} ----------------------------------------------------------------------------- -- getCallMethod 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 @@ -17,7 +17,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Stg.Syntax import GHC.Core ( AltCon(..) ) @@ -35,24 +35,24 @@ import GHC.Cmm.Graph import GHC.Runtime.Heap.Layout import GHC.Types.CostCentre -import GHC.Types.Module +import GHC.Unit import GHC.Core.DataCon import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Types.Id +import GHC.Types.Id.Info( CafInfo( NoCafRefs ) ) +import GHC.Types.Name (isInternalName) import GHC.Types.RepType (countConRepArgs) import GHC.Types.Literal -import PrelInfo -import Outputable +import GHC.Builtin.Utils +import GHC.Utils.Outputable import GHC.Platform -import Util -import MonadUtils (mapMaybeM) +import GHC.Utils.Misc +import GHC.Utils.Monad (mapMaybeM) import Control.Monad import Data.Char - - --------------------------------------------------------------- -- Top-level constructors --------------------------------------------------------------- @@ -62,10 +62,24 @@ -> DataCon -- Id -> [NonVoid StgArg] -- Args -> (CgIdInfo, FCode ()) -cgTopRhsCon dflags id con args = - let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) - in (id_info, gen_code) +cgTopRhsCon dflags id con args + | Just static_info <- precomputedStaticConInfo_maybe dflags id con args + , let static_code | isInternalName name = pure () + | otherwise = gen_code + = -- There is a pre-allocated static closure available; use it + -- See Note [Precomputed static closures]. + -- For External bindings we must keep the binding, + -- since importing modules will refer to it by name; + -- but for Internal ones we can drop it altogether + -- See Note [About the NameSorts] in Name.hs for Internal/External + (static_info, static_code) + + -- Otherwise generate a closure for the constructor. + | otherwise + = (id_Info, gen_code) + where + id_Info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) name = idName id caffy = idCafInfo id -- any stgArgHasCafRefs args closure_label = mkClosureLabel name caffy @@ -124,11 +138,10 @@ -- Return details about how to find it and initialization code buildDynCon binder actually_bound cc con args = do dflags <- getDynFlags - buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args + buildDynCon' dflags binder actually_bound cc con args buildDynCon' :: DynFlags - -> Platform -> Id -> Bool -> CostCentreStack -> DataCon @@ -146,78 +159,13 @@ premature looking at the args will cause the compiler to black-hole! -} - --------- buildDynCon': Nullary constructors -------------- --- First we deal with the case of zero-arity constructors. They --- will probably be unfolded, so we don't expect to see this case much, --- if at all, but it does no harm, and sets the scene for characters. --- --- In the case of zero-arity constructors, or, more accurately, those --- which have exclusively size-zero (VoidRep) args, we generate no code --- at all. - -buildDynCon' dflags _ binder _ _cc con [] - | isNullaryRepDataCon con - = return (litIdInfo dflags binder (mkConLFInfo con) - (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))), - return mkNop) - --------- buildDynCon': Charlike and Intlike constructors ----------- -{- The following three paragraphs about @Char@-like and @Int@-like -closures are obsolete, but I don't understand the details well enough -to properly word them, sorry. I've changed the treatment of @Char@s to -be analogous to @Int@s: only a subset is preallocated, because @Char@ -has now 31 bits. Only literals are handled here. -- Qrczak - -Now for @Char@-like closures. We generate an assignment of the -address of the closure to a temporary. It would be possible simply to -generate no code, and record the addressing mode in the environment, -but we'd have to be careful if the argument wasn't a constant --- so -for simplicity we just always assign to a temporary. - -Last special case: @Int@-like closures. We only special-case the -situation in which the argument is a literal in the range -@mIN_INTLIKE@..@mAX_INTLILKE@. NB: for @Char@-like closures we can -work with any old argument, but for @Int@-like ones the argument has -to be a literal. Reason: @Char@ like closures have an argument type -which is guaranteed in range. - -Because of this, we use can safely return an addressing mode. - -We don't support this optimisation when compiling into Windows DLLs yet -because they don't support cross package data references well. --} - -buildDynCon' dflags platform binder _ _cc con [arg] - | maybeIntLikeCon con - , platformOS platform /= OSMinGW32 || not (positionIndependent dflags) - , NonVoid (StgLitArg (LitNumber LitNumInt val _)) <- arg - , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer! - , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto... - = do { let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE") - val_int = fromIntegral val :: Int - offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1) - -- INTLIKE closures consist of a header and one word payload - intlike_amode = cmmLabelOffW (targetPlatform dflags) intlike_lbl offsetW - ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode - , return mkNop) } - -buildDynCon' dflags platform binder _ _cc con [arg] - | maybeCharLikeCon con - , platformOS platform /= OSMinGW32 || not (positionIndependent dflags) - , NonVoid (StgLitArg (LitChar val)) <- arg - , let val_int = ord val :: Int - , val_int <= mAX_CHARLIKE dflags - , val_int >= mIN_CHARLIKE dflags - = do { let charlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE") - offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1) - -- CHARLIKE closures consist of a header and one word payload - charlike_amode = cmmLabelOffW (targetPlatform dflags) charlike_lbl offsetW - ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode - , return mkNop) } +buildDynCon' dflags binder _ _cc con args + | Just cgInfo <- precomputedStaticConInfo_maybe dflags binder con args + -- , pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True + = return (cgInfo, return mkNop) -------- buildDynCon': the general case ----------- -buildDynCon' dflags _ binder actually_bound ccs con args +buildDynCon' dflags binder actually_bound ccs con args = do { (id_info, reg) <- rhsIdInfo binder lf_info ; return (id_info, gen_code reg) } @@ -243,6 +191,149 @@ blame_cc = use_cc -- cost-centre on which to blame the alloc (same) +{- Note [Precomputed static closures] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For Char/Int closures there are some value closures +built into the RTS. This is the case for all values in +the range mINT_INTLIKE .. mAX_INTLIKE (or CHARLIKE). +See Note [CHARLIKE and INTLIKE closures.] in the RTS code. + +Similarly zero-arity constructors have a closure +in their defining Module we can use. + +If possible we prefer to refer to those existing +closure instead of building new ones. + +This is true at compile time where we do this replacement +in this module. +But also at runtime where the GC does the same (but only for +INT/CHAR closures). + +`precomputedStaticConInfo_maybe` checks if a given constructor application +can be replaced with a reference to a existing static closure. + +If so the code will reference the existing closure when accessing +the binding. +Unless the binding is visible to other modules we also generate +no code for the binding itself. We can do this since then we can +always reference the existing closure. + +See Note [About the NameSorts] for the definition of external names. +For external bindings we must still generate a closure, +but won't use it inside this module. +This can sometimes reduce cache pressure. Since: +* If somebody uses the exported binding: + + This module will reference the existing closure. + + GC will reference the existing closure. + + The importing module will reference the built closure. +* If nobody uses the exported binding: + + This module will reference the RTS closures. + + GC references the RTS closures + +In the later case we avoided loading the built closure into the cache which +is what we optimize for here. + +Consider this example using Ints. + + module M(externalInt, foo, bar) where + + externalInt = 1 :: Int + internalInt = 1 :: Int + { -# NOINLINE foo #- } + foo = Just internalInt :: Maybe Int + bar = Just externalInt + + ==================== STG: ==================== + externalInt = I#! [1#]; + + bar = Just! [externalInt]; + + internalInt_rc = I#! [2#]; + + foo = Just! [internalInt_rc]; + +For externally visible bindings we must generate closures +since those may be referenced by their symbol `_closure` +when imported. + +`externalInt` is visible to other modules so we generate a closure: + + [section ""data" . M.externalInt_closure" { + M.externalInt_closure: + const GHC.Types.I#_con_info; + const 1; + }] + +It will be referenced inside this module via `M.externalInt_closure+1` + +`internalInt` is however a internal name. As such we generate no code for +it. References to it are replaced with references to the static closure as +we can see in the closure built for `foo`: + + [section ""data" . M.foo_closure" { + M.foo_closure: + const GHC.Maybe.Just_con_info; + const stg_INTLIKE_closure+289; // == I# 2 + const 3; + }] + +This holds for both local and top level bindings. + +We don't support this optimization when compiling into Windows DLLs yet +because they don't support cross package data references well. +-} + +-- (precomputedStaticConInfo_maybe dflags id con args) +-- returns (Just cg_id_info) +-- if there is a precomputed static closure for (con args). +-- In that case, cg_id_info addresses it. +-- See Note [Precomputed static closures] +precomputedStaticConInfo_maybe :: DynFlags -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo +precomputedStaticConInfo_maybe dflags binder con [] +-- Nullary constructors + | isNullaryRepDataCon con + = Just $ litIdInfo dflags binder (mkConLFInfo con) + (CmmLabel (mkClosureLabel (dataConName con) NoCafRefs)) +precomputedStaticConInfo_maybe dflags binder con [arg] + -- Int/Char values with existing closures in the RTS + | intClosure || charClosure + , platformOS platform /= OSMinGW32 || not (positionIndependent dflags) + , Just val <- getClosurePayload arg + , inRange val + = let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit label) + val_int = fromIntegral val :: Int + offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW dflags + 1) + -- INTLIKE/CHARLIKE closures consist of a header and one word payload + static_amode = cmmLabelOffW platform intlike_lbl offsetW + in Just $ litIdInfo dflags binder (mkConLFInfo con) static_amode + where + platform = targetPlatform dflags + intClosure = maybeIntLikeCon con + charClosure = maybeCharLikeCon con + getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val _))) = Just val + getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just $ (fromIntegral . ord $ val) + getClosurePayload _ = Nothing + -- Avoid over/underflow by comparisons at type Integer! + inRange :: Integer -> Bool + inRange val + = val >= min_static_range && val <= max_static_range + + min_static_range :: Integer + min_static_range + | intClosure = fromIntegral (mIN_INTLIKE dflags) + | charClosure = fromIntegral (mIN_CHARLIKE dflags) + | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" + max_static_range + | intClosure = fromIntegral (mAX_INTLIKE dflags) + | charClosure = fromIntegral (mAX_CHARLIKE dflags) + | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" + label + | intClosure = "stg_INTLIKE" + | charClosure = "stg_CHARLIKE" + | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" + +precomputedStaticConInfo_maybe _ _ _ _ = Nothing --------------------------------------------------------------- -- Binding constructor arguments 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 @@ -24,7 +24,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core.TyCon import GHC.Platform @@ -41,12 +41,12 @@ import GHC.Types.Id import GHC.Cmm.Graph import GHC.Types.Name -import Outputable +import GHC.Utils.Outputable import GHC.Stg.Syntax import GHC.Core.Type -import TysPrim +import GHC.Builtin.Types.Prim import GHC.Types.Unique.FM -import Util +import GHC.Utils.Misc import GHC.Types.Var.Env ------------------------------------- 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 @@ -14,7 +14,7 @@ #include "HsVersions.h" -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) import {-# SOURCE #-} GHC.StgToCmm.Bind ( cgBind ) @@ -41,15 +41,15 @@ import GHC.Driver.Session ( mAX_PTR_TAG ) import GHC.Types.ForeignCall import GHC.Types.Id -import PrimOp +import GHC.Builtin.PrimOps import GHC.Core.TyCon import GHC.Core.Type ( isUnliftedType ) import GHC.Types.RepType ( isVoidTy, countConRepArgs ) import GHC.Types.CostCentre ( CostCentreStack, currentCCS ) -import Maybes -import Util -import FastString -import Outputable +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Utils.Outputable import Control.Monad ( unless, void ) import Control.Arrow ( first ) @@ -64,7 +64,7 @@ cgExpr (StgApp fun args) = cgIdApp fun args -- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Op.ConstantFold +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = cgIdApp a [] @@ -325,8 +325,8 @@ Note [Dead-binder optimisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A case-binder, or data-constructor argument, may be marked as dead, -because we preserve occurrence-info on binders in GHC.Core.Op.Tidy (see -GHC.Core.Op.Tidy.tidyIdBndr). +because we preserve occurrence-info on binders in GHC.Core.Tidy (see +GHC.Core.Tidy.tidyIdBndr). If the binder is dead, we can sometimes eliminate a load. While CmmSink will eliminate that load, it's very easy to kill it at source @@ -337,7 +337,7 @@ This probably also was the reason for occurrence hack in Phab:D5339 to exist, perhaps because the occurrence information preserved by -'GHC.Core.Op.Tidy.tidyIdBndr' was insufficient. But now that CmmSink does the +'GHC.Core.Tidy.tidyIdBndr' was insufficient. But now that CmmSink does the job we deleted the hacks. -} @@ -405,7 +405,7 @@ {- Note [Handle seq#] ~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Op.ConstantFold. +See Note [seq# magic] in GHC.Core.Opt.ConstantFold. The special case for seq# in cgCase does this: case seq# a s of v @@ -420,7 +420,7 @@ cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Op.ConstantFold + -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold -- Use the same return convention as vanilla 'a'. cgCase (StgApp a []) bndr alt_type alts diff --git a/compiler/GHC/StgToCmm/ExtCode.hs b/compiler/GHC/StgToCmm/ExtCode.hs --- a/compiler/GHC/StgToCmm/ExtCode.hs +++ b/compiler/GHC/StgToCmm/ExtCode.hs @@ -37,7 +37,7 @@ where -import GhcPrelude +import GHC.Prelude import qualified GHC.StgToCmm.Monad as F import GHC.StgToCmm.Monad (FCode, newUnique) @@ -48,8 +48,8 @@ import GHC.Cmm.BlockId import GHC.Driver.Session -import FastString -import GHC.Types.Module +import GHC.Data.FastString +import GHC.Unit.Module import GHC.Types.Unique.FM import GHC.Types.Unique import GHC.Types.Unique.Supply @@ -61,8 +61,8 @@ = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type, -- eg, RtsLabel, ForeignLabel, CmmLabel etc. - | FunN UnitId -- ^ A function name from this package - | LabelN BlockId -- ^ A blockid of some code or data. + | FunN Unit -- ^ A function name from this package + | LabelN BlockId -- ^ A blockid of some code or data. -- | An environment of named things. type Env = UniqFM Named @@ -165,7 +165,7 @@ -- | Add add a local function to the environment. newFunctionName :: FastString -- ^ name of the function - -> UnitId -- ^ package of the current module + -> Unit -- ^ package of the current module -> ExtCode newFunctionName name pkg = addDecl name (FunN pkg) 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 @@ -18,7 +18,7 @@ emitCloseNursery, ) where -import GhcPrelude hiding( succ, (<*>) ) +import GHC.Prelude hiding( succ, (<*>) ) import GHC.Stg.Syntax import GHC.StgToCmm.Prof (storeCurCCS, ccsType) @@ -39,14 +39,14 @@ import GHC.Types.ForeignCall import GHC.Driver.Session import GHC.Platform -import Maybes -import Outputable +import GHC.Data.Maybe +import GHC.Utils.Outputable import GHC.Types.Unique.Supply import GHC.Types.Basic import GHC.Core.TyCo.Rep -import TysPrim -import Util (zipEqual) +import GHC.Builtin.Types.Prim +import GHC.Utils.Misc (zipEqual) import Control.Monad 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 @@ -22,7 +22,7 @@ emitSetDynHdr ) where -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) import GHC.Stg.Syntax import GHC.Cmm.CLabel @@ -44,11 +44,11 @@ import GHC.Types.CostCentre import GHC.Types.Id.Info( CafInfo(..), mayHaveCafRefs ) import GHC.Types.Id ( Id ) -import GHC.Types.Module +import GHC.Unit import GHC.Driver.Session import GHC.Platform -import FastString( mkFastString, fsLit ) -import Panic( sorry ) +import GHC.Data.FastString( mkFastString, fsLit ) +import GHC.Utils.Panic( sorry ) import Control.Monad (when) import Data.Maybe (isJust) diff --git a/compiler/GHC/StgToCmm/Hpc.hs b/compiler/GHC/StgToCmm/Hpc.hs --- a/compiler/GHC/StgToCmm/Hpc.hs +++ b/compiler/GHC/StgToCmm/Hpc.hs @@ -8,7 +8,7 @@ module GHC.StgToCmm.Hpc ( initHpc, mkTickBox ) where -import GhcPrelude +import GHC.Prelude import GHC.StgToCmm.Monad @@ -16,7 +16,7 @@ import GHC.Cmm.Graph import GHC.Cmm.Expr import GHC.Cmm.CLabel -import GHC.Types.Module +import GHC.Unit.Module import GHC.Cmm.Utils import GHC.StgToCmm.Utils import GHC.Driver.Types @@ -35,15 +35,15 @@ (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod) n +-- | Emit top-level tables for HPC and return code to initialise initHpc :: Module -> HpcInfo -> FCode () --- Emit top-level tables for HPC and return code to initialise initHpc _ (NoHpcInfo {}) = return () initHpc this_mod (HpcInfo tickCount _hashNo) = do dflags <- getDynFlags when (gopt Opt_Hpc dflags) $ - emitRawDataLits (mkHpcTicksLabel this_mod) - [ (CmmInt 0 W64) - | _ <- take tickCount [0 :: Int ..] - ] + emitDataLits (mkHpcTicksLabel this_mod) + [ (CmmInt 0 W64) + | _ <- take tickCount [0 :: Int ..] + ] 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 @@ -32,7 +32,7 @@ #include "HsVersions.h" -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) import GHC.StgToCmm.Closure import GHC.StgToCmm.Env @@ -54,12 +54,12 @@ import GHC.Types.Basic ( RepArity ) import GHC.Driver.Session import GHC.Platform -import GHC.Types.Module +import GHC.Unit -import Util +import GHC.Utils.Misc import Data.List -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import Control.Monad ------------------------------------------------------------------------ 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 @@ -59,7 +59,7 @@ CgInfoDownwards(..), CgState(..) -- non-abstract ) where -import GhcPrelude hiding( sequence, succ ) +import GHC.Prelude hiding( sequence, succ ) import GHC.Platform import GHC.Cmm @@ -70,16 +70,16 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout -import GHC.Types.Module +import GHC.Unit import GHC.Types.Id import GHC.Types.Var.Env -import OrdList +import GHC.Data.OrdList import GHC.Types.Basic( ConTagZ ) import GHC.Types.Unique import GHC.Types.Unique.Supply -import FastString -import Outputable -import Util +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Misc import Control.Monad import Data.List @@ -474,7 +474,7 @@ getPlatform :: FCode Platform getPlatform = targetPlatform <$> getDynFlags -getThisPackage :: FCode UnitId +getThisPackage :: FCode Unit getThisPackage = liftM thisPackage getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a 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 @@ -24,7 +24,7 @@ #include "HsVersions.h" -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) import GHC.StgToCmm.Layout import GHC.StgToCmm.Foreign @@ -42,16 +42,16 @@ import GHC.Cmm.Graph import GHC.Stg.Syntax import GHC.Cmm -import GHC.Types.Module ( rtsUnitId ) +import GHC.Unit ( rtsUnitId ) import GHC.Core.Type ( Type, tyConAppTyCon ) import GHC.Core.TyCon import GHC.Cmm.CLabel import GHC.Cmm.Utils -import PrimOp +import GHC.Builtin.PrimOps import GHC.Runtime.Heap.Layout -import FastString -import Outputable -import Util +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Misc import Data.Maybe import Data.Bits ((.&.), bit) 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 @@ -23,7 +23,7 @@ ldvEnter, ldvEnterClosure, ldvRecordCreate ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.StgToCmm.Closure @@ -38,9 +38,9 @@ import GHC.Types.CostCentre import GHC.Driver.Session -import FastString -import GHC.Types.Module as Module -import Outputable +import GHC.Data.FastString +import GHC.Unit.Module as Module +import GHC.Utils.Outputable import Control.Monad import Data.Char (ord) @@ -220,8 +220,8 @@ | otherwise = zero platform -- NB. bytesFS: we want the UTF-8 bytes here (#5559) ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) - ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS - $ Module.moduleName + ; modl <- newByteStringCLit (bytesFS $ moduleNameFS + $ moduleName $ cc_mod cc) ; loc <- newByteStringCLit $ bytesFS $ mkFastString $ showPpr dflags (costCentreSrcSpan cc) @@ -236,7 +236,7 @@ is_caf, -- StgInt is_caf zero platform -- struct _CostCentre *link ] - ; emitRawDataLits (mkCCLabel cc) lits + ; emitDataLits (mkCCLabel cc) lits } emitCostCentreStackDecl :: CostCentreStack -> FCode () @@ -253,7 +253,7 @@ -- layouts of structs containing long-longs, simply -- pad out the struct with zero words until we hit the -- size of the overall struct (which we get via DerivedConstants.h) - emitRawDataLits (mkCCSLabel ccs) (mk_lits cc) + emitDataLits (mkCCSLabel ccs) (mk_lits cc) Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) zero :: Platform -> CmmLit 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 @@ -105,7 +105,7 @@ tickySlowCall, tickySlowCallPat, ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) @@ -120,19 +120,19 @@ import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout -import GHC.Types.Module +import GHC.Unit import GHC.Types.Name import GHC.Types.Id import GHC.Types.Basic -import FastString -import Outputable -import Util +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Driver.Session -- Turgid imports for showTypeCategory -import PrelNames -import TcType +import GHC.Builtin.Names +import GHC.Tc.Utils.TcType import GHC.Core.TyCon import GHC.Core.Predicate @@ -243,7 +243,7 @@ ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args - ; emitRawDataLits ctr_lbl + ; emitDataLits ctr_lbl -- Must match layout of includes/rts/Ticky.h's StgEntCounter -- -- krc: note that all the fields are I32 now; some were I16 @@ -256,7 +256,7 @@ arg_descr_lit, zeroCLit platform, -- Entries into this thing zeroCLit platform, -- Heap allocated by this thing - zeroCLit platform -- Link to next StgEntCounter + zeroCLit platform -- Link to next StgEntCounter ] } 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 @@ -11,8 +11,7 @@ module GHC.StgToCmm.Utils ( cgLit, mkSimpleLit, - emitRawDataLits, mkRawDataLits, - emitRawRODataLits, mkRawRODataLits, + emitDataLits, emitRODataLits, emitDataCon, emitRtsCall, emitRtsCallWithResult, emitRtsCallGen, assignTemp, newTemp, @@ -38,7 +37,6 @@ cmmUntag, cmmIsTagged, addToMem, addToMemE, addToMemLblE, addToMemLbl, - mkWordCLit, mkByteStringCLit, newStringCLit, newByteStringCLit, blankWord, @@ -50,7 +48,7 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.StgToCmm.Monad @@ -60,7 +58,7 @@ import GHC.Cmm.Graph as CmmGraph import GHC.Platform.Regs import GHC.Cmm.CLabel -import GHC.Cmm.Utils hiding (mkDataLits, mkRODataLits, mkByteStringCLit) +import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.StgToCmm.CgUtils @@ -69,21 +67,20 @@ import GHC.Core.Type import GHC.Core.TyCon import GHC.Runtime.Heap.Layout -import GHC.Types.Module +import GHC.Unit import GHC.Types.Literal -import Digraph -import Util +import GHC.Data.Graph.Directed +import GHC.Utils.Misc import GHC.Types.Unique import GHC.Types.Unique.Supply (MonadUnique(..)) import GHC.Driver.Session -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Types.RepType import GHC.Types.CostCentre import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Char import Data.List @@ -184,10 +181,10 @@ -- ------------------------------------------------------------------------- -emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () +emitRtsCall :: Unit -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe -emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString +emitRtsCallWithResult :: LocalReg -> ForeignHint -> Unit -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCallWithResult res hint pkg fun args safe = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe @@ -276,40 +273,13 @@ -- ------------------------------------------------------------------------- -mkRawDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt --- Build a data-segment data block -mkRawDataLits section lbl lits - = CmmData section (CmmStaticsRaw lbl (map CmmStaticLit lits)) - -mkRawRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt --- Build a read-only data block -mkRawRODataLits lbl lits - = mkRawDataLits section lbl lits - where - section | any needsRelocation lits = Section RelocatableReadOnlyData lbl - | otherwise = Section ReadOnlyData lbl - needsRelocation (CmmLabel _) = True - needsRelocation (CmmLabelOff _ _) = True - needsRelocation _ = False - -mkByteStringCLit - :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt) --- We have to make a top-level decl for the string, --- and return a literal pointing to it -mkByteStringCLit lbl bytes - = (CmmLabel lbl, CmmData (Section sec lbl) (CmmStaticsRaw lbl [CmmString bytes])) - where - -- This can not happen for String literals (as there \NUL is replaced by - -- C0 80). However, it can happen with Addr# literals. - sec = if 0 `BS.elem` bytes then ReadOnlyData else CString - -emitRawDataLits :: CLabel -> [CmmLit] -> FCode () --- Emit a data-segment data block -emitRawDataLits lbl lits = emitDecl (mkRawDataLits (Section Data lbl) lbl lits) +-- | Emit a data-segment data block +emitDataLits :: CLabel -> [CmmLit] -> FCode () +emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits) -emitRawRODataLits :: CLabel -> [CmmLit] -> FCode () --- Emit a read-only data block -emitRawRODataLits lbl lits = emitDecl (mkRawRODataLits lbl lits) +-- | Emit a read-only data block +emitRODataLits :: CLabel -> [CmmLit] -> FCode () +emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits) emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode () emitDataCon lbl itbl ccs payload = emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload)) diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/SysTools.hs @@ -0,0 +1,474 @@ +{- +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2001-2003 +-- +-- Access to system tools: gcc, cp, rm etc +-- +----------------------------------------------------------------------------- +-} + +{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables #-} + +module GHC.SysTools ( + -- * Initialisation + initSysTools, + lazyInitLlvmConfig, + + -- * Interface to system tools + module GHC.SysTools.Tasks, + module GHC.SysTools.Info, + + linkDynLib, + + copy, + copyWithHeader, + + -- * General utilities + Option(..), + expandTopDir, + + -- * Platform-specifics + libmLinkOpts, + + -- * Mac OS X frameworks + getPkgFrameworkOpts, + getFrameworkOpts + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Settings.Utils + +import GHC.Unit +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Platform +import GHC.Driver.Session +import GHC.Driver.Ways + +import Control.Monad.Trans.Except (runExceptT) +import System.FilePath +import System.IO +import System.IO.Unsafe (unsafeInterleaveIO) +import GHC.SysTools.ExtraObj +import GHC.SysTools.Info +import GHC.SysTools.Tasks +import GHC.SysTools.BaseDir +import GHC.Settings.IO +import qualified Data.Set as Set + +{- +Note [How GHC finds toolchain utilities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC.SysTools.initSysProgs figures out exactly where all the auxiliary programs +are, and initialises mutable variables to make it easy to call them. +To do this, it makes use of definitions in Config.hs, which is a Haskell +file containing variables whose value is figured out by the build system. + +Config.hs contains two sorts of things + + cGCC, The *names* of the programs + cCPP e.g. cGCC = gcc + cUNLIT cCPP = gcc -E + etc They do *not* include paths + + + cUNLIT_DIR The *path* to the directory containing unlit, split etc + cSPLIT_DIR *relative* to the root of the build tree, + for use when running *in-place* in a build tree (only) + + +--------------------------------------------- +NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented): + +Another hair-brained scheme for simplifying the current tool location +nightmare in GHC: Simon originally suggested using another +configuration file along the lines of GCC's specs file - which is fine +except that it means adding code to read yet another configuration +file. What I didn't notice is that the current package.conf is +general enough to do this: + +Package + {name = "tools", import_dirs = [], source_dirs = [], + library_dirs = [], hs_libraries = [], extra_libraries = [], + include_dirs = [], c_includes = [], package_deps = [], + extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.], + extra_cc_opts = [], extra_ld_opts = []} + +Which would have the advantage that we get to collect together in one +place the path-specific package stuff with the path-specific tool +stuff. + End of NOTES +--------------------------------------------- + +************************************************************************ +* * +\subsection{Initialisation} +* * +************************************************************************ +-} + +-- Note [LLVM configuration] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The `llvm-targets` and `llvm-passes` files are shipped with GHC and contain +-- information needed by the LLVM backend to invoke `llc` and `opt`. +-- Specifically: +-- +-- * llvm-targets maps autoconf host triples to the corresponding LLVM +-- `data-layout` declarations. This information is extracted from clang using +-- the script in utils/llvm-targets/gen-data-layout.sh and should be updated +-- whenever we target a new version of LLVM. +-- +-- * llvm-passes maps GHC optimization levels to sets of LLVM optimization +-- flags that GHC should pass to `opt`. +-- +-- This information is contained in files rather the GHC source to allow users +-- to add new targets to GHC without having to recompile the compiler. +-- +-- Since this information is only needed by the LLVM backend we load it lazily +-- with unsafeInterleaveIO. Consequently it is important that we lazily pattern +-- match on LlvmConfig until we actually need its contents. + +lazyInitLlvmConfig :: String + -> IO LlvmConfig +lazyInitLlvmConfig top_dir + = unsafeInterleaveIO $ do -- see Note [LLVM configuration] + targets <- readAndParse "llvm-targets" mkLlvmTarget + passes <- readAndParse "llvm-passes" id + return $ LlvmConfig { llvmTargets = targets, llvmPasses = passes } + where + readAndParse name builder = + do let llvmConfigFile = top_dir name + llvmConfigStr <- readFile llvmConfigFile + case maybeReadFuzzy llvmConfigStr of + Just s -> return (fmap builder <$> s) + Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile) + + mkLlvmTarget :: (String, String, String) -> LlvmTarget + mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs) + + +initSysTools :: String -- TopDir path + -> IO Settings -- Set all the mutable variables above, holding + -- (a) the system programs + -- (b) the package-config file + -- (c) the GHC usage message +initSysTools top_dir = do + res <- runExceptT $ initSettings top_dir + case res of + Right a -> pure a + Left (SettingsError_MissingData msg) -> pgmError msg + Left (SettingsError_BadData msg) -> pgmError msg + +{- Note [Windows stack usage] + +See: #8870 (and #8834 for related info) and #12186 + +On Windows, occasionally we need to grow the stack. In order to do +this, we would normally just bump the stack pointer - but there's a +catch on Windows. + +If the stack pointer is bumped by more than a single page, then the +pages between the initial pointer and the resulting location must be +properly committed by the Windows virtual memory subsystem. This is +only needed in the event we bump by more than one page (i.e 4097 bytes +or more). + +Windows compilers solve this by emitting a call to a special function +called _chkstk, which does this committing of the pages for you. + +The reason this was causing a segfault was because due to the fact the +new code generator tends to generate larger functions, we needed more +stack space in GHC itself. In the x86 codegen, we needed approximately +~12kb of stack space in one go, which caused the process to segfault, +as the intervening pages were not committed. + +GCC can emit such a check for us automatically but only when the flag +-fstack-check is used. + +See https://gcc.gnu.org/onlinedocs/gnat_ugn/Stack-Overflow-Checking.html +for more information. + +-} + +copy :: DynFlags -> String -> FilePath -> FilePath -> IO () +copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to + +copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath + -> IO () +copyWithHeader dflags purpose maybe_header from to = do + showPass dflags purpose + + hout <- openBinaryFile to WriteMode + hin <- openBinaryFile from ReadMode + ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up + maybe (return ()) (header hout) maybe_header + hPutStr hout ls + hClose hout + hClose hin + where + -- write the header string in UTF-8. The header is something like + -- {-# LINE "foo.hs" #-} + -- and we want to make sure a Unicode filename isn't mangled. + header h str = do + hSetEncoding h utf8 + hPutStr h str + hSetBinaryMode h True + +{- +************************************************************************ +* * +\subsection{Support code} +* * +************************************************************************ +-} + +linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO () +linkDynLib dflags0 o_files dep_packages + = do + let -- This is a rather ugly hack to fix dynamically linked + -- GHC on Windows. If GHC is linked with -threaded, then + -- it links against libHSrts_thr. But if base is linked + -- against libHSrts, then both end up getting loaded, + -- and things go wrong. We therefore link the libraries + -- with the same RTS flags that we link GHC with. + dflags1 = if platformMisc_ghcThreaded $ platformMisc dflags0 + then addWay' WayThreaded dflags0 + else dflags0 + dflags2 = if platformMisc_ghcDebugged $ platformMisc dflags1 + then addWay' WayDebug dflags1 + else dflags1 + dflags = updateWays dflags2 + + verbFlags = getVerbFlags dflags + o_file = outputFile dflags + + pkgs <- getPreloadPackagesAnd dflags dep_packages + + let pkg_lib_paths = collectLibraryPaths dflags pkgs + let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths + get_pkg_lib_path_opts l + | ( osElfTarget (platformOS (targetPlatform dflags)) || + osMachOTarget (platformOS (targetPlatform dflags)) ) && + dynLibLoader dflags == SystemDependent && + WayDyn `Set.member` ways dflags + = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l] + -- See Note [-Xlinker -rpath vs -Wl,-rpath] + | otherwise = ["-L" ++ l] + + let lib_paths = libraryPaths dflags + let lib_path_opts = map ("-L"++) lib_paths + + -- We don't want to link our dynamic libs against the RTS package, + -- because the RTS lib comes in several flavours and we want to be + -- able to pick the flavour when a binary is linked. + -- On Windows we need to link the RTS import lib as Windows does + -- not allow undefined symbols. + -- The RTS library path is still added to the library search path + -- above in case the RTS is being explicitly linked in (see #3807). + let platform = targetPlatform dflags + os = platformOS platform + pkgs_no_rts = case os of + OSMinGW32 -> + pkgs + _ -> + filter ((/= rtsUnitId) . mkUnit) pkgs + let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts + in package_hs_libs ++ extra_libs ++ other_flags + + -- probably _stub.o files + -- and last temporary shared object file + let extra_ld_inputs = ldInputs dflags + + -- frameworks + pkg_framework_opts <- getPkgFrameworkOpts dflags platform + (map unitId pkgs) + let framework_opts = getFrameworkOpts dflags platform + + case os of + OSMinGW32 -> do + ------------------------------------------------------------- + -- Making a DLL + ------------------------------------------------------------- + let output_fn = case o_file of + Just s -> s + Nothing -> "HSdll.dll" + + runLink dflags ( + map Option verbFlags + ++ [ Option "-o" + , FileOption "" output_fn + , Option "-shared" + ] ++ + [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a") + | gopt Opt_SharedImplib dflags + ] + ++ map (FileOption "") o_files + + -- Permit the linker to auto link _symbol to _imp_symbol + -- This lets us link against DLLs without needing an "import library" + ++ [Option "-Wl,--enable-auto-import"] + + ++ extra_ld_inputs + ++ map Option ( + lib_path_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) + _ | os == OSDarwin -> do + ------------------------------------------------------------------- + -- Making a darwin dylib + ------------------------------------------------------------------- + -- About the options used for Darwin: + -- -dynamiclib + -- Apple's way of saying -shared + -- -undefined dynamic_lookup: + -- Without these options, we'd have to specify the correct + -- dependencies for each of the dylibs. Note that we could + -- (and should) do without this for all libraries except + -- the RTS; all we need to do is to pass the correct + -- HSfoo_dyn.dylib files to the link command. + -- This feature requires Mac OS X 10.3 or later; there is + -- a similar feature, -flat_namespace -undefined suppress, + -- which works on earlier versions, but it has other + -- disadvantages. + -- -single_module + -- Build the dynamic library as a single "module", i.e. no + -- dynamic binding nonsense when referring to symbols from + -- within the library. The NCG assumes that this option is + -- specified (on i386, at least). + -- -install_name + -- Mac OS/X stores the path where a dynamic library is (to + -- be) installed in the library itself. It's called the + -- "install name" of the library. Then any library or + -- executable that links against it before it's installed + -- will search for it in its ultimate install location. + -- By default we set the install name to the absolute path + -- at build time, but it can be overridden by the + -- -dylib-install-name option passed to ghc. Cabal does + -- this. + ------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + + instName <- case dylibInstallName dflags of + Just n -> return n + Nothing -> return $ "@rpath" `combine` (takeFileName output_fn) + runLink dflags ( + map Option verbFlags + ++ [ Option "-dynamiclib" + , Option "-o" + , FileOption "" output_fn + ] + ++ map Option o_files + ++ [ Option "-undefined", + Option "dynamic_lookup", + Option "-single_module" ] + ++ (if platformArch platform == ArchX86_64 + then [ ] + else [ Option "-Wl,-read_only_relocs,suppress" ]) + ++ [ Option "-install_name", Option instName ] + ++ map Option lib_path_opts + ++ extra_ld_inputs + ++ map Option framework_opts + ++ map Option pkg_lib_path_opts + ++ map Option pkg_link_opts + ++ map Option pkg_framework_opts + ++ [ Option "-Wl,-dead_strip_dylibs" ] + ) + _ -> do + ------------------------------------------------------------------- + -- Making a DSO + ------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + unregisterised = platformUnregisterised (targetPlatform dflags) + let bsymbolicFlag = -- we need symbolic linking to resolve + -- non-PIC intra-package-relocations for + -- performance (where symbolic linking works) + -- See Note [-Bsymbolic assumptions by GHC] + ["-Wl,-Bsymbolic" | not unregisterised] + + runLink dflags ( + map Option verbFlags + ++ libmLinkOpts + ++ [ Option "-o" + , FileOption "" output_fn + ] + ++ map Option o_files + ++ [ Option "-shared" ] + ++ map Option bsymbolicFlag + -- Set the library soname. We use -h rather than -soname as + -- Solaris 10 doesn't support the latter: + ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ] + ++ extra_ld_inputs + ++ map Option lib_path_opts + ++ map Option pkg_lib_path_opts + ++ map Option pkg_link_opts + ) + +-- | Some platforms require that we explicitly link against @libm@ if any +-- math-y things are used (which we assume to include all programs). See #14022. +libmLinkOpts :: [Option] +libmLinkOpts = +#if defined(HAVE_LIBM) + [Option "-lm"] +#else + [] +#endif + +getPkgFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String] +getPkgFrameworkOpts dflags platform dep_packages + | platformUsesFrameworks platform = do + pkg_framework_path_opts <- do + pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages + return $ map ("-F" ++) pkg_framework_paths + + pkg_framework_opts <- do + pkg_frameworks <- getPackageFrameworks dflags dep_packages + return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ] + + return (pkg_framework_path_opts ++ pkg_framework_opts) + + | otherwise = return [] + +getFrameworkOpts :: DynFlags -> Platform -> [String] +getFrameworkOpts dflags platform + | platformUsesFrameworks platform = framework_path_opts ++ framework_opts + | otherwise = [] + where + framework_paths = frameworkPaths dflags + framework_path_opts = map ("-F" ++) framework_paths + + frameworks = cmdlineFrameworks dflags + -- reverse because they're added in reverse order from the cmd line: + framework_opts = concat [ ["-framework", fw] + | fw <- reverse frameworks ] + +{- +Note [-Bsymbolic assumptions by GHC] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC has a few assumptions about interaction of relocations in NCG and linker: + +1. -Bsymbolic resolves internal references when the shared library is linked, + which is important for performance. +2. When there is a reference to data in a shared library from the main program, + the runtime linker relocates the data object into the main program using an + R_*_COPY relocation. +3. If we used -Bsymbolic, then this results in multiple copies of the data + object, because some references have already been resolved to point to the + original instance. This is bad! + +We work around [3.] for native compiled code by avoiding the generation of +R_*_COPY relocations. + +Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable +-Bsymbolic linking there. + +See related tickets: #4210, #15338 +-} diff --git a/compiler/GHC/SysTools/Ar.hs b/compiler/GHC/SysTools/Ar.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/SysTools/Ar.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-} +{- Note: [The need for Ar.hs] +Building `-staticlib` required the presence of libtool, and was a such +restricted to mach-o only. As libtool on macOS and gnu libtool are very +different, there was no simple portable way to support this. + +libtool for static archives does essentially: concatinate the input archives, +add the input objects, and create a symbol index. Using `ar` for this task +fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same +features across platforms (e.g. index prefixed retrieval of objects with +the same name.) + +As Archives are rather simple structurally, we can just build the archives +with Haskell directly and use ranlib on the final result to get the symbol +index. This should allow us to work around with the differences/abailability +of libtool across different platforms. +-} +module GHC.SysTools.Ar + (ArchiveEntry(..) + ,Archive(..) + ,afilter + + ,parseAr + + ,loadAr + ,loadObj + ,writeBSDAr + ,writeGNUAr + + ,isBSDSymdef + ,isGNUSymdef + ) + where + +import GHC.Prelude + +import Data.List (mapAccumL, isPrefixOf) +import Data.Monoid ((<>)) +import Data.Binary.Get +import Data.Binary.Put +import Control.Monad +import Control.Applicative +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L +#if !defined(mingw32_HOST_OS) +import qualified System.Posix.Files as POSIX +#endif +import System.FilePath (takeFileName) + +data ArchiveEntry = ArchiveEntry + { filename :: String -- ^ File name. + , filetime :: Int -- ^ File modification time. + , fileown :: Int -- ^ File owner. + , filegrp :: Int -- ^ File group. + , filemode :: Int -- ^ File mode. + , filesize :: Int -- ^ File size. + , filedata :: B.ByteString -- ^ File bytes. + } deriving (Eq, Show) + +newtype Archive = Archive [ArchiveEntry] + deriving (Eq, Show, Semigroup, Monoid) + +afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive +afilter f (Archive xs) = Archive (filter f xs) + +isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool +isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a) +isGNUSymdef a = "/" == (filename a) + +-- | Archives have numeric values padded with '\x20' to the right. +getPaddedInt :: B.ByteString -> Int +getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20') + +putPaddedInt :: Int -> Int -> Put +putPaddedInt padding i = putPaddedString '\x20' padding (show i) + +putPaddedString :: Char -> Int -> String -> Put +putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad) + +getBSDArchEntries :: Get [ArchiveEntry] +getBSDArchEntries = do + empty <- isEmpty + if empty then + return [] + else do + name <- getByteString 16 + when ('/' `C.elem` name && C.take 3 name /= "#1/") $ + fail "Looks like GNU Archive" + time <- getPaddedInt <$> getByteString 12 + own <- getPaddedInt <$> getByteString 6 + grp <- getPaddedInt <$> getByteString 6 + mode <- getPaddedInt <$> getByteString 8 + st_size <- getPaddedInt <$> getByteString 10 + end <- getByteString 2 + when (end /= "\x60\x0a") $ + fail ("[BSD Archive] Invalid archive header end marker for name: " ++ + C.unpack name) + off1 <- liftM fromIntegral bytesRead :: Get Int + -- BSD stores extended filenames, by writing #1/ into the + -- name field, the first @length@ bytes then represent the file name + -- thus the payload size is filesize + file name length. + name <- if C.unpack (C.take 3 name) == "#1/" then + liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name) + else + return $ C.unpack $ C.takeWhile (/= ' ') name + off2 <- liftM fromIntegral bytesRead :: Get Int + file <- getByteString (st_size - (off2 - off1)) + -- data sections are two byte aligned (see #15396) + when (odd st_size) $ + void (getByteString 1) + + rest <- getBSDArchEntries + return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest + +-- | GNU Archives feature a special '//' entry that contains the +-- extended names. Those are referred to as /, where num is the +-- offset into the '//' entry. +-- In addition, filenames are terminated with '/' in the archive. +getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry] +getGNUArchEntries extInfo = do + empty <- isEmpty + if empty + then return [] + else + do + name <- getByteString 16 + time <- getPaddedInt <$> getByteString 12 + own <- getPaddedInt <$> getByteString 6 + grp <- getPaddedInt <$> getByteString 6 + mode <- getPaddedInt <$> getByteString 8 + st_size <- getPaddedInt <$> getByteString 10 + end <- getByteString 2 + when (end /= "\x60\x0a") $ + fail ("[BSD Archive] Invalid archive header end marker for name: " ++ + C.unpack name) + file <- getByteString st_size + -- data sections are two byte aligned (see #15396) + when (odd st_size) $ + void (getByteString 1) + name <- return . C.unpack $ + if C.unpack (C.take 1 name) == "/" + then case C.takeWhile (/= ' ') name of + name@"/" -> name -- symbol table + name@"//" -> name -- extendedn file names table + name -> getExtName extInfo (read . C.unpack $ C.drop 1 name) + else C.takeWhile (/= '/') name + case name of + "/" -> getGNUArchEntries extInfo + "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file)) + _ -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo + + where + getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString + getExtName Nothing _ = error "Invalid extended filename reference." + getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info + +-- | put an Archive Entry. This assumes that the entries +-- have been preprocessed to account for the extenden file name +-- table section "//" e.g. for GNU Archives. Or that the names +-- have been move into the payload for BSD Archives. +putArchEntry :: ArchiveEntry -> PutM () +putArchEntry (ArchiveEntry name time own grp mode st_size file) = do + putPaddedString ' ' 16 name + putPaddedInt 12 time + putPaddedInt 6 own + putPaddedInt 6 grp + putPaddedInt 8 mode + putPaddedInt 10 (st_size + pad) + putByteString "\x60\x0a" + putByteString file + when (pad == 1) $ + putWord8 0x0a + where + pad = st_size `mod` 2 + +getArchMagic :: Get () +getArchMagic = do + magic <- liftM C.unpack $ getByteString 8 + if magic /= "!\n" + then fail $ "Invalid magic number " ++ show magic + else return () + +putArchMagic :: Put +putArchMagic = putByteString $ C.pack "!\n" + +getArch :: Get Archive +getArch = Archive <$> do + getArchMagic + getBSDArchEntries <|> getGNUArchEntries Nothing + +putBSDArch :: Archive -> PutM () +putBSDArch (Archive as) = do + putArchMagic + mapM_ putArchEntry (processEntries as) + + where + padStr pad size str = take size $ str <> repeat pad + nameSize name = case length name `divMod` 4 of + (n, 0) -> 4 * n + (n, _) -> 4 * (n + 1) + needExt name = length name > 16 || ' ' `elem` name + processEntry :: ArchiveEntry -> ArchiveEntry + processEntry archive@(ArchiveEntry name _ _ _ _ st_size _) + | needExt name = archive { filename = "#1/" <> show sz + , filedata = C.pack (padStr '\0' sz name) <> filedata archive + , filesize = st_size + sz } + | otherwise = archive + + where sz = nameSize name + + processEntries = map processEntry + +putGNUArch :: Archive -> PutM () +putGNUArch (Archive as) = do + putArchMagic + mapM_ putArchEntry (processEntries as) + + where + processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry) + processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _) + | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2 + , filedata = filedata extInfo <> C.pack name <> "/\n" } + , archive { filename = "/" <> show (filesize extInfo) } ) + | otherwise = ( extInfo, archive { filename = name <> "/" } ) + + processEntries :: [ArchiveEntry] -> [ArchiveEntry] + processEntries = + uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty) + +parseAr :: B.ByteString -> Archive +parseAr = runGet getArch . L.fromChunks . pure + +writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO () +writeBSDAr fp = L.writeFile fp . runPut . putBSDArch +writeGNUAr fp = L.writeFile fp . runPut . putGNUArch + +loadAr :: FilePath -> IO Archive +loadAr fp = parseAr <$> B.readFile fp + +loadObj :: FilePath -> IO ArchiveEntry +loadObj fp = do + payload <- B.readFile fp + (modt, own, grp, mode) <- fileInfo fp + return $ ArchiveEntry + (takeFileName fp) modt own grp mode + (B.length payload) payload + +-- | Take a filePath and return (mod time, own, grp, mode in decimal) +fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal) +#if defined(mingw32_HOST_OS) +-- on windows mod time, owner group and mode are zero. +fileInfo _ = pure (0,0,0,0) +#else +fileInfo fp = go <$> POSIX.getFileStatus fp + where go status = ( fromEnum $ POSIX.modificationTime status + , fromIntegral $ POSIX.fileOwner status + , fromIntegral $ POSIX.fileGroup status + , oct2dec . fromIntegral $ POSIX.fileMode status + ) + +oct2dec :: Int -> Int +oct2dec = foldl' (\a b -> a * 10 + b) 0 . reverse . dec 8 + where dec _ 0 = [] + dec b i = let (rest, last) = i `quotRem` b + in last:dec b rest + +#endif diff --git a/compiler/GHC/SysTools/Elf.hs b/compiler/GHC/SysTools/Elf.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/SysTools/Elf.hs @@ -0,0 +1,460 @@ +{- +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2015 +-- +-- ELF format tools +-- +----------------------------------------------------------------------------- +-} + +module GHC.SysTools.Elf ( + readElfSectionByName, + readElfNoteAsString, + makeElfNote + ) where + +import GHC.Prelude + +import GHC.Utils.Asm +import GHC.Utils.Exception +import GHC.Driver.Session +import GHC.Platform +import GHC.Utils.Error +import GHC.Data.Maybe (MaybeT(..),runMaybeT) +import GHC.Utils.Misc (charToC) +import GHC.Utils.Outputable (text,hcat,SDoc) + +import Control.Monad (when) +import Data.Binary.Get +import Data.Word +import Data.Char (ord) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as B8 + +{- Note [ELF specification] + ~~~~~~~~~~~~~~~~~~~~~~~~ + + ELF (Executable and Linking Format) is described in the System V Application + Binary Interface (or ABI). The latter is composed of two parts: a generic + part and a processor specific part. The generic ABI describes the parts of + the interface that remain constant across all hardware implementations of + System V. + + The latest release of the specification of the generic ABI is the version + 4.1 from March 18, 1997: + + - http://www.sco.com/developers/devspecs/gabi41.pdf + + Since 1997, snapshots of the draft for the "next" version are published: + + - http://www.sco.com/developers/gabi/ + + Quoting the notice on the website: "There is more than one instance of these + chapters to permit references to older instances to remain valid. All + modifications to these chapters are forward-compatible, so that correct use + of an older specification will not be invalidated by a newer instance. + Approximately on a yearly basis, a new instance will be saved, as it reaches + what appears to be a stable state." + + Nevertheless we will see that since 1998 it is not true for Note sections. + + Many ELF sections + ----------------- + + ELF-4.1: the normal section number fields in ELF are limited to 16 bits, + which runs out of bits when you try to cram in more sections than that. Two + fields are concerned: the one containing the number of the sections and the + one containing the index of the section that contains section's names. (The + same thing applies to the field containing the number of segments, but we + don't care about it here). + + ELF-next: to solve this, theses fields in the ELF header have an escape + value (different for each case), and the actual section number is stashed + into unused fields in the first section header. + + We support this extension as it is forward-compatible with ELF-4.1. + Moreover, GHC may generate objects with a lot of sections with the + "function-sections" feature (one section per function). + + Note sections + ------------- + + Sections with type "note" (SHT_NOTE in the specification) are used to add + arbitrary data into an ELF file. An entry in a note section is composed of a + name, a type and a value. + + ELF-4.1: "The note information in sections and program header elements holds + any number of entries, each of which is an array of 4-byte words in the + format of the target processor." Each entry has the following format: + | namesz | Word32: size of the name string (including the ending \0) + | descsz | Word32: size of the value + | type | Word32: type of the note + | name | Name string (with \0 padding to ensure 4-byte alignment) + | ... | + | desc | Value (with \0 padding to ensure 4-byte alignment) + | ... | + + ELF-next: "The note information in sections and program header elements + holds a variable amount of entries. In 64-bit objects (files with + e_ident[EI_CLASS] equal to ELFCLASS64), each entry is an array of 8-byte + words in the format of the target processor. In 32-bit objects (files with + e_ident[EI_CLASS] equal to ELFCLASS32), each entry is an array of 4-byte + words in the format of the target processor." (from 1998-2015 snapshots) + + This is not forward-compatible with ELF-4.1. In practice, for almost all + platforms namesz, descz and type fields are 4-byte words for both 32-bit and + 64-bit objects (see elf.h and readelf source code). + + The only exception in readelf source code is for IA_64 machines with OpenVMS + OS: "This OS has so many departures from the ELF standard that we test it at + many places" (comment for is_ia64_vms() in readelf.c). In this case, namesz, + descsz and type fields are 8-byte words and name and value fields are padded + to ensure 8-byte alignment. + + We don't support this platform in the following code. Reading a note section + could be done easily (by testing Machine and OS fields in the ELF header). + Writing a note section, however, requires that we generate a different + assembly code for GAS depending on the target platform and this is a little + bit more involved. + +-} + + +-- | ELF header +-- +-- The ELF header indicates the native word size (32-bit or 64-bit) and the +-- endianness of the target machine. We directly store getters for words of +-- different sizes as it is more convenient to use. We also store the word size +-- as it is useful to skip some uninteresting fields. +-- +-- Other information such as the target machine and OS are left out as we don't +-- use them yet. We could add them in the future if we ever need them. +data ElfHeader = ElfHeader + { gw16 :: Get Word16 -- ^ Get a Word16 with the correct endianness + , gw32 :: Get Word32 -- ^ Get a Word32 with the correct endianness + , gwN :: Get Word64 -- ^ Get a Word with the correct word size + -- and endianness + , wordSize :: Int -- ^ Word size in bytes + } + + +-- | Read the ELF header +readElfHeader :: DynFlags -> ByteString -> IO (Maybe ElfHeader) +readElfHeader dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do + debugTraceMsg dflags 3 $ + text ("Unable to read ELF header") + return Nothing + where + getHeader = do + magic <- getWord32be + ws <- getWord8 + endian <- getWord8 + version <- getWord8 + skip 9 -- skip OSABI, ABI version and padding + when (magic /= 0x7F454C46 || version /= 1) $ fail "Invalid ELF header" + + case (ws, endian) of + -- ELF 32, little endian + (1,1) -> return . Just $ ElfHeader + getWord16le + getWord32le + (fmap fromIntegral getWord32le) 4 + -- ELF 32, big endian + (1,2) -> return . Just $ ElfHeader + getWord16be + getWord32be + (fmap fromIntegral getWord32be) 4 + -- ELF 64, little endian + (2,1) -> return . Just $ ElfHeader + getWord16le + getWord32le + (fmap fromIntegral getWord64le) 8 + -- ELF 64, big endian + (2,2) -> return . Just $ ElfHeader + getWord16be + getWord32be + (fmap fromIntegral getWord64be) 8 + _ -> fail "Invalid ELF header" + + +------------------ +-- SECTIONS +------------------ + + +-- | Description of the section table +data SectionTable = SectionTable + { sectionTableOffset :: Word64 -- ^ offset of the table describing sections + , sectionEntrySize :: Word16 -- ^ size of an entry in the section table + , sectionEntryCount :: Word64 -- ^ number of sections + , sectionNameIndex :: Word32 -- ^ index of a special section which + -- contains section's names + } + +-- | Read the ELF section table +readElfSectionTable :: DynFlags + -> ElfHeader + -> ByteString + -> IO (Maybe SectionTable) + +readElfSectionTable dflags hdr bs = action `catchIO` \_ -> do + debugTraceMsg dflags 3 $ + text ("Unable to read ELF section table") + return Nothing + where + getSectionTable :: Get SectionTable + getSectionTable = do + skip (24 + 2*wordSize hdr) -- skip header and some other fields + secTableOffset <- gwN hdr + skip 10 + entrySize <- gw16 hdr + entryCount <- gw16 hdr + secNameIndex <- gw16 hdr + return (SectionTable secTableOffset entrySize + (fromIntegral entryCount) + (fromIntegral secNameIndex)) + + action = do + secTable <- runGetOrThrow getSectionTable bs + -- In some cases, the number of entries and the index of the section + -- containing section's names must be found in unused fields of the first + -- section entry (see Note [ELF specification]) + let + offSize0 = fromIntegral $ sectionTableOffset secTable + 8 + + 3 * fromIntegral (wordSize hdr) + offLink0 = fromIntegral $ offSize0 + fromIntegral (wordSize hdr) + + entryCount' <- if sectionEntryCount secTable /= 0 + then return (sectionEntryCount secTable) + else runGetOrThrow (gwN hdr) (LBS.drop offSize0 bs) + entryNameIndex' <- if sectionNameIndex secTable /= 0xffff + then return (sectionNameIndex secTable) + else runGetOrThrow (gw32 hdr) (LBS.drop offLink0 bs) + return (Just $ secTable + { sectionEntryCount = entryCount' + , sectionNameIndex = entryNameIndex' + }) + + +-- | A section +data Section = Section + { entryName :: ByteString -- ^ Name of the section + , entryBS :: ByteString -- ^ Content of the section + } + +-- | Read a ELF section +readElfSectionByIndex :: DynFlags + -> ElfHeader + -> SectionTable + -> Word64 + -> ByteString + -> IO (Maybe Section) + +readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do + debugTraceMsg dflags 3 $ + text ("Unable to read ELF section") + return Nothing + where + -- read an entry from the section table + getEntry = do + nameIndex <- gw32 hdr + skip (4+2*wordSize hdr) + offset <- fmap fromIntegral $ gwN hdr + size <- fmap fromIntegral $ gwN hdr + let bs' = LBS.take size (LBS.drop offset bs) + return (nameIndex,bs') + + -- read the entry with the given index in the section table + getEntryByIndex x = runGetOrThrow getEntry bs' + where + bs' = LBS.drop off bs + off = fromIntegral $ sectionTableOffset secTable + + x * fromIntegral (sectionEntrySize secTable) + + -- Get the name of a section + getEntryName nameIndex = do + let idx = fromIntegral (sectionNameIndex secTable) + (_,nameTable) <- getEntryByIndex idx + let bs' = LBS.drop nameIndex nameTable + runGetOrThrow getLazyByteStringNul bs' + + action = do + (nameIndex,bs') <- getEntryByIndex (fromIntegral i) + name <- getEntryName (fromIntegral nameIndex) + return (Just $ Section name bs') + + +-- | Find a section from its name. Return the section contents. +-- +-- We do not perform any check on the section type. +findSectionFromName :: DynFlags + -> ElfHeader + -> SectionTable + -> String + -> ByteString + -> IO (Maybe ByteString) +findSectionFromName dflags hdr secTable name bs = + rec [0..sectionEntryCount secTable - 1] + where + -- convert the required section name into a ByteString to perform + -- ByteString comparison instead of String comparison + name' = B8.pack name + + -- compare recursively each section name and return the contents of + -- the matching one, if any + rec [] = return Nothing + rec (x:xs) = do + me <- readElfSectionByIndex dflags hdr secTable x bs + case me of + Just e | entryName e == name' -> return (Just (entryBS e)) + _ -> rec xs + + +-- | Given a section name, read its contents as a ByteString. +-- +-- If the section isn't found or if there is any parsing error, we return +-- Nothing +readElfSectionByName :: DynFlags + -> ByteString + -> String + -> IO (Maybe LBS.ByteString) + +readElfSectionByName dflags bs name = action `catchIO` \_ -> do + debugTraceMsg dflags 3 $ + text ("Unable to read ELF section \"" ++ name ++ "\"") + return Nothing + where + action = runMaybeT $ do + hdr <- MaybeT $ readElfHeader dflags bs + secTable <- MaybeT $ readElfSectionTable dflags hdr bs + MaybeT $ findSectionFromName dflags hdr secTable name bs + +------------------ +-- NOTE SECTIONS +------------------ + +-- | read a Note as a ByteString +-- +-- If you try to read a note from a section which does not support the Note +-- format, the parsing is likely to fail and Nothing will be returned +readElfNoteBS :: DynFlags + -> ByteString + -> String + -> String + -> IO (Maybe LBS.ByteString) + +readElfNoteBS dflags bs sectionName noteId = action `catchIO` \_ -> do + debugTraceMsg dflags 3 $ + text ("Unable to read ELF note \"" ++ noteId ++ + "\" in section \"" ++ sectionName ++ "\"") + return Nothing + where + -- align the getter on n bytes + align n = do + m <- bytesRead + if m `mod` n == 0 + then return () + else skip 1 >> align n + + -- noteId as a bytestring + noteId' = B8.pack noteId + + -- read notes recursively until the one with a valid identifier is found + findNote hdr = do + align 4 + namesz <- gw32 hdr + descsz <- gw32 hdr + _ <- gw32 hdr -- we don't use the note type + name <- if namesz == 0 + then return LBS.empty + else getLazyByteStringNul + align 4 + desc <- if descsz == 0 + then return LBS.empty + else getLazyByteString (fromIntegral descsz) + if name == noteId' + then return $ Just desc + else findNote hdr + + + action = runMaybeT $ do + hdr <- MaybeT $ readElfHeader dflags bs + sec <- MaybeT $ readElfSectionByName dflags bs sectionName + MaybeT $ runGetOrThrow (findNote hdr) sec + +-- | read a Note as a String +-- +-- If you try to read a note from a section which does not support the Note +-- format, the parsing is likely to fail and Nothing will be returned +readElfNoteAsString :: DynFlags + -> FilePath + -> String + -> String + -> IO (Maybe String) + +readElfNoteAsString dflags path sectionName noteId = action `catchIO` \_ -> do + debugTraceMsg dflags 3 $ + text ("Unable to read ELF note \"" ++ noteId ++ + "\" in section \"" ++ sectionName ++ "\"") + return Nothing + where + action = do + bs <- LBS.readFile path + note <- readElfNoteBS dflags bs sectionName noteId + return (fmap B8.unpack note) + + +-- | Generate the GAS code to create a Note section +-- +-- Header fields for notes are 32-bit long (see Note [ELF specification]). +makeElfNote :: Platform -> String -> String -> Word32 -> String -> SDoc +makeElfNote platform sectionName noteName typ contents = hcat [ + text "\t.section ", + text sectionName, + text ",\"\",", + sectionType platform "note", + text "\n", + text "\t.balign 4\n", + + -- note name length (+ 1 for ending \0) + asWord32 (length noteName + 1), + + -- note contents size + asWord32 (length contents), + + -- note type + asWord32 typ, + + -- note name (.asciz for \0 ending string) + padding + text "\t.asciz \"", + text noteName, + text "\"\n", + text "\t.balign 4\n", + + -- note contents (.ascii to avoid ending \0) + padding + text "\t.ascii \"", + text (escape contents), + text "\"\n", + text "\t.balign 4\n"] + where + escape :: String -> String + escape = concatMap (charToC.fromIntegral.ord) + + asWord32 :: Show a => a -> SDoc + asWord32 x = hcat [ + text "\t.4byte ", + text (show x), + text "\n"] + + +------------------ +-- Helpers +------------------ + +-- | runGet in IO monad that throws an IOException on failure +runGetOrThrow :: Get a -> LBS.ByteString -> IO a +runGetOrThrow g bs = case runGetOrFail g bs of + Left _ -> fail "Error while reading file" + Right (_,_,a) -> return a diff --git a/compiler/GHC/SysTools/ExtraObj.hs b/compiler/GHC/SysTools/ExtraObj.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/SysTools/ExtraObj.hs @@ -0,0 +1,244 @@ +----------------------------------------------------------------------------- +-- +-- GHC Extra object linking code +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- + +module GHC.SysTools.ExtraObj ( + mkExtraObj, mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary, + checkLinkInfo, getLinkInfo, getCompilerInfo, + ghcLinkInfoSectionName, ghcLinkInfoNoteName, platformSupportsSavingLinkOpts, + haveRtsOptsFlags +) where + +import GHC.Utils.Asm +import GHC.Utils.Error +import GHC.Driver.Session +import GHC.Unit.State +import GHC.Platform +import GHC.Utils.Outputable as Outputable +import GHC.Types.SrcLoc ( noSrcSpan ) +import GHC.Unit +import GHC.SysTools.Elf +import GHC.Utils.Misc +import GHC.Prelude + +import Control.Monad +import Data.Maybe + +import Control.Monad.IO.Class + +import GHC.SysTools.FileCleanup +import GHC.SysTools.Tasks +import GHC.SysTools.Info + +mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath +mkExtraObj dflags extn xs + = do cFile <- newTempName dflags TFL_CurrentModule extn + oFile <- newTempName dflags TFL_GhcSession "o" + writeFile cFile xs + ccInfo <- liftIO $ getCompilerInfo dflags + runCc Nothing dflags + ([Option "-c", + FileOption "" cFile, + Option "-o", + FileOption "" oFile] + ++ if extn /= "s" + then cOpts + else asmOpts ccInfo) + return oFile + where + -- Pass a different set of options to the C compiler depending one whether + -- we're compiling C or assembler. When compiling C, we pass the usual + -- set of include directories and PIC flags. + cOpts = map Option (picCCOpts dflags) + ++ map (FileOption "-I") + (unitIncludeDirs $ unsafeGetUnitInfo dflags rtsUnitId) + + -- When compiling assembler code, we drop the usual C options, and if the + -- compiler is Clang, we add an extra argument to tell Clang to ignore + -- unused command line options. See trac #11684. + asmOpts ccInfo = + if any (ccInfo ==) [Clang, AppleClang, AppleClang51] + then [Option "-Qunused-arguments"] + else [] + +-- When linking a binary, we need to create a C main() function that +-- starts everything off. This used to be compiled statically as part +-- of the RTS, but that made it hard to change the -rtsopts setting, +-- so now we generate and compile a main() stub as part of every +-- binary and pass the -rtsopts setting directly to the RTS (#5373) +-- +-- On Windows, when making a shared library we also may need a DllMain. +-- +mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath +mkExtraObjToLinkIntoBinary dflags = do + when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do + putLogMsg dflags NoReason SevInfo noSrcSpan + (defaultUserStyle dflags) + (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ + text " Call hs_init_ghc() from your main() function to set these options.") + + mkExtraObj dflags "c" (showSDoc dflags main) + where + main + | gopt Opt_NoHsMain dflags = Outputable.empty + | otherwise + = case ghcLink dflags of + LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32 + then dllMain + else Outputable.empty + _ -> exeMain + + exeMain = vcat [ + text "#include ", + text "extern StgClosure ZCMain_main_closure;", + text "int main(int argc, char *argv[])", + char '{', + text " RtsConfig __conf = defaultRtsConfig;", + text " __conf.rts_opts_enabled = " + <> text (show (rtsOptsEnabled dflags)) <> semi, + text " __conf.rts_opts_suggestions = " + <> text (if rtsOptsSuggestions dflags + then "true" + else "false") <> semi, + text "__conf.keep_cafs = " + <> text (if gopt Opt_KeepCAFs dflags + then "true" + else "false") <> semi, + case rtsOpts dflags of + Nothing -> Outputable.empty + Just opts -> text " __conf.rts_opts= " <> + text (show opts) <> semi, + text " __conf.rts_hs_main = true;", + text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);", + char '}', + char '\n' -- final newline, to keep gcc happy + ] + + dllMain = vcat [ + text "#include ", + text "#include ", + text "#include ", + char '\n', + text "bool", + text "WINAPI", + text "DllMain ( HINSTANCE hInstance STG_UNUSED", + text " , DWORD reason STG_UNUSED", + text " , LPVOID reserved STG_UNUSED", + text " )", + text "{", + text " return true;", + text "}", + char '\n' -- final newline, to keep gcc happy + ] + +-- Write out the link info section into a new assembly file. Previously +-- this was included as inline assembly in the main.c file but this +-- is pretty fragile. gas gets upset trying to calculate relative offsets +-- that span the .note section (notably .text) when debug info is present +mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary dflags dep_packages = do + link_info <- getLinkInfo dflags dep_packages + + if (platformSupportsSavingLinkOpts (platformOS platform )) + then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info)) + else return [] + + where + platform = targetPlatform dflags + link_opts info = hcat [ + -- "link info" section (see Note [LinkInfo section]) + makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info, + + -- ALL generated assembly must have this section to disable + -- executable stacks. See also + -- compiler/nativeGen/AsmCodeGen.hs for another instance + -- where we need to do this. + if platformHasGnuNonexecStack platform + then text ".section .note.GNU-stack,\"\"," + <> sectionType platform "progbits" <> char '\n' + else Outputable.empty + ] + +-- | Return the "link info" string +-- +-- See Note [LinkInfo section] +getLinkInfo :: DynFlags -> [UnitId] -> IO String +getLinkInfo dflags dep_packages = do + package_link_opts <- getPackageLinkOpts dflags dep_packages + pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) + then getPackageFrameworks dflags dep_packages + else return [] + let extra_ld_inputs = ldInputs dflags + let + link_info = (package_link_opts, + pkg_frameworks, + rtsOpts dflags, + rtsOptsEnabled dflags, + gopt Opt_NoHsMain dflags, + map showOpt extra_ld_inputs, + getOpts dflags opt_l) + -- + return (show link_info) + +platformSupportsSavingLinkOpts :: OS -> Bool +platformSupportsSavingLinkOpts os + | os == OSSolaris2 = False -- see #5382 + | otherwise = osElfTarget os + +-- See Note [LinkInfo section] +ghcLinkInfoSectionName :: String +ghcLinkInfoSectionName = ".debug-ghc-link-info" + -- if we use the ".debug" prefix, then strip will strip it by default + +-- Identifier for the note (see Note [LinkInfo section]) +ghcLinkInfoNoteName :: String +ghcLinkInfoNoteName = "GHC link info" + +-- Returns 'False' if it was, and we can avoid linking, because the +-- previous binary was linked with "the same options". +checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool +checkLinkInfo dflags pkg_deps exe_file + | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) + -- ToDo: Windows and OS X do not use the ELF binary format, so + -- readelf does not work there. We need to find another way to do + -- this. + = return False -- conservatively we should return True, but not + -- linking in this case was the behaviour for a long + -- time so we leave it as-is. + | otherwise + = do + link_info <- getLinkInfo dflags pkg_deps + debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) + m_exe_link_info <- readElfNoteAsString dflags exe_file + ghcLinkInfoSectionName ghcLinkInfoNoteName + let sameLinkInfo = (Just link_info == m_exe_link_info) + debugTraceMsg dflags 3 $ case m_exe_link_info of + Nothing -> text "Exe link info: Not found" + Just s + | sameLinkInfo -> text ("Exe link info is the same") + | otherwise -> text ("Exe link info is different: " ++ s) + return (not sameLinkInfo) + +{- Note [LinkInfo section] + ~~~~~~~~~~~~~~~~~~~~~~~ + +The "link info" is a string representing the parameters of the link. We save +this information in the binary, and the next time we link, if nothing else has +changed, we use the link info stored in the existing binary to decide whether +to re-link or not. + +The "link info" string is stored in a ELF section called ".debug-ghc-link-info" +(see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to +not follow the specified record-based format (see #11022). + +-} + +haveRtsOptsFlags :: DynFlags -> Bool +haveRtsOptsFlags dflags = + isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of + RtsOptsSafeOnly -> False + _ -> True diff --git a/compiler/GHC/SysTools/Info.hs b/compiler/GHC/SysTools/Info.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/SysTools/Info.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Compiler information functions +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- +module GHC.SysTools.Info where + +import GHC.Utils.Exception +import GHC.Utils.Error +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Utils.Misc + +import Data.List +import Data.IORef + +import System.IO + +import GHC.Platform +import GHC.Prelude + +import GHC.SysTools.Process + +{- Note [Run-time linker info] + +See also: #5240, #6063, #10110 + +Before 'runLink', we need to be sure to get the relevant information +about the linker we're using at runtime to see if we need any extra +options. For example, GNU ld requires '--reduce-memory-overheads' and +'--hash-size=31' in order to use reasonable amounts of memory (see +trac #5240.) But this isn't supported in GNU gold. + +Generally, the linker changing from what was detected at ./configure +time has always been possible using -pgml, but on Linux it can happen +'transparently' by installing packages like binutils-gold, which +change what /usr/bin/ld actually points to. + +Clang vs GCC notes: + +For gcc, 'gcc -Wl,--version' gives a bunch of output about how to +invoke the linker before the version information string. For 'clang', +the version information for 'ld' is all that's output. For this +reason, we typically need to slurp up all of the standard error output +and look through it. + +Other notes: + +We cache the LinkerInfo inside DynFlags, since clients may link +multiple times. The definition of LinkerInfo is there to avoid a +circular dependency. + +-} + +{- Note [ELF needed shared libs] + +Some distributions change the link editor's default handling of +ELF DT_NEEDED tags to include only those shared objects that are +needed to resolve undefined symbols. For Template Haskell we need +the last temporary shared library also if it is not needed for the +currently linked temporary shared library. We specify --no-as-needed +to override the default. This flag exists in GNU ld and GNU gold. + +The flag is only needed on ELF systems. On Windows (PE) and Mac OS X +(Mach-O) the flag is not needed. + +-} + +{- Note [Windows static libGCC] + +The GCC versions being upgraded to in #10726 are configured with +dynamic linking of libgcc supported. This results in libgcc being +linked dynamically when a shared library is created. + +This introduces thus an extra dependency on GCC dll that was not +needed before by shared libraries created with GHC. This is a particular +issue on Windows because you get a non-obvious error due to this missing +dependency. This dependent dll is also not commonly on your path. + +For this reason using the static libgcc is preferred as it preserves +the same behaviour that existed before. There are however some very good +reasons to have the shared version as well as described on page 181 of +https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf : + +"There are several situations in which an application should use the + shared ‘libgcc’ instead of the static version. The most common of these + is when the application wishes to throw and catch exceptions across different + shared libraries. In that case, each of the libraries as well as the application + itself should use the shared ‘libgcc’. " + +-} + +neededLinkArgs :: LinkerInfo -> [Option] +neededLinkArgs (GnuLD o) = o +neededLinkArgs (GnuGold o) = o +neededLinkArgs (LlvmLLD o) = o +neededLinkArgs (DarwinLD o) = o +neededLinkArgs (SolarisLD o) = o +neededLinkArgs (AixLD o) = o +neededLinkArgs UnknownLD = [] + +-- Grab linker info and cache it in DynFlags. +getLinkerInfo :: DynFlags -> IO LinkerInfo +getLinkerInfo dflags = do + info <- readIORef (rtldInfo dflags) + case info of + Just v -> return v + Nothing -> do + v <- getLinkerInfo' dflags + writeIORef (rtldInfo dflags) (Just v) + return v + +-- See Note [Run-time linker info]. +getLinkerInfo' :: DynFlags -> IO LinkerInfo +getLinkerInfo' dflags = do + let platform = targetPlatform dflags + os = platformOS platform + (pgm,args0) = pgm_l dflags + args1 = map Option (getOpts dflags opt_l) + args2 = args0 ++ args1 + args3 = filter notNull (map showOpt args2) + + -- Try to grab the info from the process output. + parseLinkerInfo stdo _stde _exitc + | any ("GNU ld" `isPrefixOf`) stdo = + -- GNU ld specifically needs to use less memory. This especially + -- hurts on small object files. #5240. + -- Set DT_NEEDED for all shared libraries. #10110. + -- TODO: Investigate if these help or hurt when using split sections. + return (GnuLD $ map Option ["-Wl,--hash-size=31", + "-Wl,--reduce-memory-overheads", + -- ELF specific flag + -- see Note [ELF needed shared libs] + "-Wl,--no-as-needed"]) + + | any ("GNU gold" `isPrefixOf`) stdo = + -- GNU gold only needs --no-as-needed. #10110. + -- ELF specific flag, see Note [ELF needed shared libs] + return (GnuGold [Option "-Wl,--no-as-needed"]) + + | any ("LLD" `isPrefixOf`) stdo = + return (LlvmLLD $ map Option [ + -- see Note [ELF needed shared libs] + "-Wl,--no-as-needed"]) + + -- Unknown linker. + | otherwise = fail "invalid --version output, or linker is unsupported" + + -- Process the executable call + info <- catchIO (do + case os of + OSSolaris2 -> + -- Solaris uses its own Solaris linker. Even all + -- GNU C are recommended to configure with Solaris + -- linker instead of using GNU binutils linker. Also + -- all GCC distributed with Solaris follows this rule + -- precisely so we assume here, the Solaris linker is + -- used. + return $ SolarisLD [] + OSAIX -> + -- IBM AIX uses its own non-binutils linker as well + return $ AixLD [] + OSDarwin -> + -- Darwin has neither GNU Gold or GNU LD, but a strange linker + -- that doesn't support --version. We can just assume that's + -- what we're using. + return $ DarwinLD [] + OSMinGW32 -> + -- GHC doesn't support anything but GNU ld on Windows anyway. + -- Process creation is also fairly expensive on win32, so + -- we short-circuit here. + return $ GnuLD $ map Option + [ -- Reduce ld memory usage + "-Wl,--hash-size=31" + , "-Wl,--reduce-memory-overheads" + -- Emit gcc stack checks + -- Note [Windows stack usage] + , "-fstack-check" + -- Force static linking of libGCC + -- Note [Windows static libGCC] + , "-static-libgcc" ] + _ -> do + -- In practice, we use the compiler as the linker here. Pass + -- -Wl,--version to get linker version info. + (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm + (["-Wl,--version"] ++ args3) + c_locale_env + -- Split the output by lines to make certain kinds + -- of processing easier. In particular, 'clang' and 'gcc' + -- have slightly different outputs for '-Wl,--version', but + -- it's still easy to figure out. + parseLinkerInfo (lines stdo) (lines stde) exitc + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out linker information):" <+> + text (show err)) + errorMsg dflags $ hang (text "Warning:") 9 $ + text "Couldn't figure out linker information!" $$ + text "Make sure you're using GNU ld, GNU gold" <+> + text "or the built in OS X linker, etc." + return UnknownLD) + return info + +-- Grab compiler info and cache it in DynFlags. +getCompilerInfo :: DynFlags -> IO CompilerInfo +getCompilerInfo dflags = do + info <- readIORef (rtccInfo dflags) + case info of + Just v -> return v + Nothing -> do + v <- getCompilerInfo' dflags + writeIORef (rtccInfo dflags) (Just v) + return v + +-- See Note [Run-time linker info]. +getCompilerInfo' :: DynFlags -> IO CompilerInfo +getCompilerInfo' dflags = do + let pgm = pgm_c dflags + -- Try to grab the info from the process output. + parseCompilerInfo _stdo stde _exitc + -- Regular GCC + | any ("gcc version" `isInfixOf`) stde = + return GCC + -- Regular clang + | any ("clang version" `isInfixOf`) stde = + return Clang + -- FreeBSD clang + | any ("FreeBSD clang version" `isInfixOf`) stde = + return Clang + -- Xcode 5.1 clang + | any ("Apple LLVM version 5.1" `isPrefixOf`) stde = + return AppleClang51 + -- Xcode 5 clang + | any ("Apple LLVM version" `isPrefixOf`) stde = + return AppleClang + -- Xcode 4.1 clang + | any ("Apple clang version" `isPrefixOf`) stde = + return AppleClang + -- Unknown linker. + | otherwise = fail "invalid -v output, or compiler is unsupported" + + -- Process the executable call + info <- catchIO (do + (exitc, stdo, stde) <- + readProcessEnvWithExitCode pgm ["-v"] c_locale_env + -- Split the output by lines to make certain kinds + -- of processing easier. + parseCompilerInfo (lines stdo) (lines stde) exitc + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out C compiler information):" <+> + text (show err)) + errorMsg dflags $ hang (text "Warning:") 9 $ + text "Couldn't figure out C compiler information!" $$ + text "Make sure you're using GNU gcc, or clang" + return UnknownCC) + return info diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/SysTools/Process.hs @@ -0,0 +1,387 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- +-- Misc process handling code for SysTools +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- +module GHC.SysTools.Process where + +#include "HsVersions.h" + +import GHC.Utils.Exception +import GHC.Utils.Error +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Prelude +import GHC.Utils.Misc +import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) + +import Control.Concurrent +import Data.Char + +import System.Exit +import System.Environment +import System.FilePath +import System.IO +import System.IO.Error as IO +import System.Process + +import GHC.SysTools.FileCleanup + +-- | Enable process jobs support on Windows if it can be expected to work (e.g. +-- @process >= 1.6.8.0@). +enableProcessJobs :: CreateProcess -> CreateProcess +#if defined(MIN_VERSION_process) +enableProcessJobs opts = opts { use_process_jobs = True } +#else +enableProcessJobs opts = opts +#endif + +-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is +-- inherited from the parent process, and output to stderr is not captured. +readCreateProcessWithExitCode' + :: CreateProcess + -> IO (ExitCode, String) -- ^ stdout +readCreateProcessWithExitCode' proc = do + (_, Just outh, _, pid) <- + createProcess proc{ std_out = CreatePipe } + + -- fork off a thread to start consuming the output + output <- hGetContents outh + outMVar <- newEmptyMVar + _ <- forkIO $ evaluate (length output) >> putMVar outMVar () + + -- wait on the output + takeMVar outMVar + hClose outh + + -- wait on the process + ex <- waitForProcess pid + + return (ex, output) + +replaceVar :: (String, String) -> [(String, String)] -> [(String, String)] +replaceVar (var, value) env = + (var, value) : filter (\(var',_) -> var /= var') env + +-- | Version of @System.Process.readProcessWithExitCode@ that takes a +-- key-value tuple to insert into the environment. +readProcessEnvWithExitCode + :: String -- ^ program path + -> [String] -- ^ program args + -> (String, String) -- ^ addition to the environment + -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr) +readProcessEnvWithExitCode prog args env_update = do + current_env <- getEnvironment + readCreateProcessWithExitCode (enableProcessJobs $ proc prog args) { + env = Just (replaceVar env_update current_env) } "" + +-- Don't let gcc localize version info string, #8825 +c_locale_env :: (String, String) +c_locale_env = ("LANGUAGE", "C") + +-- If the -B option is set, add to PATH. This works around +-- a bug in gcc on Windows Vista where it can't find its auxiliary +-- binaries (see bug #1110). +getGccEnv :: [Option] -> IO (Maybe [(String,String)]) +getGccEnv opts = + if null b_dirs + then return Nothing + else do env <- getEnvironment + return (Just (mangle_paths env)) + where + (b_dirs, _) = partitionWith get_b_opt opts + + get_b_opt (Option ('-':'B':dir)) = Left dir + get_b_opt other = Right other + + -- Work around #1110 on Windows only (lest we stumble into #17266). +#if defined(mingw32_HOST_OS) + mangle_paths = map mangle_path + mangle_path (path,paths) | map toUpper path == "PATH" + = (path, '\"' : head b_dirs ++ "\";" ++ paths) + mangle_path other = other +#else + mangle_paths = id +#endif + + +----------------------------------------------------------------------------- +-- Running an external program + +runSomething :: DynFlags + -> String -- For -v message + -> String -- Command name (possibly a full path) + -- assumed already dos-ified + -> [Option] -- Arguments + -- runSomething will dos-ify them + -> IO () + +runSomething dflags phase_name pgm args = + runSomethingFiltered dflags id phase_name pgm args Nothing Nothing + +-- | Run a command, placing the arguments in an external response file. +-- +-- This command is used in order to avoid overlong command line arguments on +-- Windows. The command line arguments are first written to an external, +-- temporary response file, and then passed to the linker via @filepath. +-- response files for passing them in. See: +-- +-- https://gcc.gnu.org/wiki/Response_Files +-- https://gitlab.haskell.org/ghc/ghc/issues/10777 +runSomethingResponseFile + :: DynFlags -> (String->String) -> String -> String -> [Option] + -> Maybe [(String,String)] -> IO () + +runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env = + runSomethingWith dflags phase_name pgm args $ \real_args -> do + fp <- getResponseFile real_args + let args = ['@':fp] + r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env + return (r,()) + where + getResponseFile args = do + fp <- newTempName dflags TFL_CurrentModule "rsp" + withFile fp WriteMode $ \h -> do +#if defined(mingw32_HOST_OS) + hSetEncoding h latin1 +#else + hSetEncoding h utf8 +#endif + hPutStr h $ unlines $ map escape args + return fp + + -- Note: Response files have backslash-escaping, double quoting, and are + -- whitespace separated (some implementations use newline, others any + -- whitespace character). Therefore, escape any backslashes, newlines, and + -- double quotes in the argument, and surround the content with double + -- quotes. + -- + -- Another possibility that could be considered would be to convert + -- backslashes in the argument to forward slashes. This would generally do + -- the right thing, since backslashes in general only appear in arguments + -- as part of file paths on Windows, and the forward slash is accepted for + -- those. However, escaping is more reliable, in case somehow a backslash + -- appears in a non-file. + escape x = concat + [ "\"" + , concatMap + (\c -> + case c of + '\\' -> "\\\\" + '\n' -> "\\n" + '\"' -> "\\\"" + _ -> [c]) + x + , "\"" + ] + +runSomethingFiltered + :: DynFlags -> (String->String) -> String -> String -> [Option] + -> Maybe FilePath -> Maybe [(String,String)] -> IO () + +runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do + runSomethingWith dflags phase_name pgm args $ \real_args -> do + r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env + return (r,()) + +runSomethingWith + :: DynFlags -> String -> String -> [Option] + -> ([String] -> IO (ExitCode, a)) + -> IO a + +runSomethingWith dflags phase_name pgm args io = do + let real_args = filter notNull (map showOpt args) + cmdLine = showCommandForUser pgm real_args + traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args + +handleProc :: String -> String -> IO (ExitCode, r) -> IO r +handleProc pgm phase_name proc = do + (rc, r) <- proc `catchIO` handler + case rc of + ExitSuccess{} -> return r + ExitFailure n -> throwGhcExceptionIO ( + ProgramError ("`" ++ takeFileName pgm ++ "'" ++ + " failed in phase `" ++ phase_name ++ "'." ++ + " (Exit code: " ++ show n ++ ")")) + where + handler err = + if IO.isDoesNotExistError err + then does_not_exist + else throwGhcExceptionIO (ProgramError $ show err) + + does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm)) + + +builderMainLoop :: DynFlags -> (String -> String) -> FilePath + -> [String] -> Maybe FilePath -> Maybe [(String, String)] + -> IO ExitCode +builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do + chan <- newChan + + -- We use a mask here rather than a bracket because we want + -- to distinguish between cleaning up with and without an + -- exception. This is to avoid calling terminateProcess + -- unless an exception was raised. + let safely inner = mask $ \restore -> do + -- acquire + -- On Windows due to how exec is emulated the old process will exit and + -- a new process will be created. This means waiting for termination of + -- the parent process will get you in a race condition as the child may + -- not have finished yet. This caused #16450. To fix this use a + -- process job to track all child processes and wait for each one to + -- finish. + let procdata = + enableProcessJobs + $ (proc pgm real_args) { cwd = mb_cwd + , env = mb_env + , std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + (Just hStdIn, Just hStdOut, Just hStdErr, hProcess) <- restore $ + createProcess_ "builderMainLoop" procdata + let cleanup_handles = do + hClose hStdIn + hClose hStdOut + hClose hStdErr + r <- try $ restore $ do + hSetBuffering hStdOut LineBuffering + hSetBuffering hStdErr LineBuffering + let make_reader_proc h = forkIO $ readerProc chan h filter_fn + bracketOnError (make_reader_proc hStdOut) killThread $ \_ -> + bracketOnError (make_reader_proc hStdErr) killThread $ \_ -> + inner hProcess + case r of + -- onException + Left (SomeException e) -> do + terminateProcess hProcess + cleanup_handles + throw e + -- cleanup when there was no exception + Right s -> do + cleanup_handles + return s + safely $ \h -> do + -- we don't want to finish until 2 streams have been complete + -- (stdout and stderr) + log_loop chan (2 :: Integer) + -- after that, we wait for the process to finish and return the exit code. + waitForProcess h + where + -- t starts at the number of streams we're listening to (2) decrements each + -- time a reader process sends EOF. We are safe from looping forever if a + -- reader thread dies, because they send EOF in a finally handler. + log_loop _ 0 = return () + log_loop chan t = do + msg <- readChan chan + case msg of + BuildMsg msg -> do + putLogMsg dflags NoReason SevInfo noSrcSpan + (defaultUserStyle dflags) msg + log_loop chan t + BuildError loc msg -> do + putLogMsg dflags NoReason SevError (mkSrcSpan loc loc) + (defaultUserStyle dflags) msg + log_loop chan t + EOF -> + log_loop chan (t-1) + +readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO () +readerProc chan hdl filter_fn = + (do str <- hGetContents hdl + loop (linesPlatform (filter_fn str)) Nothing) + `finally` + writeChan chan EOF + -- ToDo: check errors more carefully + -- ToDo: in the future, the filter should be implemented as + -- a stream transformer. + where + loop [] Nothing = return () + loop [] (Just err) = writeChan chan err + loop (l:ls) in_err = + case in_err of + Just err@(BuildError srcLoc msg) + | leading_whitespace l -> do + loop ls (Just (BuildError srcLoc (msg $$ text l))) + | otherwise -> do + writeChan chan err + checkError l ls + Nothing -> do + checkError l ls + _ -> panic "readerProc/loop" + + checkError l ls + = case parseError l of + Nothing -> do + writeChan chan (BuildMsg (text l)) + loop ls Nothing + Just (file, lineNum, colNum, msg) -> do + let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum + loop ls (Just (BuildError srcLoc (text msg))) + + leading_whitespace [] = False + leading_whitespace (x:_) = isSpace x + +parseError :: String -> Maybe (String, Int, Int, String) +parseError s0 = case breakColon s0 of + Just (filename, s1) -> + case breakIntColon s1 of + Just (lineNum, s2) -> + case breakIntColon s2 of + Just (columnNum, s3) -> + Just (filename, lineNum, columnNum, s3) + Nothing -> + Just (filename, lineNum, 0, s2) + Nothing -> Nothing + Nothing -> Nothing + +-- | Break a line of an error message into a filename and the rest of the line, +-- taking care to ignore colons in Windows drive letters (as noted in #17786). +-- For instance, +-- +-- * @"hi.c: ABCD"@ is mapped to @Just ("hi.c", "ABCD")@ +-- * @"C:\hi.c: ABCD"@ is mapped to @Just ("C:\hi.c", "ABCD")@ +breakColon :: String -> Maybe (String, String) +breakColon = go [] + where + -- Don't break on Windows drive letters (e.g. @C:\@ or @C:/@) + go accum (':':'\\':rest) = go ('\\':':':accum) rest + go accum (':':'/':rest) = go ('/':':':accum) rest + go accum (':':rest) = Just (reverse accum, rest) + go accum (c:rest) = go (c:accum) rest + go _accum [] = Nothing + +breakIntColon :: String -> Maybe (Int, String) +breakIntColon xs = case break (':' ==) xs of + (ys, _:zs) + | not (null ys) && all isAscii ys && all isDigit ys -> + Just (read ys, zs) + _ -> Nothing + +data BuildMessage + = BuildMsg !SDoc + | BuildError !SrcLoc !SDoc + | EOF + +-- Divvy up text stream into lines, taking platform dependent +-- line termination into account. +linesPlatform :: String -> [String] +#if !defined(mingw32_HOST_OS) +linesPlatform ls = lines ls +#else +linesPlatform "" = [] +linesPlatform xs = + case lineBreak xs of + (as,xs1) -> as : linesPlatform xs1 + where + lineBreak "" = ("","") + lineBreak ('\r':'\n':xs) = ([],xs) + lineBreak ('\n':xs) = ([],xs) + lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs) + +#endif diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/SysTools/Tasks.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Tasks running external programs for SysTools +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- +module GHC.SysTools.Tasks where + +import GHC.Utils.Exception as Exception +import GHC.Utils.Error +import GHC.Driver.Types +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Utils.Misc + +import Data.List + +import System.IO +import System.Process +import GHC.Prelude + +import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersion, parseLlvmVersion) + +import GHC.SysTools.Process +import GHC.SysTools.Info + +{- +************************************************************************ +* * +\subsection{Running an external program} +* * +************************************************************************ +-} + +runUnlit :: DynFlags -> [Option] -> IO () +runUnlit dflags args = traceToolCommand dflags "unlit" $ do + let prog = pgm_L dflags + opts = getOpts dflags opt_L + runSomething dflags "Literate pre-processor" prog + (map Option opts ++ args) + +runCpp :: DynFlags -> [Option] -> IO () +runCpp dflags args = traceToolCommand dflags "cpp" $ do + let (p,args0) = pgm_P dflags + args1 = map Option (getOpts dflags opt_P) + args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] + ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "C pre-processor" p + (args0 ++ args1 ++ args2 ++ args) Nothing mb_env + +runPp :: DynFlags -> [Option] -> IO () +runPp dflags args = traceToolCommand dflags "pp" $ do + let prog = pgm_F dflags + opts = map Option (getOpts dflags opt_F) + runSomething dflags "Haskell pre-processor" prog (args ++ opts) + +-- | Run compiler of C-like languages and raw objects (such as gcc or clang). +runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO () +runCc mLanguage dflags args = traceToolCommand dflags "cc" $ do + let p = pgm_c dflags + args1 = map Option userOpts + args2 = languageOptions ++ args ++ args1 + -- We take care to pass -optc flags in args1 last to ensure that the + -- user can override flags passed by GHC. See #14452. + mb_env <- getGccEnv args2 + runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env + where + -- discard some harmless warnings from gcc that we can't turn off + cc_filter = unlines . doFilter . lines + + {- + gcc gives warnings in chunks like so: + In file included from /foo/bar/baz.h:11, + from /foo/bar/baz2.h:22, + from wibble.c:33: + /foo/flibble:14: global register variable ... + /foo/flibble:15: warning: call-clobbered r... + We break it up into its chunks, remove any call-clobbered register + warnings from each chunk, and then delete any chunks that we have + emptied of warnings. + -} + doFilter = unChunkWarnings . filterWarnings . chunkWarnings [] + -- We can't assume that the output will start with an "In file inc..." + -- line, so we start off expecting a list of warnings rather than a + -- location stack. + chunkWarnings :: [String] -- The location stack to use for the next + -- list of warnings + -> [String] -- The remaining lines to look at + -> [([String], [String])] + chunkWarnings loc_stack [] = [(loc_stack, [])] + chunkWarnings loc_stack xs + = case break loc_stack_start xs of + (warnings, lss:xs') -> + case span loc_start_continuation xs' of + (lsc, xs'') -> + (loc_stack, warnings) : chunkWarnings (lss : lsc) xs'' + _ -> [(loc_stack, xs)] + + filterWarnings :: [([String], [String])] -> [([String], [String])] + filterWarnings [] = [] + -- If the warnings are already empty then we are probably doing + -- something wrong, so don't delete anything + filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs + filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of + [] -> filterWarnings zs + ys' -> (xs, ys') : filterWarnings zs + + unChunkWarnings :: [([String], [String])] -> [String] + unChunkWarnings [] = [] + unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs + + loc_stack_start s = "In file included from " `isPrefixOf` s + loc_start_continuation s = " from " `isPrefixOf` s + wantedWarning w + | "warning: call-clobbered register used" `isContainedIn` w = False + | otherwise = True + + -- force the C compiler to interpret this file as C when + -- compiling .hc files, by adding the -x c option. + -- Also useful for plain .c files, just in case GHC saw a + -- -x c option. + (languageOptions, userOpts) = case mLanguage of + Nothing -> ([], userOpts_c) + Just language -> ([Option "-x", Option languageName], opts) + where + (languageName, opts) = case language of + LangC -> ("c", userOpts_c) + LangCxx -> ("c++", userOpts_cxx) + LangObjc -> ("objective-c", userOpts_c) + LangObjcxx -> ("objective-c++", userOpts_cxx) + LangAsm -> ("assembler", []) + RawObject -> ("c", []) -- claim C for lack of a better idea + userOpts_c = getOpts dflags opt_c + userOpts_cxx = getOpts dflags opt_cxx + +isContainedIn :: String -> String -> Bool +xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) + +-- | Run the linker with some arguments and return the output +askLd :: DynFlags -> [Option] -> IO String +askLd dflags args = traceToolCommand dflags "linker" $ do + let (p,args0) = pgm_l dflags + args1 = map Option (getOpts dflags opt_l) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingWith dflags "gcc" p args2 $ \real_args -> + readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } + +runAs :: DynFlags -> [Option] -> IO () +runAs dflags args = traceToolCommand dflags "as" $ do + let (p,args0) = pgm_a dflags + args1 = map Option (getOpts dflags opt_a) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "Assembler" p args2 Nothing mb_env + +-- | Run the LLVM Optimiser +runLlvmOpt :: DynFlags -> [Option] -> IO () +runLlvmOpt dflags args = traceToolCommand dflags "opt" $ do + let (p,args0) = pgm_lo dflags + args1 = map Option (getOpts dflags opt_lo) + -- We take care to pass -optlo flags (e.g. args0) last to ensure that the + -- user can override flags passed by GHC. See #14821. + runSomething dflags "LLVM Optimiser" p (args1 ++ args ++ args0) + +-- | Run the LLVM Compiler +runLlvmLlc :: DynFlags -> [Option] -> IO () +runLlvmLlc dflags args = traceToolCommand dflags "llc" $ do + let (p,args0) = pgm_lc dflags + args1 = map Option (getOpts dflags opt_lc) + runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args) + +-- | Run the clang compiler (used as an assembler for the LLVM +-- backend on OS X as LLVM doesn't support the OS X system +-- assembler) +runClang :: DynFlags -> [Option] -> IO () +runClang dflags args = traceToolCommand dflags "clang" $ do + let (clang,_) = pgm_lcc dflags + -- be careful what options we call clang with + -- see #5903 and #7617 for bugs caused by this. + (_,args0) = pgm_a dflags + args1 = map Option (getOpts dflags opt_a) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + Exception.catch (do + runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env + ) + (\(err :: SomeException) -> do + errorMsg dflags $ + text ("Error running clang! you need clang installed to use the" ++ + " LLVM backend") $+$ + text "(or GHC tried to execute clang incorrectly)" + throwIO err + ) + +-- | Figure out which version of LLVM we are running this session +figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion) +figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do + let (pgm,opts) = pgm_lc dflags + args = filter notNull (map showOpt opts) + -- we grab the args even though they should be useless just in + -- case the user is using a customised 'llc' that requires some + -- of the options they've specified. llc doesn't care what other + -- options are specified when '-version' is used. + args' = args ++ ["-version"] + catchIO (do + (pin, pout, perr, _) <- runInteractiveProcess pgm args' + Nothing Nothing + {- > llc -version + LLVM (http://llvm.org/): + LLVM version 3.5.2 + ... + -} + hSetBinaryMode pout False + _ <- hGetLine pout + vline <- hGetLine pout + let mb_ver = parseLlvmVersion vline + hClose pin + hClose pout + hClose perr + return mb_ver + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out LLVM version):" <+> + text (show err)) + errorMsg dflags $ vcat + [ text "Warning:", nest 9 $ + text "Couldn't figure out LLVM version!" $$ + text ("Make sure you have installed LLVM " ++ + llvmVersionStr supportedLlvmVersion) ] + return Nothing) + + +runLink :: DynFlags -> [Option] -> IO () +runLink dflags args = traceToolCommand dflags "linker" $ do + -- See Note [Run-time linker info] + -- + -- `-optl` args come at the end, so that later `-l` options + -- given there manually can fill in symbols needed by + -- Haskell libraries coming in via `args`. + linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags + let (p,args0) = pgm_l dflags + optl_args = map Option (getOpts dflags opt_l) + args2 = args0 ++ linkargs ++ args ++ optl_args + mb_env <- getGccEnv args2 + runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env + where + ld_filter = case (platformOS (targetPlatform dflags)) of + OSSolaris2 -> sunos_ld_filter + _ -> id +{- + SunOS/Solaris ld emits harmless warning messages about unresolved + symbols in case of compiling into shared library when we do not + link against all the required libs. That is the case of GHC which + does not link against RTS library explicitly in order to be able to + choose the library later based on binary application linking + parameters. The warnings look like: + +Undefined first referenced + symbol in file +stg_ap_n_fast ./T2386_Lib.o +stg_upd_frame_info ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o +newCAF ./T2386_Lib.o +stg_bh_upd_frame_info ./T2386_Lib.o +stg_ap_ppp_fast ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o +stg_ap_p_fast ./T2386_Lib.o +stg_ap_pp_fast ./T2386_Lib.o +ld: warning: symbol referencing errors + + this is actually coming from T2386 testcase. The emitting of those + warnings is also a reason why so many TH testcases fail on Solaris. + + Following filter code is SunOS/Solaris linker specific and should + filter out only linker warnings. Please note that the logic is a + little bit more complex due to the simple reason that we need to preserve + any other linker emitted messages. If there are any. Simply speaking + if we see "Undefined" and later "ld: warning:..." then we omit all + text between (including) the marks. Otherwise we copy the whole output. +-} + sunos_ld_filter :: String -> String + sunos_ld_filter = unlines . sunos_ld_filter' . lines + sunos_ld_filter' x = if (undefined_found x && ld_warning_found x) + then (ld_prefix x) ++ (ld_postfix x) + else x + breakStartsWith x y = break (isPrefixOf x) y + ld_prefix = fst . breakStartsWith "Undefined" + undefined_found = not . null . snd . breakStartsWith "Undefined" + ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors" + ld_postfix = tail . snd . ld_warn_break + ld_warning_found = not . null . snd . ld_warn_break + + +runLibtool :: DynFlags -> [Option] -> IO () +runLibtool dflags args = traceToolCommand dflags "libtool" $ do + linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags + let args1 = map Option (getOpts dflags opt_l) + args2 = [Option "-static"] ++ args1 ++ args ++ linkargs + libtool = pgm_libtool dflags + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "Linker" libtool args2 Nothing mb_env + +runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO () +runAr dflags cwd args = traceToolCommand dflags "ar" $ do + let ar = pgm_ar dflags + runSomethingFiltered dflags id "Ar" ar args cwd Nothing + +askAr :: DynFlags -> Maybe FilePath -> [Option] -> IO String +askAr dflags mb_cwd args = traceToolCommand dflags "ar" $ do + let ar = pgm_ar dflags + runSomethingWith dflags "Ar" ar args $ \real_args -> + readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd } + +runRanlib :: DynFlags -> [Option] -> IO () +runRanlib dflags args = traceToolCommand dflags "ranlib" $ do + let ranlib = pgm_ranlib dflags + runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing + +runMkDLL :: DynFlags -> [Option] -> IO () +runMkDLL dflags args = traceToolCommand dflags "mkdll" $ do + let (p,args0) = pgm_dll dflags + args1 = args0 ++ args + mb_env <- getGccEnv (args0++args) + runSomethingFiltered dflags id "Make DLL" p args1 Nothing mb_env + +runWindres :: DynFlags -> [Option] -> IO () +runWindres dflags args = traceToolCommand dflags "windres" $ do + let cc = pgm_c dflags + cc_args = map Option (sOpt_c (settings dflags)) + windres = pgm_windres dflags + opts = map Option (getOpts dflags opt_windres) + quote x = "\"" ++ x ++ "\"" + args' = -- If windres.exe and gcc.exe are in a directory containing + -- spaces then windres fails to run gcc. We therefore need + -- to tell it what command to use... + Option ("--preprocessor=" ++ + unwords (map quote (cc : + map showOpt opts ++ + ["-E", "-xc", "-DRC_INVOKED"]))) + -- ...but if we do that then if windres calls popen then + -- it can't understand the quoting, so we have to use + -- --use-temp-file so that it interprets it correctly. + -- See #1828. + : Option "--use-temp-file" + : args + mb_env <- getGccEnv cc_args + runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env + +touch :: DynFlags -> String -> String -> IO () +touch dflags purpose arg = traceToolCommand dflags "touch" $ + runSomething dflags purpose (pgm_T dflags) [FileOption "" arg] + +-- * Tracing utility + +-- | Record in the eventlog when the given tool command starts +-- and finishes, prepending the given 'String' with +-- \"systool:\", to easily be able to collect and process +-- all the systool events. +-- +-- For those events to show up in the eventlog, you need +-- to run GHC with @-v2@ or @-ddump-timings@. +traceToolCommand :: DynFlags -> String -> IO a -> IO a +traceToolCommand dflags tool = withTiming + dflags (text $ "systool:" ++ tool) (const ()) diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Deriv.hs @@ -0,0 +1,2298 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Handles @deriving@ clauses on @data@ declarations. +module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Driver.Session + +import GHC.Tc.Utils.Monad +import GHC.Tc.Instance.Family +import GHC.Tc.Types.Origin +import GHC.Core.Predicate +import GHC.Tc.Deriv.Infer +import GHC.Tc.Deriv.Utils +import GHC.Tc.Validity( allDistinctTyVars ) +import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault ) +import GHC.Tc.Utils.Env +import GHC.Tc.Deriv.Generate +import GHC.Tc.Validity( checkValidInstHead ) +import GHC.Core.InstEnv +import GHC.Tc.Utils.Instantiate +import GHC.Core.FamInstEnv +import GHC.Tc.Gen.HsType +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr ( pprTyVars ) + +import GHC.Rename.Names ( extendGlobalRdrEnvRn ) +import GHC.Rename.Bind +import GHC.Rename.Env +import GHC.Rename.Module ( addTcgDUs ) +import GHC.Types.Avail + +import GHC.Core.Unify( tcUnifyTy ) +import GHC.Core.Class +import GHC.Core.Type +import GHC.Utils.Error +import GHC.Core.DataCon +import GHC.Data.Maybe +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Name.Set as NameSet +import GHC.Core.TyCon +import GHC.Tc.Utils.TcType +import GHC.Types.Var as Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Builtin.Names +import GHC.Types.SrcLoc +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs) +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Data.List (partition, find) + +{- +************************************************************************ +* * + Overview +* * +************************************************************************ + +Overall plan +~~~~~~~~~~~~ +1. Convert the decls (i.e. data/newtype deriving clauses, + plus standalone deriving) to [EarlyDerivSpec] + +2. Infer the missing contexts for the InferTheta's + +3. Add the derived bindings, generating InstInfos +-} + +data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin]) + | GivenTheta (DerivSpec ThetaType) + -- InferTheta ds => the context for the instance should be inferred + -- In this case ds_theta is the list of all the sets of + -- constraints needed, such as (Eq [a], Eq a), together with a + -- suitable CtLoc to get good error messages. + -- The inference process is to reduce this to a + -- simpler form (e.g. Eq a) + -- + -- GivenTheta ds => the exact context for the instance is supplied + -- by the programmer; it is ds_theta + -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer + +splitEarlyDerivSpec :: [EarlyDerivSpec] + -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType]) +splitEarlyDerivSpec [] = ([],[]) +splitEarlyDerivSpec (InferTheta spec : specs) = + case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs) +splitEarlyDerivSpec (GivenTheta spec : specs) = + case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs) + +instance Outputable EarlyDerivSpec where + ppr (InferTheta spec) = ppr spec <+> text "(Infer)" + ppr (GivenTheta spec) = ppr spec <+> text "(Given)" + +{- +Note [Data decl contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data (RealFloat a) => Complex a = !a :+ !a deriving( Read ) + +We will need an instance decl like: + + instance (Read a, RealFloat a) => Read (Complex a) where + ... + +The RealFloat in the context is because the read method for Complex is bound +to construct a Complex, and doing that requires that the argument type is +in RealFloat. + +But this ain't true for Show, Eq, Ord, etc, since they don't construct +a Complex; they only take them apart. + +Our approach: identify the offending classes, and add the data type +context to the instance decl. The "offending classes" are + + Read, Enum? + +FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that +pattern matching against a constructor from a data type with a context +gives rise to the constraints for that context -- or at least the thinned +version. So now all classes are "offending". + +Note [Newtype deriving] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + class C a b + instance C [a] Char + newtype T = T Char deriving( C [a] ) + +Notice the free 'a' in the deriving. We have to fill this out to + newtype T = T Char deriving( forall a. C [a] ) + +And then translate it to: + instance C [a] Char => C [a] T where ... + +Note [Unused constructors and deriving clauses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #3221. Consider + data T = T1 | T2 deriving( Show ) +Are T1 and T2 unused? Well, no: the deriving clause expands to mention +both of them. So we gather defs/uses from deriving just like anything else. + +-} + +-- | Stuff needed to process a datatype's `deriving` clauses +data DerivInfo = DerivInfo { di_rep_tc :: TyCon + -- ^ The data tycon for normal datatypes, + -- or the *representation* tycon for data families + , di_scoped_tvs :: ![(Name,TyVar)] + -- ^ Variables that scope over the deriving clause. + , di_clauses :: [LHsDerivingClause GhcRn] + , di_ctxt :: SDoc -- ^ error context + } + +{- + +************************************************************************ +* * +Top-level function for \tr{derivings} +* * +************************************************************************ +-} + +tcDeriving :: [DerivInfo] -- All `deriving` clauses + -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations + -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn) +tcDeriving deriv_infos deriv_decls + = recoverM (do { g <- getGblEnv + ; return (g, emptyBag, emptyValBindsOut)}) $ + do { -- Fish the "deriving"-related information out of the GHC.Tc.Utils.Env + -- And make the necessary "equations". + early_specs <- makeDerivSpecs deriv_infos deriv_decls + ; traceTc "tcDeriving" (ppr early_specs) + + ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs + ; insts1 <- mapM genInst given_specs + ; insts2 <- mapM genInst infer_specs + + ; dflags <- getDynFlags + + ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2) + ; loc <- getSrcSpanM + ; let (binds, famInsts) = genAuxBinds dflags loc + (unionManyBags deriv_stuff) + + ; let mk_inst_infos1 = map fstOf3 insts1 + ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs + + -- We must put all the derived type family instances (from both + -- infer_specs and given_specs) in the local instance environment + -- before proceeding, or else simplifyInstanceContexts might + -- get stuck if it has to reason about any of those family instances. + -- See Note [Staging of tcDeriving] + ; tcExtendLocalFamInstEnv (bagToList famInsts) $ + -- NB: only call tcExtendLocalFamInstEnv once, as it performs + -- validity checking for all of the family instances you give it. + -- If the family instances have errors, calling it twice will result + -- in duplicate error messages! + + do { + -- the stand-alone derived instances (@inst_infos1@) are used when + -- inferring the contexts for "deriving" clauses' instances + -- (@infer_specs@) + ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $ + simplifyInstanceContexts infer_specs + + ; let mk_inst_infos2 = map fstOf3 insts2 + ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs + ; let inst_infos = inst_infos1 ++ inst_infos2 + + ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds + + ; unless (isEmptyBag inst_info) $ + liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + FormatHaskell + (ddump_deriving inst_info rn_binds famInsts)) + + ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) + getGblEnv + ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs) + ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } } + where + ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn + -> Bag FamInst -- ^ Rep type family instances + -> SDoc + ddump_deriving inst_infos extra_binds repFamInsts + = hang (text "Derived class instances:") + 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) + $$ ppr extra_binds) + $$ hangP "Derived type family instances:" + (vcat (map pprRepTy (bagToList repFamInsts))) + + hangP s x = text "" $$ hang (ptext (sLit s)) 2 x + + -- Apply the suspended computations given by genInst calls. + -- See Note [Staging of tcDeriving] + apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)] + -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs] + apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds)) + +-- Prints the representable type family instance +pprRepTy :: FamInst -> SDoc +pprRepTy fi@(FamInst { fi_tys = lhs }) + = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+> + equals <+> ppr rhs + where rhs = famInstRHS fi + +renameDeriv :: [InstInfo GhcPs] + -> Bag (LHsBind GhcPs, LSig GhcPs) + -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses) +renameDeriv inst_infos bagBinds + = discardWarnings $ + -- Discard warnings about unused bindings etc + setXOptM LangExt.EmptyCase $ + -- Derived decls (for empty types) can have + -- case x of {} + setXOptM LangExt.ScopedTypeVariables $ + setXOptM LangExt.KindSignatures $ + -- Derived decls (for newtype-deriving) can use ScopedTypeVariables & + -- KindSignatures + setXOptM LangExt.TypeApplications $ + -- GND/DerivingVia uses TypeApplications in generated code + -- (See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate) + unsetXOptM LangExt.RebindableSyntax $ + -- See Note [Avoid RebindableSyntax when deriving] + setXOptM LangExt.TemplateHaskellQuotes $ + -- DeriveLift makes uses of quotes + do { + -- Bring the extra deriving stuff into scope + -- before renaming the instances themselves + ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) + ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds + ; let aux_val_binds = ValBinds noExtField aux_binds (bagToList aux_sigs) + ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds + ; let bndrs = collectHsValBinders rn_aux_lhs + ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ; + ; setEnvs envs $ + do { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs + ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos + ; return (listToBag rn_inst_infos, rn_aux, + dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } } + + where + rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars) + rn_inst_info + inst_info@(InstInfo { iSpec = inst + , iBinds = InstBindings + { ib_binds = binds + , ib_tyvars = tyvars + , ib_pragmas = sigs + , ib_extensions = exts -- Only for type-checking + , ib_derived = sa } }) + = do { (rn_binds, rn_sigs, fvs) <- rnMethodBinds False (is_cls_nm inst) + tyvars binds sigs + ; let binds' = InstBindings { ib_binds = rn_binds + , ib_tyvars = tyvars + , ib_pragmas = rn_sigs + , ib_extensions = exts + , ib_derived = sa } + ; return (inst_info { iBinds = binds' }, fvs) } + +{- +Note [Staging of tcDeriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's a tricky corner case for deriving (adapted from #2721): + + class C a where + type T a + foo :: a -> T a + + instance C Int where + type T Int = Int + foo = id + + newtype N = N Int deriving C + +This will produce an instance something like this: + + instance C N where + type T N = T Int + foo = coerce (foo :: Int -> T Int) :: N -> T N + +We must be careful in order to typecheck this code. When determining the +context for the instance (in simplifyInstanceContexts), we need to determine +that T N and T Int have the same representation, but to do that, the T N +instance must be in the local family instance environment. Otherwise, GHC +would be unable to conclude that T Int is representationally equivalent to +T Int, and simplifyInstanceContexts would get stuck. + +Previously, tcDeriving would defer adding any derived type family instances to +the instance environment until the very end, which meant that +simplifyInstanceContexts would get called without all the type family instances +it needed in the environment in order to properly simplify instance like +the C N instance above. + +To avoid this scenario, we carefully structure the order of events in +tcDeriving. We first call genInst on the standalone derived instance specs and +the instance specs obtained from deriving clauses. Note that the return type of +genInst is a triple: + + TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name) + +The type family instances are in the BagDerivStuff. The first field of the +triple is a suspended computation which, given an instance context, produces +the rest of the instance. The fact that it is suspended is important, because +right now, we don't have ThetaTypes for the instances that use deriving clauses +(only the standalone-derived ones). + +Now we can collect the type family instances and extend the local instance +environment. At this point, it is safe to run simplifyInstanceContexts on the +deriving-clause instance specs, which gives us the ThetaTypes for the +deriving-clause instances. Now we can feed all the ThetaTypes to the +suspended computations and obtain our InstInfos, at which point +tcDeriving is done. + +An alternative design would be to split up genInst so that the +family instances are generated separately from the InstInfos. But this would +require carving up a lot of the GHC deriving internals to accommodate the +change. On the other hand, we can keep all of the InstInfo and type family +instance logic together in genInst simply by converting genInst to +continuation-returning style, so we opt for that route. + +Note [Why we don't pass rep_tc into deriveTyData] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Down in the bowels of mk_deriv_inst_tys_maybe, we need to convert the fam_tc +back into the rep_tc by means of a lookup. And yet we have the rep_tc right +here! Why look it up again? Answer: it's just easier this way. +We drop some number of arguments from the end of the datatype definition +in deriveTyData. The arguments are dropped from the fam_tc. +This action may drop a *different* number of arguments +passed to the rep_tc, depending on how many free variables, etc., the +dropped patterns have. + +Also, this technique carries over the kind substitution from deriveTyData +nicely. + +Note [Avoid RebindableSyntax when deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RebindableSyntax extension interacts awkwardly with the derivation of +any stock class whose methods require the use of string literals. The Show +class is a simple example (see #12688): + + {-# LANGUAGE RebindableSyntax, OverloadedStrings #-} + newtype Text = Text String + fromString :: String -> Text + fromString = Text + + data Foo = Foo deriving Show + +This will generate code to the effect of: + + instance Show Foo where + showsPrec _ Foo = showString "Foo" + +But because RebindableSyntax and OverloadedStrings are enabled, the "Foo" +string literal is now of type Text, not String, which showString doesn't +accept! This causes the generated Show instance to fail to typecheck. + +To avoid this kind of scenario, we simply turn off RebindableSyntax entirely +in derived code. + +************************************************************************ +* * + From HsSyn to DerivSpec +* * +************************************************************************ + +@makeDerivSpecs@ fishes around to find the info about needed derived instances. +-} + +makeDerivSpecs :: [DerivInfo] + -> [LDerivDecl GhcRn] + -> TcM [EarlyDerivSpec] +makeDerivSpecs deriv_infos deriv_decls + = do { eqns1 <- sequenceA + [ deriveClause rep_tc scoped_tvs dcs preds err_ctxt + | DerivInfo { di_rep_tc = rep_tc + , di_scoped_tvs = scoped_tvs + , di_clauses = clauses + , di_ctxt = err_ctxt } <- deriv_infos + , L _ (HsDerivingClause { deriv_clause_strategy = dcs + , deriv_clause_tys = L _ preds }) + <- clauses + ] + ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls + ; return $ concat eqns1 ++ catMaybes eqns2 } + +------------------------------------------------------------------ +-- | Process the derived classes in a single @deriving@ clause. +deriveClause :: TyCon + -> [(Name, TcTyVar)] -- Scoped type variables taken from tcTyConScopedTyVars + -- See Note [Scoped tyvars in a TcTyCon] in types/TyCon + -> Maybe (LDerivStrategy GhcRn) + -> [LHsSigType GhcRn] -> SDoc + -> TcM [EarlyDerivSpec] +deriveClause rep_tc scoped_tvs mb_lderiv_strat deriv_preds err_ctxt + = addErrCtxt err_ctxt $ do + traceTc "deriveClause" $ vcat + [ text "tvs" <+> ppr tvs + , text "scoped_tvs" <+> ppr scoped_tvs + , text "tc" <+> ppr tc + , text "tys" <+> ppr tys + , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat ] + tcExtendNameTyVarEnv scoped_tvs $ do + (mb_lderiv_strat', via_tvs) <- tcDerivStrategy mb_lderiv_strat + tcExtendTyVarEnv via_tvs $ + -- Moreover, when using DerivingVia one can bind type variables in + -- the `via` type as well, so these type variables must also be + -- brought into scope. + mapMaybeM (derivePred tc tys mb_lderiv_strat' via_tvs) deriv_preds + -- After typechecking the `via` type once, we then typecheck all + -- of the classes associated with that `via` type in the + -- `deriving` clause. + -- See also Note [Don't typecheck too much in DerivingVia]. + where + tvs = tyConTyVars rep_tc + (tc, tys) = case tyConFamInstSig_maybe rep_tc of + -- data family: + Just (fam_tc, pats, _) -> (fam_tc, pats) + -- NB: deriveTyData wants the *user-specified* + -- name. See Note [Why we don't pass rep_tc into deriveTyData] + + _ -> (rep_tc, mkTyVarTys tvs) -- datatype + +-- | Process a single predicate in a @deriving@ clause. +-- +-- This returns a 'Maybe' because the user might try to derive 'Typeable', +-- which is a no-op nowadays. +derivePred :: TyCon -> [Type] -> Maybe (LDerivStrategy GhcTc) -> [TyVar] + -> LHsSigType GhcRn -> TcM (Maybe EarlyDerivSpec) +derivePred tc tys mb_lderiv_strat via_tvs deriv_pred = + -- We carefully set up uses of recoverM to minimize error message + -- cascades. See Note [Recovering from failures in deriving clauses]. + recoverM (pure Nothing) $ + setSrcSpan (getLoc (hsSigType deriv_pred)) $ do + traceTc "derivePred" $ vcat + [ text "tc" <+> ppr tc + , text "tys" <+> ppr tys + , text "deriv_pred" <+> ppr deriv_pred + , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat + , text "via_tvs" <+> ppr via_tvs ] + (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred + when (cls_arg_kinds `lengthIsNot` 1) $ + failWithTc (nonUnaryErr deriv_pred) + let [cls_arg_kind] = cls_arg_kinds + mb_deriv_strat = fmap unLoc mb_lderiv_strat + if (className cls == typeableClassName) + then do warnUselessTypeable + return Nothing + else let deriv_tvs = via_tvs ++ cls_tvs in + Just <$> deriveTyData tc tys mb_deriv_strat + deriv_tvs cls cls_tys cls_arg_kind + +{- +Note [Don't typecheck too much in DerivingVia] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example: + + data D = ... + deriving (A1 t, ..., A20 t) via T t + +GHC used to be engineered such that it would typecheck the `deriving` +clause like so: + +1. Take the first class in the clause (`A1`). +2. Typecheck the `via` type (`T t`) and bring its bound type variables + into scope (`t`). +3. Typecheck the class (`A1`). +4. Move on to the next class (`A2`) and repeat the process until all + classes have been typechecked. + +This algorithm gets the job done most of the time, but it has two notable +flaws. One flaw is that it is wasteful: it requires that `T t` be typechecked +20 different times, once for each class in the `deriving` clause. This is +unnecessary because we only need to typecheck `T t` once in order to get +access to its bound type variable. + +The other issue with this algorithm arises when there are no classes in the +`deriving` clause, like in the following example: + + data D2 = ... + deriving () via Maybe Maybe + +Because there are no classes, the algorithm above will simply do nothing. +As a consequence, GHC will completely miss the fact that `Maybe Maybe` +is ill-kinded nonsense (#16923). + +To address both of these problems, GHC now uses this algorithm instead: + +1. Typecheck the `via` type and bring its bound type variables into scope. +2. Take the first class in the `deriving` clause. +3. Typecheck the class. +4. Move on to the next class and repeat the process until all classes have been + typechecked. + +This algorithm ensures that the `via` type is always typechecked, even if there +are no classes in the `deriving` clause. Moreover, it typecheck the `via` type +/exactly/ once and no more, even if there are multiple classes in the clause. + +Note [Recovering from failures in deriving clauses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider what happens if you run this program (from #10684) without +DeriveGeneric enabled: + + data A = A deriving (Show, Generic) + data B = B A deriving (Show) + +Naturally, you'd expect GHC to give an error to the effect of: + + Can't make a derived instance of `Generic A': + You need -XDeriveGeneric to derive an instance for this class + +And *only* that error, since the other two derived Show instances appear to be +independent of this derived Generic instance. Yet GHC also used to give this +additional error on the program above: + + No instance for (Show A) + arising from the 'deriving' clause of a data type declaration + When deriving the instance for (Show B) + +This was happening because when GHC encountered any error within a single +data type's set of deriving clauses, it would call recoverM and move on +to the next data type's deriving clauses. One unfortunate consequence of +this design is that if A's derived Generic instance failed, its derived +Show instance would be skipped entirely, leading to the "No instance for +(Show A)" error cascade. + +The solution to this problem is to push through uses of recoverM to the +level of the individual derived classes in a particular data type's set of +deriving clauses. That is, if you have: + + newtype C = C D + deriving (E, F, G) + +Then instead of processing instances E through M under the scope of a single +recoverM, as in the following pseudocode: + + recoverM (pure Nothing) $ mapM derivePred [E, F, G] + +We instead use recoverM in each iteration of the loop: + + mapM (recoverM (pure Nothing) . derivePred) [E, F, G] + +And then process each class individually, under its own recoverM scope. That +way, failure to derive one class doesn't cancel out other classes in the +same set of clause-derived classes. +-} + +------------------------------------------------------------------ +deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec) +-- Process a single standalone deriving declaration +-- e.g. deriving instance Show a => Show (T a) +-- Rather like tcLocalInstDecl +-- +-- This returns a Maybe because the user might try to derive Typeable, which is +-- a no-op nowadays. +deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode)) + = setSrcSpan loc $ + addErrCtxt (standaloneCtxt deriv_ty) $ + do { traceTc "Standalone deriving decl for" (ppr deriv_ty) + ; let ctxt = GHC.Tc.Types.Origin.InstDeclCtxt True + ; traceTc "Deriving strategy (standalone deriving)" $ + vcat [ppr mb_lderiv_strat, ppr deriv_ty] + ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat + ; (cls_tvs, deriv_ctxt, cls, inst_tys) + <- tcExtendTyVarEnv via_tvs $ + tcStandaloneDerivInstType ctxt deriv_ty + ; let mb_deriv_strat = fmap unLoc mb_lderiv_strat + tvs = via_tvs ++ cls_tvs + -- See Note [Unify kinds in deriving] + ; (tvs', deriv_ctxt', inst_tys', mb_deriv_strat') <- + case mb_deriv_strat of + -- Perform an additional unification with the kind of the `via` + -- type and the result of the previous kind unification. + Just (ViaStrategy via_ty) + -- This unification must be performed on the last element of + -- inst_tys, but we have not yet checked for this property. + -- (This is done later in expectNonNullaryClsArgs). For now, + -- simply do nothing if inst_tys is empty, since + -- expectNonNullaryClsArgs will error later if this + -- is the case. + | Just inst_ty <- lastMaybe inst_tys + -> do + let via_kind = tcTypeKind via_ty + inst_ty_kind = tcTypeKind inst_ty + mb_match = tcUnifyTy inst_ty_kind via_kind + + checkTc (isJust mb_match) + (derivingViaKindErr cls inst_ty_kind + via_ty via_kind) + + let Just kind_subst = mb_match + ki_subst_range = getTCvSubstRangeFVs kind_subst + -- See Note [Unification of two kind variables in deriving] + unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst + && not (v `elemVarSet` ki_subst_range)) + tvs + (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs + (final_deriv_ctxt, final_deriv_ctxt_tys) + = case deriv_ctxt of + InferContext wc -> (InferContext wc, []) + SupplyContext theta -> + let final_theta = substTheta subst theta + in (SupplyContext final_theta, final_theta) + final_inst_tys = substTys subst inst_tys + final_via_ty = substTy subst via_ty + -- See Note [Floating `via` type variables] + final_tvs = tyCoVarsOfTypesWellScoped $ + final_deriv_ctxt_tys ++ final_inst_tys + ++ [final_via_ty] + pure ( final_tvs, final_deriv_ctxt, final_inst_tys + , Just (ViaStrategy final_via_ty) ) + + _ -> pure (tvs, deriv_ctxt, inst_tys, mb_deriv_strat) + ; traceTc "Standalone deriving;" $ vcat + [ text "tvs':" <+> ppr tvs' + , text "mb_deriv_strat':" <+> ppr mb_deriv_strat' + , text "deriv_ctxt':" <+> ppr deriv_ctxt' + , text "cls:" <+> ppr cls + , text "inst_tys':" <+> ppr inst_tys' ] + -- C.f. GHC.Tc.TyCl.Instance.tcLocalInstDecl1 + + ; if className cls == typeableClassName + then do warnUselessTypeable + return Nothing + else Just <$> mkEqnHelp (fmap unLoc overlap_mode) + tvs' cls inst_tys' + deriv_ctxt' mb_deriv_strat' } + +-- Typecheck the type in a standalone deriving declaration. +-- +-- This may appear dense, but it's mostly huffing and puffing to recognize +-- the special case of a type with an extra-constraints wildcard context, e.g., +-- +-- deriving instance _ => Eq (Foo a) +-- +-- If there is such a wildcard, we typecheck this as if we had written +-- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@, +-- as the 'DerivContext', where loc is the location of the wildcard used for +-- error reporting. This indicates that we should infer the context as if we +-- were deriving Eq via a deriving clause +-- (see Note [Inferring the instance context] in GHC.Tc.Deriv.Infer). +-- +-- If there is no wildcard, then proceed as normal, and instead return +-- @'SupplyContext' theta@, where theta is the typechecked context. +-- +-- Note that this will never return @'InferContext' 'Nothing'@, as that can +-- only happen with @deriving@ clauses. +tcStandaloneDerivInstType + :: UserTypeCtxt -> LHsSigWcType GhcRn + -> TcM ([TyVar], DerivContext, Class, [Type]) +tcStandaloneDerivInstType ctxt + (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars + , hsib_body = deriv_ty_body })}) + | (tvs, theta, rho) <- splitLHsSigmaTyInvis deriv_ty_body + , L _ [wc_pred] <- theta + , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred + = do dfun_ty <- tcHsClsInstType ctxt $ + HsIB { hsib_ext = vars + , hsib_body + = L (getLoc deriv_ty_body) $ + HsForAllTy { hst_fvf = ForallInvis + , hst_bndrs = tvs + , hst_xforall = noExtField + , hst_body = rho }} + let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty + pure (tvs, InferContext (Just wc_span), cls, inst_tys) + | otherwise + = do dfun_ty <- tcHsClsInstType ctxt deriv_ty + let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty + pure (tvs, SupplyContext theta, cls, inst_tys) + +warnUselessTypeable :: TcM () +warnUselessTypeable + = do { warn <- woptM Opt_WarnDerivingTypeable + ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable) + $ text "Deriving" <+> quotes (ppr typeableClassName) <+> + text "has no effect: all types now auto-derive Typeable" } + +------------------------------------------------------------------ +deriveTyData :: TyCon -> [Type] -- LHS of data or data instance + -- Can be a data instance, hence [Type] args + -- and in that case the TyCon is the /family/ tycon + -> Maybe (DerivStrategy GhcTc) -- The optional deriving strategy + -> [TyVar] -- The type variables bound by the derived class + -> Class -- The derived class + -> [Type] -- The derived class's arguments + -> Kind -- The function argument in the derived class's kind. + -- (e.g., if `deriving Functor`, this would be + -- `Type -> Type` since + -- `Functor :: (Type -> Type) -> Constraint`) + -> TcM EarlyDerivSpec +-- The deriving clause of a data or newtype declaration +-- I.e. not standalone deriving +deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind + = do { -- Given data T a b c = ... deriving( C d ), + -- we want to drop type variables from T so that (C d (T a)) is well-kinded + let (arg_kinds, _) = splitFunTys cls_arg_kind + n_args_to_drop = length arg_kinds + n_args_to_keep = length tc_args - n_args_to_drop + -- See Note [tc_args and tycon arity] + (tc_args_to_keep, args_to_drop) + = splitAt n_args_to_keep tc_args + inst_ty_kind = tcTypeKind (mkTyConApp tc tc_args_to_keep) + + -- Match up the kinds, and apply the resulting kind substitution + -- to the types. See Note [Unify kinds in deriving] + -- We are assuming the tycon tyvars and the class tyvars are distinct + mb_match = tcUnifyTy inst_ty_kind cls_arg_kind + enough_args = n_args_to_keep >= 0 + + -- Check that the result really is well-kinded + ; checkTc (enough_args && isJust mb_match) + (derivingKindErr tc cls cls_tys cls_arg_kind enough_args) + + ; let -- Returns a singleton-element list if using ViaStrategy and an + -- empty list otherwise. Useful for free-variable calculations. + deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type] + deriv_strat_tys = foldMap (foldDerivStrategy [] (:[])) + + propagate_subst kind_subst tkvs' cls_tys' tc_args' mb_deriv_strat' + = (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) + where + ki_subst_range = getTCvSubstRangeFVs kind_subst + -- See Note [Unification of two kind variables in deriving] + unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst + && not (v `elemVarSet` ki_subst_range)) + tkvs' + (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs + final_tc_args = substTys subst tc_args' + final_cls_tys = substTys subst cls_tys' + final_mb_deriv_strat = fmap (mapDerivStrategy (substTy subst)) + mb_deriv_strat' + -- See Note [Floating `via` type variables] + final_tkvs = tyCoVarsOfTypesWellScoped $ + final_cls_tys ++ final_tc_args + ++ deriv_strat_tys final_mb_deriv_strat + + ; let tkvs = scopedSort $ fvVarList $ + unionFV (tyCoFVsOfTypes tc_args_to_keep) + (FV.mkFVs deriv_tvs) + Just kind_subst = mb_match + (tkvs', cls_tys', tc_args', mb_deriv_strat') + = propagate_subst kind_subst tkvs cls_tys + tc_args_to_keep mb_deriv_strat + + -- See Note [Unify kinds in deriving] + ; (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <- + case mb_deriv_strat' of + -- Perform an additional unification with the kind of the `via` + -- type and the result of the previous kind unification. + Just (ViaStrategy via_ty) -> do + let via_kind = tcTypeKind via_ty + inst_ty_kind + = tcTypeKind (mkTyConApp tc tc_args') + via_match = tcUnifyTy inst_ty_kind via_kind + + checkTc (isJust via_match) + (derivingViaKindErr cls inst_ty_kind via_ty via_kind) + + let Just via_subst = via_match + pure $ propagate_subst via_subst tkvs' cls_tys' + tc_args' mb_deriv_strat' + + _ -> pure (tkvs', cls_tys', tc_args', mb_deriv_strat') + + ; traceTc "deriveTyData 1" $ vcat + [ ppr final_mb_deriv_strat, pprTyVars deriv_tvs, ppr tc, ppr tc_args + , pprTyVars (tyCoVarsOfTypesList tc_args) + , ppr n_args_to_keep, ppr n_args_to_drop + , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match + , ppr final_tc_args, ppr final_cls_tys ] + + ; traceTc "deriveTyData 2" $ vcat + [ ppr final_tkvs ] + + ; let final_tc_app = mkTyConApp tc final_tc_args + final_cls_args = final_cls_tys ++ [final_tc_app] + ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c) + (derivingEtaErr cls final_cls_tys final_tc_app) + -- Check that + -- (a) The args to drop are all type variables; eg reject: + -- data instance T a Int = .... deriving( Monad ) + -- (b) The args to drop are all *distinct* type variables; eg reject: + -- class C (a :: * -> * -> *) where ... + -- data instance T a a = ... deriving( C ) + -- (c) The type class args, or remaining tycon args, + -- do not mention any of the dropped type variables + -- newtype T a s = ... deriving( ST s ) + -- newtype instance K a a = ... deriving( Monad ) + -- + -- It is vital that the implementation of allDistinctTyVars + -- expand any type synonyms. + -- See Note [Eta-reducing type synonyms] + + ; checkValidInstHead DerivClauseCtxt cls final_cls_args + -- Check that we aren't deriving an instance of a magical + -- type like (~) or Coercible (#14916). + + ; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_args + (InferContext Nothing) final_mb_deriv_strat + ; traceTc "deriveTyData 3" (ppr spec) + ; return spec } + + +{- Note [tc_args and tycon arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might wonder if we could use (tyConArity tc) at this point, rather +than (length tc_args). But for data families the two can differ! The +tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which +in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them +from DataFamInstTyCon: + +| DataFamInstTyCon -- See Note [Data type families] + (CoAxiom Unbranched) + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + -- No shorter in length than the tyConTyVars of the family TyCon + -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv + +Notice that the arg tys might not be the same as the family tycon arity +(= length tyConTyVars). + +Note [Unify kinds in deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#8534) + data T a b = MkT a deriving( Functor ) + -- where Functor :: (*->*) -> Constraint + +So T :: forall k. * -> k -> *. We want to get + instance Functor (T * (a:*)) where ... +Notice the '*' argument to T. + +Moreover, as well as instantiating T's kind arguments, we may need to instantiate +C's kind args. Consider (#8865): + newtype T a b = MkT (Either a b) deriving( Category ) +where + Category :: forall k. (k -> k -> *) -> Constraint +We need to generate the instance + instance Category * (Either a) where ... +Notice the '*' argument to Category. + +So we need to + * drop arguments from (T a b) to match the number of + arrows in the (last argument of the) class; + * and then *unify* kind of the remaining type against the + expected kind, to figure out how to instantiate C's and T's + kind arguments. + +In the two examples, + * we unify kind-of( T k (a:k) ) ~ kind-of( Functor ) + i.e. (k -> *) ~ (* -> *) to find k:=*. + yielding k:=* + + * we unify kind-of( Either ) ~ kind-of( Category ) + i.e. (* -> * -> *) ~ (k -> k -> k) + yielding k:=* + +Now we get a kind substitution. We then need to: + + 1. Remove the substituted-out kind variables from the quantified kind vars + + 2. Apply the substitution to the kinds of quantified *type* vars + (and extend the substitution to reflect this change) + + 3. Apply that extended substitution to the non-dropped args (types and + kinds) of the type and class + +Forgetting step (2) caused #8893: + data V a = V [a] deriving Functor + data P (x::k->*) (a:k) = P (x a) deriving Functor + data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor + +When deriving Functor for P, we unify k to *, but we then want +an instance $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*)) +and similarly for C. Notice the modified kind of x, both at binding +and occurrence sites. + +This can lead to some surprising results when *visible* kind binder is +unified (in contrast to the above examples, in which only non-visible kind +binders were considered). Consider this example from #11732: + + data T k (a :: k) = MkT deriving Functor + +Since unification yields k:=*, this results in a generated instance of: + + instance Functor (T *) where ... + +which looks odd at first glance, since one might expect the instance head +to be of the form Functor (T k). Indeed, one could envision an alternative +generated instance of: + + instance (k ~ *) => Functor (T k) where + +But this does not typecheck by design: kind equalities are not allowed to be +bound in types, only terms. But in essence, the two instance declarations are +entirely equivalent, since even though (T k) matches any kind k, the only +possibly value for k is *, since anything else is ill-typed. As a result, we can +just as comfortably use (T *). + +Another way of thinking about is: deriving clauses often infer constraints. +For example: + + data S a = S a deriving Eq + +infers an (Eq a) constraint in the derived instance. By analogy, when we +are deriving Functor, we might infer an equality constraint (e.g., k ~ *). +The only distinction is that GHC instantiates equality constraints directly +during the deriving process. + +Another quirk of this design choice manifests when typeclasses have visible +kind parameters. Consider this code (also from #11732): + + class Cat k (cat :: k -> k -> *) where + catId :: cat a a + catComp :: cat b c -> cat a b -> cat a c + + instance Cat * (->) where + catId = id + catComp = (.) + + newtype Fun a b = Fun (a -> b) deriving (Cat k) + +Even though we requested a derived instance of the form (Cat k Fun), the +kind unification will actually generate (Cat * Fun) (i.e., the same thing as if +the user wrote deriving (Cat *)). + +What happens with DerivingVia, when you have yet another type? Consider: + + newtype Foo (a :: Type) = MkFoo (Proxy a) + deriving Functor via Proxy + +As before, we unify the kind of Foo (* -> *) with the kind of the argument to +Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind +(k -> *), which is more general than what we want. So we must additionally +unify (k -> *) with (* -> *). + +Currently, all of this unification is implemented kludgily with the pure +unifier, which is rather tiresome. #14331 lays out a plan for how this +might be made cleaner. + +Note [Unification of two kind variables in deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As a special case of the Note above, it is possible to derive an instance of +a poly-kinded typeclass for a poly-kinded datatype. For example: + + class Category (cat :: k -> k -> *) where + newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category + +This case is surprisingly tricky. To see why, let's write out what instance GHC +will attempt to derive (using -fprint-explicit-kinds syntax): + + instance Category k1 (T k2 c) where ... + +GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst) +that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to +the type variable binder for c, since its kind is (k2 -> k2 -> *). + +We used to accomplish this by doing the following: + + unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs + (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs + +Where all_tkvs contains all kind variables in the class and instance types (in +this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping, +this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped +to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new]. +This is bad, because applying that substitution yields the following instance: + + instance Category k_new (T k1 c) where ... + +In other words, keeping k1 in unmapped_tvks taints the substitution, resulting +in an ill-kinded instance (this caused #11837). + +To prevent this, we need to filter out any variable from all_tkvs which either + +1. Appears in the domain of kind_subst. notElemTCvSubst checks this. +2. Appears in the range of kind_subst. To do this, we compute the free + variable set of the range of kind_subst with getTCvSubstRangeFVs, and check + if a kind variable appears in that set. + +Note [Eta-reducing type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One can instantiate a type in a data family instance with a type synonym that +mentions other type variables: + + type Const a b = a + data family Fam (f :: * -> *) (a :: *) + newtype instance Fam f (Const a f) = Fam (f a) deriving Functor + +It is also possible to define kind synonyms, and they can mention other types in +a datatype declaration. For example, + + type Const a b = a + newtype T f (a :: Const * f) = T (f a) deriving Functor + +When deriving, we need to perform eta-reduction analysis to ensure that none of +the eta-reduced type variables are mentioned elsewhere in the declaration. But +we need to be careful, because if we don't expand through the Const type +synonym, we will mistakenly believe that f is an eta-reduced type variable and +fail to derive Functor, even though the code above is correct (see #11416, +where this was first noticed). For this reason, we expand the type synonyms in +the eta-reduced types before doing any analysis. + +Note [Floating `via` type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When generating a derived instance, it will be of the form: + + instance forall ???. C c_args (D d_args) where ... + +To fill in ???, GHC computes the free variables of `c_args` and `d_args`. +`DerivingVia` adds an extra wrinkle to this formula, since we must also +include the variables bound by the `via` type when computing the binders +used to fill in ???. This might seem strange, since if a `via` type binds +any type variables, then in almost all scenarios it will appear free in +`c_args` or `d_args`. There are certain corner cases where this does not hold, +however, such as in the following example (adapted from #15831): + + newtype Age = MkAge Int + deriving Eq via Const Int a + +In this example, the `via` type binds the type variable `a`, but `a` appears +nowhere in `Eq Age`. Nevertheless, we include it in the generated instance: + + instance forall a. Eq Age where + (==) = coerce @(Const Int a -> Const Int a -> Bool) + @(Age -> Age -> Bool) + (==) + +The use of `forall a` is certainly required here, since the `a` in +`Const Int a` would not be in scope otherwise. This instance is somewhat +strange in that nothing in the instance head `Eq Age` ever determines what `a` +will be, so any code that uses this instance will invariably instantiate `a` +to be `Any`. We refer to this property of `a` as being a "floating" `via` +type variable. Programs with floating `via` type variables are the only known +class of program in which the `via` type quantifies type variables that aren't +mentioned in the instance head in the generated instance. + +Fortunately, the choice to instantiate floating `via` type variables to `Any` +is one that is completely transparent to the user (since the instance will +work as expected regardless of what `a` is instantiated to), so we decide to +permit them. An alternative design would make programs with floating `via` +variables illegal, by requiring that every variable mentioned in the `via` type +is also mentioned in the data header or the derived class. That restriction +would require the user to pick a particular type (the choice does not matter); +for example: + + newtype Age = MkAge Int + -- deriving Eq via Const Int a -- Floating 'a' + deriving Eq via Const Int () -- Choose a=() + deriving Eq via Const Int Any -- Choose a=Any + +No expressiveness would be lost thereby, but stylistically it seems preferable +to allow a type variable to indicate "it doesn't matter". + +Note that by quantifying the `a` in `forall a. Eq Age`, we are deferring the +work of instantiating `a` to `Any` at every use site of the instance. An +alternative approach would be to generate an instance that directly defaulted +to `Any`: + + instance Eq Age where + (==) = coerce @(Const Int Any -> Const Int Any -> Bool) + @(Age -> Age -> Bool) + (==) + +We do not implement this approach since it would require a nontrivial amount +of implementation effort to substitute `Any` for the floating `via` type +variables, and since the end result isn't distinguishable from the former +instance (at least from the user's perspective), the amount of engineering +required to obtain the latter instance just isn't worth it. +-} + +mkEqnHelp :: Maybe OverlapMode + -> [TyVar] + -> Class -> [Type] + -> DerivContext + -- SupplyContext => context supplied (standalone deriving) + -- InferContext => context inferred (deriving on data decl, or + -- standalone deriving decl with a wildcard) + -> Maybe (DerivStrategy GhcTc) + -> TcRn EarlyDerivSpec +-- Make the EarlyDerivSpec for an instance +-- forall tvs. theta => cls (tys ++ [ty]) +-- where the 'theta' is optional (that's the Maybe part) +-- Assumes that this declaration is well-kinded + +mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do + is_boot <- tcIsHsBootOrSig + when is_boot $ + bale_out (text "Cannot derive instances in hs-boot files" + $+$ text "Write an instance declaration instead") + runReaderT mk_eqn deriv_env + where + deriv_env = DerivEnv { denv_overlap_mode = overlap_mode + , denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = cls_args + , denv_ctxt = deriv_ctxt + , denv_strat = deriv_strat } + + bale_out msg = failWithTc $ derivingThingErr False cls cls_args deriv_strat msg + + mk_eqn :: DerivM EarlyDerivSpec + mk_eqn = do + DerivEnv { denv_inst_tys = cls_args + , denv_strat = mb_strat } <- ask + case mb_strat of + Just StockStrategy -> do + (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args + dit <- expectAlgTyConApp cls_tys inst_ty + mk_eqn_stock dit + + Just AnyclassStrategy -> mk_eqn_anyclass + + Just (ViaStrategy via_ty) -> do + (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args + mk_eqn_via cls_tys inst_ty via_ty + + Just NewtypeStrategy -> do + (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args + dit <- expectAlgTyConApp cls_tys inst_ty + unless (isNewTyCon (dit_rep_tc dit)) $ + derivingThingFailWith False gndNonNewtypeErr + mkNewTypeEqn True dit + + Nothing -> mk_eqn_no_strategy + +-- @expectNonNullaryClsArgs inst_tys@ checks if @inst_tys@ is non-empty. +-- If so, return @(init inst_tys, last inst_tys)@. +-- Otherwise, throw an error message. +-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this +-- property is important. +expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type) +expectNonNullaryClsArgs inst_tys = + maybe (derivingThingFailWith False derivingNullaryErr) pure $ + snocView inst_tys + +-- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application +-- of an algebraic type constructor. If so, return a 'DerivInstTys' consisting +-- of @cls_tys@ and the constituent pars of @inst_ty@. +-- Otherwise, throw an error message. +-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this +-- property is important. +expectAlgTyConApp :: [Type] -- All but the last argument to the class in a + -- derived instance + -> Type -- The last argument to the class in a + -- derived instance + -> DerivM DerivInstTys +expectAlgTyConApp cls_tys inst_ty = do + fam_envs <- lift tcGetFamInstEnvs + case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of + Nothing -> derivingThingFailWith False $ + text "The last argument of the instance must be a" + <+> text "data or newtype application" + Just dit -> do expectNonDataFamTyCon dit + pure dit + +-- @expectNonDataFamTyCon dit@ checks if @dit_rep_tc dit@ is a representation +-- type constructor for a data family instance, and if not, +-- throws an error message. +-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this +-- property is important. +expectNonDataFamTyCon :: DerivInstTys -> DerivM () +expectNonDataFamTyCon (DerivInstTys { dit_tc = tc + , dit_tc_args = tc_args + , dit_rep_tc = rep_tc }) = + -- If it's still a data family, the lookup failed; i.e no instance exists + when (isDataFamilyTyCon rep_tc) $ + derivingThingFailWith False $ + text "No family instance for" <+> quotes (pprTypeApp tc tc_args) + +mk_deriv_inst_tys_maybe :: FamInstEnvs + -> [Type] -> Type -> Maybe DerivInstTys +mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty = + fmap lookup $ tcSplitTyConApp_maybe inst_ty + where + lookup :: (TyCon, [Type]) -> DerivInstTys + lookup (tc, tc_args) = + -- Find the instance of a data family + -- Note [Looking up family instances for deriving] + let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tc tc_args + in DerivInstTys { dit_cls_tys = cls_tys + , dit_tc = tc + , dit_tc_args = tc_args + , dit_rep_tc = rep_tc + , dit_rep_tc_args = rep_tc_args } + +{- +Note [Looking up family instances for deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcLookupFamInstExact is an auxiliary lookup wrapper which requires +that looked-up family instances exist. If called with a vanilla +tycon, the old type application is simply returned. + +If we have + data instance F () = ... deriving Eq + data instance F () = ... deriving Eq +then tcLookupFamInstExact will be confused by the two matches; +but that can't happen because tcInstDecls1 doesn't call tcDeriving +if there are any overlaps. + +There are two other things that might go wrong with the lookup. +First, we might see a standalone deriving clause + deriving Eq (F ()) +when there is no data instance F () in scope. + +Note that it's OK to have + data instance F [a] = ... + deriving Eq (F [(a,b)]) +where the match is not exact; the same holds for ordinary data types +with standalone deriving declarations. + +Note [Deriving, type families, and partial applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When there are no type families, it's quite easy: + + newtype S a = MkS [a] + -- :CoS :: S ~ [] -- Eta-reduced + + instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a) + instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S + +When type families are involved it's trickier: + + data family T a b + newtype instance T Int a = MkT [a] deriving( Eq, Monad ) + -- :RT is the representation type for (T Int a) + -- :Co:RT :: :RT ~ [] -- Eta-reduced! + -- :CoF:RT a :: T Int a ~ :RT a -- Also eta-reduced! + + instance Eq [a] => Eq (T Int a) -- easy by coercion + -- d1 :: Eq [a] + -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a)) + + instance Monad [] => Monad (T Int) -- only if we can eta reduce??? + -- d1 :: Monad [] + -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT)) + +Note the need for the eta-reduced rule axioms. After all, we can +write it out + instance Monad [] => Monad (T Int) -- only if we can eta reduce??? + return x = MkT [x] + ... etc ... + +See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + +%************************************************************************ +%* * + Deriving data types +* * +************************************************************************ +-} + +-- Once the DerivSpecMechanism is known, we can finally produce an +-- EarlyDerivSpec from it. +mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec +mk_eqn_from_mechanism mechanism + = do DerivEnv { denv_overlap_mode = overlap_mode + , denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = inst_tys + , denv_ctxt = deriv_ctxt } <- ask + doDerivInstErrorChecks1 mechanism + loc <- lift getSrcSpanM + dfun_name <- lift $ newDFunName cls inst_tys loc + case deriv_ctxt of + InferContext wildcard -> + do { (inferred_constraints, tvs', inst_tys') + <- inferConstraints mechanism + ; return $ InferTheta $ DS + { ds_loc = loc + , ds_name = dfun_name, ds_tvs = tvs' + , ds_cls = cls, ds_tys = inst_tys' + , ds_theta = inferred_constraints + , ds_overlap = overlap_mode + , ds_standalone_wildcard = wildcard + , ds_mechanism = mechanism } } + + SupplyContext theta -> + return $ GivenTheta $ DS + { ds_loc = loc + , ds_name = dfun_name, ds_tvs = tvs + , ds_cls = cls, ds_tys = inst_tys + , ds_theta = theta + , ds_overlap = overlap_mode + , ds_standalone_wildcard = Nothing + , ds_mechanism = mechanism } + +mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class + -> DerivM EarlyDerivSpec +mk_eqn_stock dit@(DerivInstTys { dit_cls_tys = cls_tys + , dit_tc = tc + , dit_rep_tc = rep_tc }) + = do DerivEnv { denv_cls = cls + , denv_ctxt = deriv_ctxt } <- ask + dflags <- getDynFlags + case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys + tc rep_tc of + CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ + DerivSpecStock { dsm_stock_dit = dit + , dsm_stock_gen_fn = gen_fn } + StockClassError msg -> derivingThingFailWith False msg + _ -> derivingThingFailWith False (nonStdErr cls) + +mk_eqn_anyclass :: DerivM EarlyDerivSpec +mk_eqn_anyclass + = do dflags <- getDynFlags + case canDeriveAnyClass dflags of + IsValid -> mk_eqn_from_mechanism DerivSpecAnyClass + NotValid msg -> derivingThingFailWith False msg + +mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class + -> Type -- The newtype's representation type + -> DerivM EarlyDerivSpec +mk_eqn_newtype dit rep_ty = + mk_eqn_from_mechanism $ DerivSpecNewtype { dsm_newtype_dit = dit + , dsm_newtype_rep_ty = rep_ty } + +mk_eqn_via :: [Type] -- All arguments to the class besides the last + -> Type -- The last argument to the class + -> Type -- The @via@ type + -> DerivM EarlyDerivSpec +mk_eqn_via cls_tys inst_ty via_ty = + mk_eqn_from_mechanism $ DerivSpecVia { dsm_via_cls_tys = cls_tys + , dsm_via_inst_ty = inst_ty + , dsm_via_ty = via_ty } + +-- Derive an instance without a user-requested deriving strategy. This uses +-- heuristics to determine which deriving strategy to use. +-- See Note [Deriving strategies]. +mk_eqn_no_strategy :: DerivM EarlyDerivSpec +mk_eqn_no_strategy = do + DerivEnv { denv_cls = cls + , denv_inst_tys = cls_args } <- ask + fam_envs <- lift tcGetFamInstEnvs + + -- First, check if the last argument is an application of a type constructor. + -- If not, fall back to DeriveAnyClass. + if | Just (cls_tys, inst_ty) <- snocView cls_args + , Just dit <- mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty + -> if | isNewTyCon (dit_rep_tc dit) + -- We have a dedicated code path for newtypes (see the + -- documentation for mkNewTypeEqn as to why this is the case) + -> mkNewTypeEqn False dit + + | otherwise + -> do -- Otherwise, our only other options are stock or anyclass. + -- If it is stock, we must confirm that the last argument's + -- type constructor is algebraic. + -- See Note [DerivEnv and DerivSpecMechanism] in GHC.Tc.Deriv.Utils + whenIsJust (hasStockDeriving cls) $ \_ -> + expectNonDataFamTyCon dit + mk_eqn_originative 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_cls_tys = cls_tys + , dit_tc = tc + , dit_rep_tc = rep_tc }) = do + DerivEnv { denv_cls = cls + , denv_ctxt = deriv_ctxt } <- ask + dflags <- getDynFlags + + -- See Note [Deriving instances for classes themselves] + let dac_error msg + | isClassTyCon rep_tc + = quotes (ppr tc) <+> text "is a type class," + <+> text "and can only have a derived instance" + $+$ text "if DeriveAnyClass is enabled" + | otherwise + = nonStdErr cls $$ msg + + case checkOriginativeSideConditions dflags deriv_ctxt cls + cls_tys tc rep_tc of + NonDerivableClass msg -> derivingThingFailWith False (dac_error msg) + StockClassError msg -> derivingThingFailWith False msg + CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ + DerivSpecStock { dsm_stock_dit = dit + , dsm_stock_gen_fn = gen_fn } + CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass + +{- +************************************************************************ +* * + Deriving instances for newtypes +* * +************************************************************************ +-} + +-- Derive an instance for a newtype. We put this logic into its own function +-- because +-- +-- (a) When no explicit deriving strategy is requested, we have special +-- heuristics for newtypes to determine which deriving strategy should +-- actually be used. See Note [Deriving strategies]. +-- (b) We make an effort to give error messages specifically tailored to +-- newtypes. +mkNewTypeEqn :: Bool -- Was this instance derived using an explicit @newtype@ + -- deriving strategy? + -> DerivInstTys -> DerivM EarlyDerivSpec +mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys + , dit_tc = tycon + , dit_rep_tc = rep_tycon + , dit_rep_tc_args = rep_tc_args }) +-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ... + = do DerivEnv { denv_cls = cls + , denv_ctxt = deriv_ctxt } <- ask + dflags <- getDynFlags + + let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags + deriveAnyClass = xopt LangExt.DeriveAnyClass dflags + + bale_out = derivingThingFailWith newtype_deriving + + non_std = nonStdErr cls + suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's" + <+> text "newtype-deriving extension" + + -- Here is the plan for newtype derivings. We see + -- newtype T a1...an = MkT (t ak+1...an) + -- deriving (.., C s1 .. sm, ...) + -- where t is a type, + -- ak+1...an is a suffix of a1..an, and are all tyvars + -- ak+1...an do not occur free in t, nor in the s1..sm + -- (C s1 ... sm) is a *partial applications* of class C + -- with the last parameter missing + -- (T a1 .. ak) matches the kind of C's last argument + -- (and hence so does t) + -- The latter kind-check has been done by deriveTyData already, + -- and tc_args are already trimmed + -- + -- We generate the instance + -- instance forall ({a1..ak} u fvs(s1..sm)). + -- C s1 .. sm t => C s1 .. sm (T a1...ak) + -- where T a1...ap is the partial application of + -- the LHS of the correct kind and p >= k + -- + -- NB: the variables below are: + -- tc_tvs = [a1, ..., an] + -- tyvars_to_keep = [a1, ..., ak] + -- rep_ty = t ak .. an + -- deriv_tvs = fvs(s1..sm) \ tc_tvs + -- tys = [s1, ..., sm] + -- rep_fn' = t + -- + -- Running example: newtype T s a = MkT (ST s a) deriving( Monad ) + -- We generate the instance + -- instance Monad (ST s) => Monad (T s) where + + nt_eta_arity = newTyConEtadArity rep_tycon + -- For newtype T a b = MkT (S a a b), the TyCon + -- machinery already eta-reduces the representation type, so + -- we know that + -- T a ~ S a a + -- That's convenient here, because we may have to apply + -- it to fewer than its original complement of arguments + + -- Note [Newtype representation] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Need newTyConRhs (*not* a recursive representation finder) + -- to get the representation type. For example + -- newtype B = MkB Int + -- newtype A = MkA B deriving( Num ) + -- We want the Num instance of B, *not* the Num instance of Int, + -- when making the Num instance of A! + rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args + + ------------------------------------------------------------------- + -- Figuring out whether we can only do this newtype-deriving thing + + -- See Note [Determining whether newtype-deriving is appropriate] + might_be_newtype_derivable + = not (non_coercible_class cls) + && eta_ok +-- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes] + + -- Check that eta reduction is OK + eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity + -- The newtype can be eta-reduced to match the number + -- of type argument actually supplied + -- newtype T a b = MkT (S [a] b) deriving( Monad ) + -- Here the 'b' must be the same in the rep type (S [a] b) + -- And the [a] must not mention 'b'. That's all handled + -- by nt_eta_rity. + + cant_derive_err = ppUnless eta_ok eta_msg + eta_msg = text "cannot eta-reduce the representation type enough" + + MASSERT( cls_tys `lengthIs` (classArity cls - 1) ) + if newtype_strat + then + -- Since the user explicitly asked for GeneralizedNewtypeDeriving, + -- we don't need to perform all of the checks we normally would, + -- such as if the class being derived is known to produce ill-roled + -- coercions (e.g., Traversable), since we can just derive the + -- instance and let it error if need be. + -- See Note [Determining whether newtype-deriving is appropriate] + if eta_ok && newtype_deriving + then mk_eqn_newtype dit rep_inst_ty + else bale_out (cant_derive_err $$ + if newtype_deriving then empty else suggest_gnd) + else + if might_be_newtype_derivable + && ((newtype_deriving && not deriveAnyClass) + || std_class_via_coercible cls) + then mk_eqn_newtype dit rep_inst_ty + else case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys + tycon rep_tycon of + StockClassError msg + -- There's a particular corner case where + -- + -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are + -- both enabled at the same time + -- 2. We're deriving a particular stock derivable class + -- (such as Functor) + -- + -- and the previous cases won't catch it. This fixes the bug + -- reported in #10598. + | might_be_newtype_derivable && newtype_deriving + -> mk_eqn_newtype dit rep_inst_ty + -- Otherwise, throw an error for a stock class + | might_be_newtype_derivable && not newtype_deriving + -> bale_out (msg $$ suggest_gnd) + | otherwise + -> bale_out msg + + -- Must use newtype deriving or DeriveAnyClass + NonDerivableClass _msg + -- Too hard, even with newtype deriving + | newtype_deriving -> bale_out cant_derive_err + -- Try newtype deriving! + -- Here we suggest GeneralizedNewtypeDeriving even in cases + -- where it may not be applicable. See #9600. + | otherwise -> bale_out (non_std $$ suggest_gnd) + + -- DeriveAnyClass + CanDeriveAnyClass -> do + -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are + -- enabled, we take the diplomatic approach of defaulting to + -- DeriveAnyClass, but emitting a warning about the choice. + -- See Note [Deriving strategies] + when (newtype_deriving && deriveAnyClass) $ + lift $ whenWOptM Opt_WarnDerivingDefaults $ + addWarnTc (Reason Opt_WarnDerivingDefaults) $ sep + [ text "Both DeriveAnyClass and" + <+> text "GeneralizedNewtypeDeriving are enabled" + , text "Defaulting to the DeriveAnyClass strategy" + <+> text "for instantiating" <+> ppr cls + , text "Use DerivingStrategies to pick" + <+> text "a different strategy" + ] + mk_eqn_from_mechanism DerivSpecAnyClass + -- CanDeriveStock + CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ + DerivSpecStock { dsm_stock_dit = dit + , dsm_stock_gen_fn = gen_fn } + +{- +Note [Recursive newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Newtype deriving works fine, even if the newtype is recursive. +e.g. newtype S1 = S1 [T1 ()] + newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad ) +Remember, too, that type families are currently (conservatively) given +a recursive flag, so this also allows newtype deriving to work +for type famillies. + +We used to exclude recursive types, because we had a rather simple +minded way of generating the instance decl: + newtype A = MkA [A] + instance Eq [A] => Eq A -- Makes typechecker loop! +But now we require a simple context, so it's ok. + +Note [Determining whether newtype-deriving is appropriate] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see + newtype NT = MkNT Foo + deriving C +we have to decide how to perform the deriving. Do we do newtype deriving, +or do we do normal deriving? In general, we prefer to do newtype deriving +wherever possible. So, we try newtype deriving unless there's a glaring +reason not to. + +"Glaring reasons not to" include trying to derive a class for which a +coercion-based instance doesn't make sense. These classes are listed in +the definition of non_coercible_class. They include Show (since it must +show the name of the datatype) and Traversable (since a coercion-based +Traversable instance is ill-roled). + +However, non_coercible_class is ignored if the user explicitly requests +to derive an instance with GeneralizedNewtypeDeriving using the newtype +deriving strategy. In such a scenario, GHC will unquestioningly try to +derive the instance via coercions (even if the final generated code is +ill-roled!). See Note [Deriving strategies]. + +Note that newtype deriving might fail, even after we commit to it. This +is because the derived instance uses `coerce`, which must satisfy its +`Coercible` constraint. This is different than other deriving scenarios, +where we're sure that the resulting instance will type-check. + +Note [GND and associated type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for +classes with associated type families. A general recipe is: + + class C x y z where + type T y z x + op :: x -> [y] -> z + + newtype N a = MkN deriving( C ) + + =====> + + instance C x y => C x y (N a) where + type T y (N a) x = T y x + op = coerce (op :: x -> [y] -> ) + +However, we must watch out for three things: + +(a) The class must not contain any data families. If it did, we'd have to + generate a fresh data constructor name for the derived data family + instance, and it's not clear how to do this. + +(b) Each associated type family's type variables must mention the last type + variable of the class. As an example, you wouldn't be able to use GND to + derive an instance of this class: + + class C a b where + type T a + + But you would be able to derive an instance of this class: + + class C a b where + type T b + + The difference is that in the latter T mentions the last parameter of C + (i.e., it mentions b), but the former T does not. If you tried, e.g., + + newtype Foo x = Foo x deriving (C a) + + with the former definition of C, you'd end up with something like this: + + instance C a (Foo x) where + type T a = T ??? + + This T family instance doesn't mention the newtype (or its representation + type) at all, so we disallow such constructions with GND. + +(c) UndecidableInstances might need to be enabled. Here's a case where it is + most definitely necessary: + + class C a where + type T a + newtype Loop = Loop MkLoop deriving C + + =====> + + instance C Loop where + type T Loop = T Loop + + Obviously, T Loop would send the typechecker into a loop. Unfortunately, + you might even need UndecidableInstances even in cases where the + typechecker would be guaranteed to terminate. For example: + + instance C Int where + type C Int = Int + newtype MyInt = MyInt Int deriving C + + =====> + + instance C MyInt where + type T MyInt = T Int + + GHC's termination checker isn't sophisticated enough to conclude that the + definition of T MyInt terminates, so UndecidableInstances is required. + +(d) For the time being, we do not allow the last type variable of the class to + appear in a /kind/ of an associated type family definition. For instance: + + class C a where + type T1 a -- OK + type T2 (x :: a) -- Illegal: a appears in the kind of x + type T3 y :: a -- Illegal: a appears in the kind of (T3 y) + + The reason we disallow this is because our current approach to deriving + associated type family instances—i.e., by unwrapping the newtype's type + constructor as shown above—is ill-equipped to handle the scenario when + the last type variable appears as an implicit argument. In the worst case, + allowing the last variable to appear in a kind can result in improper Core + being generated (see #14728). + + There is hope for this feature being added some day, as one could + conceivably take a newtype axiom (which witnesses a coercion between a + newtype and its representation type) at lift that through each associated + type at the Core level. See #14728, comment:3 for a sketch of how this + might work. Until then, we disallow this featurette wholesale. + +The same criteria apply to DerivingVia. + +************************************************************************ +* * +Bindings for the various classes +* * +************************************************************************ + +After all the trouble to figure out the required context for the +derived instance declarations, all that's left is to chug along to +produce them. They will then be shoved into @tcInstDecls2@, which +will do all its usual business. + +There are lots of possibilities for code to generate. Here are +various general remarks. + +PRINCIPLES: +\begin{itemize} +\item +We want derived instances of @Eq@ and @Ord@ (both v common) to be +``you-couldn't-do-better-by-hand'' efficient. + +\item +Deriving @Show@---also pretty common--- should also be reasonable good code. + +\item +Deriving for the other classes isn't that common or that big a deal. +\end{itemize} + +PRAGMATICS: + +\begin{itemize} +\item +Deriving @Ord@ is done mostly with the 1.3 @compare@ method. + +\item +Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too. + +\item +We {\em normally} generate code only for the non-defaulted methods; +there are some exceptions for @Eq@ and (especially) @Ord@... + +\item +Sometimes we use a @_con2tag_@ function, which returns a data +constructor's numeric (@Int#@) tag. These are generated by +@gen_tag_n_con_binds@, and the heuristic for deciding if one of +these is around is given by @hasCon2TagFun@. + +The examples under the different sections below will make this +clearer. + +\item +Much less often (really just for deriving @Ix@), we use a +@_tag2con_@ function. See the examples. + +\item +We use the renamer!!! Reason: we're supposed to be +producing @LHsBinds Name@ for the methods, but that means +producing correctly-uniquified code on the fly. This is entirely +possible (the @TcM@ monad has a @UniqueSupply@), but it is painful. +So, instead, we produce @MonoBinds RdrName@ then heave 'em through +the renamer. What a great hack! +\end{itemize} +-} + +-- Generate the InstInfo for the required instance +-- plus any auxiliary bindings required +genInst :: DerivSpec theta + -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name]) +-- We must use continuation-returning style here to get the order in which we +-- typecheck family instances and derived instances right. +-- See Note [Staging of tcDeriving] +genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism + , ds_tys = tys, ds_cls = clas, ds_loc = loc + , ds_standalone_wildcard = wildcard }) + = do (meth_binds, meth_sigs, deriv_stuff, unusedNames) + <- set_span_and_ctxt $ + genDerivStuff mechanism loc clas tys tvs + let mk_inst_info theta = set_span_and_ctxt $ do + inst_spec <- newDerivClsInst theta spec + doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism + traceTc "newder" (ppr inst_spec) + return $ InstInfo + { iSpec = inst_spec + , iBinds = InstBindings + { ib_binds = meth_binds + , ib_tyvars = map Var.varName tvs + , ib_pragmas = meth_sigs + , ib_extensions = extensions + , ib_derived = True } } + return (mk_inst_info, deriv_stuff, unusedNames) + where + extensions :: [LangExt.Extension] + extensions + | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism + = [ + -- Both these flags are needed for higher-rank uses of coerce... + LangExt.ImpredicativeTypes, LangExt.RankNTypes + -- ...and this flag is needed to support the instance signatures + -- that bring type variables into scope. + -- See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate + , LangExt.InstanceSigs + ] + | otherwise + = [] + + set_span_and_ctxt :: TcM a -> TcM a + set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys) + +-- Checks: +-- +-- * All of the data constructors for a data type are in scope for a +-- standalone-derived instance (for `stock` and `newtype` deriving). +-- +-- * All of the associated type families of a class are suitable for +-- GeneralizedNewtypeDeriving or DerivingVia (for `newtype` and `via` +-- deriving). +doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM () +doDerivInstErrorChecks1 mechanism = + 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 + DerivSpecAnyClass{} + -> pure () + DerivSpecVia{} + -> atf_coerce_based_error_checks + where + -- When processing a standalone deriving declaration, check that all of the + -- constructors for the data type are in scope. For instance: + -- + -- import M (T) + -- deriving stock instance Eq T + -- + -- This should be rejected, as the derived Eq instance would need to refer + -- to the constructors for T, which are not in scope. + -- + -- Note that the only strategies that require this check are `stock` and + -- `newtype`. Neither `anyclass` nor `via` require it as the code that they + -- generate does not require using data constructors. + data_cons_in_scope_check :: DerivInstTys -> DerivM () + data_cons_in_scope_check (DerivInstTys { dit_tc = tc + , dit_rep_tc = rep_tc }) = do + standalone <- isStandaloneDeriv + when standalone $ do + let bale_out msg = do err <- derivingThingErrMechanism mechanism msg + lift $ failWithTc err + + rdr_env <- lift getGlobalRdrEnv + let data_con_names = map dataConName (tyConDataCons rep_tc) + hidden_data_cons = not (isWiredIn rep_tc) && + (isAbstractTyCon rep_tc || + any not_in_scope data_con_names) + not_in_scope dc = isNothing (lookupGRE_Name rdr_env dc) + + -- Make sure to also mark the data constructors as used so that GHC won't + -- mistakenly emit -Wunused-imports warnings about them. + lift $ addUsedDataCons rdr_env rep_tc + + unless (not hidden_data_cons) $ + bale_out $ derivingHiddenErr tc + + -- Ensure that a class's associated type variables are suitable for + -- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is + -- only required for the `newtype` and `via` strategies. + -- + -- See Note [GND and associated type families] + atf_coerce_based_error_checks :: DerivM () + atf_coerce_based_error_checks = do + cls <- asks denv_cls + let bale_out msg = do err <- derivingThingErrMechanism mechanism msg + lift $ failWithTc err + + cls_tyvars = classTyVars cls + + ats_look_sensible + = -- Check (a) from Note [GND and associated type families] + no_adfs + -- Check (b) from Note [GND and associated type families] + && isNothing at_without_last_cls_tv + -- Check (d) from Note [GND and associated type families] + && isNothing at_last_cls_tv_in_kinds + + (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs + no_adfs = null adf_tcs + -- We cannot newtype-derive data family instances + + at_without_last_cls_tv + = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs + at_last_cls_tv_in_kinds + = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind) + (tyConTyVars tc) + || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs + at_last_cls_tv_in_kind kind + = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind + at_tcs = classATs cls + last_cls_tv = ASSERT( notNull cls_tyvars ) + last cls_tyvars + + cant_derive_err + = vcat [ ppUnless no_adfs adfs_msg + , maybe empty at_without_last_cls_tv_msg + at_without_last_cls_tv + , maybe empty at_last_cls_tv_in_kinds_msg + at_last_cls_tv_in_kinds + ] + adfs_msg = text "the class has associated data types" + at_without_last_cls_tv_msg at_tc = hang + (text "the associated type" <+> quotes (ppr at_tc) + <+> text "is not parameterized over the last type variable") + 2 (text "of the class" <+> quotes (ppr cls)) + at_last_cls_tv_in_kinds_msg at_tc = hang + (text "the associated type" <+> quotes (ppr at_tc) + <+> text "contains the last type variable") + 2 (text "of the class" <+> quotes (ppr cls) + <+> text "in a kind, which is not (yet) allowed") + unless ats_look_sensible $ bale_out cant_derive_err + +doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan + -> DerivSpecMechanism -> TcM () +doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism + = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst) + ; dflags <- getDynFlags + ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures + ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures + + -- Error if PartialTypeSignatures isn't enabled when a user tries + -- to write @deriving instance _ => Eq (Foo a)@. Or, if that + -- extension is enabled, give a warning if -Wpartial-type-signatures + -- is enabled. + ; case wildcard of + Nothing -> pure () + Just span -> setSrcSpan span $ do + checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion) + warnTc (Reason Opt_WarnPartialTypeSignatures) + wpartial_sigs partial_sig_msg + + -- Check for Generic instances that are derived with an exotic + -- deriving strategy like DAC + -- See Note [Deriving strategies] + ; when (exotic_mechanism && className clas `elem` genericClassNames) $ + do { failIfTc (safeLanguageOn dflags) gen_inst_err + ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } } + where + exotic_mechanism = not $ isDerivSpecStock mechanism + + partial_sig_msg = text "Found type wildcard" <+> quotes (char '_') + <+> text "standing for" <+> quotes (pprTheta theta) + + pts_suggestion + = text "To use the inferred type, enable PartialTypeSignatures" + + gen_inst_err = text "Generic instances can only be derived in" + <+> text "Safe Haskell using the stock strategy." + +derivingThingFailWith :: Bool -- If True, add a snippet about how not even + -- GeneralizedNewtypeDeriving would make this + -- declaration work. This only kicks in when + -- an explicit deriving strategy is not given. + -> SDoc -- The error message + -> DerivM a +derivingThingFailWith newtype_deriving msg = do + err <- derivingThingErrM newtype_deriving msg + lift $ failWithTc err + +genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class + -> [Type] -> [TyVar] + -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]) +genDerivStuff mechanism loc clas inst_tys tyvars + = case mechanism of + -- See Note [Bindings for Generalised Newtype Deriving] + DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty} + -> gen_newtype_or_via rhs_ty + + -- Try a stock deriver + DerivSpecStock { dsm_stock_dit = DerivInstTys{dit_rep_tc = rep_tc} + , dsm_stock_gen_fn = gen_fn } + -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys + pure (binds, [], faminsts, field_names) + + -- Try DeriveAnyClass + DerivSpecAnyClass -> do + let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) + mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env + dflags <- getDynFlags + tyfam_insts <- + -- canDeriveAnyClass should ensure that this code can't be reached + -- unless -XDeriveAnyClass is enabled. + ASSERT2( isValid (canDeriveAnyClass dflags) + , ppr "genDerivStuff: bad derived class" <+> ppr clas ) + mapM (tcATDefault loc mini_subst emptyNameSet) + (classATItems clas) + return ( emptyBag, [] -- No method bindings are needed... + , listToBag (map DerivFamInst (concat tyfam_insts)) + -- ...but we may need to generate binding for associated type + -- family default instances. + -- See Note [DeriveAnyClass and default family instances] + , [] ) + + -- Try DerivingVia + DerivSpecVia{dsm_via_ty = via_ty} + -> gen_newtype_or_via via_ty + where + gen_newtype_or_via ty = do + (binds, sigs, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty + return (binds, sigs, faminsts, []) + +{- +Note [Bindings for Generalised Newtype Deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class Eq a => C a where + f :: a -> a + newtype N a = MkN [a] deriving( C ) + instance Eq (N a) where ... + +The 'deriving C' clause generates, in effect + instance (C [a], Eq a) => C (N a) where + f = coerce (f :: [a] -> [a]) + +This generates a cast for each method, but allows the superclasse to +be worked out in the usual way. In this case the superclass (Eq (N +a)) will be solved by the explicit Eq (N a) instance. We do *not* +create the superclasses by casting the superclass dictionaries for the +representation type. + +See the paper "Safe zero-cost coercions for Haskell". + +Note [DeriveAnyClass and default family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When a class has a associated type family with a default instance, e.g.: + + class C a where + type T a + type T a = Char + +then there are a couple of scenarios in which a user would expect T a to +default to Char. One is when an instance declaration for C is given without +an implementation for T: + + instance C Int + +Another scenario in which this can occur is when the -XDeriveAnyClass extension +is used: + + data Example = Example deriving (C, Generic) + +In the latter case, we must take care to check if C has any associated type +families with default instances, because -XDeriveAnyClass will never provide +an implementation for them. We "fill in" the default instances using the +tcATDefault function from GHC.Tc.TyCl.Class (which is also used in GHC.Tc.TyCl.Instance to +handle the empty instance declaration case). + +Note [Deriving strategies] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC has a notion of deriving strategies, which allow the user to explicitly +request which approach to use when deriving an instance (enabled with the +-XDerivingStrategies language extension). For more information, refer to the +original issue (#10598) or the associated wiki page: +https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies + +A deriving strategy can be specified in a deriving clause: + + newtype Foo = MkFoo Bar + deriving newtype C + +Or in a standalone deriving declaration: + + deriving anyclass instance C Foo + +-XDerivingStrategies also allows the use of multiple deriving clauses per data +declaration so that a user can derive some instance with one deriving strategy +and other instances with another deriving strategy. For example: + + newtype Baz = Baz Quux + deriving (Eq, Ord) + deriving stock (Read, Show) + deriving newtype (Num, Floating) + deriving anyclass C + +Currently, the deriving strategies are: + +* stock: Have GHC implement a "standard" instance for a data type, if possible + (e.g., Eq, Ord, Generic, Data, Functor, etc.) + +* anyclass: Use -XDeriveAnyClass + +* newtype: Use -XGeneralizedNewtypeDeriving + +* via: Use -XDerivingVia + +The latter two strategies (newtype and via) are referred to as the +"coerce-based" strategies, since they generate code that relies on the `coerce` +function. See, for instance, GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased. + +The former two strategies (stock and anyclass), in contrast, are +referred to as the "originative" strategies, since they create "original" +instances instead of "reusing" old instances (by way of `coerce`). +See, for instance, GHC.Tc.Deriv.Utils.checkOriginativeSideConditions. + +If an explicit deriving strategy is not given, GHC has an algorithm it uses to +determine which strategy it will actually use. The algorithm is quite long, +so it lives in the Haskell wiki at +https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies +("The deriving strategy resolution algorithm" section). + +Internally, GHC uses the DerivStrategy datatype to denote a user-requested +deriving strategy, and it uses the DerivSpecMechanism datatype to denote what +GHC will use to derive the instance after taking the above steps. In other +words, GHC will always settle on a DerivSpecMechnism, even if the user did not +ask for a particular DerivStrategy (using the algorithm linked to above). + +Note [Deriving instances for classes themselves] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Much of the code in GHC.Tc.Deriv assumes that deriving only works on data types. +But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly +reasonable to do something like this: + + {-# LANGUAGE DeriveAnyClass #-} + class C1 (a :: Constraint) where + class C2 where + deriving instance C1 C2 + -- This is equivalent to `instance C1 C2` + +If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock +deriving), we throw a special error message indicating that DeriveAnyClass is +the only way to go. We don't bother throwing this error if an explicit 'stock' +or 'newtype' keyword is used, since both options have their own perfectly +sensible error messages in the case of the above code (as C1 isn't a stock +derivable class, and C2 isn't a newtype). + +************************************************************************ +* * +What con2tag/tag2con functions are available? +* * +************************************************************************ +-} + +nonUnaryErr :: LHsSigType GhcRn -> SDoc +nonUnaryErr ct = quotes (ppr ct) + <+> text "is not a unary constraint, as expected by a deriving clause" + +nonStdErr :: Class -> SDoc +nonStdErr cls = + quotes (ppr cls) + <+> text "is not a stock derivable class (Eq, Show, etc.)" + +gndNonNewtypeErr :: SDoc +gndNonNewtypeErr = + text "GeneralizedNewtypeDeriving cannot be used on non-newtypes" + +derivingNullaryErr :: MsgDoc +derivingNullaryErr = text "Cannot derive instances for nullary classes" + +derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc +derivingKindErr tc cls cls_tys cls_kind enough_args + = sep [ hang (text "Cannot derive well-kinded instance of form" + <+> quotes (pprClassPred cls cls_tys + <+> parens (ppr tc <+> text "..."))) + 2 gen1_suggestion + , nest 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind)) + ] + where + gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args + = text "(Perhaps you intended to use PolyKinds)" + | otherwise = Outputable.empty + +derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc +derivingViaKindErr cls cls_kind via_ty via_kind + = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) + 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind) <> char ',' + $+$ text "but" <+> quotes (pprType via_ty) + <+> text "has kind" <+> quotes (pprKind via_kind)) + +derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc +derivingEtaErr cls cls_tys inst_ty + = sep [text "Cannot eta-reduce to an instance of form", + nest 2 (text "instance (...) =>" + <+> pprClassPred cls (cls_tys ++ [inst_ty]))] + +derivingThingErr :: Bool -> Class -> [Type] + -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc +derivingThingErr newtype_deriving cls cls_args mb_strat why + = derivingThingErr' newtype_deriving cls cls_args mb_strat + (maybe empty derivStrategyName mb_strat) why + +derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc +derivingThingErrM newtype_deriving why + = do DerivEnv { denv_cls = cls + , denv_inst_tys = cls_args + , denv_strat = mb_strat } <- ask + pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why + +derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc +derivingThingErrMechanism mechanism why + = do DerivEnv { denv_cls = cls + , denv_inst_tys = cls_args + , denv_strat = mb_strat } <- ask + pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_args mb_strat + (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why + +derivingThingErr' :: Bool -> Class -> [Type] + -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc +derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why + = sep [(hang (text "Can't make a derived instance of") + 2 (quotes (ppr pred) <+> via_mechanism) + $$ nest 2 extra) <> colon, + nest 2 why] + where + strat_used = isJust mb_strat + extra | not strat_used, newtype_deriving + = text "(even with cunning GeneralizedNewtypeDeriving)" + | otherwise = empty + pred = mkClassPred cls cls_args + via_mechanism | strat_used + = text "with the" <+> strat_msg <+> text "strategy" + | otherwise + = empty + +derivingHiddenErr :: TyCon -> SDoc +derivingHiddenErr tc + = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope")) + 2 (text "so you cannot derive an instance for it") + +standaloneCtxt :: LHsSigWcType GhcRn -> SDoc +standaloneCtxt ty = hang (text "In the stand-alone deriving instance for") + 2 (quotes (ppr ty)) diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Deriv/Functor.hs @@ -0,0 +1,1443 @@ +{- +(c) The University of Glasgow 2011 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} + +-- | The deriving code for the Functor, Foldable, and Traversable classes +module GHC.Tc.Deriv.Functor + ( FFoldType(..) + , functorLikeTraverse + , deepSubtypesContaining + , foldDataConArgs + + , gen_Functor_binds + , gen_Foldable_binds + , gen_Traversable_binds + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Core.DataCon +import GHC.Data.FastString +import GHC.Hs +import GHC.Utils.Outputable +import GHC.Builtin.Names +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc +import GHC.Utils.Monad.State +import GHC.Tc.Deriv.Generate +import GHC.Tc.Utils.TcType +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Utils.Misc +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Id.Make (coerceId) +import GHC.Builtin.Types (true_RDR, false_RDR) + +import Data.Maybe (catMaybes, isJust) + +{- +************************************************************************ +* * + Functor instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html + +* * +************************************************************************ + +For the data type: + + data T a = T1 Int a | T2 (T a) + +We generate the instance: + + instance Functor T where + fmap f (T1 b1 a) = T1 b1 (f a) + fmap f (T2 ta) = T2 (fmap f ta) + +Notice that we don't simply apply 'fmap' to the constructor arguments. +Rather + - Do nothing to an argument whose type doesn't mention 'a' + - Apply 'f' to an argument of type 'a' + - Apply 'fmap f' to other arguments +That's why we have to recurse deeply into the constructor argument types, +rather than just one level, as we typically do. + +What about types with more than one type parameter? In general, we only +derive Functor for the last position: + + data S a b = S1 [b] | S2 (a, T a b) + instance Functor (S a) where + fmap f (S1 bs) = S1 (fmap f bs) + fmap f (S2 (p,q)) = S2 (a, fmap f q) + +However, we have special cases for + - tuples + - functions + +More formally, we write the derivation of fmap code over type variable +'a for type 'b as ($fmap 'a 'b x). In this general notation the derived +instance for T is: + + instance Functor T where + fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2) + fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1) + + $(fmap 'a 'b x) = x -- when b does not contain a + $(fmap 'a 'a x) = f x + $(fmap 'a '(b1,b2) x) = case x of (x1,x2) -> ($(fmap 'a 'b1 x1), $(fmap 'a 'b2 x2)) + $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T + $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + $(fmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(fmap 'a' 'tc' (x $(cofmap 'a 'tb y))) + +For functions, the type parameter 'a can occur in a contravariant position, +which means we need to derive a function like: + + cofmap :: (a -> b) -> (f b -> f a) + +This is pretty much the same as $fmap, only without the $(cofmap 'a 'a x) and +$(cofmap 'a '(T b1 a) x) cases: + + $(cofmap 'a 'b x) = x -- when b does not contain a + $(cofmap 'a 'a x) = error "type variable in contravariant position" + $(cofmap 'a '(b1,b2) x) = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2) + $(cofmap 'a '(T b1 a) x) = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T + $(cofmap 'a '(T b1 b2) x) = fmap (\y. $(cofmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + $(cofmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(cofmap 'a' 'tc' (x $(fmap 'a 'tb y))) + +Note that the code produced by $(fmap _ _ _) is always a higher order function, +with type `(a -> b) -> (g a -> g b)` for some g. + +Note that there are two distinct cases in $fmap (and $cofmap) that match on an +application of some type constructor T (where T is not a tuple type +constructor): + + $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T + $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + +While the latter case technically subsumes the former case, it is important to +give special treatment to the former case to avoid unnecessary eta expansion. +See Note [Avoid unnecessary eta expansion in derived fmap implementations]. + +We also generate code for (<$) in addition to fmap—see Note [Deriving <$] for +an explanation of why this is important. Just like $fmap/$cofmap above, there +is a similar algorithm for generating `p <$ x` (for some constant `p`): + + $(replace 'a 'b x) = x -- when b does not contain a + $(replace 'a 'a x) = p + $(replace 'a '(b1,b2) x) = case x of (x1,x2) -> ($(replace 'a 'b1 x1), $(replace 'a 'b2 x2)) + $(replace 'a '(T b1 a) x) = p <$ x -- when a only occurs directly as the last argument of T + $(replace 'a '(T b1 b2) x) = fmap (\y. $(replace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + $(replace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(replace 'a' 'tc' (x $(coreplace 'a 'tb y))) + + $(coreplace 'a 'b x) = x -- when b does not contain a + $(coreplace 'a 'a x) = error "type variable in contravariant position" + $(coreplace 'a '(b1,b2) x) = case x of (x1,x2) -> ($(coreplace 'a 'b1 x1), $(coreplace 'a 'b2 x2)) + $(coreplace 'a '(T b1 a) x) = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T + $(coreplace 'a '(T b1 b2) x) = fmap (\y. $(coreplace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y))) +-} + +gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) +-- When the argument is phantom, we can use fmap _ = coerce +-- See Note [Phantom types with Functor, Foldable, and Traversable] +gen_Functor_binds loc tycon + | Phantom <- last (tyConRoles tycon) + = (unitBag fmap_bind, emptyBag) + where + fmap_name = L loc fmap_RDR + fmap_bind = mkRdrFunBind fmap_name fmap_eqns + fmap_eqns = [mkSimpleMatch fmap_match_ctxt + [nlWildPat] + coerce_Expr] + fmap_match_ctxt = mkPrefixFunRhs fmap_name + +gen_Functor_binds loc tycon + = (listToBag [fmap_bind, replace_bind], emptyBag) + where + data_cons = tyConDataCons tycon + fmap_name = L loc fmap_RDR + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns + fmap_match_ctxt = mkPrefixFunRhs fmap_name + + fmap_eqn con = flip evalState bs_RDRs $ + match_for_con fmap_match_ctxt [f_Pat] con parts + where + parts = foldDataConArgs ft_fmap con + + fmap_eqns = map fmap_eqn data_cons + + ft_fmap :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) + ft_fmap = FT { ft_triv = \x -> pure x + -- fmap f x = x + , ft_var = \x -> pure $ nlHsApp f_Expr x + -- fmap f x = f x + , ft_fun = \g h x -> mkSimpleLam $ \b -> do + gg <- g b + h $ nlHsApp x gg + -- fmap f x = \b -> h (x (g b)) + , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt) + -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..) + , ft_ty_app = \_ arg_ty g x -> + -- If the argument type is a bare occurrence of the + -- data type's last type variable, then we can generate + -- more efficient code. + -- See Note [Avoid unnecessary eta expansion in derived fmap implementations] + if tcIsTyVarTy arg_ty + then pure $ nlHsApps fmap_RDR [f_Expr,x] + else do gg <- mkSimpleLam g + pure $ nlHsApps fmap_RDR [gg,x] + -- fmap f x = fmap g x + , ft_forall = \_ g x -> g x + , ft_bad_app = panic "in other argument in ft_fmap" + , ft_co_var = panic "contravariant in ft_fmap" } + + -- See Note [Deriving <$] + replace_name = L loc replace_RDR + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns + replace_match_ctxt = mkPrefixFunRhs replace_name + + replace_eqn con = flip evalState bs_RDRs $ + match_for_con replace_match_ctxt [z_Pat] con parts + where + parts = foldDataConArgs ft_replace con + + replace_eqns = map replace_eqn data_cons + + ft_replace :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) + ft_replace = FT { ft_triv = \x -> pure x + -- p <$ x = x + , ft_var = \_ -> pure z_Expr + -- p <$ _ = p + , ft_fun = \g h x -> mkSimpleLam $ \b -> do + gg <- g b + h $ nlHsApp x gg + -- p <$ x = \b -> h (x (g b)) + , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt) + -- p <$ x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..) + , ft_ty_app = \_ arg_ty g x -> + -- If the argument type is a bare occurrence of the + -- data type's last type variable, then we can generate + -- more efficient code. + -- See [Deriving <$] + if tcIsTyVarTy arg_ty + then pure $ nlHsApps replace_RDR [z_Expr,x] + else do gg <- mkSimpleLam g + pure $ nlHsApps fmap_RDR [gg,x] + -- p <$ x = fmap (p <$) x + , ft_forall = \_ g x -> g x + , ft_bad_app = panic "in other argument in ft_replace" + , ft_co_var = panic "contravariant in ft_replace" } + + -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... + match_for_con :: Monad m + => HsMatchContext GhcPs + -> [LPat GhcPs] -> DataCon + -> [LHsExpr GhcPs -> m (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_for_con ctxt = mkSimpleConMatch ctxt $ + \con_name xsM -> do xs <- sequence xsM + pure $ nlHsApps con_name xs -- Con x1 x2 .. + +{- +Note [Avoid unnecessary eta expansion in derived fmap implementations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the sake of simplicity, the algorithm that derived implementations of +fmap used to have a single case that dealt with applications of some type +constructor T (where T is not a tuple type constructor): + + $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + +This generated less than optimal code in certain situations, however. Consider +this example: + + data List a = Nil | Cons a (List a) deriving Functor + +This would generate the following Functor instance: + + instance Functor List where + fmap f Nil = Nil + fmap f (Cons x xs) = Cons (f x) (fmap (\y -> f y) xs) + +The code `fmap (\y -> f y) xs` is peculiar, since it eta expands an application +of `f`. What's worse, this eta expansion actually degrades performance! To see +why, we can trace an invocation of fmap on a small List: + + fmap id $ Cons 0 $ Cons 0 $ Cons 0 $ Cons 0 Nil + + Cons (id 0) $ fmap (\y -> id y) + $ Cons 0 $ Cons 0 $ Cons 0 Nil + + Cons (id 0) $ Cons ((\y -> id y) 0) + $ fmap (\y' -> (\y -> id y) y') + $ Cons 0 $ Cons 0 Nil + + Cons (id 0) $ Cons ((\y -> id y) 0) + $ Cons ((\y' -> (\y -> id y) y') 0) + $ fmap (\y'' -> (\y' -> (\y -> id y) y') y'') + $ Cons 0 Nil + + Cons (id 0) $ Cons ((\y -> id y) 0) + $ Cons ((\y' -> (\y -> id y) y') 0) + $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0) + $ fmap (\y''' -> (\y'' -> (\y' -> (\y -> id y) y') y'') y''') + $ Nil + + Cons (id 0) $ Cons ((\y -> id y) 0) + $ Cons ((\y' -> (\y -> id y) y') 0) + $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0) + $ Nil + +Notice how the number of lambdas—and hence, the number of closures—one +needs to evaluate grows very quickly. In general, a List with N cons cells will +require (1 + 2 + ... (N-1)) beta reductions, which takes O(N^2) time! This is +what caused the performance issues observed in #7436. + +But hold on a second: shouldn't GHC's optimizer be able to eta reduce +`\y -> f y` to `f` and avoid these beta reductions? Unfortunately, this is not +the case. In general, eta reduction can change the semantics of a program. For +instance, (\x -> ⊥) `seq` () converges, but ⊥ `seq` () diverges. It just so +happens that the fmap implementation above would have the same semantics +regardless of whether or not `\y -> f y` or `f` is used, but GHC's optimizer is +not yet smart enough to realize this (see #17881). + +To avoid this quadratic blowup, we add a special case to $fmap that applies +`fmap f` directly: + + $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T + $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + +With this modified algorithm, the derived Functor List instance becomes: + + instance Functor List where + fmap f Nil = Nil + fmap f (Cons x xs) = Cons (f x) (fmap f xs) + +No lambdas in sight, just the way we like it. + +This special case does not prevent all sources quadratic closure buildup, +however. In this example: + + data PolyList a = PLNil | PLCons a (PolyList (PolyList a)) + deriving Functor + +We would derive the following code: + + instance Functor PolyList where + fmap f PLNil = PLNil + fmap f (PLCons x xs) = PLCons (f x) (fmap (\y -> fmap f y) xs) + +The use of `fmap (\y -> fmap f y) xs` builds up closures in much the same way +as `fmap (\y -> f y) xs`. The difference here is that even if we eta reduced +to `fmap (fmap f) xs`, GHC would /still/ build up a closure, since we are +recursively invoking fmap with a different argument (fmap f). Since we end up +paying the price of building a closure either way, we do not extend the special +case in $fmap any further, since it wouldn't buy us anything. + +The ft_ty_app field of FFoldType distinguishes between these two $fmap cases by +inspecting the argument type. If the argument type is a bare type variable, +then we can conclude the type variable /must/ be the same as the data type's +last type parameter. We know that this must be the case since there is an +invariant that the argument type in ft_ty_app will always contain the last +type parameter somewhere (see Note [FFoldType and functorLikeTraverse]), so +if the argument type is a bare variable, then that must be exactly the last +type parameter. + +Note that the ft_ty_app case of ft_replace (which derives implementations of +(<$)) also inspects the argument type to generate more efficient code. +See Note [Deriving <$]. + +Note [Deriving <$] +~~~~~~~~~~~~~~~~~~ + +We derive the definition of <$. Allowing this to take the default definition +can lead to memory leaks: mapping over a structure with a constant function can +fill the result structure with trivial thunks that retain the values from the +original structure. The simplifier seems to handle this all right for simple +types, but not for recursive ones. Consider + +data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor + +-- fmap _ Tip = Tip +-- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r) + +Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that +simplifies no further. Why is that? `fmap` is defined recursively, so GHC +cannot inline it. The static argument transformation would turn the definition +into a non-recursive one + +-- fmap f = go where +-- go Tip = Tip +-- go (Bin l v r) = Bin (go l) (f v) (go r) + +which GHC could inline, producing an efficient definion of `<$`. But there are +several problems. First, GHC does not perform the static argument transformation +by default, even with -O2. Second, even when it does perform the static argument +transformation, it does so only when there are at least two static arguments, +which is not the case for fmap. Finally, when the type in question is +non-regular, such as + +data Nesty a = Z a | S (Nesty a) (Nest (a, a)) + +the function argument is no longer (entirely) static, so the static argument +transformation will do nothing for us. + +Applying the default definition of `<$` will produce a tree full of thunks that +look like ((\_ -> x) x0), which represents unnecessary thunk allocation and +also retention of the previous value, potentially leaking memory. Instead, we +derive <$ separately. Two aspects are different from fmap: the case of the +sought type variable (ft_var) and the case of a type application (ft_ty_app). +The interesting one is ft_ty_app. We have to distinguish two cases: the +"immediate" case where the type argument *is* the sought type variable, and +the "nested" case where the type argument *contains* the sought type variable. + +The immediate case: + +Suppose we have + +data Imm a = Imm (F ... a) + +Then we want to define + +x <$ Imm q = Imm (x <$ q) + +The nested case: + +Suppose we have + +data Nes a = Nes (F ... (G a)) + +Then we want to define + +x <$ Nes q = Nes (fmap (x <$) q) + +We inspect the argument type in ft_ty_app +(see Note [FFoldType and functorLikeTraverse]) to distinguish between these +two cases. If the argument type is a bare type variable, then we know that it +must be the same variable as the data type's last type parameter. +This is very similar to a trick that derived fmap implementations +use in their own ft_ty_app case. +See Note [Avoid unnecessary eta expansion in derived fmap implementations], +which explains why checking if the argument type is a bare variable is +the right thing to do. + +We could, but do not, give tuples special treatment to improve efficiency +in some cases. Suppose we have + +data Nest a = Z a | S (Nest (a,a)) + +The optimal definition would be + +x <$ Z _ = Z x +x <$ S t = S ((x, x) <$ t) + +which produces a result with maximal internal sharing. The reason we do not +attempt to treat this case specially is that we have no way to give +user-provided tuple-like types similar treatment. If the user changed the +definition to + +data Pair a = Pair a a +data Nest a = Z a | S (Nest (Pair a)) + +they would experience a surprising degradation in performance. -} + + +{- +Utility functions related to Functor deriving. + +Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse. +This function works like a fold: it makes a value of type 'a' in a bottom up way. +-} + +-- Generic traversal for Functor deriving +-- See Note [FFoldType and functorLikeTraverse] +data FFoldType a -- Describes how to fold over a Type in a functor like way + = FT { ft_triv :: a + -- ^ Does not contain variable + , ft_var :: a + -- ^ The variable itself + , ft_co_var :: a + -- ^ The variable itself, contravariantly + , ft_fun :: a -> a -> a + -- ^ Function type + , ft_tup :: TyCon -> [a] -> a + -- ^ Tuple type. The @[a]@ is the result of folding over the + -- arguments of the tuple. + , ft_ty_app :: Type -> Type -> a -> a + -- ^ Type app, variable only in last argument. The two 'Type's are + -- the function and argument parts of @fun_ty arg_ty@, + -- respectively. + , ft_bad_app :: a + -- ^ Type app, variable other than in last argument + , ft_forall :: TcTyVar -> a -> a + -- ^ Forall type + } + +functorLikeTraverse :: forall a. + TyVar -- ^ Variable to look for + -> FFoldType a -- ^ How to fold + -> Type -- ^ Type to process + -> a +functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar + , ft_co_var = caseCoVar, ft_fun = caseFun + , ft_tup = caseTuple, ft_ty_app = caseTyApp + , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) + ty + = fst (go False ty) + where + go :: Bool -- Covariant or contravariant context + -> Type + -> (a, Bool) -- (result of type a, does type contain var) + + go co ty | Just ty' <- tcView ty = go co ty' + go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True) + go co (FunTy { ft_arg = x, ft_res = y, ft_af = af }) + | InvisArg <- af = go co y + | xc || yc = (caseFun xr yr,True) + where (xr,xc) = go (not co) x + (yr,yc) = go co y + go co (AppTy x y) | xc = (caseWrongArg, True) + | yc = (caseTyApp x y yr, True) + where (_, xc) = go co x + (yr,yc) = go co y + go co ty@(TyConApp con args) + | not (or xcs) = (caseTrivial, False) -- Variable does not occur + -- At this point we know that xrs, xcs is not empty, + -- and at least one xr is True + | isTupleTyCon con = (caseTuple con xrs, True) + | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty + | Just (fun_ty, arg_ty) <- splitAppTy_maybe ty -- T (..no var..) ty + = (caseTyApp fun_ty arg_ty (last xrs), True) + | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function) + where + -- When folding over an unboxed tuple, we must explicitly drop the + -- runtime rep arguments, or else GHC will generate twice as many + -- variables in a unboxed tuple pattern match and expression as it + -- actually needs. See #12399 + (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args)) + go co (ForAllTy (Bndr v vis) x) + | isVisibleArgFlag vis = panic "unexpected visible binder" + | v /= var && xc = (caseForAll v xr,True) + where (xr,xc) = go co x + + go _ _ = (caseTrivial,False) + +-- Return all syntactic subterms of ty that contain var somewhere +-- These are the things that should appear in instance constraints +deepSubtypesContaining :: TyVar -> Type -> [TcType] +deepSubtypesContaining tv + = functorLikeTraverse tv + (FT { ft_triv = [] + , ft_var = [] + , ft_fun = (++) + , ft_tup = \_ xs -> concat xs + , ft_ty_app = \t _ ts -> t:ts + , ft_bad_app = panic "in other argument in deepSubtypesContaining" + , ft_co_var = panic "contravariant in deepSubtypesContaining" + , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs }) + + +foldDataConArgs :: FFoldType a -> DataCon -> [a] +-- Fold over the arguments of the datacon +foldDataConArgs ft con + = map foldArg (dataConOrigArgTys con) + where + foldArg + = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of + Just tv -> functorLikeTraverse tv ft + Nothing -> const (ft_triv ft) + -- If we are deriving Foldable for a GADT, there is a chance that the last + -- type variable in the data type isn't actually a type variable at all. + -- (for example, this can happen if the last type variable is refined to + -- be a concrete type such as Int). If the last type variable is refined + -- to be a specific type, then getTyVar_maybe will return Nothing. + -- See Note [DeriveFoldable with ExistentialQuantification] + -- + -- The kind checks have ensured the last type parameter is of kind *. + +-- Make a HsLam using a fresh variable from a State monad +mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) + -> State [RdrName] (LHsExpr GhcPs) +-- (mkSimpleLam fn) returns (\x. fn(x)) +mkSimpleLam lam = + get >>= \case + n:names -> do + put names + body <- lam (nlHsVar n) + return (mkHsLam [nlVarPat n] body) + _ -> panic "mkSimpleLam" + +mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs + -> State [RdrName] (LHsExpr GhcPs)) + -> State [RdrName] (LHsExpr GhcPs) +mkSimpleLam2 lam = + get >>= \case + n1:n2:names -> do + put names + body <- lam (nlHsVar n1) (nlHsVar n2) + return (mkHsLam [nlVarPat n1,nlVarPat n2] body) + _ -> panic "mkSimpleLam2" + +-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" +-- +-- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in +-- which the LHS pattern-matches on @extra_pats@, followed by a match on the +-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ +-- and its arguments, applying an expression (from @insides@) to each of the +-- respective arguments of @con@. +mkSimpleConMatch :: Monad m => HsMatchContext GhcPs + -> (RdrName -> [a] -> m (LHsExpr GhcPs)) + -> [LPat GhcPs] + -> DataCon + -> [LHsExpr GhcPs -> a] + -> m (LMatch GhcPs (LHsExpr GhcPs)) +mkSimpleConMatch ctxt fold extra_pats con insides = do + let con_name = getRdrName con + let vars_needed = takeList insides as_RDRs + let bare_pat = nlConVarPat con_name vars_needed + let pat = if null vars_needed + then bare_pat + else nlParPat bare_pat + rhs <- fold con_name + (zipWith (\i v -> i $ nlHsVar v) insides vars_needed) + return $ mkMatch ctxt (extra_pats ++ [pat]) rhs + (noLoc emptyLocalBinds) + +-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" +-- +-- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to +-- 'mkSimpleConMatch', with two key differences: +-- +-- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a +-- @[LHsExpr RdrName]@. This is because it filters out the expressions +-- corresponding to arguments whose types do not mention the last type +-- variable in a derived 'Foldable' or 'Traversable' instance (i.e., the +-- 'Nothing' elements of @insides@). +-- +-- 2. @fold@ takes an expression as its first argument instead of a +-- constructor name. This is because it uses a specialized +-- constructor function expression that only takes as many parameters as +-- there are argument types that mention the last type variable. +-- +-- See Note [Generated code for DeriveFoldable and DeriveTraversable] +mkSimpleConMatch2 :: Monad m + => HsMatchContext GhcPs + -> (LHsExpr GhcPs -> [LHsExpr GhcPs] + -> m (LHsExpr GhcPs)) + -> [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) +mkSimpleConMatch2 ctxt fold extra_pats con insides = do + let con_name = getRdrName con + vars_needed = takeList insides as_RDRs + pat = nlConVarPat con_name vars_needed + -- Make sure to zip BEFORE invoking catMaybes. We want the variable + -- indices in each expression to match up with the argument indices + -- in con_expr (defined below). + exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i) + insides vars_needed + -- An element of argTysTyVarInfo is True if the constructor argument + -- with the same index has a type which mentions the last type + -- variable. + argTysTyVarInfo = map isJust insides + (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars + + con_expr + | null asWithTyVar = nlHsApps con_name asWithoutTyVar + | otherwise = + let bs = filterByList argTysTyVarInfo bs_RDRs + vars = filterByLists argTysTyVarInfo bs_Vars as_Vars + in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars) + + rhs <- fold con_expr exps + return $ mkMatch ctxt (extra_pats ++ [pat]) rhs + (noLoc emptyLocalBinds) + +-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" +mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a] + -> m (LMatch GhcPs (LHsExpr GhcPs))) + -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs) +mkSimpleTupleCase match_for_con tc insides x + = do { let data_con = tyConSingleDataCon tc + ; match <- match_for_con [] data_con insides + ; return $ nlHsCase x [match] } + +{- +************************************************************************ +* * + Foldable instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html + +* * +************************************************************************ + +Deriving Foldable instances works the same way as Functor instances, +only Foldable instances are not possible for function types at all. +Given (data T a = T a a (T a) deriving Foldable), we get: + + instance Foldable T where + foldr f z (T x1 x2 x3) = + $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) ) + +-XDeriveFoldable is different from -XDeriveFunctor in that it filters out +arguments to the constructor that would produce useless code in a Foldable +instance. For example, the following datatype: + + data Foo a = Foo Int a Int deriving Foldable + +would have the following generated Foldable instance: + + instance Foldable Foo where + foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2 + +since neither of the two Int arguments are folded over. + +The cases are: + + $(foldr 'a 'a) = f + $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z ) + $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2 + +Note that the arguments to the real foldr function are the wrong way around, +since (f :: a -> b -> b), while (foldr f :: b -> t a -> b). + +One can envision a case for types that don't contain the last type variable: + + $(foldr 'a 'b) = \x z -> z -- when b does not contain a + +But this case will never materialize, since the aforementioned filtering +removes all such types from consideration. +See Note [Generated code for DeriveFoldable and DeriveTraversable]. + +Foldable instances differ from Functor and Traversable instances in that +Foldable instances can be derived for data types in which the last type +variable is existentially quantified. In particular, if the last type variable +is refined to a more specific type in a GADT: + + data GADT a where + G :: a ~ Int => a -> G Int + +then the deriving machinery does not attempt to check that the type a contains +Int, since it is not syntactically equal to a type variable. That is, the +derived Foldable instance for GADT is: + + instance Foldable GADT where + foldr _ z (GADT _) = z + +See Note [DeriveFoldable with ExistentialQuantification]. + +Note [Deriving null] +~~~~~~~~~~~~~~~~~~~~ + +In some cases, deriving the definition of 'null' can produce much better +results than the default definition. For example, with + + data SnocList a = Nil | Snoc (SnocList a) a + +the default definition of 'null' would walk the entire spine of a +nonempty snoc-list before concluding that it is not null. But looking at +the Snoc constructor, we can immediately see that it contains an 'a', and +so 'null' can return False immediately if it matches on Snoc. When we +derive 'null', we keep track of things that cannot be null. The interesting +case is type application. Given + + data Wrap a = Wrap (Foo (Bar a)) + +we use + + null (Wrap fba) = all null fba + +but if we see + + data Wrap a = Wrap (Foo a) + +we can just use + + null (Wrap fa) = null fa + +Indeed, we allow this to happen even for tuples: + + data Wrap a = Wrap (Foo (a, Int)) + +produces + + null (Wrap fa) = null fa + +As explained in Note [Deriving <$], giving tuples special performance treatment +could surprise users if they switch to other types, but Ryan Scott seems to +think it's okay to do it for now. +-} + +gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) +-- When the parameter is phantom, we can use foldMap _ _ = mempty +-- See Note [Phantom types with Functor, Foldable, and Traversable] +gen_Foldable_binds loc tycon + | Phantom <- last (tyConRoles tycon) + = (unitBag foldMap_bind, emptyBag) + where + foldMap_name = L loc foldMap_RDR + foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns + foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt + [nlWildPat, nlWildPat] + mempty_Expr] + foldMap_match_ctxt = mkPrefixFunRhs foldMap_name + +gen_Foldable_binds loc tycon + | null data_cons -- There's no real point producing anything but + -- foldMap for a type with no constructors. + = (unitBag foldMap_bind, emptyBag) + + | otherwise + = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag) + where + data_cons = tyConDataCons tycon + + foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns + eqns = map foldr_eqn data_cons + foldr_eqn con + = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs + where + parts = sequence $ foldDataConArgs ft_foldr con + + foldMap_name = L loc foldMap_RDR + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr) + foldMap_name foldMap_eqns + + foldMap_eqns = map foldMap_eqn data_cons + + foldMap_eqn con + = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs + where + parts = sequence $ foldDataConArgs ft_foldMap con + + -- Given a list of NullM results, produce Nothing if any of + -- them is NotNull, and otherwise produce a list of Maybes + -- with Justs representing unknowns and Nothings representing + -- things that are definitely null. + convert :: [NullM a] -> Maybe [Maybe a] + convert = traverse go where + go IsNull = Just Nothing + go NotNull = Nothing + go (NullM a) = Just (Just a) + + null_name = L loc null_RDR + null_match_ctxt = mkPrefixFunRhs null_name + null_bind = mkRdrFunBind null_name null_eqns + null_eqns = map null_eqn data_cons + null_eqn con + = flip evalState bs_RDRs $ do + parts <- sequence $ foldDataConArgs ft_null con + case convert parts of + Nothing -> return $ + mkMatch null_match_ctxt [nlParPat (nlWildConPat con)] + false_Expr (noLoc emptyLocalBinds) + Just cp -> match_null [] con cp + + -- Yields 'Just' an expression if we're folding over a type that mentions + -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. + -- See Note [FFoldType and functorLikeTraverse] + ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) + ft_foldr + = FT { ft_triv = return Nothing + -- foldr f = \x z -> z + , ft_var = return $ Just f_Expr + -- foldr f = f + , ft_tup = \t g -> do + gg <- sequence g + lam <- mkSimpleLam2 $ \x z -> + mkSimpleTupleCase (match_foldr z) t gg x + return (Just lam) + -- foldr f = (\x z -> case x of ...) + , ft_ty_app = \_ _ g -> do + gg <- g + mapM (\gg' -> mkSimpleLam2 $ \x z -> return $ + nlHsApps foldable_foldr_RDR [gg',z,x]) gg + -- foldr f = (\x z -> foldr g z x) + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant in ft_foldr" + , ft_fun = panic "function in ft_foldr" + , ft_bad_app = panic "in other argument in ft_foldr" } + + match_foldr :: Monad m + => LHsExpr GhcPs + -> [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs) + where + -- g1 v1 (g2 v2 (.. z)) + mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs + mkFoldr = foldr nlHsApp z + + -- See Note [FFoldType and functorLikeTraverse] + ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) + ft_foldMap + = FT { ft_triv = return Nothing + -- foldMap f = \x -> mempty + , ft_var = return (Just f_Expr) + -- foldMap f = f + , ft_tup = \t g -> do + gg <- sequence g + lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg + return (Just lam) + -- foldMap f = \x -> case x of (..,) + , ft_ty_app = \_ _ g -> fmap (nlHsApp foldMap_Expr) <$> g + -- foldMap f = foldMap g + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant in ft_foldMap" + , ft_fun = panic "function in ft_foldMap" + , ft_bad_app = panic "in other argument in ft_foldMap" } + + match_foldMap :: Monad m + => [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs) + where + -- mappend v1 (mappend v2 ..) + mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs + mkFoldMap [] = mempty_Expr + mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs + + -- See Note [FFoldType and functorLikeTraverse] + -- Yields NullM an expression if we're folding over an expression + -- that may or may not be null. Yields IsNull if it's certainly + -- null, and yields NotNull if it's certainly not null. + -- See Note [Deriving null] + ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs))) + ft_null + = FT { ft_triv = return IsNull + -- null = \_ -> True + , ft_var = return NotNull + -- null = \_ -> False + , ft_tup = \t g -> do + gg <- sequence g + case convert gg of + Nothing -> pure NotNull + Just ggg -> + NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg) + -- null = \x -> case x of (..,) + , ft_ty_app = \_ _ g -> flip fmap g $ \nestedResult -> + case nestedResult of + -- If e definitely contains the parameter, + -- then we can test if (G e) contains it by + -- simply checking if (G e) is null + NotNull -> NullM null_Expr + -- This case is unreachable--it will actually be + -- caught by ft_triv + IsNull -> IsNull + -- The general case uses (all null), + -- (all (all null)), etc. + NullM nestedTest -> NullM $ + nlHsApp all_Expr nestedTest + -- null fa = null fa, or null fa = all null fa, or null fa = True + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant in ft_null" + , ft_fun = panic "function in ft_null" + , ft_bad_app = panic "in other argument in ft_null" } + + match_null :: Monad m + => [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs) + where + -- v1 && v2 && .. + mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs + mkNull [] = true_Expr + mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs + +data NullM a = + IsNull -- Definitely null + | NotNull -- Definitely not null + | NullM a -- Unknown + +{- +************************************************************************ +* * + Traversable instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html +* * +************************************************************************ + +Again, Traversable is much like Functor and Foldable. + +The cases are: + + $(traverse 'a 'a) = f + $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> + liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2) + $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2 + +Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types +do not mention the last type parameter. Therefore, the following datatype: + + data Foo a = Foo Int a Int + +would have the following derived Traversable instance: + + instance Traversable Foo where + traverse f (Foo x1 x2 x3) = + fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 ) + +since the two Int arguments do not produce any effects in a traversal. + +One can envision a case for types that do not mention the last type parameter: + + $(traverse 'a 'b) = pure -- when b does not contain a + +But this case will never materialize, since the aforementioned filtering +removes all such types from consideration. +See Note [Generated code for DeriveFoldable and DeriveTraversable]. +-} + +gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) +-- When the argument is phantom, we can use traverse = pure . coerce +-- See Note [Phantom types with Functor, Foldable, and Traversable] +gen_Traversable_binds loc tycon + | Phantom <- last (tyConRoles tycon) + = (unitBag traverse_bind, emptyBag) + where + traverse_name = L loc traverse_RDR + traverse_bind = mkRdrFunBind traverse_name traverse_eqns + traverse_eqns = + [mkSimpleMatch traverse_match_ctxt + [nlWildPat, z_Pat] + (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])] + traverse_match_ctxt = mkPrefixFunRhs traverse_name + +gen_Traversable_binds loc tycon + = (unitBag traverse_bind, emptyBag) + where + data_cons = tyConDataCons tycon + + traverse_name = L loc traverse_RDR + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr) + traverse_name traverse_eqns + traverse_eqns = map traverse_eqn data_cons + traverse_eqn con + = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs + where + parts = sequence $ foldDataConArgs ft_trav con + + -- Yields 'Just' an expression if we're folding over a type that mentions + -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. + -- See Note [FFoldType and functorLikeTraverse] + ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) + ft_trav + = FT { ft_triv = return Nothing + -- traverse f = pure x + , ft_var = return (Just f_Expr) + -- traverse f = f x + , ft_tup = \t gs -> do + gg <- sequence gs + lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg + return (Just lam) + -- traverse f = \x -> case x of (a1,a2,..) -> + -- liftA2 (,,) (g1 a1) (g2 a2) <*> .. + , ft_ty_app = \_ _ g -> fmap (nlHsApp traverse_Expr) <$> g + -- traverse f = traverse g + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant in ft_trav" + , ft_fun = panic "function in ft_trav" + , ft_bad_app = panic "in other argument in ft_trav" } + + -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) + -- (g2 a2) <*> ... + match_for_con :: Monad m + => [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_for_con = mkSimpleConMatch2 CaseAlt $ + \con xs -> return (mkApCon con xs) + where + -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. + mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs + mkApCon con [] = nlHsApps pure_RDR [con] + mkApCon con [x] = nlHsApps fmap_RDR [con,x] + mkApCon con (x1:x2:xs) = + foldl' appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs + where appAp x y = nlHsApps ap_RDR [x,y] + +----------------------------------------------------------------------- + +f_Expr, z_Expr, mempty_Expr, foldMap_Expr, + traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr, + all_Expr, null_Expr :: LHsExpr GhcPs +f_Expr = nlHsVar f_RDR +z_Expr = nlHsVar z_RDR +mempty_Expr = nlHsVar mempty_RDR +foldMap_Expr = nlHsVar foldMap_RDR +traverse_Expr = nlHsVar traverse_RDR +coerce_Expr = nlHsVar (getRdrName coerceId) +pure_Expr = nlHsVar pure_RDR +true_Expr = nlHsVar true_RDR +false_Expr = nlHsVar false_RDR +all_Expr = nlHsVar all_RDR +null_Expr = nlHsVar null_RDR + +f_RDR, z_RDR :: RdrName +f_RDR = mkVarUnqual (fsLit "f") +z_RDR = mkVarUnqual (fsLit "z") + +as_RDRs, bs_RDRs :: [RdrName] +as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] +bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] + +as_Vars, bs_Vars :: [LHsExpr GhcPs] +as_Vars = map nlHsVar as_RDRs +bs_Vars = map nlHsVar bs_RDRs + +f_Pat, z_Pat :: LPat GhcPs +f_Pat = nlVarPat f_RDR +z_Pat = nlVarPat z_RDR + +{- +Note [DeriveFoldable with ExistentialQuantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Functor and Traversable instances can only be derived for data types whose +last type parameter is truly universally polymorphic. For example: + + data T a b where + T1 :: b -> T a b -- YES, b is unconstrained + T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b) + T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int) + T4 :: Int -> T a Int -- NO, this is just like T3 + T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even + -- though a is existential + T6 :: Int -> T Int b -- YES, b is unconstrained + +For Foldable instances, however, we can completely lift the constraint that +the last type parameter be truly universally polymorphic. This means that T +(as defined above) can have a derived Foldable instance: + + instance Foldable (T a) where + foldr f z (T1 b) = f b z + foldr f z (T2 b) = f b z + foldr f z (T3 b) = f b z + foldr f z (T4 b) = z + foldr f z (T5 a b) = f b z + foldr f z (T6 a) = z + + foldMap f (T1 b) = f b + foldMap f (T2 b) = f b + foldMap f (T3 b) = f b + foldMap f (T4 b) = mempty + foldMap f (T5 a b) = f b + foldMap f (T6 a) = mempty + +In a Foldable instance, it is safe to fold over an occurrence of the last type +parameter that is not truly universally polymorphic. However, there is a bit +of subtlety in determining what is actually an occurrence of a type parameter. +T3 and T4, as defined above, provide one example: + + data T a b where + ... + T3 :: b ~ Int => b -> T a b + T4 :: Int -> T a Int + ... + + instance Foldable (T a) where + ... + foldr f z (T3 b) = f b z + foldr f z (T4 b) = z + ... + foldMap f (T3 b) = f b + foldMap f (T4 b) = mempty + ... + +Notice that the argument of T3 is folded over, whereas the argument of T4 is +not. This is because we only fold over constructor arguments that +syntactically mention the universally quantified type parameter of that +particular data constructor. See foldDataConArgs for how this is implemented. + +As another example, consider the following data type. The argument of each +constructor has the same type as the last type parameter: + + data E a where + E1 :: (a ~ Int) => a -> E a + E2 :: Int -> E Int + E3 :: (a ~ Int) => a -> E Int + E4 :: (a ~ Int) => Int -> E a + +Only E1's argument is an occurrence of a universally quantified type variable +that is syntactically equivalent to the last type parameter, so only E1's +argument will be folded over in a derived Foldable instance. + +See #10447 for the original discussion on this feature. Also see +https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/derive-functor +for a more in-depth explanation. + +Note [FFoldType and functorLikeTraverse] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deriving Functor, Foldable, and Traversable all require generating expressions +which perform an operation on each argument of a data constructor depending +on the argument's type. In particular, a generated operation can be different +depending on whether the type mentions the last type variable of the datatype +(e.g., if you have data T a = MkT a Int, then a generated foldr expression would +fold over the first argument of MkT, but not the second). + +This pattern is abstracted with the FFoldType datatype, which provides hooks +for the user to specify how a constructor argument should be folded when it +has a type with a particular "shape". The shapes are as follows (assume that +a is the last type variable in a given datatype): + +* ft_triv: The type does not mention the last type variable at all. + Examples: Int, b + +* ft_var: The type is syntactically equal to the last type variable. + Moreover, the type appears in a covariant position (see + the Deriving Functor instances section of the user's guide + for an in-depth explanation of covariance vs. contravariance). + Example: a (covariantly) + +* ft_co_var: The type is syntactically equal to the last type variable. + Moreover, the type appears in a contravariant position. + Example: a (contravariantly) + +* ft_fun: A function type which mentions the last type variable in + the argument position, result position or both. + Examples: a -> Int, Int -> a, Maybe a -> [a] + +* ft_tup: A tuple type which mentions the last type variable in at least + one of its fields. The TyCon argument of ft_tup represents the + particular tuple's type constructor. + Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #) + +* ft_ty_app: A type is being applied to the last type parameter, where the + applied type does not mention the last type parameter (if it + did, it would fall under ft_bad_app) and the argument type + mentions the last type parameter (if it did not, it would fall + under ft_triv). The first two Type arguments to + ft_ty_app represent the applied type and argument type, + respectively. + + Currently, only DeriveFunctor makes use of the argument type. + It inspects the argument type so that it can generate more + efficient implementations of fmap + (see Note [Avoid unnecessary eta expansion in derived fmap implementations]) + and (<$) (see Note [Deriving <$]) in certain cases. + + Note that functions, tuples, and foralls are distinct cases + and take precedence over ft_ty_app. (For example, (Int -> a) would + fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a). + Examples: Maybe a, Either b a + +* ft_bad_app: A type application uses the last type parameter in a position + other than the last argument. This case is singled out because + Functor, Foldable, and Traversable instances cannot be derived + for datatypes containing arguments with such types. + Examples: Either a Int, Const a b + +* ft_forall: A forall'd type mentions the last type parameter on its right- + hand side (and is not quantified on the left-hand side). This + case is present mostly for plumbing purposes. + Example: forall b. Either b a + +If FFoldType describes a strategy for folding subcomponents of a Type, then +functorLikeTraverse is the function that applies that strategy to the entirety +of a Type, returning the final folded-up result. + +foldDataConArgs applies functorLikeTraverse to every argument type of a +constructor, returning a list of the fold results. This makes foldDataConArgs +a natural way to generate the subexpressions in a generated fmap, foldr, +foldMap, or traverse definition (the subexpressions must then be combined in +a method-specific fashion to form the final generated expression). + +Deriving Generic1 also does validity checking by looking for the last type +variable in certain positions of a constructor's argument types, so it also +uses foldDataConArgs. See Note [degenerate use of FFoldType] in GHC.Tc.Deriv.Generics. + +Note [Generated code for DeriveFoldable and DeriveTraversable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on +that of -XDeriveFunctor. However, there an important difference between deriving +the former two typeclasses and the latter one, which is best illustrated by the +following scenario: + + data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable) + +The generated code for the Functor instance is straightforward: + + instance Functor WithInt where + fmap f (WithInt a i) = WithInt (f a) i + +But if we use too similar of a strategy for deriving the Foldable and +Traversable instances, we end up with this code: + + instance Foldable WithInt where + foldMap f (WithInt a i) = f a <> mempty + + instance Traversable WithInt where + traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i + +This is unsatisfying for two reasons: + +1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure + expects an argument whose type is of kind *. This effectively prevents + Traversable from being derived for any datatype with an unlifted argument + type (#11174). + +2. The generated code contains superfluous expressions. By the Monoid laws, + we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can + reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)). + +We can fix both of these issues by incorporating a slight twist to the usual +algorithm that we use for -XDeriveFunctor. The differences can be summarized +as follows: + +1. In the generated expression, we only fold over arguments whose types + mention the last type parameter. Any other argument types will simply + produce useless 'mempty's or 'pure's, so they can be safely ignored. + +2. In the case of -XDeriveTraversable, instead of applying ConName, + we apply (\b_i ... b_k -> ConName a_1 ... a_n), where + + * ConName has n arguments + * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond + to the arguments whose types mention the last type parameter. As a + consequence, taking the difference of {a_1, ..., a_n} and + {b_i, ..., b_k} yields the all the argument values of ConName whose types + do not mention the last type parameter. Note that [i, ..., k] is a + strictly increasing—but not necessarily consecutive—integer sequence. + + For example, the datatype + + data Foo a = Foo Int a Int a + + would generate the following Traversable instance: + + instance Traversable Foo where + traverse f (Foo a1 a2 a3 a4) = + fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4 + +Technically, this approach would also work for -XDeriveFunctor as well, but we +decide not to do so because: + +1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a)) + instead of (WithInt (f a) i). + +2. There would be certain datatypes for which the above strategy would + generate Functor code that would fail to typecheck. For example: + + data Bar f a = Bar (forall f. Functor f => f a) deriving Functor + + With the conventional algorithm, it would generate something like: + + fmap f (Bar a) = Bar (fmap f a) + + which typechecks. But with the strategy mentioned above, it would generate: + + fmap f (Bar a) = (\b -> Bar b) (fmap f a) + + which does not typecheck, since GHC cannot unify the rank-2 type variables + in the types of b and (fmap f a). + +Note [Phantom types with Functor, Foldable, and Traversable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Given a type F :: * -> * whose type argument has a phantom role, we can always +produce lawful Functor and Traversable instances using + + fmap _ = coerce + traverse _ = pure . coerce + +Indeed, these are equivalent to any *strictly lawful* instances one could +write, except that this definition of 'traverse' may be lazier. That is, if +instances obey the laws under true equality (rather than up to some equivalence +relation), then they will be essentially equivalent to these. These definitions +are incredibly cheap, so we want to use them even if it means ignoring some +non-strictly-lawful instance in an embedded type. + +Foldable has far fewer laws to work with, which leaves us unwelcome +freedom in implementing it. At a minimum, we would like to ensure that +a derived foldMap is always at least as good as foldMapDefault with a +derived traverse. To accomplish that, we must define + + foldMap _ _ = mempty + +in these cases. + +This may have different strictness properties from a standard derivation. +Consider + + data NotAList a = Nil | Cons (NotAList a) deriving Foldable + +The usual deriving mechanism would produce + + foldMap _ Nil = mempty + foldMap f (Cons x) = foldMap f x + +which is strict in the entire spine of the NotAList. + +Final point: why do we even care about such types? Users will rarely if ever +map, fold, or traverse over such things themselves, but other derived +instances may: + + data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable + +Note [EmptyDataDecls with Functor, Foldable, and Traversable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are some slightly tricky decisions to make about how to handle +Functor, Foldable, and Traversable instances for types with no constructors. +For fmap, the two basic options are + + fmap _ _ = error "Sorry, no constructors" + +or + + fmap _ z = case z of + +In most cases, the latter is more helpful: if the thunk passed to fmap +throws an exception, we're generally going to be much more interested in +that exception than in the fact that there aren't any constructors. + +In order to match the semantics for phantoms (see note above), we need to +be a bit careful about 'traverse'. The obvious definition would be + + traverse _ z = case z of + +but this is stricter than the one for phantoms. We instead use + + traverse _ z = pure $ case z of + +For foldMap, the obvious choices are + + foldMap _ _ = mempty + +or + + foldMap _ z = case z of + +We choose the first one to be consistent with what foldMapDefault does for +a derived Traversable instance. +-} diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -0,0 +1,2429 @@ +{- + % +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Generating derived instance declarations +-- +-- This module is nominally ``subordinate'' to @GHC.Tc.Deriv@, which is the +-- ``official'' interface to deriving-related things. +-- +-- This is where we do all the grimy bindings' generation. +module GHC.Tc.Deriv.Generate ( + BagDerivStuff, DerivStuff(..), + + gen_Eq_binds, + gen_Ord_binds, + gen_Enum_binds, + gen_Bounded_binds, + gen_Ix_binds, + gen_Show_binds, + gen_Read_binds, + gen_Data_binds, + gen_Lift_binds, + gen_Newtype_binds, + mkCoerceClassMethEqn, + genAuxBinds, + ordOpTbl, boxConTbl, litConTbl, + mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Utils.Monad +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Types.Basic +import GHC.Core.DataCon +import GHC.Types.Name +import GHC.Utils.Fingerprint +import GHC.Utils.Encoding + +import GHC.Driver.Session +import GHC.Builtin.Utils +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.Types.SrcLoc +import GHC.Core.TyCon +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcType +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.Var.Set +import GHC.Types.Var.Env +import GHC.Utils.Misc +import GHC.Types.Var +import GHC.Utils.Outputable +import GHC.Utils.Lexeme +import GHC.Data.FastString +import GHC.Data.Pair +import GHC.Data.Bag + +import Data.List ( find, partition, intersperse ) + +type BagDerivStuff = Bag DerivStuff + +data AuxBindSpec + = DerivCon2Tag TyCon -- The con2Tag for given TyCon + | DerivTag2Con TyCon -- ...ditto tag2Con + | DerivMaxTag TyCon -- ...and maxTag + deriving( Eq ) + -- All these generate ZERO-BASED tag operations + -- I.e first constructor has tag 0 + +data DerivStuff -- Please add this auxiliary stuff + = DerivAuxBind AuxBindSpec + + -- Generics and DeriveAnyClass + | DerivFamInst FamInst -- New type family instances + + -- New top-level auxiliary bindings + | DerivHsBind (LHsBind GhcPs, LSig GhcPs) -- Also used for SYB + + +{- +************************************************************************ +* * + Eq instances +* * +************************************************************************ + +Here are the heuristics for the code we generate for @Eq@. Let's +assume we have a data type with some (possibly zero) nullary data +constructors and some ordinary, non-nullary ones (the rest, also +possibly zero of them). Here's an example, with both \tr{N}ullary and +\tr{O}rdinary data cons. + + data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... + +* For the ordinary constructors (if any), we emit clauses to do The + Usual Thing, e.g.,: + + (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2 + (==) (O2 a1) (O2 a2) = a1 == a2 + (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2 + + Note: if we're comparing unlifted things, e.g., if 'a1' and + 'a2' are Float#s, then we have to generate + case (a1 `eqFloat#` a2) of r -> r + for that particular test. + +* If there are a lot of (more than ten) nullary constructors, we emit a + catch-all clause of the form: + + (==) a b = case (con2tag_Foo a) of { a# -> + case (con2tag_Foo b) of { b# -> + case (a# ==# b#) of { + r -> r }}} + + If con2tag gets inlined this leads to join point stuff, so + it's better to use regular pattern matching if there aren't too + many nullary constructors. "Ten" is arbitrary, of course + +* If there aren't any nullary constructors, we emit a simpler + catch-all: + + (==) a b = False + +* For the @(/=)@ method, we normally just use the default method. + If the type is an enumeration type, we could/may/should? generate + special code that calls @con2tag_Foo@, much like for @(==)@ shown + above. + +We thought about doing this: If we're also deriving 'Ord' for this +tycon, we generate: + instance ... Eq (Foo ...) where + (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False} + (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True } +However, that requires that (Ord ) was put in the context +for the instance decl, which it probably wasn't, so the decls +produced don't get through the typechecker. +-} + +gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) +gen_Eq_binds loc tycon = do + dflags <- getDynFlags + return (method_binds dflags, aux_binds) + where + all_cons = tyConDataCons tycon + (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons + + -- If there are ten or more (arbitrary number) nullary constructors, + -- use the con2tag stuff. For small types it's better to use + -- ordinary pattern matching. + (tag_match_cons, pat_match_cons) + | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons) + | otherwise = ([], all_cons) + + no_tag_match_cons = null tag_match_cons + + fall_through_eqn dflags + | no_tag_match_cons -- All constructors have arguments + = case pat_match_cons of + [] -> [] -- No constructors; no fall-though case + [_] -> [] -- One constructor; no fall-though case + _ -> -- Two or more constructors; add fall-through of + -- (==) _ _ = False + [([nlWildPat, nlWildPat], false_Expr)] + + | otherwise -- One or more tag_match cons; add fall-through of + -- extract tags compare for equality + = [([a_Pat, b_Pat], + untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] + (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] + + aux_binds | no_tag_match_cons = emptyBag + | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon + + method_binds dflags = unitBag (eq_bind dflags) + eq_bind dflags = mkFunBindEC 2 loc eq_RDR (const true_Expr) + (map pats_etc pat_match_cons + ++ fall_through_eqn dflags) + + ------------------------------------------------------------------ + pats_etc data_con + = let + con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed + con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed + + data_con_RDR = getRdrName data_con + con_arity = length tys_needed + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs + tys_needed = dataConOrigArgTys data_con + in + ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) + where + nested_eq_expr [] [] [] = true_Expr + nested_eq_expr tys as bs + = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) + -- Using 'foldr1' here ensures that the derived code is correctly + -- associated. See #10859. + where + nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b)) + +{- +************************************************************************ +* * + Ord instances +* * +************************************************************************ + +Note [Generating Ord instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose constructors are K1..Kn, and some are nullary. +The general form we generate is: + +* Do case on first argument + case a of + K1 ... -> rhs_1 + K2 ... -> rhs_2 + ... + Kn ... -> rhs_n + _ -> nullary_rhs + +* To make rhs_i + If i = 1, 2, n-1, n, generate a single case. + rhs_2 case b of + K1 {} -> LT + K2 ... -> ...eq_rhs(K2)... + _ -> GT + + Otherwise do a tag compare against the bigger range + (because this is the one most likely to succeed) + rhs_3 case tag b of tb -> + if 3 <# tg then GT + else case b of + K3 ... -> ...eq_rhs(K3).... + _ -> LT + +* To make eq_rhs(K), which knows that + a = K a1 .. av + b = K b1 .. bv + we just want to compare (a1,b1) then (a2,b2) etc. + Take care on the last field to tail-call into comparing av,bv + +* To make nullary_rhs generate this + case con2tag a of a# -> + case con2tag b of -> + a# `compare` b# + +Several special cases: + +* Two or fewer nullary constructors: don't generate nullary_rhs + +* Be careful about unlifted comparisons. When comparing unboxed + values we can't call the overloaded functions. + See function unliftedOrdOp + +Note [Game plan for deriving Ord] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's a bad idea to define only 'compare', and build the other binary +comparisons on top of it; see #2130, #4019. Reason: we don't +want to laboriously make a three-way comparison, only to extract a +binary result, something like this: + (>) (I# x) (I# y) = case <# x y of + True -> False + False -> case ==# x y of + True -> False + False -> True + +This being said, we can get away with generating full code only for +'compare' and '<' thus saving us generation of other three operators. +Other operators can be cheaply expressed through '<': +a <= b = not $ b < a +a > b = b < a +a >= b = not $ a < b + +So for sufficiently small types (few constructors, or all nullary) +we generate all methods; for large ones we just use 'compare'. + +-} + +data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT + +------------ +ordMethRdr :: OrdOp -> RdrName +ordMethRdr op + = case op of + OrdCompare -> compare_RDR + OrdLT -> lt_RDR + OrdLE -> le_RDR + OrdGE -> ge_RDR + OrdGT -> gt_RDR + +------------ +ltResult :: OrdOp -> LHsExpr GhcPs +-- Knowing a LHsExpr GhcPs +-- Knowing a=b, what is the result for a `op` b? +eqResult OrdCompare = eqTag_Expr +eqResult OrdLT = false_Expr +eqResult OrdLE = true_Expr +eqResult OrdGE = true_Expr +eqResult OrdGT = false_Expr + +------------ +gtResult :: OrdOp -> LHsExpr GhcPs +-- Knowing a>b, what is the result for a `op` b? +gtResult OrdCompare = gtTag_Expr +gtResult OrdLT = false_Expr +gtResult OrdLE = false_Expr +gtResult OrdGE = true_Expr +gtResult OrdGT = true_Expr + +------------ +gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) +gen_Ord_binds loc tycon = do + dflags <- getDynFlags + return $ if null tycon_data_cons -- No data-cons => invoke bale-out case + then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) [] + , emptyBag) + else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags + , aux_binds) + where + aux_binds | single_con_type = emptyBag + | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon + + -- Note [Game plan for deriving Ord] + other_ops dflags + | (last_tag - first_tag) <= 2 -- 1-3 constructors + || null non_nullary_cons -- Or it's an enumeration + = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE] + | otherwise + = emptyBag + + negate_expr = nlHsApp (nlHsVar not_RDR) + lE = mkSimpleGeneratedFunBind loc le_RDR [a_Pat, b_Pat] $ + negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr) + gT = mkSimpleGeneratedFunBind loc gt_RDR [a_Pat, b_Pat] $ + nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr + gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $ + negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr) + + get_tag con = dataConTag con - fIRST_TAG + -- We want *zero-based* tags, because that's what + -- con2Tag returns (generated by untag_Expr)! + + tycon_data_cons = tyConDataCons tycon + single_con_type = isSingleton tycon_data_cons + (first_con : _) = tycon_data_cons + (last_con : _) = reverse tycon_data_cons + first_tag = get_tag first_con + last_tag = get_tag last_con + + (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons + + + mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs + -- Returns a binding op a b = ... compares a and b according to op .... + mkOrdOp dflags op = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat] + (mkOrdOpRhs dflags op) + + mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs + mkOrdOpRhs dflags op -- RHS for comparing 'a' and 'b' according to op + | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases + = nlHsCase (nlHsVar a_RDR) $ + map (mkOrdOpAlt dflags op) tycon_data_cons + -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y... + -- C2 x -> case b of C2 x -> ....comopare x.... } + + | null non_nullary_cons -- All nullary, so go straight to comparing tags + = mkTagCmp dflags op + + | otherwise -- Mixed nullary and non-nullary + = nlHsCase (nlHsVar a_RDR) $ + (map (mkOrdOpAlt dflags op) non_nullary_cons + ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)]) + + + mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon + -> LMatch GhcPs (LHsExpr GhcPs) + -- Make the alternative (Ki a1 a2 .. av -> + mkOrdOpAlt dflags op data_con + = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed) + (mkInnerRhs dflags op data_con) + where + as_needed = take (dataConSourceArity data_con) as_RDRs + data_con_RDR = getRdrName data_con + + mkInnerRhs dflags op data_con + | single_con_type + = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ] + + | tag == first_tag + = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (ltResult op) ] + | tag == last_tag + = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (gtResult op) ] + + | tag == first_tag + 1 + = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con) + (gtResult op) + , mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (ltResult op) ] + | tag == last_tag - 1 + = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con) + (ltResult op) + , mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (gtResult op) ] + + | tag > last_tag `div` 2 -- lower range is larger + = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ + nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit) + (gtResult op) $ -- Definitely GT + nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (ltResult op) ] + + | otherwise -- upper range is larger + = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ + nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit) + (ltResult op) $ -- Definitely LT + nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (gtResult op) ] + where + tag = get_tag data_con + tag_lit = noLoc (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag))) + + mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) + -- First argument 'a' known to be built with K + -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) + mkInnerEqAlt op data_con + = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $ + mkCompareFields op (dataConOrigArgTys data_con) + where + data_con_RDR = getRdrName data_con + bs_needed = take (dataConSourceArity data_con) bs_RDRs + + mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs + -- Both constructors known to be nullary + -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b# + mkTagCmp dflags op = + untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ + unliftedOrdOp intPrimTy op ah_RDR bh_RDR + +mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs +-- Generates nested comparisons for (a1,a2...) against (b1,b2,...) +-- where the ai,bi have the given types +mkCompareFields op tys + = go tys as_RDRs bs_RDRs + where + go [] _ _ = eqResult op + go [ty] (a:_) (b:_) + | isUnliftedType ty = unliftedOrdOp ty op a b + | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b) + go (ty:tys) (a:as) (b:bs) = mk_compare ty a b + (ltResult op) + (go tys as bs) + (gtResult op) + go _ _ _ = panic "mkCompareFields" + + -- (mk_compare ty a b) generates + -- (case (compare a b) of { LT -> ; EQ -> ; GT -> }) + -- but with suitable special cases for + mk_compare ty a b lt eq gt + | isUnliftedType ty + = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt + | otherwise + = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr)) + [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt, + mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq, + mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt] + where + a_expr = nlHsVar a + b_expr = nlHsVar b + (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty + +unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs +unliftedOrdOp ty op a b + = case op of + OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr + ltTag_Expr eqTag_Expr gtTag_Expr + OrdLT -> wrap lt_op + OrdLE -> wrap le_op + OrdGE -> wrap ge_op + OrdGT -> wrap gt_op + where + (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty + wrap prim_op = genPrimOpApp a_expr prim_op b_expr + a_expr = nlHsVar a + b_expr = nlHsVar b + +unliftedCompare :: RdrName -> RdrName + -> LHsExpr GhcPs -> LHsExpr GhcPs -- What to compare + -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs + -- Three results + -> LHsExpr GhcPs +-- Return (if a < b then lt else if a == b then eq else gt) +unliftedCompare lt_op eq_op a_expr b_expr lt eq gt + = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $ + -- Test (<) first, not (==), because the latter + -- is true less often, so putting it first would + -- mean more tests (dynamically) + nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt + where + ascribeBool e = nlExprWithTySig e boolTy + +nlConWildPat :: DataCon -> LPat GhcPs +-- The pattern (K {}) +nlConWildPat con = noLoc $ ConPat + { pat_con_ext = noExtField + , pat_con = noLoc $ getRdrName con + , pat_args = RecCon $ HsRecFields + { rec_flds = [] + , rec_dotdot = Nothing } + } + +{- +************************************************************************ +* * + Enum instances +* * +************************************************************************ + +@Enum@ can only be derived for enumeration types. For a type +\begin{verbatim} +data Foo ... = N1 | N2 | ... | Nn +\end{verbatim} + +we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a +@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@). + +\begin{verbatim} +instance ... Enum (Foo ...) where + succ x = toEnum (1 + fromEnum x) + pred x = toEnum (fromEnum x - 1) + + toEnum i = tag2con_Foo i + + enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo] + + -- or, really... + enumFrom a + = case con2tag_Foo a of + a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo) + + enumFromThen a b + = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo] + + -- or, really... + enumFromThen a b + = case con2tag_Foo a of { a# -> + case con2tag_Foo b of { b# -> + map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo) + }} +\end{verbatim} + +For @enumFromTo@ and @enumFromThenTo@, we use the default methods. +-} + +gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) +gen_Enum_binds loc tycon = do + dflags <- getDynFlags + return (method_binds dflags, aux_binds) + where + method_binds dflags = listToBag + [ succ_enum dflags + , pred_enum dflags + , to_enum dflags + , enum_from dflags + , enum_from_then dflags + , from_enum dflags + ] + aux_binds = listToBag $ map DerivAuxBind + [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon] + + occ_nm = getOccString tycon + + succ_enum dflags + = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $ + untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ + nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon), + nlHsVarApps intDataCon_RDR [ah_RDR]]) + (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration") + (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) + (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], + nlHsIntLit 1])) + + pred_enum dflags + = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $ + untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ + nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, + nlHsVarApps intDataCon_RDR [ah_RDR]]) + (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") + (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) + (nlHsApps plus_RDR + [ nlHsVarApps intDataCon_RDR [ah_RDR] + , nlHsLit (HsInt noExtField + (mkIntegralLit (-1 :: Int)))])) + + to_enum dflags + = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $ + nlHsIf (nlHsApps and_RDR + [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], + nlHsApps le_RDR [ nlHsVar a_RDR + , nlHsVar (maxtag_RDR dflags tycon)]]) + (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR]) + (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon)) + + enum_from dflags + = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $ + untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ + nlHsApps map_RDR + [nlHsVar (tag2con_RDR dflags tycon), + nlHsPar (enum_from_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVar (maxtag_RDR dflags tycon)))] + + enum_from_then dflags + = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ + untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ + nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ + nlHsPar (enum_from_then_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVarApps intDataCon_RDR [bh_RDR]) + (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], + nlHsVarApps intDataCon_RDR [bh_RDR]]) + (nlHsIntLit 0) + (nlHsVar (maxtag_RDR dflags tycon)) + )) + + from_enum dflags + = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $ + untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ + (nlHsVarApps intDataCon_RDR [ah_RDR]) + +{- +************************************************************************ +* * + Bounded instances +* * +************************************************************************ +-} + +gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) +gen_Bounded_binds loc tycon + | isEnumerationTyCon tycon + = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag) + | otherwise + = ASSERT(isSingleton data_cons) + (listToBag [ min_bound_1con, max_bound_1con ], emptyBag) + where + data_cons = tyConDataCons tycon + + ----- enum-flavored: --------------------------- + min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) + max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) + + data_con_1 = head data_cons + data_con_N = last data_cons + data_con_1_RDR = getRdrName data_con_1 + data_con_N_RDR = getRdrName data_con_N + + ----- single-constructor-flavored: ------------- + arity = dataConSourceArity data_con_1 + + min_bound_1con = mkHsVarBind loc minBound_RDR $ + nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR) + max_bound_1con = mkHsVarBind loc maxBound_RDR $ + nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR) + +{- +************************************************************************ +* * + Ix instances +* * +************************************************************************ + +Deriving @Ix@ is only possible for enumeration types and +single-constructor types. We deal with them in turn. + +For an enumeration type, e.g., +\begin{verbatim} + data Foo ... = N1 | N2 | ... | Nn +\end{verbatim} +things go not too differently from @Enum@: +\begin{verbatim} +instance ... Ix (Foo ...) where + range (a, b) + = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b] + + -- or, really... + range (a, b) + = case (con2tag_Foo a) of { a# -> + case (con2tag_Foo b) of { b# -> + map tag2con_Foo (enumFromTo (I# a#) (I# b#)) + }} + + -- Generate code for unsafeIndex, because using index leads + -- to lots of redundant range tests + unsafeIndex c@(a, b) d + = case (con2tag_Foo d -# con2tag_Foo a) of + r# -> I# r# + + inRange (a, b) c + = let + p_tag = con2tag_Foo c + in + p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b + + -- or, really... + inRange (a, b) c + = case (con2tag_Foo a) of { a_tag -> + case (con2tag_Foo b) of { b_tag -> + case (con2tag_Foo c) of { c_tag -> + if (c_tag >=# a_tag) then + c_tag <=# b_tag + else + False + }}} +\end{verbatim} +(modulo suitable case-ification to handle the unlifted tags) + +For a single-constructor type (NB: this includes all tuples), e.g., +\begin{verbatim} + data Foo ... = MkFoo a b Int Double c c +\end{verbatim} +we follow the scheme given in Figure~19 of the Haskell~1.2 report +(p.~147). +-} + +gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) + +gen_Ix_binds loc tycon = do + dflags <- getDynFlags + return $ if isEnumerationTyCon tycon + then (enum_ixes dflags, listToBag $ map DerivAuxBind + [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]) + else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon))) + where + -------------------------------------------------------------- + enum_ixes dflags = listToBag + [ enum_range dflags + , enum_index dflags + , enum_inRange dflags + ] + + enum_range dflags + = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ + untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ + untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ + nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ + nlHsPar (enum_from_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVarApps intDataCon_RDR [bh_RDR])) + + enum_index dflags + = mkSimpleGeneratedFunBind loc unsafeIndex_RDR + [noLoc (AsPat noExtField (noLoc c_RDR) + (nlTuplePat [a_Pat, nlWildPat] Boxed)), + d_Pat] ( + untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( + untag_Expr dflags tycon [(d_RDR, dh_RDR)] ( + let + rhs = nlHsVarApps intDataCon_RDR [c_RDR] + in + nlHsCase + (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR)) + [mkHsCaseAlt (nlVarPat c_RDR) rhs] + )) + ) + + -- This produces something like `(ch >= ah) && (ch <= bh)` + enum_inRange dflags + = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ + untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( + untag_Expr dflags tycon [(b_RDR, bh_RDR)] ( + untag_Expr dflags tycon [(c_RDR, ch_RDR)] ( + -- This used to use `if`, which interacts badly with RebindableSyntax. + -- See #11396. + nlHsApps and_RDR + [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR) + , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR) + ] + ))) + + -------------------------------------------------------------- + single_con_ixes + = listToBag [single_con_range, single_con_index, single_con_inRange] + + data_con + = case tyConSingleDataCon_maybe tycon of -- just checking... + Nothing -> panic "get_Ix_binds" + Just dc -> dc + + con_arity = dataConSourceArity data_con + data_con_RDR = getRdrName data_con + + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs + cs_needed = take con_arity cs_RDRs + + con_pat xs = nlConVarPat data_con_RDR xs + con_expr = nlHsVarApps data_con_RDR cs_needed + + -------------------------------------------------------------- + single_con_range + = mkSimpleGeneratedFunBind loc range_RDR + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ + noLoc (mkHsComp ListComp stmts con_expr) + where + stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed + + mk_qual a b c = noLoc $ mkPsBindStmt (nlVarPat c) + (nlHsApp (nlHsVar range_RDR) + (mkLHsVarTuple [a,b])) + + ---------------- + single_con_index + = mkSimpleGeneratedFunBind loc unsafeIndex_RDR + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, + con_pat cs_needed] + -- We need to reverse the order we consider the components in + -- so that + -- range (l,u) !! index (l,u) i == i -- when i is in range + -- (from http://haskell.org/onlinereport/ix.html) holds. + (mk_index (reverse $ zip3 as_needed bs_needed cs_needed)) + where + -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) + mk_index [] = nlHsIntLit 0 + mk_index [(l,u,i)] = mk_one l u i + mk_index ((l,u,i) : rest) + = genOpApp ( + mk_one l u i + ) plus_RDR ( + genOpApp ( + (nlHsApp (nlHsVar unsafeRangeSize_RDR) + (mkLHsVarTuple [l,u])) + ) times_RDR (mk_index rest) + ) + mk_one l u i + = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i] + + ------------------ + single_con_inRange + = mkSimpleGeneratedFunBind loc inRange_RDR + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, + con_pat cs_needed] $ + if con_arity == 0 + -- If the product type has no fields, inRange is trivially true + -- (see #12853). + then true_Expr + else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range + as_needed bs_needed cs_needed) + where + in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c] + +{- +************************************************************************ +* * + Read instances +* * +************************************************************************ + +Example + + infix 4 %% + data T = Int %% Int + | T1 { f1 :: Int } + | T2 T + +instance Read T where + readPrec = + parens + ( prec 4 ( + do x <- ReadP.step Read.readPrec + expectP (Symbol "%%") + y <- ReadP.step Read.readPrec + return (x %% y)) + +++ + prec (appPrec+1) ( + -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok + -- Record construction binds even more tightly than application + do expectP (Ident "T1") + expectP (Punc '{') + x <- Read.readField "f1" (ReadP.reset readPrec) + expectP (Punc '}') + return (T1 { f1 = x })) + +++ + prec appPrec ( + do expectP (Ident "T2") + x <- ReadP.step Read.readPrec + return (T2 x)) + ) + + readListPrec = readListPrecDefault + readList = readListDefault + + +Note [Use expectP] +~~~~~~~~~~~~~~~~~~ +Note that we use + expectP (Ident "T1") +rather than + Ident "T1" <- lexP +The latter desugares to inline code for matching the Ident and the +string, and this can be very voluminous. The former is much more +compact. Cf #7258, although that also concerned non-linearity in +the occurrence analyser, a separate issue. + +Note [Read for empty data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should we get for this? (#7931) + data Emp deriving( Read ) -- No data constructors + +Here we want + read "[]" :: [Emp] to succeed, returning [] +So we do NOT want + instance Read Emp where + readPrec = error "urk" +Rather we want + instance Read Emp where + readPred = pfail -- Same as choose [] + +Because 'pfail' allows the parser to backtrack, but 'error' doesn't. +These instances are also useful for Read (Either Int Emp), where +we want to be able to parse (Left 3) just fine. +-} + +gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon + -> (LHsBinds GhcPs, BagDerivStuff) + +gen_Read_binds get_fixity loc tycon + = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag) + where + ----------------------------------------------------------------------- + default_readlist + = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR) + + default_readlistprec + = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) + ----------------------------------------------------------------------- + + data_cons = tyConDataCons tycon + (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons + + read_prec = mkHsVarBind loc readPrec_RDR rhs + where + rhs | null data_cons -- See Note [Read for empty data types] + = nlHsVar pfail_RDR + | otherwise + = nlHsApp (nlHsVar parens_RDR) + (foldr1 mk_alt (read_nullary_cons ++ + read_non_nullary_cons)) + + read_non_nullary_cons = map read_non_nullary_con non_nullary_cons + + read_nullary_cons + = case nullary_cons of + [] -> [] + [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])] + _ -> [nlHsApp (nlHsVar choose_RDR) + (nlList (map mk_pair nullary_cons))] + -- NB For operators the parens around (:=:) are matched by the + -- enclosing "parens" call, so here we must match the naked + -- data_con_str con + + match_con con | isSym con_str = [symbol_pat con_str] + | otherwise = ident_h_pat con_str + where + con_str = data_con_str con + -- For nullary constructors we must match Ident s for normal constrs + -- and Symbol s for operators + + mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), + result_expr con []] + + read_non_nullary_con data_con + | is_infix = mk_parser infix_prec infix_stmts body + | is_record = mk_parser record_prec record_stmts body +-- Using these two lines instead allows the derived +-- read for infix and record bindings to read the prefix form +-- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body) +-- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body) + | otherwise = prefix_parser + where + body = result_expr data_con as_needed + con_str = data_con_str data_con + + prefix_parser = mk_parser prefix_prec prefix_stmts body + + read_prefix_con + | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"] + | otherwise = ident_h_pat con_str + + read_infix_con + | isSym con_str = [symbol_pat con_str] + | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"] + + prefix_stmts -- T a b c + = read_prefix_con ++ read_args + + infix_stmts -- a %% b, or a `T` b + = [read_a1] + ++ read_infix_con + ++ [read_a2] + + record_stmts -- T { f1 = a, f2 = b } + = read_prefix_con + ++ [read_punc "{"] + ++ concat (intersperse [read_punc ","] field_stmts) + ++ [read_punc "}"] + + field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed + + con_arity = dataConSourceArity data_con + labels = map flLabel $ dataConFieldLabels data_con + dc_nm = getName data_con + is_infix = dataConIsInfix data_con + is_record = labels `lengthExceeds` 0 + as_needed = take con_arity as_RDRs + read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con) + (read_a1:read_a2:_) = read_args + + prefix_prec = appPrecedence + infix_prec = getPrecedence get_fixity dc_nm + record_prec = appPrecedence + 1 -- Record construction binds even more tightly + -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2}) + + ------------------------------------------------------------------------ + -- Helpers + ------------------------------------------------------------------------ + mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 + mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) + , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])] + con_app con as = nlHsVarApps (getRdrName con) as -- con as + result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) + + -- For constructors and field labels ending in '#', we hackily + -- let the lexer generate two tokens, and look for both in sequence + -- Thus [Ident "I"; Symbol "#"]. See #5041 + ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] + | otherwise = [ ident_pat s ] + + bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p + -- See Note [Use expectP] + ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo") + symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>") + read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<") + + data_con_str con = occNameString (getOccName con) + + read_arg a ty = ASSERT( not (isUnliftedType ty) ) + noLoc (mkPsBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) + + -- When reading field labels we might encounter + -- a = 3 + -- _a = 3 + -- or (#) = 4 + -- Note the parens! + read_field lbl a = + [noLoc + (mkPsBindStmt + (nlVarPat a) + (nlHsApp + read_field + (nlHsVarApps reset_RDR [readPrec_RDR]) + ) + ) + ] + where + lbl_str = unpackFS lbl + mk_read_field read_field_rdr lbl + = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)] + read_field + | isSym lbl_str + = mk_read_field readSymField_RDR lbl_str + | Just (ss, '#') <- snocView lbl_str -- #14918 + = mk_read_field readFieldHash_RDR ss + | otherwise + = mk_read_field readField_RDR lbl_str + +{- +************************************************************************ +* * + Show instances +* * +************************************************************************ + +Example + + infixr 5 :^: + + data Tree a = Leaf a | Tree a :^: Tree a + + instance (Show a) => Show (Tree a) where + + showsPrec d (Leaf m) = showParen (d > app_prec) showStr + where + showStr = showString "Leaf " . showsPrec (app_prec+1) m + + showsPrec d (u :^: v) = showParen (d > up_prec) showStr + where + showStr = showsPrec (up_prec+1) u . + showString " :^: " . + showsPrec (up_prec+1) v + -- Note: right-associativity of :^: ignored + + up_prec = 5 -- Precedence of :^: + app_prec = 10 -- Application has precedence one more than + -- the most tightly-binding operator +-} + +gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon + -> (LHsBinds GhcPs, BagDerivStuff) + +gen_Show_binds get_fixity loc tycon + = (unitBag shows_prec, emptyBag) + where + data_cons = tyConDataCons tycon + shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons) + comma_space = nlHsVar showCommaSpace_RDR + + pats_etc data_con + | nullary_con = -- skip the showParen junk... + ASSERT(null bs_needed) + ([nlWildPat, con_pat], mk_showString_app op_con_str) + | otherwise = + ([a_Pat, con_pat], + showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit + (HsInt noExtField (mkIntegralLit con_prec_plus_one)))) + (nlHsPar (nested_compose_Expr show_thingies))) + where + data_con_RDR = getRdrName data_con + con_arity = dataConSourceArity data_con + bs_needed = take con_arity bs_RDRs + arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed + con_pat = nlConVarPat data_con_RDR bs_needed + nullary_con = con_arity == 0 + labels = map flLabel $ dataConFieldLabels data_con + lab_fields = length labels + record_syntax = lab_fields > 0 + + dc_nm = getName data_con + dc_occ_nm = getOccName data_con + con_str = occNameString dc_occ_nm + op_con_str = wrapOpParens con_str + backquote_str = wrapOpBackquotes con_str + + show_thingies + | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2] + | record_syntax = mk_showString_app (op_con_str ++ " {") : + show_record_args ++ [mk_showString_app "}"] + | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args + + show_label l = mk_showString_app (nm ++ " = ") + -- Note the spaces around the "=" sign. If we + -- don't have them then we get Foo { x=-1 } and + -- the "=-" parses as a single lexeme. Only the + -- space after the '=' is necessary, but it + -- seems tidier to have them both sides. + where + nm = wrapOpParens (unpackFS l) + + show_args = zipWithEqual "gen_Show_binds" show_arg bs_needed arg_tys + (show_arg1:show_arg2:_) = show_args + show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args + + -- Assumption for record syntax: no of fields == no of + -- labelled fields (and in same order) + show_record_args = concat $ + intersperse [comma_space] $ + [ [show_label lbl, arg] + | (lbl,arg) <- zipEqual "gen_Show_binds" + labels show_args ] + + show_arg :: RdrName -> Type -> LHsExpr GhcPs + show_arg b arg_ty + | isUnliftedType arg_ty + -- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer + = with_conv $ + nlHsApps compose_RDR + [mk_shows_app boxed_arg, mk_showString_app postfixMod] + | otherwise + = mk_showsPrec_app arg_prec arg + where + 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 + con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm + arg_prec | record_syntax = 0 -- Record fields don't need parens + | otherwise = con_prec_plus_one + +wrapOpParens :: String -> String +wrapOpParens s | isSym s = '(' : s ++ ")" + | otherwise = s + +wrapOpBackquotes :: String -> String +wrapOpBackquotes s | isSym s = s + | otherwise = '`' : s ++ "`" + +isSym :: String -> Bool +isSym "" = False +isSym (c : _) = startsVarSym c || startsConSym c + +-- | showString :: String -> ShowS +mk_showString_app :: String -> LHsExpr GhcPs +mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) + +-- | showsPrec :: Show a => Int -> a -> ShowS +mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs +mk_showsPrec_app p x + = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExtField (mkIntegralLit p)), x] + +-- | shows :: Show a => a -> ShowS +mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs +mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x + +getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer +getPrec is_infix get_fixity nm + | not is_infix = appPrecedence + | otherwise = getPrecedence get_fixity nm + +appPrecedence :: Integer +appPrecedence = fromIntegral maxPrecedence + 1 + -- One more than the precedence of the most + -- tightly-binding operator + +getPrecedence :: (Name -> Fixity) -> Name -> Integer +getPrecedence get_fixity nm + = case get_fixity nm of + Fixity _ x _assoc -> fromIntegral x + -- NB: the Report says that associativity is not taken + -- into account for either Read or Show; hence we + -- ignore associativity here + +{- +************************************************************************ +* * + Data instances +* * +************************************************************************ + +From the data type + + data T a b = T1 a b | T2 + +we generate + + $cT1 = mkDataCon $dT "T1" Prefix + $cT2 = mkDataCon $dT "T2" Prefix + $dT = mkDataType "Module.T" [] [$con_T1, $con_T2] + -- the [] is for field labels. + + instance (Data a, Data b) => Data (T a b) where + gfoldl k z (T1 a b) = z T `k` a `k` b + gfoldl k z T2 = z T2 + -- ToDo: add gmapT,Q,M, gfoldr + + gunfold k z c = case conIndex c of + I# 1# -> k (k (z T1)) + I# 2# -> z T2 + + toConstr (T1 _ _) = $cT1 + toConstr T2 = $cT2 + + dataTypeOf _ = $dT + + dataCast1 = gcast1 -- If T :: * -> * + dataCast2 = gcast2 -- if T :: * -> * -> * +-} + +gen_Data_binds :: SrcSpan + -> TyCon -- For data families, this is the + -- *representation* TyCon + -> TcM (LHsBinds GhcPs, -- The method bindings + BagDerivStuff) -- Auxiliary bindings +gen_Data_binds loc rep_tc + = do { dflags <- getDynFlags + + -- Make unique names for the data type and constructor + -- auxiliary bindings. Start with the name of the TyCon/DataCon + -- but that might not be unique: see #12245. + ; dt_occ <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc)) + ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName) + (tyConDataCons rep_tc) + ; let dt_rdr = mkRdrUnqual dt_occ + dc_rdrs = map mkRdrUnqual dc_occs + + -- OK, now do the work + ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) } + +gen_data :: DynFlags -> RdrName -> [RdrName] + -> SrcSpan -> TyCon + -> (LHsBinds GhcPs, -- The method bindings + BagDerivStuff) -- Auxiliary bindings +gen_data dflags data_type_name constr_names loc rep_tc + = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] + `unionBags` gcast_binds, + -- Auxiliary definitions: the data type and constructors + listToBag ( genDataTyCon + : zipWith genDataDataCon data_cons constr_names ) ) + where + data_cons = tyConDataCons rep_tc + n_cons = length data_cons + one_constr = n_cons == 1 + genDataTyCon :: DerivStuff + genDataTyCon -- $dT + = DerivHsBind (mkHsVarBind loc data_type_name rhs, + L loc (TypeSig noExtField [L loc data_type_name] sig_ty)) + + sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR) + ctx = initDefaultSDocContext dflags + rhs = nlHsVar mkDataType_RDR + `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (ppr rep_tc))) + `nlHsApp` nlList (map nlHsVar constr_names) + + genDataDataCon :: DataCon -> RdrName -> DerivStuff + genDataDataCon dc constr_name -- $cT1 etc + = DerivHsBind (mkHsVarBind loc constr_name rhs, + L loc (TypeSig noExtField [L loc constr_name] sig_ty)) + where + sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR) + rhs = nlHsApps mkConstr_RDR constr_args + + constr_args + = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag + nlHsVar (data_type_name) -- DataType + , nlHsLit (mkHsString (occNameString dc_occ)) -- String name + , nlList labels -- Field labels + , nlHsVar fixity ] -- Fixity + + labels = map (nlHsLit . mkHsString . unpackFS . flLabel) + (dataConFieldLabels dc) + dc_occ = getOccName dc + is_infix = isDataSymOcc dc_occ + fixity | is_infix = infix_RDR + | otherwise = prefix_RDR + + ------------ gfoldl + gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons) + + gfoldl_eqn con + = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed], + foldl' mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed) + where + con_name :: RdrName + con_name = getRdrName con + as_needed = take (dataConSourceArity con) as_RDRs + mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) + + ------------ gunfold + gunfold_bind = mkSimpleGeneratedFunBind loc + gunfold_RDR + [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat] + gunfold_rhs + + gunfold_rhs + | one_constr = mk_unfold_rhs (head data_cons) -- No need for case + | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) + (map gunfold_alt data_cons) + + gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) + mk_unfold_rhs dc = foldr nlHsApp + (z_Expr `nlHsApp` nlHsVar (getRdrName dc)) + (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) + + mk_unfold_pat dc -- Last one is a wild-pat, to avoid + -- redundant test, and annoying warning + | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor + | otherwise = nlConPat intDataCon_RDR + [nlLitPat (HsIntPrim NoSourceText (toInteger tag))] + where + tag = dataConTag dc + + ------------ toConstr + toCon_bind = mkFunBindEC 1 loc toConstr_RDR id + (zipWith to_con_eqn data_cons constr_names) + to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) + + ------------ dataTypeOf + dataTypeOf_bind = mkSimpleGeneratedFunBind + loc + dataTypeOf_RDR + [nlWildPat] + (nlHsVar data_type_name) + + ------------ gcast1/2 + -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> * + -- or dataCast2 x = gcast2 s -- if T :: * -> * -> * + -- (or nothing if T has neither of these two types) + + -- But care is needed for data families: + -- If we have data family D a + -- data instance D (a,b,c) = A | B deriving( Data ) + -- and we want instance ... => Data (D [(a,b,c)]) where ... + -- then we need dataCast1 x = gcast1 x + -- because D :: * -> * + -- even though rep_tc has kind * -> * -> * -> * + -- Hence looking for the kind of fam_tc not rep_tc + -- See #4896 + tycon_kind = case tyConFamInst_maybe rep_tc of + Just (fam_tc, _) -> tyConKind fam_tc + Nothing -> tyConKind rep_tc + gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR + | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR + | otherwise = emptyBag + mk_gcast dataCast_RDR gcast_RDR + = unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR] + (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)) + + +kind1, kind2 :: Kind +kind1 = typeToTypeKind +kind2 = liftedTypeKind `mkVisFunTy` kind1 + +gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, + mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, + dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR, + constr_RDR, dataType_RDR, + eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR , + eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , + eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR , + eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR , + eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR , + eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR , + eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR, + 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, + extendWord8_RDR, extendInt8_RDR, + extendWord16_RDR, extendInt16_RDR :: RdrName +gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") +gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") +toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") +dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf") +dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1") +dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2") +gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1") +gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2") +mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") +constr_RDR = tcQual_RDR gENERICS (fsLit "Constr") +mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") +dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType") +conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") +prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix") +infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") + +eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#") +ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#") +leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#") +gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#") +geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#") + +eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#") +ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" ) +leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#") +gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" ) +geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#") + +eqInt8_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt8#") +ltInt8_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt8#" ) +leInt8_RDR = varQual_RDR gHC_PRIM (fsLit "leInt8#") +gtInt8_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt8#" ) +geInt8_RDR = varQual_RDR gHC_PRIM (fsLit "geInt8#") + +eqInt16_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt16#") +ltInt16_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt16#" ) +leInt16_RDR = varQual_RDR gHC_PRIM (fsLit "leInt16#") +gtInt16_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt16#" ) +geInt16_RDR = varQual_RDR gHC_PRIM (fsLit "geInt16#") + +eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#") +ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#") +leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#") +gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#") +geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#") + +eqWord8_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord8#") +ltWord8_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord8#" ) +leWord8_RDR = varQual_RDR gHC_PRIM (fsLit "leWord8#") +gtWord8_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord8#" ) +geWord8_RDR = varQual_RDR gHC_PRIM (fsLit "geWord8#") + +eqWord16_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord16#") +ltWord16_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord16#" ) +leWord16_RDR = varQual_RDR gHC_PRIM (fsLit "leWord16#") +gtWord16_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord16#" ) +geWord16_RDR = varQual_RDR gHC_PRIM (fsLit "geWord16#") + +eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#") +ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#") +leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#") +gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#") +geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#") + +eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#") +ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#") +leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#") +gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#") +geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#") + +eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##") +ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" ) +leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##") +gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" ) +geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##") + +extendWord8_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord8#") +extendInt8_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt8#") + +extendWord16_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord16#") +extendInt16_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt16#") + + +{- +************************************************************************ +* * + Lift instances +* * +************************************************************************ + +Example: + + data Foo a = Foo a | a :^: a deriving Lift + + ==> + + instance (Lift a) => Lift (Foo a) where + lift (Foo a) = [| Foo a |] + lift ((:^:) u v) = [| (:^:) u v |] + + liftTyped (Foo a) = [|| Foo a ||] + liftTyped ((:^:) u v) = [|| (:^:) u v ||] +-} + + +gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) +gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag) + where + lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr) + (map (pats_etc mk_exp) data_cons) + liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr) + (map (pats_etc mk_texp) data_cons) + + mk_exp = ExpBr noExtField + mk_texp = TExpBr noExtField + data_cons = tyConDataCons tycon + + pats_etc mk_bracket data_con + = ([con_pat], lift_Expr) + where + con_pat = nlConVarPat data_con_RDR as_needed + data_con_RDR = getRdrName data_con + con_arity = dataConSourceArity data_con + as_needed = take con_arity as_RDRs + lift_Expr = noLoc (HsBracket noExtField (mk_bracket br_body)) + br_body = nlHsApps (Exact (dataConName data_con)) + (map nlHsVar as_needed) + +{- +************************************************************************ +* * + Newtype-deriving instances +* * +************************************************************************ + +Note [Newtype-deriving instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We take every method in the original instance and `coerce` it to fit +into the derived instance. We need type applications on the argument +to `coerce` to make it obvious what instantiation of the method we're +coercing from. So from, say, + + class C a b where + op :: forall c. a -> [b] -> c -> Int + + newtype T x = MkT + + instance C a => C a (T x) where + op :: forall c. a -> [T x] -> c -> Int + op = coerce @(a -> [] -> c -> Int) + @(a -> [T x] -> c -> Int) + op + +In addition to the type applications, we also have an explicit +type signature on the entire RHS. This brings the method-bound variable +`c` into scope over the two type applications. +See Note [GND and QuantifiedConstraints] for more information on why this +is important. + +Giving 'coerce' two explicitly-visible type arguments grants us finer control +over how it should be instantiated. Recall + + coerce :: Coercible a b => a -> b + +By giving it explicit type arguments we deal with the case where +'op' has a higher rank type, and so we must instantiate 'coerce' with +a polytype. E.g. + + class C a where op :: a -> forall b. b -> b + newtype T x = MkT + instance C => C (T x) where + op :: T x -> forall b. b -> b + op = coerce @( -> forall b. b -> b) + @(T x -> forall b. b -> b) + op + +The use of type applications is crucial here. If we had tried using only +explicit type signatures, like so: + + instance C => C (T x) where + op :: T x -> forall b. b -> b + op = coerce (op :: -> forall b. b -> b) + +Then GHC will attempt to deeply skolemize the two type signatures, which will +wreak havoc with the Coercible solver. Therefore, we instead use type +applications, which do not deeply skolemize and thus avoid this issue. +The downside is that we currently require -XImpredicativeTypes to permit this +polymorphic type instantiation, so we have to switch that flag on locally in +GHC.Tc.Deriv.genInst. See #8503 for more discussion. + +Note [Newtype-deriving trickiness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#12768): + class C a where { op :: D a => a -> a } + + instance C a => C [a] where { op = opList } + + opList :: (C a, D [a]) => [a] -> [a] + opList = ... + +Now suppose we try GND on this: + newtype N a = MkN [a] deriving( C ) + +The GND is expecting to get an implementation of op for N by +coercing opList, thus: + + instance C a => C (N a) where { op = opN } + + opN :: (C a, D (N a)) => N a -> N a + opN = coerce @([a] -> [a]) + @([N a] -> [N a] + opList :: D (N a) => [N a] -> [N a] + +But there is no reason to suppose that (D [a]) and (D (N a)) +are inter-coercible; these instances might completely different. +So GHC rightly rejects this code. + +Note [GND and QuantifiedConstraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example from #15290: + + class C m where + join :: m (m a) -> m a + + newtype T m a = MkT (m a) + + deriving instance + (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => + C (T m) + +The code that GHC used to generate for this was: + + instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => + C (T m) where + join = coerce @(forall a. m (m a) -> m a) + @(forall a. T m (T m a) -> T m a) + join + +This instantiates `coerce` at a polymorphic type, a form of impredicative +polymorphism, so we're already on thin ice. And in fact the ice breaks, +as we'll explain: + +The call to `coerce` gives rise to: + + Coercible (forall a. m (m a) -> m a) + (forall a. T m (T m a) -> T m a) + +And that simplified to the following implication constraint: + + forall a . m (T m a) ~R# m (m a) + +But because this constraint is under a `forall`, inside a type, we have to +prove it *without computing any term evidence* (hence the ). Alas, we +*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. + +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 +we can avoid this situation altogether. Instead of applying `coerce` to two +polymorphic types, we instead let an instance signature do the polymorphic +instantiation, and omit the `forall`s in the type applications. +More concretely, we generate the following code instead: + + instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => + C (T m) where + join :: forall a. T m (T m a) -> T m a + join = coerce @( m (m a) -> m a) + @(T m (T m a) -> T m a) + join + +Now the visible type arguments are both monotypes, so we don't need any of this +funny quantified constraint instantiation business. While this particular +example no longer uses impredicative instantiation, we still need to enable +ImpredicativeTypes to typecheck GND-generated code for class methods with +higher-rank types. See Note [Newtype-deriving instances]. + +You might think that that second @(T m (T m a) -> T m a) argument is redundant +in the presence of the instance signature, but in fact leaving it off will +break this example (from the T15290d test case): + + class C a where + c :: Int -> forall b. b -> a + + instance C Int + + instance C Age where + c :: Int -> forall b. b -> Age + c = coerce @(Int -> forall b. b -> Int) + c + +That is because the instance signature deeply skolemizes the forall-bound +`b`, which wreaks havoc with the `Coercible` solver. An additional visible type +argument of @(Int -> forall b. b -> Age) is enough to prevent this. + +Be aware that the use of an instance signature doesn't /solve/ this +problem; it just makes it less likely to occur. For example, if a class has +a truly higher-rank type like so: + + class CProblem m where + op :: (forall b. ... (m b) ...) -> Int + +Then the same situation will arise again. But at least it won't arise for the +common case of methods with ordinary, prenex-quantified types. + +Note [GND and ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~ +We make an effort to make the code generated through GND be robust w.r.t. +ambiguous type variables. As one example, consider the following example +(from #15637): + + class C a where f :: String + instance C () where f = "foo" + newtype T = T () deriving C + +A naïve attempt and generating a C T instance would be: + + instance C T where + f :: String + f = coerce @String @String f + +This isn't going to typecheck, however, since GHC doesn't know what to +instantiate the type variable `a` with in the call to `f` in the method body. +(Note that `f :: forall a. String`!) To compensate for the possibility of +ambiguity here, we explicitly instantiate `a` like so: + + instance C T where + f :: String + f = coerce @String @String (f @()) + +All better now. +-} + +gen_Newtype_binds :: SrcSpan + -> Class -- the class being derived + -> [TyVar] -- the tvs in the instance head (this includes + -- the tvs from both the class types and the + -- newtype itself) + -> [Type] -- instance head parameters (incl. newtype) + -> Type -- the representation type + -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff) +-- See Note [Newtype-deriving instances] +gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty + = do let ats = classATs cls + (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls) + atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats ) + mapM mk_atf_inst ats + return ( listToBag binds + , sigs + , listToBag $ map DerivFamInst atf_insts ) + where + -- For each class method, generate its derived binding and instance + -- signature. Using the first example from + -- Note [Newtype-deriving instances]: + -- + -- class C a b where + -- op :: forall c. a -> [b] -> c -> Int + -- + -- newtype T x = MkT + -- + -- Then we would generate below: + -- + -- instance C a => C a (T x) where + -- + mk_bind_and_sig :: Id -> (LHsBind GhcPs, LSig GhcPs) + mk_bind_and_sig meth_id + = ( -- The derived binding, e.g., + -- + -- op = coerce @(a -> [] -> c -> Int) + -- @(a -> [T x] -> c -> Int) + -- op + mkRdrFunBind loc_meth_RDR [mkSimpleMatch + (mkPrefixFunRhs loc_meth_RDR) + [] rhs_expr] + , -- The derived instance signature, e.g., + -- + -- op :: forall c. a -> [T x] -> c -> Int + L loc $ ClassOpSig noExtField False [loc_meth_RDR] + $ mkLHsSigType $ typeToLHsType to_ty + ) + where + Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id + (_, _, from_tau) = tcSplitSigmaTy from_ty + (_, _, to_tau) = tcSplitSigmaTy to_ty + + meth_RDR = getRdrName meth_id + loc_meth_RDR = L loc meth_RDR + + rhs_expr = nlHsVar (getRdrName coerceId) + `nlHsAppType` from_tau + `nlHsAppType` to_tau + `nlHsApp` meth_app + + -- The class method, applied to all of the class instance types + -- (including the representation type) to avoid potential ambiguity. + -- See Note [GND and ambiguity] + meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $ + filterOutInferredTypes (classTyCon cls) underlying_inst_tys + -- Filter out any inferred arguments, since they can't be + -- applied with visible type application. + + mk_atf_inst :: TyCon -> TcM FamInst + mk_atf_inst fam_tc = do + rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) + rep_lhs_tys + let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs' + fam_tc rep_lhs_tys rep_rhs_ty + -- Check (c) from Note [GND and associated type families] in GHC.Tc.Deriv + checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom) + newFamInst SynFamilyInst axiom + where + cls_tvs = classTyVars cls + in_scope = mkInScopeSet $ mkVarSet inst_tvs + lhs_env = zipTyEnv cls_tvs inst_tys + lhs_subst = mkTvSubst in_scope lhs_env + rhs_env = zipTyEnv cls_tvs underlying_inst_tys + rhs_subst = mkTvSubst in_scope rhs_env + fam_tvs = tyConTyVars fam_tc + rep_lhs_tys = substTyVars lhs_subst fam_tvs + rep_rhs_tys = substTyVars rhs_subst fam_tvs + rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys + rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys + (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs + rep_tvs' = scopedSort rep_tvs + rep_cvs' = scopedSort rep_cvs + + -- Same as inst_tys, but with the last argument type replaced by the + -- representation type. + underlying_inst_tys :: [Type] + underlying_inst_tys = changeLast inst_tys rhs_ty + +nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs +nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty) + where + hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s) + +nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs +nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty + where + hs_ty = mkLHsSigWcType (typeToLHsType s) + +mkCoerceClassMethEqn :: Class -- the class being derived + -> [TyVar] -- the tvs in the instance head (this includes + -- the tvs from both the class types and the + -- newtype itself) + -> [Type] -- instance head parameters (incl. newtype) + -> Type -- the representation type + -> Id -- the method to look at + -> Pair Type +-- See Note [Newtype-deriving instances] +-- See also Note [Newtype-deriving trickiness] +-- The pair is the (from_type, to_type), where to_type is +-- the type of the method we are trying to get +mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id + = Pair (substTy rhs_subst user_meth_ty) + (substTy lhs_subst user_meth_ty) + where + cls_tvs = classTyVars cls + in_scope = mkInScopeSet $ mkVarSet inst_tvs + lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys) + rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty)) + (_class_tvs, _class_constraint, user_meth_ty) + = tcSplitMethodTy (varType id) + +{- +************************************************************************ +* * +\subsection{Generating extra binds (@con2tag@ and @tag2con@)} +* * +************************************************************************ + +\begin{verbatim} +data Foo ... = ... + +con2tag_Foo :: Foo ... -> Int# +tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# +maxtag_Foo :: Int -- ditto (NB: not unlifted) +\end{verbatim} + +The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) +fiddling around. +-} + +genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec + -> (LHsBind GhcPs, LSig GhcPs) +genAuxBindSpec dflags loc (DerivCon2Tag tycon) + = (mkFunBindSE 0 loc rdr_name eqns, + L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) + where + rdr_name = con2tag_RDR dflags tycon + + sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $ + mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ + mkParentType tycon `mkVisFunTy` intPrimTy + + lots_of_constructors = tyConFamilySize tycon > 8 + -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS + -- but we don't do vectored returns any more. + + eqns | lots_of_constructors = [get_tag_eqn] + | otherwise = map mk_eqn (tyConDataCons tycon) + + get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr) + + mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs) + mk_eqn con = ([nlWildConPat con], + nlHsLit (HsIntPrim NoSourceText + (toInteger ((dataConTag con) - fIRST_TAG)))) + +genAuxBindSpec dflags loc (DerivTag2Con tycon) + = (mkFunBindSE 0 loc rdr_name + [([nlConVarPat intDataCon_RDR [a_RDR]], + nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], + L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) + where + sig_ty = mkLHsSigWcType $ L loc $ + XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ + intTy `mkVisFunTy` mkParentType tycon + + rdr_name = tag2con_RDR dflags tycon + +genAuxBindSpec dflags loc (DerivMaxTag tycon) + = (mkHsVarBind loc rdr_name rhs, + L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) + where + rdr_name = maxtag_RDR dflags tycon + sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy))) + rhs = nlHsApp (nlHsVar intDataCon_RDR) + (nlHsLit (HsIntPrim NoSourceText max_tag)) + max_tag = case (tyConDataCons tycon) of + data_cons -> toInteger ((length data_cons) - fIRST_TAG) + +type SeparateBagsDerivStuff = + -- AuxBinds and SYB bindings + ( Bag (LHsBind GhcPs, LSig GhcPs) + -- Extra family instances (used by Generic and DeriveAnyClass) + , Bag (FamInst) ) + +genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff +genAuxBinds dflags loc b = genAuxBinds' b2 where + (b1,b2) = partitionBagWith splitDerivAuxBind b + splitDerivAuxBind (DerivAuxBind x) = Left x + splitDerivAuxBind x = Right x + + rm_dups = foldr dup_check emptyBag + dup_check a b = if anyBag (== a) b then b else consBag a b + + genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff + genAuxBinds' = foldr f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1) + , emptyBag ) + f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff + f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before + f (DerivHsBind b) = add1 b + f (DerivFamInst t) = add2 t + + add1 x (a,b) = (x `consBag` a,b) + add2 x (a,b) = (a,x `consBag` b) + +mkParentType :: TyCon -> Type +-- Turn the representation tycon of a family into +-- a use of its family constructor +mkParentType tc + = case tyConFamInst_maybe tc of + Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc)) + Just (fam_tc,tys) -> mkTyConApp fam_tc tys + +{- +************************************************************************ +* * +\subsection{Utility bits for generating bindings} +* * +************************************************************************ +-} + +-- | Make a function binding. If no equations are given, produce a function +-- with the given arity that produces a stock error. +mkFunBindSE :: Arity -> SrcSpan -> RdrName + -> [([LPat GhcPs], LHsExpr GhcPs)] + -> LHsBind GhcPs +mkFunBindSE arity loc fun pats_and_exprs + = mkRdrFunBindSE arity (L loc fun) matches + where + matches = [mkMatch (mkPrefixFunRhs (L loc fun)) + (map (parenthesizePat appPrec) p) e + (noLoc emptyLocalBinds) + | (p,e) <-pats_and_exprs] + +mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] + -> LHsBind GhcPs +mkRdrFunBind fun@(L loc _fun_rdr) matches + = L loc (mkFunBind Generated 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 +-- argument that is passes to the given function to produce the right-hand +-- side. +mkFunBindEC :: Arity -> SrcSpan -> RdrName + -> (LHsExpr GhcPs -> LHsExpr GhcPs) + -> [([LPat GhcPs], LHsExpr GhcPs)] + -> LHsBind GhcPs +mkFunBindEC arity loc fun catch_all pats_and_exprs + = mkRdrFunBindEC arity catch_all (L loc fun) matches + where + matches = [ mkMatch (mkPrefixFunRhs (L loc fun)) + (map (parenthesizePat appPrec) p) e + (noLoc emptyLocalBinds) + | (p,e) <- pats_and_exprs ] + +-- | Produces a function binding. When no equations are given, it generates +-- a binding of the given arity and an empty case expression +-- for the last argument that it passes to the given function to produce +-- the right-hand side. +mkRdrFunBindEC :: Arity + -> (LHsExpr GhcPs -> LHsExpr GhcPs) + -> Located RdrName + -> [LMatch GhcPs (LHsExpr GhcPs)] + -> LHsBind GhcPs +mkRdrFunBindEC arity catch_all + fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches') + where + -- Catch-all eqn looks like + -- fmap _ z = case z of {} + -- or + -- traverse _ z = pure (case z of) + -- or + -- foldMap _ z = mempty + -- It's needed if there no data cons at all, + -- which can happen with -XEmptyDataDecls + -- See #4302 + matches' = if null matches + then [mkMatch (mkPrefixFunRhs fun) + (replicate (arity - 1) nlWildPat ++ [z_Pat]) + (catch_all $ nlHsCase z_Expr []) + (noLoc emptyLocalBinds)] + else matches + +-- | Produces a function binding. When there are no equations, it generates +-- a binding with the given arity that produces an error based on the name of +-- the type of the last argument. +mkRdrFunBindSE :: Arity -> Located RdrName -> + [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs +mkRdrFunBindSE arity + fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches') + where + -- Catch-all eqn looks like + -- compare _ _ = error "Void compare" + -- It's needed if there no data cons at all, + -- which can happen with -XEmptyDataDecls + -- See #4302 + matches' = if null matches + then [mkMatch (mkPrefixFunRhs fun) + (replicate arity nlWildPat) + (error_Expr str) (noLoc emptyLocalBinds)] + else matches + str = "Void " ++ occNameString (rdrNameOcc fun_rdr) + + +box :: String -- The class involved + -> LHsExpr GhcPs -- The argument + -> Type -- The argument type + -> LHsExpr GhcPs -- Boxed version of the arg +-- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer +box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg + +--------------------- +primOrdOps :: String -- The class involved + -> Type -- The type + -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt) +-- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer +primOrdOps str ty = assoc_ty_id str ordOpTbl ty + +ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] +ordOpTbl + = [(charPrimTy , (ltChar_RDR , leChar_RDR + , eqChar_RDR , geChar_RDR , gtChar_RDR )) + ,(intPrimTy , (ltInt_RDR , leInt_RDR + , eqInt_RDR , geInt_RDR , gtInt_RDR )) + ,(int8PrimTy , (ltInt8_RDR , leInt8_RDR + , eqInt8_RDR , geInt8_RDR , gtInt8_RDR )) + ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR + , eqInt16_RDR , geInt16_RDR , gtInt16_RDR )) + ,(wordPrimTy , (ltWord_RDR , leWord_RDR + , eqWord_RDR , geWord_RDR , gtWord_RDR )) + ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR + , eqWord8_RDR , geWord8_RDR , gtWord8_RDR )) + ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR + , eqWord16_RDR, geWord16_RDR, gtWord16_RDR )) + ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR + , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) + ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR + , eqFloat_RDR , geFloat_RDR , gtFloat_RDR )) + ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR + , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ] + +-- 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)) + , (intPrimTy , nlHsApp (nlHsVar $ getRdrName intDataCon)) + , (wordPrimTy , nlHsApp (nlHsVar $ getRdrName wordDataCon )) + , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon )) + , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon)) + , (int8PrimTy, + nlHsApp (nlHsVar $ getRdrName intDataCon) + . nlHsApp (nlHsVar extendInt8_RDR)) + , (word8PrimTy, + nlHsApp (nlHsVar $ getRdrName wordDataCon) + . nlHsApp (nlHsVar extendWord8_RDR)) + , (int16PrimTy, + nlHsApp (nlHsVar $ getRdrName intDataCon) + . nlHsApp (nlHsVar extendInt16_RDR)) + , (word16PrimTy, + nlHsApp (nlHsVar $ getRdrName wordDataCon) + . nlHsApp (nlHsVar extendWord16_RDR)) + ] + + +-- | A table of postfix modifiers for unboxed values. +postfixModTbl :: [(Type, String)] +postfixModTbl + = [(charPrimTy , "#" ) + ,(intPrimTy , "#" ) + ,(wordPrimTy , "##") + ,(floatPrimTy , "#" ) + ,(doublePrimTy, "##") + ,(int8PrimTy, "#") + ,(word8PrimTy, "##") + ,(int16PrimTy, "#") + ,(word16PrimTy, "##") + ] + +primConvTbl :: [(Type, String)] +primConvTbl = + [ (int8PrimTy, "narrowInt8#") + , (word8PrimTy, "narrowWord8#") + , (int16PrimTy, "narrowInt16#") + , (word16PrimTy, "narrowWord16#") + ] + +litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] +litConTbl + = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR)) + ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR) + . nlHsApp (nlHsVar toInteger_RDR)) + ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR) + . nlHsApp (nlHsVar toInteger_RDR)) + ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR) + . nlHsApp (nlHsApp + (nlHsVar map_RDR) + (compose_RDR `nlHsApps` + [ nlHsVar fromIntegral_RDR + , nlHsVar fromEnum_RDR + ]))) + ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR) + . nlHsApp (nlHsVar toRational_RDR)) + ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR) + . nlHsApp (nlHsVar toRational_RDR)) + ] + +-- | Lookup `Type` in an association list. +assoc_ty_id :: HasCallStack => String -- The class involved + -> [(Type,a)] -- The table + -> Type -- The type + -> a -- The result of the lookup +assoc_ty_id cls_str tbl ty + | Just a <- assoc_ty_id_maybe tbl ty = a + | otherwise = + pprPanic "Error in deriving:" + (text "Can't derive" <+> text cls_str <+> + text "for primitive type" <+> ppr ty) + +-- | Lookup `Type` in an association list. +assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a +assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl + +----------------------------------------------------------------------- + +and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +and_Expr a b = genOpApp a and_RDR b + +----------------------------------------------------------------------- + +eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +eq_Expr ty a b + | not (isUnliftedType ty) = genOpApp a eq_RDR b + | otherwise = genPrimOpApp a prim_eq b + where + (_, _, prim_eq, _, _) = primOrdOps "Eq" ty + +untag_Expr :: DynFlags -> TyCon -> [( RdrName, RdrName)] + -> LHsExpr GhcPs -> LHsExpr GhcPs +untag_Expr _ _ [] expr = expr +untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr + = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon) + [untag_this])) {-of-} + [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)] + +enum_from_to_Expr + :: LHsExpr GhcPs -> LHsExpr GhcPs + -> LHsExpr GhcPs +enum_from_then_to_Expr + :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs + -> LHsExpr GhcPs + +enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2 +enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2 + +showParen_Expr + :: LHsExpr GhcPs -> LHsExpr GhcPs + -> LHsExpr GhcPs + +showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 + +nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs + +nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty +nested_compose_Expr [e] = parenify e +nested_compose_Expr (e:es) + = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es) + +-- impossible_Expr is used in case RHSs that should never happen. +-- We generate these to keep the desugarer from complaining that they *might* happen! +error_Expr :: String -> LHsExpr GhcPs +error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string)) + +-- illegal_Expr is used when signalling error conditions in the RHS of a derived +-- method. It is currently only used by Enum.{succ,pred} +illegal_Expr :: String -> String -> String -> LHsExpr GhcPs +illegal_Expr meth tp msg = + nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg))) + +-- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you +-- to include the value of a_RDR in the error string. +illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs +illegal_toEnum_tag tp maxtag = + nlHsApp (nlHsVar error_RDR) + (nlHsApp (nlHsApp (nlHsVar append_RDR) + (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag (")))) + (nlHsApp (nlHsApp (nlHsApp + (nlHsVar showsPrec_RDR) + (nlHsIntLit 0)) + (nlHsVar a_RDR)) + (nlHsApp (nlHsApp + (nlHsVar append_RDR) + (nlHsLit (mkHsString ") is outside of enumeration's range (0,"))) + (nlHsApp (nlHsApp (nlHsApp + (nlHsVar showsPrec_RDR) + (nlHsIntLit 0)) + (nlHsVar maxtag)) + (nlHsLit (mkHsString ")")))))) + +parenify :: LHsExpr GhcPs -> LHsExpr GhcPs +parenify e@(L _ (HsVar _ _)) = e +parenify e = mkHsPar e + +-- genOpApp wraps brackets round the operator application, so that the +-- renamer won't subsequently try to re-associate it. +genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs +genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) + +genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs +genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2)) + +a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR + :: RdrName +a_RDR = mkVarUnqual (fsLit "a") +b_RDR = mkVarUnqual (fsLit "b") +c_RDR = mkVarUnqual (fsLit "c") +d_RDR = mkVarUnqual (fsLit "d") +f_RDR = mkVarUnqual (fsLit "f") +k_RDR = mkVarUnqual (fsLit "k") +z_RDR = mkVarUnqual (fsLit "z") +ah_RDR = mkVarUnqual (fsLit "a#") +bh_RDR = mkVarUnqual (fsLit "b#") +ch_RDR = mkVarUnqual (fsLit "c#") +dh_RDR = mkVarUnqual (fsLit "d#") + +as_RDRs, bs_RDRs, cs_RDRs :: [RdrName] +as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] +bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] +cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] + +a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr, + true_Expr, pure_Expr :: LHsExpr GhcPs +a_Expr = nlHsVar a_RDR +b_Expr = nlHsVar b_RDR +c_Expr = nlHsVar c_RDR +z_Expr = nlHsVar z_RDR +ltTag_Expr = nlHsVar ltTag_RDR +eqTag_Expr = nlHsVar eqTag_RDR +gtTag_Expr = nlHsVar gtTag_RDR +false_Expr = nlHsVar false_RDR +true_Expr = nlHsVar true_RDR +pure_Expr = nlHsVar pure_RDR + +a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs +a_Pat = nlVarPat a_RDR +b_Pat = nlVarPat b_RDR +c_Pat = nlVarPat c_RDR +d_Pat = nlVarPat d_RDR +k_Pat = nlVarPat k_RDR +z_Pat = nlVarPat z_RDR + +minusInt_RDR, tagToEnum_RDR :: RdrName +minusInt_RDR = getRdrName (primOpId IntSubOp ) +tagToEnum_RDR = getRdrName (primOpId TagToEnumOp) + +con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName +-- Generates Orig s RdrName, for the binding positions +con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc +tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc +maxtag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc + +mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName +mk_tc_deriv_name dflags tycon occ_fun = + mkAuxBinderName dflags (tyConName tycon) occ_fun + +mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName +-- ^ Make a top-level binder name for an auxiliary binding for a parent name +-- See Note [Auxiliary binders] +mkAuxBinderName dflags parent occ_fun + = mkRdrUnqual (occ_fun stable_parent_occ) + where + stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string + stable_string + | hasPprDebug dflags = parent_stable + | otherwise = parent_stable_hash + parent_stable = nameStableString parent + parent_stable_hash = + let Fingerprint high low = fingerprintString parent_stable + in toBase62 high ++ toBase62Padded low + -- See Note [Base 62 encoding 128-bit integers] in GHC.Utils.Encoding + parent_occ = nameOccName parent + + +{- +Note [Auxiliary binders] +~~~~~~~~~~~~~~~~~~~~~~~~ +We often want to make a top-level auxiliary binding. E.g. for comparison we have + + instance Ord T where + compare a b = $con2tag a `compare` $con2tag b + + $con2tag :: T -> Int + $con2tag = ...code.... + +Of course these top-level bindings should all have distinct name, and we are +generating RdrNames here. We can't just use the TyCon or DataCon to distinguish +because with standalone deriving two imported TyCons might both be called T! +(See #7947.) + +So we use package name, module name and the name of the parent +(T in this example) as part of the OccName we generate for the new binding. +To make the symbol names short we take a base62 hash of the full name. + +In the past we used the *unique* from the parent, but that's not stable across +recompilations as uniques are nondeterministic. +-} diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -0,0 +1,1039 @@ +{- +(c) The University of Glasgow 2011 + +-} + +{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | The deriving code for the Generic class +module GHC.Tc.Deriv.Generics + (canDoGenerics + , canDoGenerics1 + , GenericKind(..) + , gen_Generic_binds + , get_gen1_constrained_tys + ) +where + +import GHC.Prelude + +import GHC.Hs +import GHC.Core.Type +import GHC.Tc.Utils.TcType +import GHC.Tc.Deriv.Generate +import GHC.Tc.Deriv.Functor +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) +import GHC.Tc.Instance.Family +import GHC.Unit.Module ( moduleName, moduleNameFS + , moduleUnit, unitFS, getModule ) +import GHC.Iface.Env ( newGlobalBinder ) +import GHC.Types.Name hiding ( varName ) +import GHC.Types.Name.Reader +import GHC.Types.Basic +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.Types +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.Data.FastString +import GHC.Utils.Misc + +import Control.Monad (mplus) +import Data.List (zip4, partition) +import Data.Maybe (isJust) + +#include "HsVersions.h" + +{- +************************************************************************ +* * +\subsection{Bindings for the new generic deriving mechanism} +* * +************************************************************************ + +For the generic representation we need to generate: +\begin{itemize} +\item A Generic instance +\item A Rep type instance +\item Many auxiliary datatypes and instances for them (for the meta-information) +\end{itemize} +-} + +gen_Generic_binds :: GenericKind -> TyCon -> [Type] + -> TcM (LHsBinds GhcPs, FamInst) +gen_Generic_binds gk tc inst_tys = do + repTyInsts <- tc_mkRepFamInsts gk tc inst_tys + return (mkBindsRep gk tc, repTyInsts) + +{- +************************************************************************ +* * +\subsection{Generating representation types} +* * +************************************************************************ +-} + +get_gen1_constrained_tys :: TyVar -> Type -> [Type] +-- called by GHC.Tc.Deriv.Infer.inferConstraints; generates a list of +-- types, each of which must be a Functor in order for the Generic1 instance to +-- work. +get_gen1_constrained_tys argVar + = argTyFold argVar $ ArgTyAlg { ata_rec0 = const [] + , ata_par1 = [], ata_rec1 = const [] + , ata_comp = (:) } + +{- + +Note [Requirements for deriving Generic and Rep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the following, T, Tfun, and Targ are "meta-variables" ranging over type +expressions. + +(Generic T) and (Rep T) are derivable for some type expression T if the +following constraints are satisfied. + + (a) D is a type constructor *value*. In other words, D is either a type + constructor or it is equivalent to the head of a data family instance (up to + alpha-renaming). + + (b) D cannot have a "stupid context". + + (c) The right-hand side of D cannot include existential types, universally + quantified types, or "exotic" unlifted types. An exotic unlifted type + is one which is not listed in the definition of allowedUnliftedTy + (i.e., one for which we have no representation type). + See Note [Generics and unlifted types] + + (d) T :: *. + +(Generic1 T) and (Rep1 T) are derivable for some type expression T if the +following constraints are satisfied. + + (a),(b),(c) As above. + + (d) T must expect arguments, and its last parameter must have kind *. + + We use `a' to denote the parameter of D that corresponds to the last + parameter of T. + + (e) For any type-level application (Tfun Targ) in the right-hand side of D + where the head of Tfun is not a tuple constructor: + + (b1) `a' must not occur in Tfun. + + (b2) If `a' occurs in Targ, then Tfun :: * -> *. + +-} + +canDoGenerics :: TyCon -> Validity +-- canDoGenerics determines if Generic/Rep can be derived. +-- +-- Check (a) from Note [Requirements for deriving Generic and Rep] is taken +-- care of because canDoGenerics is applied to rep tycons. +-- +-- It returns IsValid if deriving is possible. It returns (NotValid reason) +-- if not. +canDoGenerics tc + = mergeErrors ( + -- Check (b) from Note [Requirements for deriving Generic and Rep]. + (if (not (null (tyConStupidTheta tc))) + then (NotValid (tc_name <+> text "must not have a datatype context")) + else IsValid) + -- See comment below + : (map bad_con (tyConDataCons tc))) + where + -- The tc can be a representation tycon. When we want to display it to the + -- user (in an error message) we should print its parent + tc_name = ppr $ case tyConFamInst_maybe tc of + Just (ptc, _) -> ptc + _ -> tc + + -- Check (c) from Note [Requirements for deriving Generic and Rep]. + -- + -- If any of the constructors has an exotic unlifted type as argument, + -- then we can't build the embedding-projection pair, because + -- it relies on instantiating *polymorphic* sum and product types + -- at the argument types of the constructors + bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc)) + then (NotValid (ppr dc <+> text + "must not have exotic unlifted or polymorphic arguments")) + else (if (not (isVanillaDataCon dc)) + then (NotValid (ppr dc <+> text "must be a vanilla data constructor")) + else IsValid) + + -- Nor can we do the job if it's an existential data constructor, + -- Nor if the args are polymorphic types (I don't think) + bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty)) + || not (isTauTy ty) + +-- Returns True the Type argument is an unlifted type which has a +-- corresponding generic representation type. For example, +-- (allowedUnliftedTy Int#) would return True since there is the UInt +-- representation type. +allowedUnliftedTy :: Type -> Bool +allowedUnliftedTy = isJust . unboxedRepRDRs + +mergeErrors :: [Validity] -> Validity +mergeErrors [] = IsValid +mergeErrors (NotValid s:t) = case mergeErrors t of + IsValid -> NotValid s + NotValid s' -> NotValid (s <> text ", and" $$ s') +mergeErrors (IsValid : t) = mergeErrors t + +-- A datatype used only inside of canDoGenerics1. It's the result of analysing +-- a type term. +data Check_for_CanDoGenerics1 = CCDG1 + { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in + -- this type? + , _ccdg1_errors :: Validity -- errors generated by this type + } + +{- + +Note [degenerate use of FFoldType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We use foldDataConArgs here only for its ability to treat tuples +specially. foldDataConArgs also tracks covariance (though it assumes all +higher-order type parameters are covariant) and has hooks for special handling +of functions and polytypes, but we do *not* use those. + +The key issue is that Generic1 deriving currently offers no sophisticated +support for functions. For example, we cannot handle + + data F a = F ((a -> Int) -> Int) + +even though a is occurring covariantly. + +In fact, our rule is harsh: a is simply not allowed to occur within the first +argument of (->). We treat (->) the same as any other non-tuple tycon. + +Unfortunately, this means we have to track "the parameter occurs in this type" +explicitly, even though foldDataConArgs is also doing this internally. + +-} + +-- canDoGenerics1 determines if a Generic1/Rep1 can be derived. +-- +-- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep] +-- are taken care of by the call to canDoGenerics. +-- +-- It returns IsValid if deriving is possible. It returns (NotValid reason) +-- if not. +canDoGenerics1 :: TyCon -> Validity +canDoGenerics1 rep_tc = + canDoGenerics rep_tc `andValid` additionalChecks + where + additionalChecks + -- check (d) from Note [Requirements for deriving Generic and Rep] + | null (tyConTyVars rep_tc) = NotValid $ + text "Data type" <+> quotes (ppr rep_tc) + <+> text "must have some type parameters" + + | otherwise = mergeErrors $ concatMap check_con data_cons + + data_cons = tyConDataCons rep_tc + check_con con = case check_vanilla con of + j@(NotValid {}) -> [j] + IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con + + bad :: DataCon -> SDoc -> SDoc + bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg + + check_vanilla :: DataCon -> Validity + check_vanilla con | isVanillaDataCon con = IsValid + | otherwise = NotValid (bad con existential) + + bmzero = CCDG1 False IsValid + bmbad con s = CCDG1 True $ NotValid $ bad con s + bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2) + + -- check (e) from Note [Requirements for deriving Generic and Rep] + -- See also Note [degenerate use of FFoldType] + ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1 + ft_check con = FT + { ft_triv = bmzero + + , ft_var = caseVar, ft_co_var = caseVar + + -- (component_0,component_1,...,component_n) + , ft_tup = \_ components -> if any _ccdg1_hasParam (init components) + then bmbad con wrong_arg + else foldr bmplus bmzero components + + -- (dom -> rng), where the head of ty is not a tuple tycon + , ft_fun = \dom rng -> -- cf #8516 + if _ccdg1_hasParam dom + then bmbad con wrong_arg + else bmplus dom rng + + -- (ty arg), where head of ty is neither (->) nor a tuple constructor and + -- the parameter of interest does not occur in ty + , ft_ty_app = \_ _ arg -> arg + + , ft_bad_app = bmbad con wrong_arg + , ft_forall = \_ body -> body -- polytypes are handled elsewhere + } + where + caseVar = CCDG1 True IsValid + + + existential = text "must not have existential arguments" + wrong_arg = text "applies a type to an argument involving the last parameter" + $$ text "but the applied type is not of kind * -> *" + +{- +************************************************************************ +* * +\subsection{Generating the RHS of a generic default method} +* * +************************************************************************ +-} + +type US = Int -- Local unique supply, just a plain Int +type Alt = (LPat GhcPs, LHsExpr GhcPs) + +-- GenericKind serves to mark if a datatype derives Generic (Gen0) or +-- Generic1 (Gen1). +data GenericKind = Gen0 | Gen1 + +-- as above, but with a payload of the TyCon's name for "the" parameter +data GenericKind_ = Gen0_ | Gen1_ TyVar + +-- as above, but using a single datacon's name for "the" parameter +data GenericKind_DC = Gen0_DC | Gen1_DC TyVar + +forgetArgVar :: GenericKind_DC -> GenericKind +forgetArgVar Gen0_DC = Gen0 +forgetArgVar Gen1_DC{} = Gen1 + +-- When working only within a single datacon, "the" parameter's name should +-- match that datacon's name for it. +gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC +gk2gkDC Gen0_ _ = Gen0_DC +gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d + + +-- Bindings for the Generic instance +mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs +mkBindsRep gk tycon = + unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn]) + `unionBags` + unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn]) + where + -- The topmost M1 (the datatype metadata) has the exact same type + -- across all cases of a from/to definition, and can be factored out + -- to save some allocations during typechecking. + -- See Note [Generics compilation speed tricks] + from_eqn = mkHsCaseAlt x_Pat $ mkM1_E + $ nlHsPar $ nlHsCase x_Expr from_matches + to_eqn = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches + + from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts] + to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ] + loc = srcLocSpan (getSrcLoc tycon) + datacons = tyConDataCons tycon + + (from01_RDR, to01_RDR) = case gk of + Gen0 -> (from_RDR, to_RDR) + Gen1 -> (from1_RDR, to1_RDR) + + -- Recurse over the sum first + from_alts, to_alts :: [Alt] + (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons + where gk_ = case gk of + Gen0 -> Gen0_ + Gen1 -> ASSERT(tyvars `lengthAtLeast` 1) + Gen1_ (last tyvars) + where tyvars = tyConTyVars tycon + +-------------------------------------------------------------------------------- +-- The type synonym instance and synonym +-- type instance Rep (D a b) = Rep_D a b +-- type Rep_D a b = ...representation type for D ... +-------------------------------------------------------------------------------- + +tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 + -> TyCon -- The type to generate representation for + -> [Type] -- The type(s) to which Generic(1) is applied + -- in the generated instance + -> TcM FamInst -- Generated representation0 coercion +tc_mkRepFamInsts gk tycon inst_tys = + -- Consider the example input tycon `D`, where data D a b = D_ a + -- Also consider `R:DInt`, where { data family D x y :: * -> * + -- ; data instance D Int a b = D_ a } + do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family) + fam_tc <- case gk of + Gen0 -> tcLookupTyCon repTyConName + Gen1 -> tcLookupTyCon rep1TyConName + + ; fam_envs <- tcGetFamInstEnvs + + ; let -- If the derived instance is + -- instance Generic (Foo x) + -- then: + -- `arg_ki` = *, `inst_ty` = Foo x :: * + -- + -- If the derived instance is + -- instance Generic1 (Bar x :: k -> *) + -- then: + -- `arg_k` = k, `inst_ty` = Bar x :: k -> * + (arg_ki, inst_ty) = case (gk, inst_tys) of + (Gen0, [inst_t]) -> (liftedTypeKind, inst_t) + (Gen1, [arg_k, inst_t]) -> (arg_k, inst_t) + _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys) + + ; let mbFamInst = tyConFamInst_maybe tycon + -- If we're examining a data family instance, we grab the parent + -- TyCon (ptc) and use it to determine the type arguments + -- (inst_args) for the data family *instance*'s type variables. + ptc = maybe tycon fst mbFamInst + (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd + $ tcSplitTyConApp inst_ty + + ; let -- `tyvars` = [a,b] + (tyvars, gk_) = case gk of + Gen0 -> (all_tyvars, Gen0_) + Gen1 -> ASSERT(not $ null all_tyvars) + (init all_tyvars, Gen1_ $ last all_tyvars) + where all_tyvars = tyConTyVars tycon + + -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * + ; repTy <- tc_mkRepTy gk_ tycon arg_ki + + -- `rep_name` is a name we generate for the synonym + ; mod <- getModule + ; loc <- getSrcSpanM + ; let tc_occ = nameOccName (tyConName tycon) + rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ + ; rep_name <- newGlobalBinder mod rep_occ loc + + -- We make sure to substitute the tyvars with their user-supplied + -- type arguments before generating the Rep/Rep1 instance, since some + -- of the tyvars might have been instantiated when deriving. + -- See Note [Generating a correctly typed Rep instance]. + ; let (env_tyvars, env_inst_args) + = case gk_ of + Gen0_ -> (tyvars, inst_args) + Gen1_ last_tv + -- See the "wrinkle" in + -- Note [Generating a correctly typed Rep instance] + -> ( last_tv : tyvars + , anyTypeOfKind (tyVarKind last_tv) : inst_args ) + env = zipTyEnv env_tyvars env_inst_args + in_scope = mkInScopeSet (tyCoVarsOfTypes inst_tys) + subst = mkTvSubst in_scope env + repTy' = substTyUnchecked subst repTy + tcv' = tyCoVarsOfTypeList inst_ty + (tv', cv') = partition isTyVar tcv' + tvs' = scopedSort tv' + cvs' = scopedSort cv' + axiom = mkSingleCoAxiom Nominal rep_name tvs' [] cvs' + fam_tc inst_tys repTy' + + ; newFamInst SynFamilyInst axiom } + +-------------------------------------------------------------------------------- +-- Type representation +-------------------------------------------------------------------------------- + +-- | See documentation of 'argTyFold'; that function uses the fields of this +-- type to interpret the structure of a type when that type is considered as an +-- argument to a constructor that is being represented with 'Rep1'. +data ArgTyAlg a = ArgTyAlg + { ata_rec0 :: (Type -> a) + , ata_par1 :: a, ata_rec1 :: (Type -> a) + , ata_comp :: (Type -> a -> a) + } + +-- | @argTyFold@ implements a generalised and safer variant of the @arg@ +-- function from Figure 3 in . @arg@ +-- is conceptually equivalent to: +-- +-- > arg t = case t of +-- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t +-- > App f [t'] | +-- > representable1 f && +-- > t' == argVar -> Rec1 f +-- > App f [t'] | +-- > representable1 f && +-- > t' has tyvars -> f :.: (arg t') +-- > _ -> Rec0 t +-- +-- where @argVar@ is the last type variable in the data type declaration we are +-- finding the representation for. +-- +-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to +-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and +-- @:.:@. +-- +-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for +-- some data types. The problematic case is when @t@ is an application of a +-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the +-- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in +-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some +-- representable1 checks have been relaxed, and others were moved to +-- @canDoGenerics1@. +argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a +argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0, + ata_par1 = mkPar1, ata_rec1 = mkRec1, + ata_comp = mkComp}) = + -- mkRec0 is the default; use it if there is no interesting structure + -- (e.g. occurrences of parameters or recursive occurrences) + \t -> maybe (mkRec0 t) id $ go t where + go :: Type -> -- type to fold through + Maybe a -- the result (e.g. representation type), unless it's trivial + go t = isParam `mplus` isApp where + + isParam = do -- handles parameters + t' <- getTyVar_maybe t + Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter + else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0 + + isApp = do -- handles applications + (phi, beta) <- tcSplitAppTy_maybe t + + let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta + + -- Does it have no interesting structure to represent? + if not interesting then Nothing + else -- Is the argument the parameter? Special case for mkRec1. + if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi + else mkComp phi `fmap` go beta -- It must be a composition. + + +tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 + GenericKind_ + -- The type to generate representation for + -> TyCon + -- The kind of the representation type's argument + -- See Note [Handling kinds in a Rep instance] + -> Kind + -- Generated representation0 type + -> TcM Type +tc_mkRepTy gk_ tycon k = + do + d1 <- tcLookupTyCon d1TyConName + c1 <- tcLookupTyCon c1TyConName + s1 <- tcLookupTyCon s1TyConName + rec0 <- tcLookupTyCon rec0TyConName + rec1 <- tcLookupTyCon rec1TyConName + par1 <- tcLookupTyCon par1TyConName + u1 <- tcLookupTyCon u1TyConName + v1 <- tcLookupTyCon v1TyConName + plus <- tcLookupTyCon sumTyConName + times <- tcLookupTyCon prodTyConName + comp <- tcLookupTyCon compTyConName + uAddr <- tcLookupTyCon uAddrTyConName + uChar <- tcLookupTyCon uCharTyConName + uDouble <- tcLookupTyCon uDoubleTyConName + uFloat <- tcLookupTyCon uFloatTyConName + uInt <- tcLookupTyCon uIntTyConName + uWord <- tcLookupTyCon uWordTyConName + + let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon + + md <- tcLookupPromDataCon metaDataDataConName + mc <- tcLookupPromDataCon metaConsDataConName + ms <- tcLookupPromDataCon metaSelDataConName + pPrefix <- tcLookupPromDataCon prefixIDataConName + pInfix <- tcLookupPromDataCon infixIDataConName + pLA <- tcLookupPromDataCon leftAssociativeDataConName + pRA <- tcLookupPromDataCon rightAssociativeDataConName + pNA <- tcLookupPromDataCon notAssociativeDataConName + pSUpk <- tcLookupPromDataCon sourceUnpackDataConName + pSNUpk <- tcLookupPromDataCon sourceNoUnpackDataConName + pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName + pSLzy <- tcLookupPromDataCon sourceLazyDataConName + pSStr <- tcLookupPromDataCon sourceStrictDataConName + pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName + pDLzy <- tcLookupPromDataCon decidedLazyDataConName + pDStr <- tcLookupPromDataCon decidedStrictDataConName + pDUpk <- tcLookupPromDataCon decidedUnpackDataConName + + fix_env <- getFixityEnv + + let mkSum' a b = mkTyConApp plus [k,a,b] + mkProd a b = mkTyConApp times [k,a,b] + mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a + mkRec1 a = mkTyConApp rec1 [k,a] + mkPar1 = mkTyConTy par1 + mkD a = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ] + mkC a = mkTyConApp c1 [ k + , metaConsTy a + , prod (dataConInstOrigArgTys a + . mkTyVarTys . tyConTyVars $ tycon) + (dataConSrcBangs a) + (dataConImplBangs a) + (dataConFieldLabels a)] + mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a] + + -- Sums and products are done in the same way for both Rep and Rep1 + sumP l = foldBal mkSum' (mkTyConApp v1 [k]) . map mkC $ l + -- The Bool is True if this constructor has labelled fields + prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type + prod l sb ib fl = foldBal mkProd (mkTyConApp u1 [k]) + [ ASSERT(null fl || lengthExceeds fl j) + arg t sb' ib' (if null fl + then Nothing + else Just (fl !! j)) + | (t,sb',ib',j) <- zip4 l sb ib [0..] ] + + arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type + arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of + -- Here we previously used Par0 if t was a type variable, but we + -- realized that we can't always guarantee that we are wrapping-up + -- all type variables in Par0. So we decided to stop using Par0 + -- altogether, and use Rec0 all the time. + Gen0_ -> mkRec0 t + Gen1_ argVar -> argPar argVar t + where + -- Builds argument representation for Rep1 (more complicated due to + -- the presence of composition). + argPar argVar = argTyFold argVar $ ArgTyAlg + {ata_rec0 = mkRec0, ata_par1 = mkPar1, + ata_rec1 = mkRec1, ata_comp = mkComp comp k} + + tyConName_user = case tyConFamInst_maybe tycon of + Just (ptycon, _) -> tyConName ptycon + Nothing -> tyConName tycon + + dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user + mdName = mkStrLitTy . moduleNameFS . moduleName + . nameModule . tyConName $ tycon + pkgName = mkStrLitTy . unitFS . moduleUnit + . nameModule . tyConName $ tycon + isNT = mkTyConTy $ if isNewTyCon tycon + then promotedTrueDataCon + else promotedFalseDataCon + + ctName = mkStrLitTy . occNameFS . nameOccName . dataConName + ctFix c + | dataConIsInfix c + = case lookupFixity fix_env (dataConName c) of + Fixity _ n InfixL -> buildFix n pLA + Fixity _ n InfixR -> buildFix n pRA + Fixity _ n InfixN -> buildFix n pNA + | otherwise = mkTyConTy pPrefix + buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc + , mkNumLitTy (fromIntegral n)] + + isRec c = mkTyConTy $ if dataConFieldLabels c `lengthExceeds` 0 + then promotedTrueDataCon + else promotedFalseDataCon + + selName = mkStrLitTy . flLabel + + mbSel Nothing = mkTyConApp promotedNothingDataCon [typeSymbolKind] + mbSel (Just s) = mkTyConApp promotedJustDataCon + [typeSymbolKind, selName s] + + metaDataTy = mkTyConApp md [dtName, mdName, pkgName, isNT] + metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c] + metaSelTy mlbl su ss ib = + mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness] + where + pSUpkness = mkTyConTy $ case su of + SrcUnpack -> pSUpk + SrcNoUnpack -> pSNUpk + NoSrcUnpack -> pNSUpkness + + pSStrness = mkTyConTy $ case ss of + SrcLazy -> pSLzy + SrcStrict -> pSStr + NoSrcStrict -> pNSStrness + + pDStrness = mkTyConTy $ case ib of + HsLazy -> pDLzy + HsStrict -> pDStr + HsUnpack{} -> pDUpk + + return (mkD tycon) + +mkComp :: TyCon -> Kind -> Type -> Type -> Type +mkComp comp k f g + | k1_first = mkTyConApp comp [k,liftedTypeKind,f,g] + | otherwise = mkTyConApp comp [liftedTypeKind,k,f,g] + where + -- Which of these is the case? + -- newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... + -- or newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... + -- We want to instantiate with k1=k, and k2=* + -- Reason for k2=*: see Note [Handling kinds in a Rep instance] + -- But we need to know which way round! + k1_first = k_first == p_kind_var + [k_first,_,_,_,p] = tyConTyVars comp + Just p_kind_var = getTyVar_maybe (tyVarKind p) + +-- Given the TyCons for each URec-related type synonym, check to see if the +-- given type is an unlifted type that generics understands. If so, return +-- its representation type. Otherwise, return Rec0. +-- See Note [Generics and unlifted types] +mkBoxTy :: TyCon -- UAddr + -> TyCon -- UChar + -> TyCon -- UDouble + -> TyCon -- UFloat + -> TyCon -- UInt + -> TyCon -- UWord + -> TyCon -- Rec0 + -> Kind -- What to instantiate Rec0's kind variable with + -> Type + -> Type +mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty + | ty `eqType` addrPrimTy = mkTyConApp uAddr [k] + | ty `eqType` charPrimTy = mkTyConApp uChar [k] + | ty `eqType` doublePrimTy = mkTyConApp uDouble [k] + | ty `eqType` floatPrimTy = mkTyConApp uFloat [k] + | ty `eqType` intPrimTy = mkTyConApp uInt [k] + | ty `eqType` wordPrimTy = mkTyConApp uWord [k] + | otherwise = mkTyConApp rec0 [k,ty] + +-------------------------------------------------------------------------------- +-- Dealing with sums +-------------------------------------------------------------------------------- + +mkSum :: GenericKind_ -- Generic or Generic1? + -> US -- Base for generating unique names + -> [DataCon] -- The data constructors + -> ([Alt], -- Alternatives for the T->Trep "from" function + [Alt]) -- Alternatives for the Trep->T "to" function + +-- Datatype without any constructors +mkSum _ _ [] = ([from_alt], [to_alt]) + where + from_alt = (x_Pat, nlHsCase x_Expr []) + to_alt = (x_Pat, nlHsCase x_Expr []) + -- These M1s are meta-information for the datatype + +-- Datatype with at least one constructor +mkSum gk_ us datacons = + -- switch the payload of gk_ to be datacon-centric instead of tycon-centric + unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d + | (d,i) <- zip datacons [1..] ] + +-- Build the sum for a particular constructor +mk1Sum :: GenericKind_DC -- Generic or Generic1? + -> US -- Base for generating unique names + -> Int -- The index of this constructor + -> Int -- Total number of constructors + -> DataCon -- The data constructor + -> (Alt, -- Alternative for the T->Trep "from" function + Alt) -- Alternative for the Trep->T "to" function +mk1Sum gk_ us i n datacon = (from_alt, to_alt) + where + gk = forgetArgVar gk_ + + -- Existentials already excluded + argTys = dataConOrigArgTys datacon + n_args = dataConSourceArity datacon + + datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys + datacon_vars = map fst datacon_varTys + + datacon_rdr = getRdrName datacon + + from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) + from_alt_rhs = genLR_E i n (mkProd_E gk_ datacon_varTys) + + to_alt = ( genLR_P i n (mkProd_P gk datacon_varTys) + , to_alt_rhs + ) -- These M1s are meta-information for the datatype + to_alt_rhs = case gk_ of + Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars + Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys + where + argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where + converter = argTyFold argVar $ ArgTyAlg + {ata_rec0 = nlHsVar . unboxRepRDR, + ata_par1 = nlHsVar unPar1_RDR, + ata_rec1 = const $ nlHsVar unRec1_RDR, + ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv) + `nlHsCompose` nlHsVar unComp1_RDR} + + +-- Generates the L1/R1 sum pattern +genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs +genLR_P i n p + | n == 0 = error "impossible" + | n == 1 = p + | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] + | otherwise = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] + where m = div n 2 + +-- Generates the L1/R1 sum expression +genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs +genLR_E i n e + | n == 0 = error "impossible" + | n == 1 = e + | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` + nlHsPar (genLR_E i (div n 2) e) + | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` + nlHsPar (genLR_E (i-m) (n-m) e) + where m = div n 2 + +-------------------------------------------------------------------------------- +-- Dealing with products +-------------------------------------------------------------------------------- + +-- Build a product expression +mkProd_E :: GenericKind_DC -- Generic or Generic1? + -> [(RdrName, Type)] + -- List of variables matched on the lhs and their types + -> LHsExpr GhcPs -- Resulting product expression +mkProd_E gk_ varTys = mkM1_E (foldBal prod (nlHsVar u1DataCon_RDR) appVars) + -- These M1s are meta-information for the constructor + where + appVars = map (wrapArg_E gk_) varTys + prod a b = prodDataCon_RDR `nlHsApps` [a,b] + +wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs +wrapArg_E Gen0_DC (var, ty) = mkM1_E $ + boxRepRDR ty `nlHsVarApps` [var] + -- This M1 is meta-information for the selector +wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ + converter ty `nlHsApp` nlHsVar var + -- This M1 is meta-information for the selector + where converter = argTyFold argVar $ ArgTyAlg + {ata_rec0 = nlHsVar . boxRepRDR, + ata_par1 = nlHsVar par1DataCon_RDR, + ata_rec1 = const $ nlHsVar rec1DataCon_RDR, + ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose` + (nlHsVar fmap_RDR `nlHsApp` cnv)} + +boxRepRDR :: Type -> RdrName +boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs + +unboxRepRDR :: Type -> RdrName +unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs + +-- Retrieve the RDRs associated with each URec data family instance +-- constructor. See Note [Generics and unlifted types] +unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName) +unboxedRepRDRs ty + | ty `eqType` addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR) + | ty `eqType` charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR) + | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR) + | ty `eqType` floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR) + | ty `eqType` intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR) + | ty `eqType` wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR) + | otherwise = Nothing + +-- Build a product pattern +mkProd_P :: GenericKind -- Gen0 or Gen1 + -> [(RdrName, Type)] -- List of variables to match, + -- along with their types + -> LPat GhcPs -- Resulting product pattern +mkProd_P gk varTys = mkM1_P (foldBal prod (nlNullaryConPat u1DataCon_RDR) appVars) + -- These M1s are meta-information for the constructor + where + appVars = unzipWith (wrapArg_P gk) varTys + prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b] + +wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs +wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v]) + -- This M1 is meta-information for the selector +wrapArg_P Gen1 v _ = nlParPat $ m1DataCon_RDR `nlConVarPat` [v] + +mkGenericLocal :: US -> RdrName +mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) + +x_RDR :: RdrName +x_RDR = mkVarUnqual (fsLit "x") + +x_Expr :: LHsExpr GhcPs +x_Expr = nlHsVar x_RDR + +x_Pat :: LPat GhcPs +x_Pat = nlVarPat x_RDR + +mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs +mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e + +mkM1_P :: LPat GhcPs -> LPat GhcPs +mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p] + +nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +nlHsCompose x y = compose_RDR `nlHsApps` [x, y] + +-- | Variant of foldr for producing balanced lists +foldBal :: (a -> a -> a) -> a -> [a] -> a +foldBal _ x [] = x +foldBal _ _ [y] = y +foldBal op x l = let (a,b) = splitAt (length l `div` 2) l + in foldBal op x a `op` foldBal op x b + +{- +Note [Generics and unlifted types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Normally, all constants are marked with K1/Rec0. The exception to this rule is +when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In +that case, we must use a data family instance of URec (from GHC.Generics) to +mark it. As a result, before we can generate K1 or unK1, we must first check +to see if the type is actually one of the unlifted types for which URec has a +data family instance; if so, we generate that instead. + +See wiki:commentary/compiler/generic-deriving#handling-unlifted-types for more +details on why URec is implemented the way it is. + +Note [Generating a correctly typed Rep instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving +Generic(1). That is, it derives the ellipsis in the following: + + instance Generic Foo where + type Rep Foo = ... + +However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which +a Generic(1) instance is being derived, not the fully instantiated type. As a +result, tc_mkRepTy builds the most generalized Rep(1) instance possible using +the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This +can cause problems when the instance has instantiated type variables +(see #11732). As an example: + + data T a = MkT a + deriving instance Generic (T Int) + ==> + instance Generic (T Int) where + type Rep (T Int) = (... (Rec0 a)) -- wrong! + +-XStandaloneDeriving is one way for the type variables to become instantiated. +Another way is when Generic1 is being derived for a datatype with a visible +kind binder, e.g., + + data P k (a :: k) = MkP k deriving Generic1 + ==> + instance Generic1 (P *) where + type Rep1 (P *) = (... (Rec0 k)) -- wrong! + +See Note [Unify kinds in deriving] in GHC.Tc.Deriv. + +In any such scenario, we must prevent a discrepancy between the LHS and RHS of +a Rep(1) instance. To do so, we create a type variable substitution that maps +the tyConTyVars of the TyCon to their counterparts in the fully instantiated +type. (For example, using T above as example, you'd map a :-> Int.) We then +apply the substitution to the RHS before generating the instance. + +A wrinkle in all of this: when forming the type variable substitution for +Generic1 instances, we map the last type variable of the tycon to Any. Why? +It's because of wily data types like this one (#15012): + + data T a = MkT (FakeOut a) + type FakeOut a = Int + +If we ignore a, then we'll produce the following Rep1 instance: + + instance Generic1 T where + type Rep1 T = ... (Rec0 (FakeOut a)) + ... + +Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we +ensure that `a` is mapped to Any: + + instance Generic1 T where + type Rep1 T = ... (Rec0 (FakeOut Any)) + ... + +And now all is good. + +Alternatively, we could have avoided this problem by expanding all type +synonyms on the RHSes of Rep1 instances. But we might blow up the size of +these types even further by doing this, so we choose not to do so. + +Note [Handling kinds in a Rep instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because Generic1 is poly-kinded, the representation types were generalized to +be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply +the kind of the instance being derived to all the representation type +constructors. For instance, if you have + + data Empty (a :: k) = Empty deriving Generic1 + +Then the generated code is now approximately (with -fprint-explicit-kinds +syntax): + + instance Generic1 k (Empty k) where + type Rep1 k (Empty k) = U1 k + +Most representation types have only one kind variable, making them easy to deal +with. The only non-trivial case is (:.:), which is only used in Generic1 +instances: + + newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) = + Comp1 { unComp1 :: f (g p) } + +Here, we do something a bit counter-intuitive: we make k1 be the kind of the +instance being derived, and we always make k2 be *. Why *? It's because +the code that GHC generates using (:.:) is always of the form x :.: Rec1 y +for some types x and y. In other words, the second type to which (:.:) is +applied always has kind k -> *, for some kind k, so k2 cannot possibly be +anything other than * in a generated Generic1 instance. + +Note [Generics compilation speed tricks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deriving Generic(1) is known to have a large constant factor during +compilation, which contributes to noticeable compilation slowdowns when +deriving Generic(1) for large datatypes (see #5642). + +To ease the pain, there is a trick one can play when generating definitions for +to(1) and from(1). If you have a datatype like: + + data Letter = A | B | C | D + +then a naïve Generic instance for Letter would be: + + instance Generic Letter where + type Rep Letter = D1 ('MetaData ...) ... + + to (M1 (L1 (L1 (M1 U1)))) = A + to (M1 (L1 (R1 (M1 U1)))) = B + to (M1 (R1 (L1 (M1 U1)))) = C + to (M1 (R1 (R1 (M1 U1)))) = D + + from A = M1 (L1 (L1 (M1 U1))) + from B = M1 (L1 (R1 (M1 U1))) + from C = M1 (R1 (L1 (M1 U1))) + from D = M1 (R1 (R1 (M1 U1))) + +Notice that in every LHS pattern-match of the 'to' definition, and in every RHS +expression in the 'from' definition, the topmost constructor is M1. This +corresponds to the datatype-specific metadata (the D1 in the Rep Letter +instance). But this is wasteful from a typechecking perspective, since this +definition requires GHC to typecheck an application of M1 in every single case, +leading to an O(n) increase in the number of coercions the typechecker has to +solve, which in turn increases allocations and degrades compilation speed. + +Luckily, since the topmost M1 has the exact same type across every case, we can +factor it out reduce the typechecker's burden: + + instance Generic Letter where + type Rep Letter = D1 ('MetaData ...) ... + + to (M1 x) = case x of + L1 (L1 (M1 U1)) -> A + L1 (R1 (M1 U1)) -> B + R1 (L1 (M1 U1)) -> C + R1 (R1 (M1 U1)) -> D + + from x = M1 (case x of + A -> L1 (L1 (M1 U1)) + B -> L1 (R1 (M1 U1)) + C -> R1 (L1 (M1 U1)) + D -> R1 (R1 (M1 U1))) + +A simple change, but one that pays off, since it goes turns an O(n) amount of +coercions to an O(1) amount. +-} diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -0,0 +1,1081 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + +-- | Functions for inferring (and simplifying) the context for derived instances. +module GHC.Tc.Deriv.Infer + ( inferConstraints + , simplifyInstanceContexts + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Types.Basic +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Utils.Error +import GHC.Tc.Utils.Instantiate +import GHC.Utils.Outputable +import GHC.Data.Pair +import GHC.Builtin.Names +import GHC.Tc.Deriv.Utils +import GHC.Tc.Utils.Env +import GHC.Tc.Deriv.Generate +import GHC.Tc.Deriv.Functor +import GHC.Tc.Deriv.Generics +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Utils.TcType +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr (pprTyVars) +import GHC.Core.Type +import GHC.Tc.Solver +import GHC.Tc.Validity (validDerivPred) +import GHC.Tc.Utils.Unify (buildImplicationFor, checkConstraints) +import GHC.Builtin.Types (typeToTypeKind) +import GHC.Core.Unify (tcUnifyTy) +import GHC.Utils.Misc +import GHC.Types.Var +import GHC.Types.Var.Set + +import Control.Monad +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ask) +import Data.List (sortBy) +import Data.Maybe + +---------------------- + +inferConstraints :: DerivSpecMechanism + -> DerivM ([ThetaOrigin], [TyVar], [TcType]) +-- inferConstraints figures out the constraints needed for the +-- instance declaration generated by a 'deriving' clause on a +-- data type declaration. It also returns the new in-scope type +-- variables and instance types, in case they were changed due to +-- the presence of functor-like constraints. +-- See Note [Inferring the instance context] + +-- e.g. inferConstraints +-- C Int (T [a]) -- Class and inst_tys +-- :RTList a -- Rep tycon and its arg tys +-- where T [a] ~R :RTList a +-- +-- Generate a sufficiently large set of constraints that typechecking the +-- generated method definitions should succeed. This set will be simplified +-- before being used in the instance declaration +inferConstraints mechanism + = do { DerivEnv { denv_tvs = tvs + , denv_cls = main_cls + , denv_inst_tys = inst_tys } <- ask + ; wildcard <- isStandaloneWildcardDeriv + ; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType]) + infer_constraints = + case mechanism of + DerivSpecStock{dsm_stock_dit = dit} + -> inferConstraintsStock dit + DerivSpecAnyClass + -> infer_constraints_simple inferConstraintsAnyclass + DerivSpecNewtype { dsm_newtype_dit = + DerivInstTys{dit_cls_tys = cls_tys} + , dsm_newtype_rep_ty = rep_ty } + -> infer_constraints_simple $ + inferConstraintsCoerceBased cls_tys rep_ty + DerivSpecVia { dsm_via_cls_tys = cls_tys + , dsm_via_ty = via_ty } + -> infer_constraints_simple $ + inferConstraintsCoerceBased cls_tys via_ty + + -- Most deriving strategies do not need to do anything special to + -- the type variables and arguments to the class in the derived + -- instance, so they can pass through unchanged. The exception to + -- this rule is stock deriving. See + -- Note [Inferring the instance context]. + infer_constraints_simple + :: DerivM [ThetaOrigin] + -> DerivM ([ThetaOrigin], [TyVar], [TcType]) + infer_constraints_simple infer_thetas = do + thetas <- infer_thetas + pure (thetas, tvs, inst_tys) + + -- Constraints arising from superclasses + -- See Note [Superclasses of derived instance] + cls_tvs = classTyVars main_cls + sc_constraints = ASSERT2( equalLength cls_tvs inst_tys + , ppr main_cls <+> ppr inst_tys ) + [ mkThetaOrigin (mkDerivOrigin wildcard) + TypeLevel [] [] [] $ + substTheta cls_subst (classSCTheta main_cls) ] + cls_subst = ASSERT( equalLength cls_tvs inst_tys ) + zipTvSubst cls_tvs inst_tys + + ; (inferred_constraints, tvs', inst_tys') <- infer_constraints + ; lift $ traceTc "inferConstraints" $ vcat + [ ppr main_cls <+> ppr inst_tys' + , ppr inferred_constraints + ] + ; return ( sc_constraints ++ inferred_constraints + , tvs', inst_tys' ) } + +-- | Like 'inferConstraints', but used only in the case of the @stock@ deriving +-- strategy. The constraints are inferred by inspecting the fields of each data +-- constructor. In this example: +-- +-- > data Foo = MkFoo Int Char deriving Show +-- +-- We would infer the following constraints ('ThetaOrigin's): +-- +-- > (Show Int, Show Char) +-- +-- Note that this function also returns the type variables ('TyVar's) and +-- class arguments ('TcType's) for the resulting instance. This is because +-- when deriving 'Functor'-like classes, we must sometimes perform kind +-- substitutions to ensure the resulting instance is well kinded, which may +-- affect the type variables and class arguments. In this example: +-- +-- > newtype Compose (f :: k -> Type) (g :: Type -> k) (a :: Type) = +-- > Compose (f (g a)) deriving stock Functor +-- +-- We must unify @k@ with @Type@ in order for the resulting 'Functor' instance +-- to be well kinded, so we return @[]@/@[Type, f, g]@ for the +-- 'TyVar's/'TcType's, /not/ @[k]@/@[k, f, g]@. +-- See Note [Inferring the instance context]. +inferConstraintsStock :: DerivInstTys + -> DerivM ([ThetaOrigin], [TyVar], [TcType]) +inferConstraintsStock (DerivInstTys { dit_cls_tys = cls_tys + , dit_tc = tc + , dit_tc_args = tc_args + , dit_rep_tc = rep_tc + , dit_rep_tc_args = rep_tc_args }) + = do DerivEnv { denv_tvs = tvs + , denv_cls = main_cls + , denv_inst_tys = inst_tys } <- ask + wildcard <- isStandaloneWildcardDeriv + + let inst_ty = mkTyConApp tc tc_args + tc_binders = tyConBinders rep_tc + choose_level bndr + | isNamedTyConBinder bndr = KindLevel + | otherwise = TypeLevel + t_or_ks = map choose_level tc_binders ++ repeat TypeLevel + -- want to report *kind* errors when possible + + -- Constraints arising from the arguments of each constructor + con_arg_constraints + :: (CtOrigin -> TypeOrKind + -> Type + -> [([PredOrigin], Maybe TCvSubst)]) + -> ([ThetaOrigin], [TyVar], [TcType]) + con_arg_constraints get_arg_constraints + = let (predss, mbSubsts) = unzip + [ preds_and_mbSubst + | data_con <- tyConDataCons rep_tc + , (arg_n, arg_t_or_k, arg_ty) + <- zip3 [1..] t_or_ks $ + dataConInstOrigArgTys data_con all_rep_tc_args + -- No constraints for unlifted types + -- See Note [Deriving and unboxed types] + , not (isUnliftedType arg_ty) + , let orig = DerivOriginDC data_con arg_n wildcard + , preds_and_mbSubst + <- get_arg_constraints orig arg_t_or_k arg_ty + ] + preds = concat predss + -- If the constraints require a subtype to be of kind + -- (* -> *) (which is the case for functor-like + -- constraints), then we explicitly unify the subtype's + -- kinds with (* -> *). + -- See Note [Inferring the instance context] + subst = foldl' composeTCvSubst + emptyTCvSubst (catMaybes mbSubsts) + unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst + && not (v `isInScope` subst)) tvs + (subst', _) = substTyVarBndrs subst unmapped_tvs + preds' = map (substPredOrigin subst') preds + inst_tys' = substTys subst' inst_tys + tvs' = tyCoVarsOfTypesWellScoped inst_tys' + in ([mkThetaOriginFromPreds preds'], tvs', inst_tys') + + is_generic = main_cls `hasKey` genClassKey + is_generic1 = main_cls `hasKey` gen1ClassKey + -- is_functor_like: see Note [Inferring the instance context] + is_functor_like = tcTypeKind inst_ty `tcEqKind` typeToTypeKind + || is_generic1 + + get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type + -> [([PredOrigin], Maybe TCvSubst)] + get_gen1_constraints functor_cls orig t_or_k ty + = mk_functor_like_constraints orig t_or_k functor_cls $ + get_gen1_constrained_tys last_tv ty + + get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type + -> [([PredOrigin], Maybe TCvSubst)] + get_std_constrained_tys orig t_or_k ty + | is_functor_like + = mk_functor_like_constraints orig t_or_k main_cls $ + deepSubtypesContaining last_tv ty + | otherwise + = [( [mk_cls_pred orig t_or_k main_cls ty] + , Nothing )] + + mk_functor_like_constraints :: CtOrigin -> TypeOrKind + -> Class -> [Type] + -> [([PredOrigin], Maybe TCvSubst)] + -- 'cls' is usually main_cls (Functor or Traversable etc), but if + -- main_cls = Generic1, then 'cls' can be Functor; see + -- get_gen1_constraints + -- + -- For each type, generate two constraints, + -- [cls ty, kind(ty) ~ (*->*)], and a kind substitution that results + -- from unifying kind(ty) with * -> *. If the unification is + -- successful, it will ensure that the resulting instance is well + -- kinded. If not, the second constraint will result in an error + -- message which points out the kind mismatch. + -- See Note [Inferring the instance context] + mk_functor_like_constraints orig t_or_k cls + = map $ \ty -> let ki = tcTypeKind ty in + ( [ mk_cls_pred orig t_or_k cls ty + , mkPredOrigin orig KindLevel + (mkPrimEqPred ki typeToTypeKind) ] + , tcUnifyTy ki typeToTypeKind + ) + + rep_tc_tvs = tyConTyVars rep_tc + last_tv = last rep_tc_tvs + -- When we first gather up the constraints to solve, most of them + -- contain rep_tc_tvs, i.e., the type variables from the derived + -- datatype's type constructor. We don't want these type variables + -- to appear in the final instance declaration, so we must + -- substitute each type variable with its counterpart in the derived + -- instance. rep_tc_args lists each of these counterpart types in + -- the same order as the type variables. + all_rep_tc_args + = rep_tc_args ++ map mkTyVarTy + (drop (length rep_tc_args) rep_tc_tvs) + + -- Stupid constraints + stupid_constraints + = [ mkThetaOrigin deriv_origin TypeLevel [] [] [] $ + substTheta tc_subst (tyConStupidTheta rep_tc) ] + tc_subst = -- See the comment with all_rep_tc_args for an + -- explanation of this assertion + ASSERT( equalLength rep_tc_tvs all_rep_tc_args ) + zipTvSubst rep_tc_tvs all_rep_tc_args + + -- Extra Data constraints + -- The Data class (only) requires that for + -- instance (...) => Data (T t1 t2) + -- IF t1:*, t2:* + -- THEN (Data t1, Data t2) are among the (...) constraints + -- Reason: when the IF holds, we generate a method + -- dataCast2 f = gcast2 f + -- and we need the Data constraints to typecheck the method + extra_constraints = [mkThetaOriginFromPreds constrs] + where + constrs + | main_cls `hasKey` dataClassKey + , all (isLiftedTypeKind . tcTypeKind) rep_tc_args + = [ mk_cls_pred deriv_origin t_or_k main_cls ty + | (t_or_k, ty) <- zip t_or_ks rep_tc_args] + | otherwise + = [] + + mk_cls_pred orig t_or_k cls ty + -- Don't forget to apply to cls_tys' too + = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty])) + cls_tys' | is_generic1 = [] + -- In the awkward Generic1 case, cls_tys' should be + -- empty, since we are applying the class Functor. + + | otherwise = cls_tys + + deriv_origin = mkDerivOrigin wildcard + + if -- Generic constraints are easy + | is_generic + -> return ([], tvs, inst_tys) + + -- Generic1 needs Functor + -- See Note [Getting base classes] + | is_generic1 + -> ASSERT( rep_tc_tvs `lengthExceeds` 0 ) + -- Generic1 has a single kind variable + ASSERT( cls_tys `lengthIs` 1 ) + do { functorClass <- lift $ tcLookupClass functorClassName + ; pure $ con_arg_constraints + $ get_gen1_constraints functorClass } + + -- The others are a bit more complicated + | otherwise + -> -- See the comment with all_rep_tc_args for an explanation of + -- this assertion + ASSERT2( equalLength rep_tc_tvs all_rep_tc_args + , ppr main_cls <+> ppr rep_tc + $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args ) + do { let (arg_constraints, tvs', inst_tys') + = con_arg_constraints get_std_constrained_tys + ; lift $ traceTc "inferConstraintsStock" $ vcat + [ ppr main_cls <+> ppr inst_tys' + , ppr arg_constraints + ] + ; return ( stupid_constraints ++ extra_constraints + ++ arg_constraints + , tvs', inst_tys') } + +-- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@, +-- which gathers its constraints based on the type signatures of the class's +-- methods instead of the types of the data constructor's field. +-- +-- See Note [Gathering and simplifying constraints for DeriveAnyClass] +-- for an explanation of how these constraints are used to determine the +-- derived instance context. +inferConstraintsAnyclass :: DerivM [ThetaOrigin] +inferConstraintsAnyclass + = do { DerivEnv { denv_cls = cls + , denv_inst_tys = inst_tys } <- ask + ; wildcard <- isStandaloneWildcardDeriv + + ; let gen_dms = [ (sel_id, dm_ty) + | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ] + + cls_tvs = classTyVars cls + + do_one_meth :: (Id, Type) -> TcM ThetaOrigin + -- (Id,Type) are the selector Id and the generic default method type + -- NB: the latter is /not/ quantified over the class variables + -- See Note [Gathering and simplifying constraints for DeriveAnyClass] + do_one_meth (sel_id, gen_dm_ty) + = do { let (sel_tvs, _cls_pred, meth_ty) + = tcSplitMethodTy (varType sel_id) + meth_ty' = substTyWith sel_tvs inst_tys meth_ty + (meth_tvs, meth_theta, meth_tau) + = tcSplitNestedSigmaTys meth_ty' + + gen_dm_ty' = substTyWith cls_tvs inst_tys gen_dm_ty + (dm_tvs, dm_theta, dm_tau) + = tcSplitNestedSigmaTys gen_dm_ty' + tau_eq = mkPrimEqPred meth_tau dm_tau + ; return (mkThetaOrigin (mkDerivOrigin wildcard) TypeLevel + meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) } + + ; theta_origins <- lift $ mapM do_one_meth gen_dms + ; return theta_origins } + +-- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and +-- @DerivingVia@. Since both strategies generate code involving 'coerce', the +-- inferred constraints set up the scaffolding needed to typecheck those uses +-- of 'coerce'. In this example: +-- +-- > newtype Age = MkAge Int deriving newtype Num +-- +-- We would infer the following constraints ('ThetaOrigin's): +-- +-- > (Num Int, Coercible Age Int) +inferConstraintsCoerceBased :: [Type] -> Type + -> DerivM [ThetaOrigin] +inferConstraintsCoerceBased cls_tys rep_ty = do + DerivEnv { denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = inst_tys } <- ask + sa_wildcard <- isStandaloneWildcardDeriv + let -- The following functions are polymorphic over the representation + -- type, since we might either give it the underlying type of a + -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type + -- (for DerivingVia). + rep_tys ty = cls_tys ++ [ty] + rep_pred ty = mkClassPred cls (rep_tys ty) + rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty) + -- rep_pred is the representation dictionary, from where + -- we are going to get all the methods for the final + -- dictionary + deriv_origin = mkDerivOrigin sa_wildcard + + -- Next we collect constraints for the class methods + -- If there are no methods, we don't need any constraints + -- Otherwise we need (C rep_ty), for the representation methods, + -- and constraints to coerce each individual method + meth_preds :: Type -> [PredOrigin] + meth_preds ty + | null meths = [] -- No methods => no constraints + -- (#12814) + | otherwise = rep_pred_o ty : coercible_constraints ty + meths = classMethods cls + coercible_constraints ty + = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard) + TypeLevel (mkReprPrimEqPred t1 t2) + | meth <- meths + , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs + inst_tys ty meth ] + + all_thetas :: Type -> [ThetaOrigin] + all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty] + + pure (all_thetas rep_ty) + +{- Note [Inferring the instance context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are two sorts of 'deriving', as represented by the two constructors +for DerivContext: + + * InferContext mb_wildcard: This can either be: + - The deriving clause for a data type. + (e.g, data T a = T1 a deriving( Eq )) + In this case, mb_wildcard = Nothing. + - A standalone declaration with an extra-constraints wildcard + (e.g., deriving instance _ => Eq (Foo a)) + In this case, mb_wildcard = Just loc, where loc is the location + of the extra-constraints wildcard. + + Here we must infer an instance context, + and generate instance declaration + instance Eq a => Eq (T a) where ... + + * SupplyContext theta: standalone deriving + deriving instance Eq a => Eq (T a) + Here we only need to fill in the bindings; + the instance context (theta) is user-supplied + +For the InferContext case, we must figure out the +instance context (inferConstraintsStock). Suppose we are inferring +the instance context for + C t1 .. tn (T s1 .. sm) +There are two cases + + * (T s1 .. sm) :: * (the normal case) + Then we behave like Eq and guess (C t1 .. tn t) + for each data constructor arg of type t. More + details below. + + * (T s1 .. sm) :: * -> * (the functor-like case) + Then we behave like Functor. + +In both cases we produce a bunch of un-simplified constraints +and them simplify them in simplifyInstanceContexts; see +Note [Simplifying the instance context]. + +In the functor-like case, we may need to unify some kind variables with * in +order for the generated instance to be well-kinded. An example from +#10524: + + newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) + = Compose (f (g a)) deriving Functor + +Earlier in the deriving pipeline, GHC unifies the kind of Compose f g +(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this +alone isn't enough, since k2 wasn't unified with *: + + instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) => + Functor (Compose f g) where ... + +The two Functor constraints are ill-kinded. To ensure this doesn't happen, we: + + 1. Collect all of a datatype's subtypes which require functor-like + constraints. + 2. For each subtype, create a substitution by unifying the subtype's kind + with (* -> *). + 3. Compose all the substitutions into one, then apply that substitution to + all of the in-scope type variables and the instance types. + +Note [Getting base classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Functor and Typeable are defined in package 'base', and that is not available +when compiling 'ghc-prim'. So we must be careful that 'deriving' for stuff in +ghc-prim does not use Functor or Typeable implicitly via these lookups. + +Note [Deriving and unboxed types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have some special hacks to support things like + data T = MkT Int# deriving ( Show ) + +Specifically, we use GHC.Tc.Deriv.Generate.box to box the Int# into an Int +(which we know how to show), and append a '#'. Parentheses are not required +for unboxed values (`MkT -3#` is a valid expression). + +Note [Superclasses of derived instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, a derived instance decl needs the superclasses of the derived +class too. So if we have + data T a = ...deriving( Ord ) +then the initial context for Ord (T a) should include Eq (T a). Often this is +redundant; we'll also generate an Ord constraint for each constructor argument, +and that will probably generate enough constraints to make the Eq (T a) constraint +be satisfied too. But not always; consider: + + data S a = S + instance Eq (S a) + instance Ord (S a) + + data T a = MkT (S a) deriving( Ord ) + instance Num a => Eq (T a) + +The derived instance for (Ord (T a)) must have a (Num a) constraint! +Similarly consider: + data T a = MkT deriving( Data ) +Here there *is* no argument field, but we must nevertheless generate +a context for the Data instances: + instance Typeable a => Data (T a) where ... + + +************************************************************************ +* * + Finding the fixed point of deriving equations +* * +************************************************************************ + +Note [Simplifying the instance context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T a b = C1 (Foo a) (Bar b) + | C2 Int (T b a) + | C3 (T a a) + deriving (Eq) + +We want to come up with an instance declaration of the form + + instance (Ping a, Pong b, ...) => Eq (T a b) where + x == y = ... + +It is pretty easy, albeit tedious, to fill in the code "...". The +trick is to figure out what the context for the instance decl is, +namely Ping, Pong and friends. + +Let's call the context reqd for the T instance of class C at types +(a,b, ...) C (T a b). Thus: + + Eq (T a b) = (Ping a, Pong b, ...) + +Now we can get a (recursive) equation from the data decl. This part +is done by inferConstraintsStock. + + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + + +Foo and Bar may have explicit instances for Eq, in which case we can +just substitute for them. Alternatively, either or both may have +their Eq instances given by deriving clauses, in which case they +form part of the system of equations. + +Now all we need do is simplify and solve the equations, iterating to +find the least fixpoint. This is done by simplifyInstanceConstraints. +Notice that the order of the arguments can +switch around, as here in the recursive calls to T. + +Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b. + +We start with: + + Eq (T a b) = {} -- The empty set + +Next iteration: + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + + After simplification: + = Eq a u Ping b u {} u {} u {} + = Eq a u Ping b + +Next iteration: + + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + + After simplification: + = Eq a u Ping b + u (Eq b u Ping a) + u (Eq a u Ping a) + + = Eq a u Ping b u Eq b u Ping a + +The next iteration gives the same result, so this is the fixpoint. We +need to make a canonical form of the RHS to ensure convergence. We do +this by simplifying the RHS to a form in which + + - the classes constrain only tyvars + - the list is sorted by tyvar (major key) and then class (minor key) + - no duplicates, of course + +Note [Deterministic simplifyInstanceContexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting +with nonDetCmpType puts the returned lists in a nondeterministic order. +If we were to return them, we'd get class constraints in +nondeterministic order. + +Consider: + + data ADT a b = Z a b deriving Eq + +The generated code could be either: + + instance (Eq a, Eq b) => Eq (Z a b) where + +Or: + + instance (Eq b, Eq a) => Eq (Z a b) where + +To prevent the order from being nondeterministic we only +canonicalize when comparing and return them in the same order as +simplifyDeriv returned them. +See also Note [nonDetCmpType nondeterminism] +-} + + +simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]] + -> TcM [DerivSpec ThetaType] +-- Used only for deriving clauses or standalone deriving with an +-- extra-constraints wildcard (InferContext) +-- See Note [Simplifying the instance context] + +simplifyInstanceContexts [] = return [] + +simplifyInstanceContexts infer_specs + = do { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs) + ; iterate_deriv 1 initial_solutions } + where + ------------------------------------------------------------------ + -- The initial solutions for the equations claim that each + -- instance has an empty context; this solution is certainly + -- in canonical form. + initial_solutions :: [ThetaType] + initial_solutions = [ [] | _ <- infer_specs ] + + ------------------------------------------------------------------ + -- iterate_deriv calculates the next batch of solutions, + -- compares it with the current one; finishes if they are the + -- same, otherwise recurses with the new solutions. + -- It fails if any iteration fails + iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType] + iterate_deriv n current_solns + | n > 20 -- Looks as if we are in an infinite loop + -- This can happen if we have -XUndecidableInstances + -- (See GHC.Tc.Solver.tcSimplifyDeriv.) + = pprPanic "solveDerivEqns: probable loop" + (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns) + | otherwise + = do { -- Extend the inst info from the explicit instance decls + -- with the current set of solutions, and simplify each RHS + inst_specs <- zipWithM newDerivClsInst current_solns infer_specs + ; new_solns <- checkNoErrs $ + extendLocalInstEnv inst_specs $ + mapM gen_soln infer_specs + + ; if (current_solns `eqSolution` new_solns) then + return [ spec { ds_theta = soln } + | (spec, soln) <- zip infer_specs current_solns ] + else + iterate_deriv (n+1) new_solns } + + eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b) + -- Canonicalise for comparison + -- See Note [Deterministic simplifyInstanceContexts] + canSolution = map (sortBy nonDetCmpType) + ------------------------------------------------------------------ + gen_soln :: DerivSpec [ThetaOrigin] -> TcM ThetaType + gen_soln (DS { ds_loc = loc, ds_tvs = tyvars + , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) + = setSrcSpan loc $ + addErrCtxt (derivInstCtxt the_pred) $ + do { theta <- simplifyDeriv the_pred tyvars deriv_rhs + -- checkValidInstance tyvars theta clas inst_tys + -- Not necessary; see Note [Exotic derived instance contexts] + + ; traceTc "GHC.Tc.Deriv" (ppr deriv_rhs $$ ppr theta) + -- Claim: the result instance declaration is guaranteed valid + -- Hence no need to call: + -- checkValidInstance tyvars theta clas inst_tys + ; return theta } + where + the_pred = mkClassPred clas inst_tys + +derivInstCtxt :: PredType -> MsgDoc +derivInstCtxt pred + = text "When deriving the instance for" <+> parens (ppr pred) + +{- +*********************************************************************************** +* * +* Simplify derived constraints +* * +*********************************************************************************** +-} + +-- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much +-- as possible. Fail if not possible. +simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are + -- deriving. Only used for SkolemInfo. + -> [TyVar] -- ^ The tyvars bound by @inst_ty@. + -> [ThetaOrigin] -- ^ Given and wanted constraints + -> TcM ThetaType -- ^ Needed constraints (after simplification), + -- i.e. @['PredType']@. +simplifyDeriv pred tvs thetas + = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize + -- The constraint solving machinery + -- expects *TcTyVars* not TyVars. + -- We use *non-overlappable* (vanilla) skolems + -- See Note [Overlap and deriving] + + ; let skol_set = mkVarSet tvs_skols + skol_info = DerivSkol pred + doc = text "deriving" <+> parens (ppr pred) + + mk_given_ev :: PredType -> TcM EvVar + mk_given_ev given = + let given_pred = substTy skol_subst given + in newEvVar given_pred + + emit_wanted_constraints :: [TyVar] -> [PredOrigin] -> TcM () + emit_wanted_constraints metas_to_be preds + = do { -- We instantiate metas_to_be with fresh meta type + -- variables. Currently, these can only be type variables + -- quantified in generic default type signatures. + -- See Note [Gathering and simplifying constraints for + -- DeriveAnyClass] + (meta_subst, _meta_tvs) <- newMetaTyVars metas_to_be + + -- Now make a constraint for each of the instantiated predicates + ; let wanted_subst = skol_subst `unionTCvSubst` meta_subst + mk_wanted_ct (PredOrigin wanted orig t_or_k) + = do { ev <- newWanted orig (Just t_or_k) $ + substTyUnchecked wanted_subst wanted + ; return (mkNonCanonical ev) } + ; cts <- mapM mk_wanted_ct preds + + -- And emit them into the monad + ; emitSimples (listToCts cts) } + + -- Create the implications we need to solve. For stock and newtype + -- deriving, these implication constraints will be simple class + -- constraints like (C a, Ord b). + -- But with DeriveAnyClass, we make an implication constraint. + -- See Note [Gathering and simplifying constraints for DeriveAnyClass] + mk_wanteds :: ThetaOrigin -> TcM WantedConstraints + mk_wanteds (ThetaOrigin { to_anyclass_skols = ac_skols + , to_anyclass_metas = ac_metas + , to_anyclass_givens = ac_givens + , to_wanted_origins = preds }) + = do { ac_given_evs <- mapM mk_given_ev ac_givens + ; (_, wanteds) + <- captureConstraints $ + checkConstraints skol_info ac_skols ac_given_evs $ + -- The checkConstraints bumps the TcLevel, and + -- wraps the wanted constraints in an implication, + -- when (but only when) necessary + emit_wanted_constraints ac_metas preds + ; pure wanteds } + + -- See [STEP DAC BUILD] + -- Generate the implication constraints, one for each method, to solve + -- with the skolemized variables. Start "one level down" because + -- we are going to wrap the result in an implication with tvs_skols, + -- in step [DAC RESIDUAL] + ; (tc_lvl, wanteds) <- pushTcLevelM $ + mapM mk_wanteds thetas + + ; traceTc "simplifyDeriv inputs" $ + vcat [ pprTyVars tvs $$ ppr thetas $$ ppr wanteds, doc ] + + -- See [STEP DAC SOLVE] + -- Simplify the constraints, starting at the same level at which + -- they are generated (c.f. the call to runTcSWithEvBinds in + -- simplifyInfer) + ; solved_wanteds <- setTcLevel tc_lvl $ + runTcSDeriveds $ + solveWantedsAndDrop $ + unionsWC wanteds + + -- It's not yet zonked! Obviously zonk it before peering at it + ; solved_wanteds <- zonkWC solved_wanteds + + -- See [STEP DAC HOIST] + -- From the simplified constraints extract a subset 'good' that will + -- become the context 'min_theta' for the derived instance. + ; let residual_simple = approximateWC True solved_wanteds + good = mapMaybeBag get_good residual_simple + + -- 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. + get_good :: Ct -> Maybe PredType + get_good ct | validDerivPred skol_set p + , isWantedCt ct + = Just p + -- TODO: This is wrong + -- NB re 'isWantedCt': residual_wanted may contain + -- unsolved CtDerived and we stick them into the + -- bad set so that reportUnsolved may decide what + -- to do with them + | otherwise + = Nothing + where p = ctPred ct + + ; traceTc "simplifyDeriv outputs" $ + vcat [ ppr tvs_skols, ppr residual_simple, ppr good ] + + -- Return the good unsolved constraints (unskolemizing on the way out.) + ; let min_theta = mkMinimalBySCs id (bagToList good) + -- An important property of mkMinimalBySCs (used above) is that in + -- addition to removing constraints that are made redundant by + -- superclass relationships, it also removes _duplicate_ + -- constraints. + -- See Note [Gathering and simplifying constraints for + -- DeriveAnyClass] + subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs + -- The reverse substitution (sigh) + + -- See [STEP DAC RESIDUAL] + -- Ensure that min_theta is enough to solve /all/ the constraints in + -- solved_wanteds, by solving the implication constraint + -- + -- forall tvs. min_theta => solved_wanteds + ; min_theta_vars <- mapM newEvVar min_theta + ; (leftover_implic, _) + <- buildImplicationFor tc_lvl skol_info tvs_skols + 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. + ; simplifyTopImplic leftover_implic + + ; return (substTheta subst_skol min_theta) } + +{- +Note [Overlap and deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider some overlapping instances: + instance Show a => Show [a] where .. + instance Show [Char] where ... + +Now a data type with deriving: + data T a = MkT [a] deriving( Show ) + +We want to get the derived instance + instance Show [a] => Show (T a) where... +and NOT + instance Show a => Show (T a) where... +so that the (Show (T Char)) instance does the Right Thing + +It's very like the situation when we're inferring the type +of a function + f x = show [x] +and we want to infer + f :: Show [a] => a -> String + +BOTTOM LINE: use vanilla, non-overlappable skolems when inferring + the context for the derived instance. + Hence tcInstSkolTyVars not tcInstSuperSkolTyVars + +Note [Gathering and simplifying constraints for DeriveAnyClass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +DeriveAnyClass works quite differently from stock and newtype deriving in +the way it gathers and simplifies constraints to be used in a derived +instance's context. Stock and newtype deriving gather constraints by looking +at the data constructors of the data type for which we are deriving an +instance. But DeriveAnyClass doesn't need to know about a data type's +definition at all! + +To see why, consider this example of DeriveAnyClass: + + class Foo a where + bar :: forall b. Ix b => a -> b -> String + default bar :: (Show a, Ix c) => a -> c -> String + bar x y = show x ++ show (range (y,y)) + + baz :: Eq a => a -> a -> Bool + default baz :: (Ord a, Show a) => a -> a -> Bool + baz x y = compare x y == EQ + +Because 'bar' and 'baz' have default signatures, this generates a top-level +definition for these generic default methods + + $gdm_bar :: forall a. Foo a + => forall c. (Show a, Ix c) + => a -> c -> String + $gdm_bar x y = show x ++ show (range (y,y)) + +(and similarly for baz). Now consider a 'deriving' clause + data Maybe s = ... deriving Foo + +This derives an instance of the form: + instance (CX) => Foo (Maybe s) where + bar = $gdm_bar + baz = $gdm_baz + +Now it is GHC's job to fill in a suitable instance context (CX). If +GHC were typechecking the binding + bar = $gdm bar +it would + * skolemise the expected type of bar + * instantiate the type of $gdm_bar with meta-type variables + * build an implication constraint + +[STEP DAC BUILD] +So that's what we do. We build the constraint (call it C1) + + forall[2] b. Ix b => (Show (Maybe s), Ix cc, + Maybe s -> b -> String + ~ Maybe s -> cc -> String) + +Here: +* The level of this forall constraint is forall[2], because we are later + going to wrap it in a forall[1] in [STEP DAC RESIDUAL] + +* The 'b' comes from the quantified type variable in the expected type + of bar (i.e., 'to_anyclass_skols' in 'ThetaOrigin'). The 'cc' is a unification + variable that comes from instantiating the quantified type variable 'c' in + $gdm_bar's type (i.e., 'to_anyclass_metas' in 'ThetaOrigin). + +* The (Ix b) constraint comes from the context of bar's type + (i.e., 'to_wanted_givens' in 'ThetaOrigin'). The (Show (Maybe s)) and (Ix cc) + constraints come from the context of $gdm_bar's type + (i.e., 'to_anyclass_givens' in 'ThetaOrigin'). + +* The equality constraint (Maybe s -> b -> String) ~ (Maybe s -> cc -> String) + comes from marrying up the instantiated type of $gdm_bar with the specified + type of bar. Notice that the type variables from the instance, 's' in this + case, are global to this constraint. + +Note that it is vital that we instantiate the `c` in $gdm_bar's type with a new +unification variable for each iteration of simplifyDeriv. If we re-use the same +unification variable across multiple iterations, then bad things can happen, +such as #14933. + +Similarly for 'baz', giving the constraint C2 + + forall[2]. Eq (Maybe s) => (Ord a, Show a, + Maybe s -> Maybe s -> Bool + ~ Maybe s -> Maybe s -> Bool) + +In this case baz has no local quantification, so the implication +constraint has no local skolems and there are no unification +variables. + +[STEP DAC SOLVE] +We can combine these two implication constraints into a single +constraint (C1, C2), and simplify, unifying cc:=b, to get: + + forall[2] b. Ix b => Show a + /\ + forall[2]. Eq (Maybe s) => (Ord a, Show a) + +[STEP DAC HOIST] +Let's call that (C1', C2'). Now we need to hoist the unsolved +constraints out of the implications to become our candidate for +(CX). That is done by approximateWC, which will return: + + (Show a, Ord a, Show a) + +Now we can use mkMinimalBySCs to remove superclasses and duplicates, giving + + (Show a, Ord a) + +And that's what GHC uses for CX. + +[STEP DAC RESIDUAL] +In this case we have solved all the leftover constraints, but what if +we don't? Simple! We just form the final residual constraint + + forall[1] s. CX => (C1',C2') + +and simplify that. In simple cases it'll succeed easily, because CX +literally contains the constraints in C1', C2', but if there is anything +more complicated it will be reported in a civilised way. + +Note [Error reporting for deriving clauses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A surprisingly tricky aspect of deriving to get right is reporting sensible +error messages. In particular, if simplifyDeriv reaches a constraint that it +cannot solve, which might include: + +1. Insoluble constraints +2. "Exotic" constraints (See Note [Exotic derived instance contexts]) + +Then we report an error immediately in simplifyDeriv. + +Another possible choice is to punt and let another part of the typechecker +(e.g., simplifyInstanceContexts) catch the errors. But this tends to lead +to worse error messages, so we do it directly in simplifyDeriv. + +simplifyDeriv checks for errors in a clever way. If the deriving machinery +infers the context (Foo a)--that is, if this instance is to be generated: + + instance Foo a => ... + +Then we form an implication of the form: + + forall a. Foo a => + +And pass it to the simplifier. If the context (Foo a) is enough to discharge +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 new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -0,0 +1,1111 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE TypeFamilies #-} + +-- | Error-checking and other utilities for @deriving@ clauses or declarations. +module GHC.Tc.Deriv.Utils ( + DerivM, DerivEnv(..), + DerivSpec(..), pprDerivSpec, DerivInstTys(..), + DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock, + isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia, + DerivContext(..), OriginativeDerivStatus(..), + isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin, + PredOrigin(..), ThetaOrigin(..), mkPredOrigin, + mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin, + checkOriginativeSideConditions, hasStockDeriving, + canDeriveAnyClass, + std_class_via_coercible, non_coercible_class, + newDerivClsInst, extendLocalInstEnv + ) where + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Types.Basic +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Driver.Session +import GHC.Utils.Error +import GHC.Driver.Types (lookupFixity, mi_fix) +import GHC.Hs +import GHC.Tc.Utils.Instantiate +import GHC.Core.InstEnv +import GHC.Iface.Load (loadInterfaceForName) +import GHC.Unit.Module (getModule) +import GHC.Types.Name +import GHC.Utils.Outputable +import GHC.Builtin.Names +import GHC.Types.SrcLoc +import GHC.Tc.Deriv.Generate +import GHC.Tc.Deriv.Functor +import GHC.Tc.Deriv.Generics +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Builtin.Names.TH (liftClassKey) +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr (pprSourceTyCon) +import GHC.Core.Type +import GHC.Utils.Misc +import GHC.Types.Var.Set + +import Control.Monad.Trans.Reader +import Data.Maybe +import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.List.SetOps (assocMaybe) + +-- | To avoid having to manually plumb everything in 'DerivEnv' throughout +-- various functions in @GHC.Tc.Deriv@ and @GHC.Tc.Deriv.Infer@, we use 'DerivM', which +-- is a simple reader around 'TcRn'. +type DerivM = ReaderT DerivEnv TcRn + +-- | Is GHC processing a standalone deriving declaration? +isStandaloneDeriv :: DerivM Bool +isStandaloneDeriv = asks (go . denv_ctxt) + where + go :: DerivContext -> Bool + go (InferContext wildcard) = isJust wildcard + go (SupplyContext {}) = True + +-- | Is GHC processing a standalone deriving declaration with an +-- extra-constraints wildcard as the context? +-- (e.g., @deriving instance _ => Eq (Foo a)@) +isStandaloneWildcardDeriv :: DerivM Bool +isStandaloneWildcardDeriv = asks (go . denv_ctxt) + where + go :: DerivContext -> Bool + go (InferContext wildcard) = isJust wildcard + go (SupplyContext {}) = False + +-- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True', +-- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting. +mkDerivOrigin :: Bool -> CtOrigin +mkDerivOrigin standalone_wildcard + | standalone_wildcard = StandAloneDerivOrigin + | otherwise = DerivClauseOrigin + +-- | Contains all of the information known about a derived instance when +-- determining what its @EarlyDerivSpec@ should be. +-- See @Note [DerivEnv and DerivSpecMechanism]@. +data DerivEnv = DerivEnv + { denv_overlap_mode :: Maybe OverlapMode + -- ^ Is this an overlapping instance? + , denv_tvs :: [TyVar] + -- ^ Universally quantified type variables in the instance + , denv_cls :: Class + -- ^ Class for which we need to derive an instance + , denv_inst_tys :: [Type] + -- ^ All arguments to to 'denv_cls' in the derived instance. + , denv_ctxt :: DerivContext + -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the + -- context of the instance). + -- 'InferContext' for @deriving@ clauses, or for standalone deriving that + -- uses a wildcard constraint. + -- See @Note [Inferring the instance context]@. + , denv_strat :: Maybe (DerivStrategy GhcTc) + -- ^ 'Just' if user requests a particular deriving strategy. + -- Otherwise, 'Nothing'. + } + +instance Outputable DerivEnv where + ppr (DerivEnv { denv_overlap_mode = overlap_mode + , denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = inst_tys + , denv_ctxt = ctxt + , denv_strat = mb_strat }) + = hang (text "DerivEnv") + 2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode + , text "denv_tvs" <+> ppr tvs + , text "denv_cls" <+> ppr cls + , text "denv_inst_tys" <+> ppr inst_tys + , text "denv_ctxt" <+> ppr ctxt + , text "denv_strat" <+> ppr mb_strat ]) + +data DerivSpec theta = DS { ds_loc :: SrcSpan + , ds_name :: Name -- DFun name + , ds_tvs :: [TyVar] + , ds_theta :: theta + , ds_cls :: Class + , ds_tys :: [Type] + , ds_overlap :: Maybe OverlapMode + , ds_standalone_wildcard :: Maybe SrcSpan + -- See Note [Inferring the instance context] + -- in GHC.Tc.Deriv.Infer + , ds_mechanism :: DerivSpecMechanism } + -- This spec implies a dfun declaration of the form + -- df :: forall tvs. theta => C tys + -- The Name is the name for the DFun we'll build + -- The tyvars bind all the variables in the theta + + -- the theta is either the given and final theta, in standalone deriving, + -- or the not-yet-simplified list of constraints together with their origin + + -- ds_mechanism specifies the means by which GHC derives the instance. + -- See Note [Deriving strategies] in GHC.Tc.Deriv + +{- +Example: + + newtype instance T [a] = MkT (Tree a) deriving( C s ) +==> + axiom T [a] = :RTList a + axiom :RTList a = Tree a + + DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]] + , ds_mechanism = DerivSpecNewtype (Tree a) } +-} + +pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc +pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c, + ds_tys = tys, ds_theta = rhs, + ds_standalone_wildcard = wildcard, ds_mechanism = mech }) + = hang (text "DerivSpec") + 2 (vcat [ text "ds_loc =" <+> ppr l + , text "ds_name =" <+> ppr n + , text "ds_tvs =" <+> ppr tvs + , text "ds_cls =" <+> ppr c + , text "ds_tys =" <+> ppr tys + , text "ds_theta =" <+> ppr rhs + , text "ds_standalone_wildcard =" <+> ppr wildcard + , text "ds_mechanism =" <+> ppr mech ]) + +instance Outputable theta => Outputable (DerivSpec theta) where + ppr = pprDerivSpec + +-- | Information about the arguments to the class in a stock- or +-- newtype-derived instance. +-- See @Note [DerivEnv and DerivSpecMechanism]@. +data DerivInstTys = DerivInstTys + { dit_cls_tys :: [Type] + -- ^ Other arguments to the class except the last + , dit_tc :: TyCon + -- ^ Type constructor for which the instance is requested + -- (last arguments to the type class) + , dit_tc_args :: [Type] + -- ^ Arguments to the type constructor + , dit_rep_tc :: TyCon + -- ^ The representation tycon for 'dit_tc' + -- (for data family instances). Otherwise the same as 'dit_tc'. + , dit_rep_tc_args :: [Type] + -- ^ The representation types for 'dit_tc_args' + -- (for data family instances). Otherwise the same as 'dit_tc_args'. + } + +instance Outputable DerivInstTys where + ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args + , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args }) + = hang (text "DITTyConHead") + 2 (vcat [ text "dit_cls_tys" <+> ppr cls_tys + , text "dit_tc" <+> ppr tc + , text "dit_tc_args" <+> ppr tc_args + , text "dit_rep_tc" <+> ppr rep_tc + , text "dit_rep_tc_args" <+> ppr rep_tc_args ]) + +-- | What action to take in order to derive a class instance. +-- See @Note [DerivEnv and DerivSpecMechanism]@, as well as +-- @Note [Deriving strategies]@ in "GHC.Tc.Deriv". +data DerivSpecMechanism + -- | \"Standard\" classes + = DerivSpecStock + { dsm_stock_dit :: DerivInstTys + -- ^ Information about the arguments to the class in the derived + -- instance, including what type constructor the last argument is + -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. + , dsm_stock_gen_fn :: + SrcSpan -> TyCon + -> [Type] + -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]) + -- ^ This function returns three things: + -- + -- 1. @LHsBinds GhcPs@: The derived instance's function bindings + -- (e.g., @compare (T x) (T y) = compare x y@) + -- + -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived + -- instance. As examples, derived 'Generic' instances require + -- associated type family instances, and derived 'Eq' and 'Ord' + -- instances require top-level @con2tag@ functions. + -- See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate". + -- + -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be + -- suppressed. This is used to suppress unused warnings for record + -- selectors when deriving 'Read', 'Show', or 'Generic'. + -- See @Note [Deriving and unused record selectors]@. + } + + -- | @GeneralizedNewtypeDeriving@ + | DerivSpecNewtype + { dsm_newtype_dit :: DerivInstTys + -- ^ Information about the arguments to the class in the derived + -- instance, including what type constructor the last argument is + -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. + , dsm_newtype_rep_ty :: Type + -- ^ The newtype rep type. + } + + -- | @DeriveAnyClass@ + | DerivSpecAnyClass + + -- | @DerivingVia@ + | DerivSpecVia + { dsm_via_cls_tys :: [Type] + -- ^ All arguments to the class besides the last one. + , dsm_via_inst_ty :: Type + -- ^ The last argument to the class. + , dsm_via_ty :: Type + -- ^ The @via@ type + } + +-- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'. +derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc +derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy +derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy +derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy +derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t + +isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia + :: DerivSpecMechanism -> Bool +isDerivSpecStock (DerivSpecStock{}) = True +isDerivSpecStock _ = False + +isDerivSpecNewtype (DerivSpecNewtype{}) = True +isDerivSpecNewtype _ = False + +isDerivSpecAnyClass DerivSpecAnyClass = True +isDerivSpecAnyClass _ = False + +isDerivSpecVia (DerivSpecVia{}) = True +isDerivSpecVia _ = False + +instance Outputable DerivSpecMechanism where + ppr (DerivSpecStock{dsm_stock_dit = dit}) + = hang (text "DerivSpecStock") + 2 (vcat [ text "dsm_stock_dit" <+> ppr dit ]) + ppr (DerivSpecNewtype { dsm_newtype_dit = dit, dsm_newtype_rep_ty = rep_ty }) + = hang (text "DerivSpecNewtype") + 2 (vcat [ text "dsm_newtype_dit" <+> ppr dit + , text "dsm_newtype_rep_ty" <+> ppr rep_ty ]) + ppr DerivSpecAnyClass = text "DerivSpecAnyClass" + ppr (DerivSpecVia { dsm_via_cls_tys = cls_tys, dsm_via_inst_ty = inst_ty + , dsm_via_ty = via_ty }) + = hang (text "DerivSpecVia") + 2 (vcat [ text "dsm_via_cls_tys" <+> ppr cls_tys + , text "dsm_via_inst_ty" <+> ppr inst_ty + , text "dsm_via_ty" <+> ppr via_ty ]) + +{- +Note [DerivEnv and DerivSpecMechanism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +DerivEnv contains all of the bits and pieces that are common to every +deriving strategy. (See Note [Deriving strategies] in GHC.Tc.Deriv.) Some deriving +strategies impose stricter requirements on the types involved in the derived +instance than others, and these differences are factored out into the +DerivSpecMechanism type. Suppose that the derived instance looks like this: + + instance ... => C arg_1 ... arg_n + +Each deriving strategy imposes restrictions on arg_1 through arg_n as follows: + +* stock (DerivSpecStock): + + Stock deriving requires that: + + - n must be a positive number. This is checked by + GHC.Tc.Deriv.expectNonNullaryClsArgs + - arg_n must be an application of an algebraic type constructor. Here, + "algebraic type constructor" means: + + + An ordinary data type constructor, or + + A data family type constructor such that the arguments it is applied to + give rise to a data family instance. + + This is checked by GHC.Tc.Deriv.expectAlgTyConApp. + + This extra structure is witnessed by the DerivInstTys data type, which stores + arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor + (dit_tc), and its arguments (dit_tc_args). If dit_tc is an ordinary data type + constructor, then dit_rep_tc/dit_rep_tc_args are the same as + dit_tc/dit_tc_args. If dit_tc is a data family type constructor, then + dit_rep_tc is the representation type constructor for the data family + instance, and dit_rep_tc_args are the arguments to the representation type + constructor in the corresponding instance. + +* newtype (DerivSpecNewtype): + + Newtype deriving imposes the same DerivInstTys requirements as stock + deriving. This is necessary because we need to know what the underlying type + that the newtype wraps is, and this information can only be learned by + knowing dit_rep_tc. + +* anyclass (DerivSpecAnyclass): + + DeriveAnyClass is the most permissive deriving strategy of all, as it + essentially imposes no requirements on the derived instance. This is because + DeriveAnyClass simply derives an empty instance, so it does not need any + particular knowledge about the types involved. It can do several things + that stock/newtype deriving cannot do (#13154): + + - n can be 0. That is, one is allowed to anyclass-derive an instance with + no arguments to the class, such as in this example: + + class C + deriving anyclass instance C + + - One can derive an instance for a type that is not headed by a type + constructor, such as in the following example: + + class C (n :: Nat) + deriving instance C 0 + deriving instance C 1 + ... + + - One can derive an instance for a data family with no data family instances, + such as in the following example: + + data family Foo a + class C a + deriving anyclass instance C (Foo a) + +* via (DerivSpecVia): + + Like newtype deriving, DerivingVia requires that n must be a positive number. + This is because when one derives something like this: + + deriving via Foo instance C Bar + + Then the generated code must specifically mention Bar. However, in + contrast with newtype deriving, DerivingVia does *not* require Bar to be + an application of an algebraic type constructor. This is because the + generated code simply defers to invoking `coerce`, which does not need to + know anything in particular about Bar (besides that it is representationally + equal to Foo). This allows DerivingVia to do some things that are not + possible with newtype deriving, such as deriving instances for data families + without data instances (#13154): + + data family Foo a + newtype ByBar a = ByBar a + class Baz a where ... + instance Baz (ByBar a) where ... + deriving via ByBar (Foo a) instance Baz (Foo a) +-} + +-- | Whether GHC is processing a @deriving@ clause or a standalone deriving +-- declaration. +data DerivContext + = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either: + -- + -- * A @deriving@ clause (in which case + -- @mb_wildcard@ is 'Nothing'). + -- + -- * A standalone deriving declaration with + -- an extra-constraints wildcard as the + -- context (in which case @mb_wildcard@ is + -- @'Just' loc@, where @loc@ is the location + -- of the wildcard. + -- + -- GHC should infer the context. + + | SupplyContext ThetaType -- ^ @'SupplyContext' theta@ is a standalone + -- deriving declaration, where @theta@ is the + -- context supplied by the user. + +instance Outputable DerivContext where + ppr (InferContext standalone) = text "InferContext" <+> ppr standalone + ppr (SupplyContext theta) = text "SupplyContext" <+> ppr theta + +-- | Records whether a particular class can be derived by way of an +-- /originative/ deriving strategy (i.e., @stock@ or @anyclass@). +-- +-- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv". +data OriginativeDerivStatus + = CanDeriveStock -- Stock class, can derive + (SrcSpan -> TyCon -> [Type] + -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) + | StockClassError SDoc -- Stock class, but can't do it + | CanDeriveAnyClass -- See Note [Deriving any class] + | NonDerivableClass SDoc -- Cannot derive with either stock or anyclass + +-- A stock class is one either defined in the Haskell report or for which GHC +-- otherwise knows how to generate code for (possibly requiring the use of a +-- language extension), such as Eq, Ord, Ix, Data, Generic, etc.) + +-- | A 'PredType' annotated with the origin of the constraint 'CtOrigin', +-- and whether or the constraint deals in types or kinds. +data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind + +-- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') to +-- simplify when inferring a derived instance's context. These are used in all +-- deriving strategies, but in the particular case of @DeriveAnyClass@, we +-- need extra information. In particular, we need: +-- +-- * 'to_anyclass_skols', the list of type variables bound by a class method's +-- regular type signature, which should be rigid. +-- +-- * 'to_anyclass_metas', the list of type variables bound by a class method's +-- default type signature. These can be unified as necessary. +-- +-- * 'to_anyclass_givens', the list of constraints from a class method's +-- regular type signature, which can be used to help solve constraints +-- in the 'to_wanted_origins'. +-- +-- (Note that 'to_wanted_origins' will likely contain type variables from the +-- derived type class or data type, neither of which will appear in +-- 'to_anyclass_skols' or 'to_anyclass_metas'.) +-- +-- For all other deriving strategies, it is always the case that +-- 'to_anyclass_skols', 'to_anyclass_metas', and 'to_anyclass_givens' are +-- empty. +-- +-- Here is an example to illustrate this: +-- +-- @ +-- class Foo a where +-- bar :: forall b. Ix b => a -> b -> String +-- default bar :: forall y. (Show a, Ix y) => a -> y -> String +-- bar x y = show x ++ show (range (y, y)) +-- +-- baz :: Eq a => a -> a -> Bool +-- default baz :: Ord a => a -> a -> Bool +-- baz x y = compare x y == EQ +-- +-- data Quux q = Quux deriving anyclass Foo +-- @ +-- +-- Then it would generate two 'ThetaOrigin's, one for each method: +-- +-- @ +-- [ ThetaOrigin { to_anyclass_skols = [b] +-- , to_anyclass_metas = [y] +-- , to_anyclass_givens = [Ix b] +-- , to_wanted_origins = [ Show (Quux q), Ix y +-- , (Quux q -> b -> String) ~ +-- (Quux q -> y -> String) +-- ] } +-- , ThetaOrigin { to_anyclass_skols = [] +-- , to_anyclass_metas = [] +-- , to_anyclass_givens = [Eq (Quux q)] +-- , to_wanted_origins = [ Ord (Quux q) +-- , (Quux q -> Quux q -> Bool) ~ +-- (Quux q -> Quux q -> Bool) +-- ] } +-- ] +-- @ +-- +-- (Note that the type variable @q@ is bound by the data type @Quux@, and thus +-- it appears in neither 'to_anyclass_skols' nor 'to_anyclass_metas'.) +-- +-- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@ +-- in "GHC.Tc.Deriv.Infer" for an explanation of how 'to_wanted_origins' are +-- determined in @DeriveAnyClass@, as well as how 'to_anyclass_skols', +-- 'to_anyclass_metas', and 'to_anyclass_givens' are used. +data ThetaOrigin + = ThetaOrigin { to_anyclass_skols :: [TyVar] + , to_anyclass_metas :: [TyVar] + , to_anyclass_givens :: ThetaType + , to_wanted_origins :: [PredOrigin] } + +instance Outputable PredOrigin where + ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging + +instance Outputable ThetaOrigin where + ppr (ThetaOrigin { to_anyclass_skols = ac_skols + , to_anyclass_metas = ac_metas + , to_anyclass_givens = ac_givens + , to_wanted_origins = wanted_origins }) + = hang (text "ThetaOrigin") + 2 (vcat [ text "to_anyclass_skols =" <+> ppr ac_skols + , text "to_anyclass_metas =" <+> ppr ac_metas + , text "to_anyclass_givens =" <+> ppr ac_givens + , text "to_wanted_origins =" <+> ppr wanted_origins ]) + +mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin +mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k + +mkThetaOrigin :: CtOrigin -> TypeOrKind + -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType + -> ThetaOrigin +mkThetaOrigin origin t_or_k skols metas givens + = ThetaOrigin skols metas givens . map (mkPredOrigin origin t_or_k) + +-- A common case where the ThetaOrigin only contains wanted constraints, with +-- no givens or locally scoped type variables. +mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin +mkThetaOriginFromPreds = ThetaOrigin [] [] [] + +substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin +substPredOrigin subst (PredOrigin pred origin t_or_k) + = PredOrigin (substTy subst pred) origin t_or_k + +{- +************************************************************************ +* * + Class deriving diagnostics +* * +************************************************************************ + +Only certain blessed classes can be used in a deriving clause (without the +assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes +are listed below in the definition of hasStockDeriving. The stockSideConditions +function determines the criteria that needs to be met in order for a particular +stock class to be able to be derived successfully. + +A class might be able to be used in a deriving clause if -XDeriveAnyClass +is willing to support it. The canDeriveAnyClass function checks if this is the +case. +-} + +hasStockDeriving + :: Class -> Maybe (SrcSpan + -> TyCon + -> [Type] + -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) +hasStockDeriving clas + = assocMaybe gen_list (getUnique clas) + where + gen_list + :: [(Unique, SrcSpan + -> TyCon + -> [Type] + -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))] + gen_list = [ (eqClassKey, simpleM gen_Eq_binds) + , (ordClassKey, simpleM gen_Ord_binds) + , (enumClassKey, simpleM gen_Enum_binds) + , (boundedClassKey, simple gen_Bounded_binds) + , (ixClassKey, simpleM gen_Ix_binds) + , (showClassKey, read_or_show gen_Show_binds) + , (readClassKey, read_or_show gen_Read_binds) + , (dataClassKey, simpleM gen_Data_binds) + , (functorClassKey, simple gen_Functor_binds) + , (foldableClassKey, simple gen_Foldable_binds) + , (traversableClassKey, simple gen_Traversable_binds) + , (liftClassKey, simple gen_Lift_binds) + , (genClassKey, generic (gen_Generic_binds Gen0)) + , (gen1ClassKey, generic (gen_Generic_binds Gen1)) ] + + simple gen_fn loc tc _ + = let (binds, deriv_stuff) = gen_fn loc tc + in return (binds, deriv_stuff, []) + + simpleM gen_fn loc tc _ + = do { (binds, deriv_stuff) <- gen_fn loc tc + ; return (binds, deriv_stuff, []) } + + read_or_show gen_fn loc tc _ + = do { fix_env <- getDataConFixityFun tc + ; let (binds, deriv_stuff) = gen_fn fix_env loc tc + field_names = all_field_names tc + ; return (binds, deriv_stuff, field_names) } + + generic gen_fn _ tc inst_tys + = do { (binds, faminst) <- gen_fn tc inst_tys + ; let field_names = all_field_names tc + ; return (binds, unitBag (DerivFamInst faminst), field_names) } + + -- See Note [Deriving and unused record selectors] + all_field_names = map flSelector . concatMap dataConFieldLabels + . tyConDataCons + +{- +Note [Deriving and unused record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (see #13919): + + module Main (main) where + + data Foo = MkFoo {bar :: String} deriving Show + + main :: IO () + main = print (Foo "hello") + +Strictly speaking, the record selector `bar` is unused in this module, since +neither `main` nor the derived `Show` instance for `Foo` mention `bar`. +However, the behavior of `main` is affected by the presence of `bar`, since +it will print different output depending on whether `MkFoo` is defined using +record selectors or not. Therefore, we do not to issue a +"Defined but not used: ‘bar’" warning for this module, since removing `bar` +changes the program's behavior. This is the reason behind the [Name] part of +the return type of `hasStockDeriving`—it tracks all of the record selector +`Name`s for which -Wunused-binds should be suppressed. + +Currently, the only three stock derived classes that require this are Read, +Show, and Generic, as their derived code all depend on the record selectors +of the derived data type's constructors. + +See also Note [Newtype deriving and unused constructors] in GHC.Tc.Deriv for +another example of a similar trick. +-} + +getDataConFixityFun :: TyCon -> TcM (Name -> Fixity) +-- If the TyCon is locally defined, we want the local fixity env; +-- but if it is imported (which happens for standalone deriving) +-- we need to get the fixity env from the interface file +-- c.f. GHC.Rename.Env.lookupFixity, and #9830 +getDataConFixityFun tc + = do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod name + then do { fix_env <- getFixityEnv + ; return (lookupFixity fix_env) } + else do { iface <- loadInterfaceForName doc name + -- Should already be loaded! + ; return (mi_fix iface . nameOccName) } } + where + name = tyConName tc + doc = text "Data con fixities for" <+> ppr name + +------------------------------------------------------------------ +-- Check side conditions that dis-allow derivability for the originative +-- deriving strategies (stock and anyclass). +-- See Note [Deriving strategies] in GHC.Tc.Deriv for an explanation of what +-- "originative" means. +-- +-- This is *apart* from the coerce-based strategies, newtype and via. +-- +-- Here we get the representation tycon in case of family instances as it has +-- the data constructors - but we need to be careful to fall back to the +-- family tycon (with indexes) in error messages. + +checkOriginativeSideConditions + :: DynFlags -> DerivContext -> Class -> [TcType] + -> TyCon -> TyCon + -> OriginativeDerivStatus +checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc + -- First, check if stock deriving is possible... + | Just cond <- stockSideConditions deriv_ctxt cls + = case (cond dflags tc rep_tc) of + NotValid err -> StockClassError err -- Class-specific error + IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys) + -- All stock derivable classes are unary in the sense that + -- there should be not types in cls_tys (i.e., no type args + -- other than last). Note that cls_types can contain + -- invisible types as well (e.g., for Generic1, which is + -- poly-kinded), so make sure those are not counted. + , Just gen_fn <- hasStockDeriving cls + -> CanDeriveStock gen_fn + | otherwise -> StockClassError (classArgsErr cls cls_tys) + -- e.g. deriving( Eq s ) + + -- ...if not, try falling back on DeriveAnyClass. + | NotValid err <- canDeriveAnyClass dflags + = NonDerivableClass err -- Neither anyclass nor stock work + + | otherwise + = CanDeriveAnyClass -- DeriveAnyClass should work + +classArgsErr :: Class -> [Type] -> SDoc +classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class" + +-- Side conditions (whether the datatype must have at least one constructor, +-- required language extensions, etc.) for using GHC's stock deriving +-- mechanism on certain classes (as opposed to classes that require +-- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a +-- class for which stock deriving isn't possible. +stockSideConditions :: DerivContext -> Class -> Maybe Condition +stockSideConditions deriv_ctxt cls + | 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 + -- Vanilla data constructors, at least one, and monotype arguments + cond_vanilla = cond_stdOK deriv_ctxt True + -- Vanilla data constructors but allow no data cons or polytype arguments + +canDeriveAnyClass :: DynFlags -> Validity +-- IsValid: we can (try to) derive it via an empty instance declaration +-- NotValid s: we can't, reason s +canDeriveAnyClass dflags + | not (xopt LangExt.DeriveAnyClass dflags) + = NotValid (text "Try enabling DeriveAnyClass") + | otherwise + = IsValid -- OK! + +type Condition + = DynFlags + + -> TyCon -- ^ The data type's 'TyCon'. For data families, this is the + -- family 'TyCon'. + + -> TyCon -- ^ For data families, this is the representation 'TyCon'. + -- Otherwise, this is the same as the other 'TyCon' argument. + + -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is + -- possible. Otherwise, it's @'NotValid' err@, where @err@ + -- explains what went wrong. + +orCond :: Condition -> Condition -> Condition +orCond c1 c2 dflags tc rep_tc + = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of + (IsValid, _) -> IsValid -- c1 succeeds + (_, IsValid) -> IsValid -- c21 succeeds + (NotValid x, NotValid y) -> NotValid (x $$ text " or" $$ y) + -- Both fail + +andCond :: Condition -> Condition -> Condition +andCond c1 c2 dflags tc rep_tc + = c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc + +-- | Some common validity checks shared among stock derivable classes. One +-- check that absolutely must hold is that if an instance @C (T a)@ is being +-- derived, then @T@ must be a tycon for a data type or a newtype. The +-- remaining checks are only performed if using a @deriving@ clause (i.e., +-- they're ignored if using @StandaloneDeriving@): +-- +-- 1. The data type must have at least one constructor (this check is ignored +-- if using @EmptyDataDeriving@). +-- +-- 2. The data type cannot have any GADT constructors. +-- +-- 3. The data type cannot have any constructors with existentially quantified +-- type variables. +-- +-- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@). +-- +-- 5. The data type cannot have fields with higher-rank types. +cond_stdOK + :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a + -- user-supplied context, 'InferContext' if not. + -- If it is the former, we relax some of the validity checks + -- we would otherwise perform (i.e., "just go for it"). + + -> Bool -- ^ 'True' <=> allow higher rank arguments and empty data + -- types (with no data constructors) even in the absence of + -- the -XEmptyDataDeriving extension. + + -> Condition +cond_stdOK deriv_ctxt permissive dflags tc rep_tc + = valid_ADT `andValid` valid_misc + where + valid_ADT, valid_misc :: Validity + valid_ADT + | isAlgTyCon tc || isDataFamilyTyCon tc + = IsValid + | otherwise + -- Complain about functions, primitive types, and other tycons that + -- stock deriving can't handle. + = NotValid $ text "The last argument of the instance must be a" + <+> text "data or newtype application" + + valid_misc + = case deriv_ctxt of + SupplyContext _ -> IsValid + -- Don't check these conservative conditions for + -- standalone deriving; just generate the code + -- and let the typechecker handle the result + InferContext wildcard + | null data_cons -- 1. + , not permissive + -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid` + NotValid (no_cons_why rep_tc $$ empty_data_suggestion) + | not (null con_whys) + -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard) + | otherwise + -> IsValid + + empty_data_suggestion = + text "Use EmptyDataDeriving to enable deriving for empty data types" + possible_fix_suggestion wildcard + = case wildcard of + Just _ -> + text "Possible fix: fill in the wildcard constraint yourself" + Nothing -> + text "Possible fix: use a standalone deriving declaration instead" + data_cons = tyConDataCons rep_tc + con_whys = getInvalids (map check_con data_cons) + + check_con :: DataCon -> Validity + check_con con + | not (null eq_spec) -- 2. + = bad "is a GADT" + | not (null ex_tvs) -- 3. + = bad "has existential type variables in its type" + | not (null theta) -- 4. + = bad "has constraints in its type" + | not (permissive || all isTauTy (dataConOrigArgTys con)) -- 5. + = bad "has a higher-rank type" + | otherwise + = IsValid + where + (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con + bad msg = NotValid (badCon con (text msg)) + +no_cons_why :: TyCon -> SDoc +no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> + text "must have at least one data constructor" + +cond_RepresentableOk :: Condition +cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc + +cond_Representable1Ok :: Condition +cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc + +cond_enumOrProduct :: Class -> Condition +cond_enumOrProduct cls = cond_isEnumeration `orCond` + (cond_isProduct `andCond` cond_args cls) + +cond_args :: Class -> Condition +-- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types +-- by generating specialised code. For others (eg 'Data') we don't. +-- For even others (eg 'Lift'), unlifted types aren't even a special +-- consideration! +cond_args cls _ _ rep_tc + = case bad_args of + [] -> IsValid + (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls)) + 2 (text "for type" <+> quotes (ppr ty))) + where + bad_args = [ arg_ty | con <- tyConDataCons rep_tc + , arg_ty <- dataConOrigArgTys con + , isLiftedType_maybe arg_ty /= Just True + , not (ok_ty arg_ty) ] + + cls_key = classKey cls + ok_ty arg_ty + | cls_key == eqClassKey = check_in arg_ty ordOpTbl + | cls_key == ordClassKey = check_in arg_ty ordOpTbl + | cls_key == showClassKey = check_in arg_ty boxConTbl + | cls_key == liftClassKey = True -- Lift is levity-polymorphic + | otherwise = False -- Read, Ix etc + + check_in :: Type -> [(Type,a)] -> Bool + check_in arg_ty tbl = any (eqType arg_ty . fst) tbl + + +cond_isEnumeration :: Condition +cond_isEnumeration _ _ rep_tc + | isEnumerationTyCon rep_tc = IsValid + | otherwise = NotValid why + where + why = sep [ quotes (pprSourceTyCon rep_tc) <+> + text "must be an enumeration type" + , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ] + -- See Note [Enumeration types] in GHC.Core.TyCon + +cond_isProduct :: Condition +cond_isProduct _ _ rep_tc + | isProductTyCon rep_tc = IsValid + | otherwise = NotValid why + where + why = quotes (pprSourceTyCon rep_tc) <+> + text "must have precisely one constructor" + +cond_functorOK :: Bool -> Bool -> Condition +-- OK for Functor/Foldable/Traversable class +-- Currently: (a) at least one argument +-- (b) don't use argument contravariantly +-- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) +-- (d) optionally: don't use function types +-- (e) no "stupid context" on data type +cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc + | null tc_tvs + = NotValid (text "Data type" <+> quotes (ppr rep_tc) + <+> text "must have some type parameters") + + | not (null bad_stupid_theta) + = NotValid (text "Data type" <+> quotes (ppr rep_tc) + <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) + + | otherwise + = allValid (map check_con data_cons) + where + tc_tvs = tyConTyVars rep_tc + last_tv = last tc_tvs + bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc) + is_bad pred = last_tv `elemVarSet` exactTyCoVarsOfType pred + -- See Note [Check that the type variable is truly universal] + + data_cons = tyConDataCons rep_tc + check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con) + + check_universal :: DataCon -> Validity + check_universal con + | allowExQuantifiedLastTyVar + = IsValid -- See Note [DeriveFoldable with ExistentialQuantification] + -- in GHC.Tc.Deriv.Functor + | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) + , tv `elem` dataConUnivTyVars con + , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con)) + = IsValid -- See Note [Check that the type variable is truly universal] + | otherwise + = NotValid (badCon con existential) + + ft_check :: DataCon -> FFoldType Validity + ft_check con = FT { ft_triv = IsValid, ft_var = IsValid + , ft_co_var = NotValid (badCon con covariant) + , ft_fun = \x y -> if allowFunctions then x `andValid` y + else NotValid (badCon con functions) + , ft_tup = \_ xs -> allValid xs + , ft_ty_app = \_ _ x -> x + , ft_bad_app = NotValid (badCon con wrong_arg) + , ft_forall = \_ x -> x } + + existential = text "must be truly polymorphic in the last argument of the data type" + covariant = text "must not use the type variable in a function argument" + functions = text "must not contain function types" + wrong_arg = text "must use the type variable only as the last argument of a data type" + +checkFlag :: LangExt.Extension -> Condition +checkFlag flag dflags _ _ + | xopt flag dflags = IsValid + | otherwise = NotValid why + where + why = text "You need " <> text flag_str + <+> text "to derive an instance for this class" + flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of + [s] -> s + other -> pprPanic "checkFlag" (ppr other) + +std_class_via_coercible :: Class -> Bool +-- These standard classes can be derived for a newtype +-- using the coercible trick *even if no -XGeneralizedNewtypeDeriving +-- because giving so gives the same results as generating the boilerplate +std_class_via_coercible clas + = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] + -- Not Read/Show because they respect the type + -- Not Enum, because newtypes are never in Enum + + +non_coercible_class :: Class -> Bool +-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift +-- by Coercible, even with -XGeneralizedNewtypeDeriving +-- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived +-- instance behave differently if there's a non-lawful Applicative out there. +-- Besides, with roles, Coercible-deriving Traversable is ill-roled. +non_coercible_class cls + = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey + , genClassKey, gen1ClassKey, typeableClassKey + , traversableClassKey, liftClassKey ]) + +badCon :: DataCon -> SDoc -> SDoc +badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg + +------------------------------------------------------------------ + +newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst +newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode + , ds_tvs = tvs, ds_cls = clas, ds_tys = tys }) + = newClsInst overlap_mode dfun_name tvs theta clas tys + +extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a +-- Add new locally-defined instances; don't bother to check +-- for functional dependency errors -- that'll happen in GHC.Tc.TyCl.Instance +extendLocalInstEnv dfuns thing_inside + = do { env <- getGblEnv + ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns + env' = env { tcg_inst_env = inst_env' } + ; setGblEnv env' thing_inside } + +{- +Note [Deriving any class] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Classic uses of a deriving clause, or a standalone-deriving declaration, are +for: + * a stock class like Eq or Show, for which GHC knows how to generate + the instance code + * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving + +The DeriveAnyClass extension adds a third way to derive instances, based on +empty instance declarations. + +The canonical use case is in combination with GHC.Generics and default method +signatures. These allow us to have instance declarations being empty, but still +useful, e.g. + + data T a = ...blah..blah... deriving( Generic ) + instance C a => C (T a) -- No 'where' clause + +where C is some "random" user-defined class. + +This boilerplate code can be replaced by the more compact + + data T a = ...blah..blah... deriving( Generic, C ) + +if DeriveAnyClass is enabled. + +This is not restricted to Generics; any class can be derived, simply giving +rise to an empty instance. + +See Note [Gathering and simplifying constraints for DeriveAnyClass] in +GHC.Tc.Deriv.Infer for an explanation hof how the instance context is inferred for +DeriveAnyClass. + +Note [Check that the type variable is truly universal] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For Functor and Traversable instances, we must check that the *last argument* +of the type constructor is used truly universally quantified. Example + + data T a b where + T1 :: a -> b -> T a b -- Fine! Vanilla H-98 + T2 :: b -> c -> T a b -- Fine! Existential c, but we can still map over 'b' + T3 :: b -> T Int b -- Fine! Constraint 'a', but 'b' is still polymorphic + T4 :: Ord b => b -> T a b -- No! 'b' is constrained + T5 :: b -> T b b -- No! 'b' is constrained + T6 :: T a (b,b) -- No! 'b' is constrained + +Notice that only the first of these constructors is vanilla H-98. We only +need to take care about the last argument (b in this case). See #8678. +Eg. for T1-T3 we can write + + fmap f (T1 a b) = T1 a (f b) + fmap f (T2 b c) = T2 (f b) c + fmap f (T3 x) = T3 (f x) + +We need not perform these checks for Foldable instances, however, since +functions in Foldable can only consume existentially quantified type variables, +rather than produce them (as is the case in Functor and Traversable functions.) +As a result, T can have a derived Foldable instance: + + foldr f z (T1 a b) = f b z + foldr f z (T2 b c) = f b z + foldr f z (T3 x) = f x z + foldr f z (T4 x) = f x z + foldr f z (T5 x) = f x z + foldr _ z T6 = z + +See Note [DeriveFoldable with ExistentialQuantification] in GHC.Tc.Deriv.Functor. + +For Functor and Traversable, we must take care not to let type synonyms +unfairly reject a type for not being truly universally quantified. An +example of this is: + + type C (a :: Constraint) b = a + data T a b = C (Show a) b => MkT b + +Here, the existential context (C (Show a) b) does technically mention the last +type variable b. But this is OK, because expanding the type synonym C would +give us the context (Show a), which doesn't mention b. Therefore, we must make +sure to expand type synonyms before performing this check. Not doing so led to +#13813. +-} diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Errors.hs @@ -0,0 +1,2984 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Tc.Errors( + reportUnsolved, reportAllUnsolved, warnAllUnsolved, + warnDefaulting, + + solverDepthErrorTcS + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Unify( occCheckForErrors, MetaTyVarUpdateResult(..) ) +import GHC.Tc.Utils.Env( tcInitTidyEnv ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Origin +import GHC.Rename.Unbound ( unknownNameSuggestions ) +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE ) +import GHC.Core.Unify ( tcMatchTys ) +import GHC.Unit.Module +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv ( flattenTys ) +import GHC.Tc.Utils.Instantiate +import GHC.Core.InstEnv +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.EvTerm +import GHC.Hs.Binds ( PatSynBind(..) ) +import GHC.Types.Name +import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual ) +import GHC.Builtin.Names ( typeableClassName ) +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Name.Set +import GHC.Data.Bag +import GHC.Utils.Error ( ErrMsg, errDoc, pprLocErrMsg ) +import GHC.Types.Basic +import GHC.Core.ConLike ( ConLike(..)) +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Driver.Session +import GHC.Data.List.SetOps ( equivClasses ) +import GHC.Data.Maybe +import qualified GHC.LanguageExtensions as LangExt +import GHC.Utils.FV ( fvVarList, unionFV ) + +import Control.Monad ( when ) +import Data.Foldable ( toList ) +import Data.List ( partition, mapAccumL, nub, sortBy, unfoldr ) + +import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits ) + +-- import Data.Semigroup ( Semigroup ) +import qualified Data.Semigroup as Semigroup + + +{- +************************************************************************ +* * +\section{Errors and contexts} +* * +************************************************************************ + +ToDo: for these error messages, should we note the location as coming +from the insts, or just whatever seems to be around in the monad just +now? + +Note [Deferring coercion errors to runtime] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While developing, sometimes it is desirable to allow compilation to succeed even +if there are type errors in the code. Consider the following case: + + module Main where + + a :: Int + a = 'a' + + main = print "b" + +Even though `a` is ill-typed, it is not used in the end, so if all that we're +interested in is `main` it is handy to be able to ignore the problems in `a`. + +Since we treat type equalities as evidence, this is relatively simple. Whenever +we run into a type mismatch in GHC.Tc.Utils.Unify, we normally just emit an error. But it +is always safe to defer the mismatch to the main constraint solver. If we do +that, `a` will get transformed into + + co :: Int ~ Char + co = ... + + a :: Int + a = 'a' `cast` co + +The constraint solver would realize that `co` is an insoluble constraint, and +emit an error with `reportUnsolved`. But we can also replace the right-hand side +of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program +to compile, and it will run fine unless we evaluate `a`. This is what +`deferErrorsToRuntime` does. + +It does this by keeping track of which errors correspond to which coercion +in GHC.Tc.Errors. GHC.Tc.Errors.reportTidyWanteds does not print the errors +and does not fail if -fdefer-type-errors is on, so that we can continue +compilation. The errors are turned into warnings in `reportUnsolved`. +-} + +-- | Report unsolved goals as errors or warnings. We may also turn some into +-- deferred run-time errors if `-fdefer-type-errors` is on. +reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) +reportUnsolved wanted + = do { binds_var <- newTcEvBinds + ; defer_errors <- goptM Opt_DeferTypeErrors + ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283 + ; let type_errors | not defer_errors = TypeError + | warn_errors = TypeWarn (Reason Opt_WarnDeferredTypeErrors) + | otherwise = TypeDefer + + ; defer_holes <- goptM Opt_DeferTypedHoles + ; warn_holes <- woptM Opt_WarnTypedHoles + ; let expr_holes | not defer_holes = HoleError + | warn_holes = HoleWarn + | otherwise = HoleDefer + + ; partial_sigs <- xoptM LangExt.PartialTypeSignatures + ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures + ; let type_holes | not partial_sigs = HoleError + | warn_partial_sigs = HoleWarn + | otherwise = HoleDefer + + ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables + ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables + ; let out_of_scope_holes | not defer_out_of_scope = HoleError + | warn_out_of_scope = HoleWarn + | otherwise = HoleDefer + + ; report_unsolved type_errors expr_holes + type_holes out_of_scope_holes + binds_var wanted + + ; ev_binds <- getTcEvBindsMap binds_var + ; return (evBindMapBinds ev_binds)} + +-- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on +-- However, do not make any evidence bindings, because we don't +-- have any convenient place to put them. +-- NB: Type-level holes are OK, because there are no bindings. +-- See Note [Deferring coercion errors to runtime] +-- Used by solveEqualities for kind equalities +-- (see Note [Fail fast on kind errors] in GHC.Tc.Solver) +-- and for simplifyDefault. +reportAllUnsolved :: WantedConstraints -> TcM () +reportAllUnsolved wanted + = do { ev_binds <- newNoTcEvBinds + + ; partial_sigs <- xoptM LangExt.PartialTypeSignatures + ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures + ; let type_holes | not partial_sigs = HoleError + | warn_partial_sigs = HoleWarn + | otherwise = HoleDefer + + ; report_unsolved TypeError HoleError type_holes HoleError + ev_binds wanted } + +-- | Report all unsolved goals as warnings (but without deferring any errors to +-- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in +-- GHC.Tc.Solver +warnAllUnsolved :: WantedConstraints -> TcM () +warnAllUnsolved wanted + = do { ev_binds <- newTcEvBinds + ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn + ev_binds wanted } + +-- | Report unsolved goals as errors or warnings. +report_unsolved :: TypeErrorChoice -- Deferred type errors + -> HoleChoice -- Expression holes + -> HoleChoice -- Type holes + -> HoleChoice -- Out of scope holes + -> EvBindsVar -- cec_binds + -> WantedConstraints -> TcM () +report_unsolved type_errors expr_holes + type_holes out_of_scope_holes binds_var wanted + | isEmptyWC wanted + = return () + | otherwise + = do { traceTc "reportUnsolved {" $ + vcat [ text "type errors:" <+> ppr type_errors + , text "expr holes:" <+> ppr expr_holes + , text "type holes:" <+> ppr type_holes + , text "scope holes:" <+> ppr out_of_scope_holes ] + ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) + + ; wanted <- zonkWC wanted -- Zonk to reveal all information + -- If we are deferring we are going to need /all/ evidence around, + -- including the evidence produced by unflattening (zonkWC) + ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs + free_tvs = tyCoVarsOfWCList wanted + + ; traceTc "reportUnsolved (after zonking):" $ + vcat [ text "Free tyvars:" <+> pprTyVars free_tvs + , text "Tidy env:" <+> ppr tidy_env + , text "Wanted:" <+> ppr wanted ] + + ; warn_redundant <- woptM Opt_WarnRedundantConstraints + ; let err_ctxt = CEC { cec_encl = [] + , cec_tidy = tidy_env + , cec_defer_type_errors = type_errors + , cec_expr_holes = expr_holes + , cec_type_holes = type_holes + , cec_out_of_scope_holes = out_of_scope_holes + , cec_suppress = insolubleWC wanted + -- See Note [Suppressing error messages] + -- Suppress low-priority errors if there + -- are insoluble errors anywhere; + -- See #15539 and c.f. setting ic_status + -- in GHC.Tc.Solver.setImplicationStatus + , cec_warn_redundant = warn_redundant + , cec_binds = binds_var } + + ; tc_lvl <- getTcLevel + ; reportWanteds err_ctxt tc_lvl wanted + ; traceTc "reportUnsolved }" empty } + +-------------------------------------------- +-- Internal functions +-------------------------------------------- + +-- | An error Report collects messages categorised by their importance. +-- See Note [Error report] for details. +data Report + = Report { report_important :: [SDoc] + , report_relevant_bindings :: [SDoc] + , report_valid_hole_fits :: [SDoc] + } + +instance Outputable Report where -- Debugging only + ppr (Report { report_important = imp + , report_relevant_bindings = rel + , report_valid_hole_fits = val }) + = vcat [ text "important:" <+> vcat imp + , text "relevant:" <+> vcat rel + , text "valid:" <+> vcat val ] + +{- Note [Error report] +The idea is that error msgs are divided into three parts: the main msg, the +context block (\"In the second argument of ...\"), and the relevant bindings +block, which are displayed in that order, with a mark to divide them. The +idea is that the main msg ('report_important') varies depending on the error +in question, but context and relevant bindings are always the same, which +should simplify visual parsing. + +The context is added when the Report is passed off to 'mkErrorReport'. +Unfortunately, unlike the context, the relevant bindings are added in +multiple places so they have to be in the Report. +-} + +instance Semigroup Report where + Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2) + +instance Monoid Report where + mempty = Report [] [] [] + mappend = (Semigroup.<>) + +-- | Put a doc into the important msgs block. +important :: SDoc -> Report +important doc = mempty { report_important = [doc] } + +-- | Put a doc into the relevant bindings block. +relevant_bindings :: SDoc -> Report +relevant_bindings doc = mempty { report_relevant_bindings = [doc] } + +-- | Put a doc into the valid hole fits block. +valid_hole_fits :: SDoc -> Report +valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] } + +data TypeErrorChoice -- What to do for type errors found by the type checker + = TypeError -- A type error aborts compilation with an error message + | TypeWarn WarnReason + -- A type error is deferred to runtime, plus a compile-time warning + -- The WarnReason should usually be (Reason Opt_WarnDeferredTypeErrors) + -- but it isn't for the Safe Haskell Overlapping Instances warnings + -- see warnAllUnsolved + | TypeDefer -- A type error is deferred to runtime; no error or warning at compile time + +data HoleChoice + = HoleError -- A hole is a compile-time error + | HoleWarn -- Defer to runtime, emit a compile-time warning + | HoleDefer -- Defer to runtime, no warning + +instance Outputable HoleChoice where + ppr HoleError = text "HoleError" + ppr HoleWarn = text "HoleWarn" + ppr HoleDefer = text "HoleDefer" + +instance Outputable TypeErrorChoice where + ppr TypeError = text "TypeError" + ppr (TypeWarn reason) = text "TypeWarn" <+> ppr reason + ppr TypeDefer = text "TypeDefer" + +data ReportErrCtxt + = CEC { cec_encl :: [Implication] -- Enclosing implications + -- (innermost first) + -- ic_skols and givens are tidied, rest are not + , cec_tidy :: TidyEnv + + , cec_binds :: EvBindsVar -- Make some errors (depending on cec_defer) + -- into warnings, and emit evidence bindings + -- into 'cec_binds' for unsolved constraints + + , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime + + -- cec_expr_holes is a union of: + -- cec_type_holes - a set of typed holes: '_', '_a', '_foo' + -- cec_out_of_scope_holes - a set of variables which are + -- out of scope: 'x', 'y', 'bar' + , cec_expr_holes :: HoleChoice -- Holes in expressions + , cec_type_holes :: HoleChoice -- Holes in types + , cec_out_of_scope_holes :: HoleChoice -- Out of scope holes + + , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints + + , cec_suppress :: Bool -- True <=> More important errors have occurred, + -- so create bindings if need be, but + -- don't issue any more errors/warnings + -- See Note [Suppressing error messages] + } + +instance Outputable ReportErrCtxt where + ppr (CEC { cec_binds = bvar + , cec_defer_type_errors = dte + , cec_expr_holes = eh + , cec_type_holes = th + , cec_out_of_scope_holes = osh + , cec_warn_redundant = wr + , cec_suppress = sup }) + = text "CEC" <+> braces (vcat + [ text "cec_binds" <+> equals <+> ppr bvar + , text "cec_defer_type_errors" <+> equals <+> ppr dte + , text "cec_expr_holes" <+> equals <+> ppr eh + , text "cec_type_holes" <+> equals <+> ppr th + , text "cec_out_of_scope_holes" <+> equals <+> ppr osh + , text "cec_warn_redundant" <+> equals <+> ppr wr + , text "cec_suppress" <+> equals <+> ppr sup ]) + +-- | Returns True <=> the ReportErrCtxt indicates that something is deferred +deferringAnyBindings :: ReportErrCtxt -> Bool + -- Don't check cec_type_holes, as these don't cause bindings to be deferred +deferringAnyBindings (CEC { cec_defer_type_errors = TypeError + , cec_expr_holes = HoleError + , cec_out_of_scope_holes = HoleError }) = False +deferringAnyBindings _ = True + +-- | Transforms a 'ReportErrCtxt' into one that does not defer any bindings +-- at all. +noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt +noDeferredBindings ctxt = ctxt { cec_defer_type_errors = TypeError + , cec_expr_holes = HoleError + , cec_out_of_scope_holes = HoleError } + +{- Note [Suppressing error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The cec_suppress flag says "don't report any errors". Instead, just create +evidence bindings (as usual). It's used when more important errors have occurred. + +Specifically (see reportWanteds) + * If there are insoluble Givens, then we are in unreachable code and all bets + are off. So don't report any further errors. + * If there are any insolubles (eg Int~Bool), here or in a nested implication, + then suppress errors from the simple constraints here. Sometimes the + simple-constraint errors are a knock-on effect of the insolubles. + +This suppression behaviour is controlled by the Bool flag in +ReportErrorSpec, as used in reportWanteds. + +But we need to take care: flags can turn errors into warnings, and we +don't want those warnings to suppress subsequent errors (including +suppressing the essential addTcEvBind for them: #15152). So in +tryReporter we use askNoErrs to see if any error messages were +/actually/ produced; if not, we don't switch on suppression. + +A consequence is that warnings never suppress warnings, so turning an +error into a warning may allow subsequent warnings to appear that were +previously suppressed. (e.g. partial-sigs/should_fail/T14584) +-} + +reportImplic :: ReportErrCtxt -> Implication -> TcM () +reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope + , ic_given = given + , ic_wanted = wanted, ic_binds = evb + , ic_status = status, ic_info = info + , ic_tclvl = tc_lvl }) + | BracketSkol <- info + , not insoluble + = return () -- For Template Haskell brackets report only + -- definite errors. The whole thing will be re-checked + -- later when we plug it in, and meanwhile there may + -- certainly be un-satisfied constraints + + | otherwise + = do { traceTc "reportImplic" (ppr implic') + ; reportWanteds ctxt' tc_lvl wanted + ; when (cec_warn_redundant ctxt) $ + warnRedundantConstraints ctxt' tcl_env info' dead_givens + ; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs } + where + tcl_env = ic_env implic + insoluble = isInsolubleStatus status + (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs + info' = tidySkolemInfo env1 info + implic' = implic { ic_skols = tvs' + , ic_given = map (tidyEvVar env1) given + , ic_info = info' } + ctxt1 | CoEvBindsVar{} <- evb = noDeferredBindings ctxt + | otherwise = ctxt + -- If we go inside an implication that has no term + -- evidence (e.g. unifying under a forall), we can't defer + -- type errors. You could imagine using the /enclosing/ + -- bindings (in cec_binds), but that may not have enough stuff + -- in scope for the bindings to be well typed. So we just + -- switch off deferred type errors altogether. See #14605. + + ctxt' = ctxt1 { cec_tidy = env1 + , cec_encl = implic' : cec_encl ctxt + + , cec_suppress = insoluble || cec_suppress ctxt + -- Suppress inessential errors if there + -- are insolubles anywhere in the + -- tree rooted here, or we've come across + -- a suppress-worthy constraint higher up (#11541) + + , cec_binds = evb } + + dead_givens = case status of + IC_Solved { ics_dead = dead } -> dead + _ -> [] + + bad_telescope = case status of + IC_BadTelescope -> True + _ -> False + +warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM () +-- See Note [Tracking redundant constraints] in GHC.Tc.Solver +warnRedundantConstraints ctxt env info ev_vars + | null redundant_evs + = return () + + | SigSkol {} <- info + = setLclEnv env $ -- We want to add "In the type signature for f" + -- to the error context, which is a bit tiresome + addErrCtxt (text "In" <+> ppr info) $ + do { env <- getLclEnv + ; msg <- mkErrorReport ctxt env (important doc) + ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } + + | 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 + = do { msg <- mkErrorReport ctxt env (important doc) + ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } + where + doc = text "Redundant constraint" <> plural redundant_evs <> colon + <+> pprEvVarTheta redundant_evs + + redundant_evs = + filterOut is_type_error $ + case info of -- See Note [Redundant constraints in instance decls] + InstSkol -> filterOut (improving . idType) ev_vars + _ -> ev_vars + + -- See #15232 + is_type_error = isJust . userTypeError_maybe . idType + + improving pred -- (transSuperClasses p) does not include p + = any isImprovementPred (pred : transSuperClasses pred) + +reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TcTyVar] -> TcM () +reportBadTelescope ctxt env (Just telescope) skols + = do { msg <- mkErrorReport ctxt env (important doc) + ; reportError msg } + where + doc = hang (text "These kind and type variables:" <+> telescope $$ + text "are out of dependency order. Perhaps try this ordering:") + 2 (pprTyVars sorted_tvs) + + sorted_tvs = scopedSort skols + +reportBadTelescope _ _ Nothing skols + = pprPanic "reportBadTelescope" (ppr skols) + +{- Note [Redundant constraints in instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For instance declarations, 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.. +-} + +reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () +reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics }) + = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples + , text "Suppress =" <+> ppr (cec_suppress ctxt)]) + ; traceTc "rw2" (ppr tidy_cts) + + -- First deal with things that are utterly wrong + -- Like Int ~ Bool (incl nullary TyCons) + -- or Int ~ t a (AppTy on one side) + -- These /ones/ are not suppressed by the incoming context + ; let ctxt_for_insols = ctxt { cec_suppress = False } + ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts + + -- Now all the other constraints. We suppress errors here if + -- any of the first batch failed, or if the enclosing context + -- says to suppress + ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } + ; (_, leftovers) <- tryReporters ctxt2 report2 cts1 + ; MASSERT2( null leftovers, ppr leftovers ) + + -- All the Derived ones have been filtered out of simples + -- by the constraint solver. This is ok; we don't want + -- to report unsolved Derived goals as errors + -- See Note [Do not report derived but soluble errors] + + ; mapBagM_ (reportImplic ctxt2) implics } + -- NB ctxt2: don't suppress inner insolubles if there's only a + -- wanted insoluble here; but do suppress inner insolubles + -- if there's a *given* insoluble here (= inaccessible code) + where + env = cec_tidy ctxt + tidy_cts = bagToList (mapBag (tidyCt env) simples) + + -- report1: ones that should *not* be suppressed by + -- an insoluble somewhere else in the tree + -- It's crucial that anything that is considered insoluble + -- (see GHC.Tc.Utils.insolubleCt) is caught here, otherwise + -- we might suppress its error message, and proceed on past + -- type checking to get a Lint error later + report1 = [ ("Out of scope", unblocked is_out_of_scope, True, mkHoleReporter tidy_cts) + , ("Holes", unblocked is_hole, False, mkHoleReporter tidy_cts) + , ("custom_error", unblocked is_user_type_error, True, mkUserTypeErrorReporter) + + , given_eq_spec + , ("insoluble2", unblocked utterly_wrong, True, mkGroupReporter mkEqErr) + , ("skolem eq1", unblocked very_wrong, True, mkSkolReporter) + , ("skolem eq2", unblocked skolem_eq, True, mkSkolReporter) + , ("non-tv eq", unblocked non_tv_eq, True, mkSkolReporter) + + -- The only remaining equalities are alpha ~ ty, + -- 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 + , ("Homo eqs", unblocked is_homo_equality, True, mkGroupReporter mkEqErr) + , ("Other eqs", unblocked is_equality, True, mkGroupReporter mkEqErr) + , ("Blocked eqs", is_equality, False, mkSuppressReporter mkBlockedEqErr)] + + -- report2: we suppress these if there are insolubles elsewhere in the tree + report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr) + , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) + , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] + + -- also checks to make sure the constraint isn't BlockedCIS + -- See TcCanonical Note [Equalities with incompatible kinds], (4) + unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool + unblocked _ (CIrredCan { cc_status = BlockedCIS }) _ = False + unblocked checker ct pred = checker ct pred + + -- rigid_nom_eq, rigid_nom_tv_eq, + is_hole, is_dict, + is_equality, is_ip, is_irred :: Ct -> Pred -> Bool + + is_given_eq ct pred + | EqPred {} <- pred = arisesFromGivens ct + | otherwise = False + -- I think all given residuals are equalities + + -- Things like (Int ~N Bool) + utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2 + utterly_wrong _ _ = False + + -- Things like (a ~N Int) + very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2 + very_wrong _ _ = False + + -- Things like (a ~N b) or (a ~N F Bool) + skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1 + skolem_eq _ _ = False + + -- Things like (F a ~N Int) + non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1) + non_tv_eq _ _ = False + + is_out_of_scope ct _ = isOutOfScopeCt ct + is_hole ct _ = isHoleCt ct + + is_user_type_error ct _ = isUserTypeErrorCt ct + + is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2 + is_homo_equality _ _ = False + + is_equality _ (EqPred {}) = True + is_equality _ _ = False + + is_dict _ (ClassPred {}) = True + is_dict _ _ = False + + is_ip _ (ClassPred cls _) = isIPClass cls + is_ip _ _ = False + + is_irred _ (IrredPred {}) = True + is_irred _ _ = False + + given_eq_spec -- See Note [Given errors] + | has_gadt_match (cec_encl ctxt) + = ("insoluble1a", is_given_eq, True, mkGivenErrorReporter) + | otherwise + = ("insoluble1b", is_given_eq, False, ignoreErrorReporter) + -- False means don't suppress subsequent errors + -- Reason: we don't report all given errors + -- (see mkGivenErrorReporter), and we should only suppress + -- subsequent errors if we actually report this one! + -- #13446 is an example + + -- See Note [Given errors] + has_gadt_match [] = False + has_gadt_match (implic : implics) + | PatSkol {} <- ic_info implic + , not (ic_no_eqs implic) + , ic_warn_inaccessible implic + -- Don't bother doing this if -Winaccessible-code isn't enabled. + -- See Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance. + = True + | otherwise + = has_gadt_match implics + +--------------- +isSkolemTy :: TcLevel -> Type -> Bool +-- The type is a skolem tyvar +isSkolemTy tc_lvl ty + | Just tv <- getTyVar_maybe ty + = isSkolemTyVar tv + || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv) + -- The last case is for touchable TyVarTvs + -- we postpone untouchables to a latter test (too obscure) + + | otherwise + = False + +isTyFun_maybe :: Type -> Maybe TyCon +isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of + Just (tc,_) | isTypeFamilyTyCon tc -> Just tc + _ -> Nothing + +-------------------------------------------- +-- Reporters +-------------------------------------------- + +type Reporter + = ReportErrCtxt -> [Ct] -> TcM () +type ReporterSpec + = ( String -- Name + , Ct -> Pred -> Bool -- Pick these ones + , Bool -- True <=> suppress subsequent reporters + , Reporter) -- The reporter itself + +mkSkolReporter :: Reporter +-- Suppress duplicates with either the same LHS, or same location +mkSkolReporter ctxt cts + = mapM_ (reportGroup mkEqErr ctxt) (group cts) + where + group [] = [] + group (ct:cts) = (ct : yeses) : group noes + where + (yeses, noes) = partition (group_with ct) cts + + group_with ct1 ct2 + | EQ <- cmp_loc ct1 ct2 = True + | eq_lhs_type ct1 ct2 = True + | otherwise = False + +mkHoleReporter :: [Ct] -> Reporter +-- Reports errors one at a time +mkHoleReporter tidy_simples ctxt + = mapM_ $ \ct -> do { err <- mkHoleError tidy_simples ctxt ct + ; maybeReportHoleError ctxt ct err + ; maybeAddDeferredHoleBinding ctxt err ct } + +mkUserTypeErrorReporter :: Reporter +mkUserTypeErrorReporter ctxt + = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct + ; maybeReportError ctxt err + ; addDeferredBinding ctxt err ct } + +mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg +mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct + $ important + $ pprUserTypeErrorTy + $ case getUserTypeErrorMsg ct of + Just msg -> msg + Nothing -> pprPanic "mkUserTypeError" (ppr ct) + + +mkGivenErrorReporter :: Reporter +-- See Note [Given errors] +mkGivenErrorReporter ctxt cts + = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct + ; dflags <- getDynFlags + ; let (implic:_) = cec_encl ctxt + -- Always non-empty when mkGivenErrorReporter is called + ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic)) + -- For given constraints we overwrite the env (and hence src-loc) + -- with one from the immediately-enclosing implication. + -- See Note [Inaccessible code] + + inaccessible_msg = hang (text "Inaccessible code in") + 2 (ppr (ic_info implic)) + report = important inaccessible_msg `mappend` + relevant_bindings binds_msg + + ; err <- mkEqErr_help dflags ctxt report ct' + Nothing ty1 ty2 + + ; traceTc "mkGivenErrorReporter" (ppr ct) + ; reportWarning (Reason Opt_WarnInaccessibleCode) err } + where + (ct : _ ) = cts -- Never empty + (ty1, ty2) = getEqPredTys (ctPred ct) + +ignoreErrorReporter :: Reporter +-- Discard Given errors that don't come from +-- a pattern match; maybe we should warn instead? +ignoreErrorReporter ctxt cts + = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt)) + ; return () } + + +{- Note [Given errors] +~~~~~~~~~~~~~~~~~~~~~~ +Given constraints represent things for which we have (or will have) +evidence, so they aren't errors. But if a Given constraint is +insoluble, this code is inaccessible, and we might want to at least +warn about that. A classic case is + + data T a where + T1 :: T Int + T2 :: T a + T3 :: T Bool + + f :: T Int -> Bool + f T1 = ... + f T2 = ... + f T3 = ... -- We want to report this case as inaccessible + +We'd like to point out that the T3 match is inaccessible. It +will have a Given constraint [G] Int ~ Bool. + +But we don't want to report ALL insoluble Given constraints. See Trac +#12466 for a long discussion. For example, if we aren't careful +we'll complain about + f :: ((Int ~ Bool) => a -> a) -> Int +which arguably is OK. It's more debatable for + g :: (Int ~ Bool) => Int -> Int +but it's tricky to distinguish these cases so we don't report +either. + +The bottom line is this: has_gadt_match looks for an enclosing +pattern match which binds some equality constraints. If we +find one, we report the insoluble Given. +-} + +mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) + -- 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 cts + = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) + +-- Like mkGroupReporter, but doesn't actually print error messages +mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter +mkSuppressReporter mk_err ctxt cts + = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) + +eq_lhs_type :: Ct -> Ct -> Bool +eq_lhs_type ct1 ct2 + = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of + (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) -> + (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2) + _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2) + +cmp_loc :: Ct -> Ct -> Ordering +cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2) + +reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter +reportGroup mk_err ctxt cts = + ASSERT( not (null cts)) + do { err <- mk_err ctxt cts + ; traceTc "About to maybeReportErr" $ + vcat [ text "Constraint:" <+> ppr cts + , text "cec_suppress =" <+> ppr (cec_suppress ctxt) + , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ] + ; maybeReportError ctxt err + -- But see Note [Always warn with -fdefer-type-errors] + ; traceTc "reportGroup" (ppr cts) + ; mapM_ (addDeferredBinding ctxt err) cts } + -- Add deferred bindings for all + -- Redundant if we are going to abort compilation, + -- but that's hard to know for sure, and if we don't + -- abort, we need bindings for all (e.g. #12156) + +-- like reportGroup, but does not actually report messages. It still adds +-- -fdefer-type-errors bindings, though. +suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter +suppressGroup mk_err ctxt cts + = do { err <- mk_err ctxt cts + ; traceTc "Suppressing errors for" (ppr cts) + ; mapM_ (addDeferredBinding ctxt err) cts } + +maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM () +-- Unlike maybeReportError, these "hole" errors are +-- /not/ suppressed by cec_suppress. We want to see them! +maybeReportHoleError ctxt ct err + -- When -XPartialTypeSignatures is on, warnings (instead of errors) are + -- generated for holes in partial type signatures. + -- Unless -fwarn-partial-type-signatures is not on, + -- in which case the messages are discarded. + | isTypeHoleCt ct + = -- For partial type signatures, generate warnings only, and do that + -- only if -fwarn-partial-type-signatures is on + case cec_type_holes ctxt of + HoleError -> reportError err + HoleWarn -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err + HoleDefer -> return () + + -- Always report an error for out-of-scope variables + -- Unless -fdefer-out-of-scope-variables is on, + -- in which case the messages are discarded. + -- See #12170, #12406 + | isOutOfScopeCt ct + = -- If deferring, report a warning only if -Wout-of-scope-variables is on + case cec_out_of_scope_holes ctxt of + HoleError -> reportError err + HoleWarn -> + reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err + HoleDefer -> return () + + -- Otherwise this is a typed hole in an expression, + -- but not for an out-of-scope variable + | otherwise + = -- If deferring, report a warning only if -Wtyped-holes is on + case cec_expr_holes ctxt of + HoleError -> reportError err + HoleWarn -> reportWarning (Reason Opt_WarnTypedHoles) err + HoleDefer -> return () + +maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM () +-- Report the error and/or make a deferred binding for it +maybeReportError ctxt err + | cec_suppress ctxt -- Some worse error has occurred; + = return () -- so suppress this error/warning + + | otherwise + = case cec_defer_type_errors ctxt of + TypeDefer -> return () + TypeWarn reason -> reportWarning reason err + TypeError -> reportError err + +addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () +-- See Note [Deferring coercion errors to runtime] +addDeferredBinding ctxt err ct + | deferringAnyBindings ctxt + , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct + -- Only add deferred bindings for Wanted constraints + = do { dflags <- getDynFlags + ; let err_msg = pprLocErrMsg err + err_fs = mkFastString $ showSDoc dflags $ + err_msg $$ text "(deferred type error)" + err_tm = evDelayedError pred err_fs + ev_binds_var = cec_binds ctxt + + ; case dest of + EvVarDest evar + -> addTcEvBind ev_binds_var $ mkWantedEvBind evar 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 + ; fillCoercionHole hole (mkTcCoVarCo co_var) }} + + | otherwise -- Do not set any evidence for Given/Derived + = return () + +maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () +maybeAddDeferredHoleBinding ctxt err ct + | isExprHoleCt ct + = addDeferredBinding ctxt err ct -- Only add bindings for holes in expressions + | otherwise -- not for holes in partial type signatures + = return () + +tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) +-- Use the first reporter in the list whose predicate says True +tryReporters ctxt reporters cts + = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts + ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts) + ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts + ; traceTc "tryReporters }" (ppr cts') + ; return (ctxt', cts') } + where + go ctxt [] vis_cts invis_cts + = return (ctxt, vis_cts ++ invis_cts) + + go ctxt (r : rs) vis_cts invis_cts + -- always look at *visible* Origins before invisible ones + -- this is the whole point of isVisibleOrigin + = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts + ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts + ; go ctxt'' rs vis_cts' invis_cts' } + -- Carry on with the rest, because we must make + -- deferred bindings for them if we have -fdefer-type-errors + -- But suppress their error messages + +tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct]) +tryReporter ctxt (str, keep_me, suppress_after, reporter) cts + | null yeses + = return (ctxt, cts) + | otherwise + = 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] + ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt } + ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after) + ; return (ctxt', nos) } + where + (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts + + +pprArising :: CtOrigin -> SDoc +-- Used for the main, top-level error message +-- We've done special processing for TypeEq, KindEq, Given +pprArising (TypeEqOrigin {}) = empty +pprArising (KindEqOrigin {}) = empty +pprArising (GivenOrigin {}) = empty +pprArising orig = pprCtOrigin orig + +-- Add the "arising from..." part to a message about bunch of dicts +addArising :: CtOrigin -> SDoc -> SDoc +addArising orig msg = hang msg 2 (pprArising orig) + +pprWithArising :: [Ct] -> (CtLoc, SDoc) +-- Print something like +-- (Eq a) arising from a use of x at y +-- (Show a) arising from a use of p at q +-- Also return a location for the error message +-- Works for Wanted/Derived only +pprWithArising [] + = panic "pprWithArising" +pprWithArising (ct:cts) + | null cts + = (loc, addArising (ctLocOrigin loc) + (pprTheta [ctPred ct])) + | otherwise + = (loc, vcat (map ppr_one (ct:cts))) + where + loc = ctLoc ct + ppr_one ct' = hang (parens (pprType (ctPred ct'))) + 2 (pprCtLoc (ctLoc ct')) + +mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg +mkErrorMsgFromCt ctxt ct report + = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report + +mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg +mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs) + = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) + ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing) + (errDoc important [context] (relevant_bindings ++ valid_subs)) + } + +type UserGiven = Implication + +getUserGivens :: ReportErrCtxt -> [UserGiven] +-- One item for each enclosing implication +getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics + +getUserGivensFromImplics :: [Implication] -> [UserGiven] +getUserGivensFromImplics implics + = reverse (filterOut (null . ic_given) implics) + +{- Note [Always warn with -fdefer-type-errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When -fdefer-type-errors is on we warn about *all* type errors, even +if cec_suppress is on. This can lead to a lot more warnings than you +would get errors without -fdefer-type-errors, but if we suppress any of +them you might get a runtime error that wasn't warned about at compile +time. + +This is an easy design choice to change; just flip the order of the +first two equations for maybeReportError + +To be consistent, we should also report multiple warnings from a single +location in mkGroupReporter, when -fdefer-type-errors is on. But that +is perhaps a bit *over*-consistent! Again, an easy choice to change. + +With #10283, you can now opt out of deferred type error warnings. + +Note [Deferred errors for coercion holes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we need to defer a type error where the destination for the evidence +is a coercion hole. We can't just put the error in the hole, because we can't +make an erroneous coercion. (Remember that coercions are erased for runtime.) +Instead, we invent a new EvVar, bind it to an error and then make a coercion +from that EvVar, filling the hole with that coercion. Because coercions' +types are unlifted, the error is guaranteed to be hit before we get to the +coercion. + +Note [Do not report derived but soluble errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The wc_simples include Derived constraints that have not been solved, +but are not insoluble (in that case they'd be reported by 'report1'). +We do not want to report these as errors: + +* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have + an unsolved [D] Eq a, and we do not want to report that; it's just noise. + +* Functional dependencies. For givens, consider + class C a b | a -> b + data T a where + MkT :: C a d => [d] -> T a + f :: C a b => T a -> F Int + f (MkT xs) = length xs + Then we get a [D] b~d. But there *is* a legitimate call to + f, namely f (MkT [True]) :: T Bool, in which b=d. So we should + not reject the program. + + For wanteds, something similar + data T a where + MkT :: C Int b => a -> b -> T a + g :: C Int c => c -> () + f :: T a -> () + f (MkT x y) = g x + Here we get [G] C Int b, [W] C Int a, hence [D] a~b. + But again f (MkT True True) is a legitimate call. + +(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose +derived superclasses between iterations of the solver.) + +For functional dependencies, here is a real example, +stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs + + class C a b | a -> b + g :: C a b => a -> b -> () + f :: C a b => a -> b -> () + f xa xb = + let loop = g xa + in loop xb + +We will first try to infer a type for loop, and we will succeed: + C a b' => b' -> () +Subsequently, we will type check (loop xb) and all is good. But, +recall that we have to solve a final implication constraint: + C a b => (C a b' => .... cts from body of loop .... )) +And now we have a problem as we will generate an equality b ~ b' and fail to +solve it. + + +************************************************************************ +* * + Irreducible predicate errors +* * +************************************************************************ +-} + +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkIrredErr ctxt cts + = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 + ; let orig = ctOrigin ct1 + msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig) + ; mkErrorMsgFromCt ctxt ct1 $ + important msg `mappend` relevant_bindings binds_msg } + where + (ct1:_) = cts + +---------------- +mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg +mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort }) + | isOutOfScopeCt ct -- Out of scope variables, like 'a', where 'a' isn't bound + -- Suggest possible in-scope variables in the message + = do { dflags <- getDynFlags + ; rdr_env <- getGlobalRdrEnv + ; imp_info <- getImports + ; curr_mod <- getModule + ; hpt <- getHpt + ; mkErrDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing) $ + errDoc [out_of_scope_msg] [] + [unknownNameSuggestions dflags hpt curr_mod rdr_env + (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)] } + + | otherwise -- Explicit holes, like "_" or "_f" + = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct + -- The 'False' means "don't filter the bindings"; see Trac #8191 + + ; show_hole_constraints <- goptM Opt_ShowHoleConstraints + ; let constraints_msg + | isExprHoleCt ct, show_hole_constraints + = givenConstraintsMsg ctxt + | otherwise + = empty + + ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits + ; (ctxt, sub_msg) <- if show_valid_hole_fits + then validHoleFits ctxt tidy_simples ct + else return (ctxt, empty) + + ; mkErrorMsgFromCt ctxt ct $ + important hole_msg `mappend` + relevant_bindings (binds_msg $$ constraints_msg) `mappend` + valid_hole_fits sub_msg } + + where + ct_loc = ctLoc ct + lcl_env = ctLocEnv ct_loc + hole_ty = ctEvPred (ctEvidence ct) + hole_kind = tcTypeKind hole_ty + tyvars = tyCoVarsOfTypeList hole_ty + boring_type = isTyVarTy hole_ty + + out_of_scope_msg -- Print v :: ty only if the type has structure + | boring_type = hang herald 2 (ppr occ) + | otherwise = hang herald 2 pp_with_type + + pp_with_type = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) + herald | isDataOcc occ = text "Data constructor not in scope:" + | otherwise = text "Variable not in scope:" + + hole_msg = case hole_sort of + ExprHole -> vcat [ hang (text "Found hole:") + 2 pp_with_type + , tyvars_msg, expr_hole_hint ] + TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ)) + 2 (text "standing for" <+> quotes pp_hole_type_with_kind) + , tyvars_msg, type_hole_hint ] + + pp_hole_type_with_kind + | isLiftedTypeKind hole_kind + || isCoVarType hole_ty -- Don't print the kind of unlifted + -- equalities (#15039) + = pprType hole_ty + | otherwise + = pprType hole_ty <+> dcolon <+> pprKind hole_kind + + tyvars_msg = ppUnless (null tyvars) $ + text "Where:" <+> (vcat (map loc_msg other_tvs) + $$ pprSkols ctxt skol_tvs) + where + (skol_tvs, other_tvs) = partition is_skol tyvars + is_skol tv = isTcTyVar tv && isSkolemTyVar tv + -- Coercion variables can be free in the + -- hole, via kind casts + + type_hole_hint + | HoleError <- cec_type_holes ctxt + = text "To use the inferred type, enable PartialTypeSignatures" + | otherwise + = empty + + expr_hole_hint -- Give hint for, say, f x = _x + | lengthFS (occNameFS occ) > 1 -- Don't give this hint for plain "_" + = text "Or perhaps" <+> quotes (ppr occ) + <+> text "is mis-spelled, or not in scope" + | otherwise + = empty + + loc_msg tv + | isTyVar tv + = case tcTyVarDetails tv of + MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" + _ -> empty -- Skolems dealt with already + | otherwise -- A coercion variable can be free in the hole type + = ppWhenOption sdocPrintExplicitCoercions $ + quotes (ppr tv) <+> text "is a coercion variable" + +mkHoleError _ _ ct = pprPanic "mkHoleError" (ppr ct) + +-- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module +-- imports +validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the + -- implications and the tidy environment + -> [Ct] -- Unsolved simple constraints + -> Ct -- The hole constraint. + -> TcM (ReportErrCtxt, SDoc) -- We return the new context + -- with a possibly updated + -- tidy environment, and + -- the message. +validHoleFits ctxt@(CEC {cec_encl = implics + , cec_tidy = lcl_env}) simps ct + = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps ct + ; return (ctxt {cec_tidy = tidy_env}, msg) } + +-- See Note [Constraints include ...] +givenConstraintsMsg :: ReportErrCtxt -> SDoc +givenConstraintsMsg ctxt = + let constraints :: [(Type, RealSrcSpan)] + constraints = + do { implic@Implic{ ic_given = given } <- cec_encl ctxt + ; constraint <- given + ; return (varType constraint, tcl_loc (ic_env implic)) } + + pprConstraint (constraint, loc) = + ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) + + in ppUnless (null constraints) $ + hang (text "Constraints include") + 2 (vcat $ map pprConstraint constraints) + +---------------- +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkIPErr ctxt cts + = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 + ; let orig = ctOrigin ct1 + preds = map ctPred cts + givens = getUserGivens ctxt + msg | null givens + = addArising orig $ + sep [ text "Unbound implicit parameter" <> plural cts + , nest 2 (pprParendTheta preds) ] + | otherwise + = couldNotDeduce givens (preds, orig) + + ; mkErrorMsgFromCt ctxt ct1 $ + important msg `mappend` relevant_bindings binds_msg } + where + (ct1:_) = cts + +{- +Note [Constraints include ...] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'givenConstraintsMsg' returns the "Constraints include ..." message enabled by +-fshow-hole-constraints. For example, the following hole: + + foo :: (Eq a, Show a) => a -> String + foo x = _ + +would generate the message: + + Constraints include + Eq a (from foo.hs:1:1-36) + Show a (from foo.hs:1:1-36) + +Constraints are displayed in order from innermost (closest to the hole) to +outermost. There's currently no filtering or elimination of duplicates. + +************************************************************************ +* * + Equality errors +* * +************************************************************************ + +Note [Inaccessible code] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a where + T1 :: T a + T2 :: T Bool + + f :: (a ~ Int) => T a -> Int + f T1 = 3 + f T2 = 4 -- Unreachable code + +Here the second equation is unreachable. The original constraint +(a~Int) from the signature gets rewritten by the pattern-match to +(Bool~Int), so the danger is that we report the error as coming from +the *signature* (#7293). So, for Given errors we replace the +env (and hence src-loc) on its CtLoc with that from the immediately +enclosing implication. + +Note [Error messages for untouchables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#9109) + data G a where { GBool :: G Bool } + foo x = case x of GBool -> True + +Here we can't solve (t ~ Bool), where t is the untouchable result +meta-var 't', because of the (a ~ Bool) from the pattern match. +So we infer the type + f :: forall a t. G a -> t +making the meta-var 't' into a skolem. So when we come to report +the unsolved (t ~ Bool), t won't look like an untouchable meta-var +any more. So we don't assert that it is. +-} + +-- Don't have multiple equality errors from the same location +-- E.g. (Int,Bool) ~ (Bool,Int) one error will do! +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct +mkEqErr _ [] = panic "mkEqErr" + +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg +mkEqErr1 ctxt ct -- Wanted or derived; + -- givens handled in mkGivenErrorReporter + = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct + ; rdr_env <- getGlobalRdrEnv + ; fam_envs <- tcGetFamInstEnvs + ; exp_syns <- goptM Opt_PrintExpandedSynonyms + ; let (keep_going, is_oriented, wanted_msg) + = mk_wanted_extra (ctLoc ct) exp_syns + coercible_msg = case ctEqRel ct of + NomEq -> empty + ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + ; dflags <- getDynFlags + ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct) $$ ppr keep_going) + ; let report = mconcat [important wanted_msg, important coercible_msg, + relevant_bindings binds_msg] + ; if keep_going + then mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2 + else mkErrorMsgFromCt ctxt ct report } + where + (ty1, ty2) = getEqPredTys (ctPred ct) + + -- If the types in the error message are the same as the types + -- we are unifying, don't add the extra expected/actual message + mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc) + mk_wanted_extra loc expandSyns + = case ctLocOrigin loc of + orig@TypeEqOrigin {} -> mkExpectedActualMsg ty1 ty2 orig + t_or_k expandSyns + where + t_or_k = ctLocTypeOrKind_maybe loc + + KindEqOrigin cty1 mb_cty2 sub_o sub_t_or_k + -> (True, Nothing, msg1 $$ msg2) + where + sub_what = case sub_t_or_k of Just KindLevel -> text "kinds" + _ -> text "types" + msg1 = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> + case mb_cty2 of + Just cty2 + | printExplicitCoercions + || not (cty1 `pickyEqType` cty2) + -> hang (text "When matching" <+> sub_what) + 2 (vcat [ ppr cty1 <+> dcolon <+> + ppr (tcTypeKind cty1) + , ppr cty2 <+> dcolon <+> + ppr (tcTypeKind cty2) ]) + _ -> text "When matching the kind of" <+> quotes (ppr cty1) + msg2 = case sub_o of + TypeEqOrigin {} + | Just cty2 <- mb_cty2 -> + thdOf3 (mkExpectedActualMsg cty1 cty2 sub_o sub_t_or_k + expandSyns) + _ -> empty + _ -> (True, Nothing, empty) + +-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint +-- is left over. +mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs + -> TcType -> TcType -> SDoc +mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + | Just (tc, tys) <- tcSplitTyConApp_maybe ty1 + , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys + , Just msg <- coercible_msg_for_tycon rep_tc + = msg + | Just (tc, tys) <- splitTyConApp_maybe ty2 + , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys + , Just msg <- coercible_msg_for_tycon rep_tc + = msg + | Just (s1, _) <- tcSplitAppTy_maybe ty1 + , Just (s2, _) <- tcSplitAppTy_maybe ty2 + , s1 `eqType` s2 + , has_unknown_roles s1 + = hang (text "NB: We cannot know what roles the parameters to" <+> + quotes (ppr s1) <+> text "have;") + 2 (text "we must assume that the role is nominal") + | otherwise + = empty + where + coercible_msg_for_tycon tc + | isAbstractTyCon tc + = Just $ hsep [ text "NB: The type constructor" + , quotes (pprSourceTyCon tc) + , text "is abstract" ] + | isNewTyCon tc + , [data_con] <- tyConDataCons tc + , let dc_name = dataConName data_con + , isNothing (lookupGRE_Name rdr_env dc_name) + = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name)) + 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) + , text "is not in scope" ]) + | otherwise = Nothing + + has_unknown_roles ty + | Just (tc, tys) <- tcSplitTyConApp_maybe ty + = tys `lengthAtLeast` tyConArity tc -- oversaturated tycon + | Just (s, _) <- tcSplitAppTy_maybe ty + = has_unknown_roles s + | isTyVarTy ty + = True + | otherwise + = False + +{- +-- | Make a listing of role signatures for all the parameterised tycons +-- used in the provided types + + +-- SLPJ Jun 15: I could not convince myself that these hints were really +-- useful. Maybe they are, but I think we need more work to make them +-- actually helpful. +mkRoleSigs :: Type -> Type -> SDoc +mkRoleSigs ty1 ty2 + = ppUnless (null role_sigs) $ + hang (text "Relevant role signatures:") + 2 (vcat role_sigs) + where + tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2 + role_sigs = mapMaybe ppr_role_sig tcs + + ppr_role_sig tc + | null roles -- if there are no parameters, don't bother printing + = Nothing + | isBuiltInSyntax (tyConName tc) -- don't print roles for (->), etc. + = Nothing + | otherwise + = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles + where + roles = tyConRoles tc +-} + +mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report + -> Ct + -> Maybe SwapFlag -- Nothing <=> not sure + -> TcType -> TcType -> TcM ErrMsg +mkEqErr_help dflags ctxt report ct oriented ty1 ty2 + | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 + = mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 + | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2 + = mkTyVarEqErr dflags ctxt report ct swapped tv2 ty1 + | otherwise + = reportEqErr ctxt report ct oriented ty1 ty2 + where + swapped = fmap flipSwap oriented + +reportEqErr :: ReportErrCtxt -> Report + -> Ct + -> Maybe SwapFlag -- Nothing <=> not sure + -> TcType -> TcType -> TcM ErrMsg +reportEqErr ctxt report ct oriented ty1 ty2 + = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo]) + where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2 + eqInfo = important $ mkEqInfoMsg ct ty1 ty2 + +mkTyVarEqErr, mkTyVarEqErr' + :: DynFlags -> ReportErrCtxt -> Report -> Ct + -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg +-- tv1 and ty2 are already tidied +mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 + = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) + ; mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2 } + +mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2 + | not insoluble_occurs_check -- See Note [Occurs check wins] + , isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would + -- be oriented the other way round; + -- see GHC.Tc.Solver.Canonical.canEqTyVarTyVar + || isTyVarTyVar tv1 && not (isTyVarTy ty2) + || ctEqRel ct == ReprEq + -- the cases below don't really apply to ReprEq (except occurs check) + = mkErrorMsgFromCt ctxt ct $ mconcat + [ important $ misMatchOrCND ctxt ct oriented ty1 ty2 + , important $ extraTyVarEqInfo ctxt tv1 ty2 + , report + ] + + | MTVU_Occurs <- occ_check_expand + -- 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 + -- See Note [Occurs check error] in GHC.Tc.Solver.Canonical + = do { let main_msg = addArising (ctOrigin ct) $ + hang (text "Occurs check: cannot construct the infinite" <+> what <> colon) + 2 (sep [ppr ty1, char '~', ppr ty2]) + + extra2 = important $ mkEqInfoMsg ct ty1 ty2 + + interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ + filter isTyVar $ + fvVarList $ + tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 + extra3 = relevant_bindings $ + ppWhen (not (null interesting_tyvars)) $ + hang (text "Type variable kinds:") 2 $ + vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) + interesting_tyvars) + + tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) + ; mkErrorMsgFromCt ctxt ct $ + mconcat [important main_msg, extra2, extra3, report] } + + | MTVU_Bad <- occ_check_expand + = do { let msg = vcat [ text "Cannot instantiate unification variable" + <+> quotes (ppr tv1) + , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) + , nest 2 (text "GHC doesn't yet support impredicative polymorphism") ] + -- Unlike the other reports, this discards the old 'report_important' + -- instead of augmenting it. This is because the details are not likely + -- to be helpful since this is just an unimplemented feature. + ; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } } + + -- 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 + -- that there's no occurs-check or forall problem + | (implic:_) <- cec_encl ctxt + , Implic { ic_skols = skols } <- implic + , tv1 `elem` skols + = mkErrorMsgFromCt ctxt ct $ mconcat + [ important $ misMatchMsg ct oriented ty1 ty2 + , important $ extraTyVarEqInfo ctxt tv1 ty2 + , report + ] + + -- Check for skolem escape + | (implic:_) <- cec_encl ctxt -- Get the innermost context + , Implic { ic_skols = skols, ic_info = skol_info } <- implic + , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols + , not (null esc_skols) + = do { let msg = important $ misMatchMsg ct oriented ty1 ty2 + esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols + <+> pprQuotedList esc_skols + , text "would escape" <+> + if isSingleton esc_skols then text "its scope" + else text "their scope" ] + tv_extra = important $ + vcat [ nest 2 $ esc_doc + , sep [ (if isSingleton esc_skols + then text "This (rigid, skolem)" <+> + what <+> text "variable is" + else text "These (rigid, skolem)" <+> + what <+> text "variables are") + <+> text "bound by" + , nest 2 $ ppr skol_info + , nest 2 $ text "at" <+> + ppr (tcl_loc (ic_env implic)) ] ] + ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) } + + -- Nastiest case: attempt to unify an untouchable variable + -- So tv is a meta tyvar (or started that way before we + -- generalised it). So presumably it is an *untouchable* + -- meta tyvar or a TyVarTv, else it'd have been unified + -- See Note [Error messages for untouchables] + | (implic:_) <- cec_encl ctxt -- Get the innermost context + , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic + = ASSERT2( not (isTouchableMetaTyVar lvl tv1) + , ppr tv1 $$ ppr lvl ) -- See Note [Error messages for untouchables] + do { let msg = important $ misMatchMsg ct oriented ty1 ty2 + tclvl_extra = important $ + nest 2 $ + sep [ quotes (ppr tv1) <+> text "is untouchable" + , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given + , nest 2 $ text "bound by" <+> ppr skol_info + , nest 2 $ text "at" <+> + ppr (tcl_loc (ic_env implic)) ] + tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2 + add_sig = important $ suggestAddSig ctxt ty1 ty2 + ; mkErrorMsgFromCt ctxt ct $ mconcat + [msg, tclvl_extra, tv_extra, add_sig, report] } + + | otherwise + = reportEqErr ctxt report ct oriented (mkTyVarTy tv1) ty2 + -- This *can* happen (#6123, and test T2627b) + -- Consider an ambiguous top-level constraint (a ~ F a) + -- Not an occurs check, because F is a type function. + where + ty1 = mkTyVarTy tv1 + occ_check_expand = occCheckForErrors dflags tv1 ty2 + insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2 + + what = case ctLocTypeOrKind_maybe (ctLoc ct) of + Just KindLevel -> text "kind" + _ -> text "type" + +mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc +-- Report (a) ambiguity if either side is a type function application +-- e.g. F a0 ~ Int +-- (b) warning about injectivity if both sides are the same +-- type function application F a ~ F b +-- See Note [Non-injective type functions] +mkEqInfoMsg ct ty1 ty2 + = tyfun_msg $$ ambig_msg + where + mb_fun1 = isTyFun_maybe ty1 + mb_fun2 = isTyFun_maybe ty2 + + ambig_msg | isJust mb_fun1 || isJust mb_fun2 + = snd (mkAmbigMsg False ct) + | otherwise = empty + + tyfun_msg | Just tc1 <- mb_fun1 + , Just tc2 <- mb_fun2 + , tc1 == tc2 + , not (isInjectiveTyCon tc1 Nominal) + = text "NB:" <+> quotes (ppr tc1) + <+> text "is a non-injective type family" + | otherwise = empty + +isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool +-- See Note [Reporting occurs-check errors] +isUserSkolem ctxt tv + = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt) + where + is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info }) + = tv `elem` sks && is_user_skol_info skol_info + + is_user_skol_info (InferSkol {}) = False + is_user_skol_info _ = True + +misMatchOrCND :: ReportErrCtxt -> Ct + -> Maybe SwapFlag -> TcType -> TcType -> SDoc +-- If oriented then ty1 is actual, ty2 is expected +misMatchOrCND ctxt ct oriented ty1 ty2 + | null givens || + (isRigidTy ty1 && isRigidTy ty2) || + isGivenCt ct + -- If the equality is unconditionally insoluble + -- or there is no context, don't report the context + = misMatchMsg ct oriented ty1 ty2 + | otherwise + = couldNotDeduce givens ([eq_pred], orig) + where + ev = ctEvidence ct + eq_pred = ctEvPred ev + orig = ctEvOrigin ev + givens = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)] + -- Keep only UserGivens that have some equalities. + -- See Note [Suppress redundant givens during error reporting] + +couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc +couldNotDeduce givens (wanteds, orig) + = vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds) + , vcat (pp_givens givens)] + +pp_givens :: [UserGiven] -> [SDoc] +pp_givens givens + = case givens of + [] -> [] + (g:gs) -> ppr_given (text "from the context:") g + : map (ppr_given (text "or from:")) gs + where + ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info }) + = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs)) + -- See Note [Suppress redundant givens during error reporting] + -- for why we use mkMinimalBySCs above. + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> ppr (tcl_loc (ic_env implic)) ]) + +-- These are for the "blocked" equalities, as described in TcCanonical +-- Note [Equalities with incompatible kinds], wrinkle (2). 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. +mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report + where + report = important msg + msg = vcat [ hang (text "Cannot use equality for substitution:") + 2 (ppr (ctPred ct)) + , text "Doing so would be ill-kinded." ] + -- This is a terrible message. Perhaps worse, if the user + -- has -fprint-explicit-kinds on, they will see that the two + -- sides have the same kind, as there is an invisible cast. + -- I really don't know how to do better. +mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints" + +{- +Note [Suppress redundant givens during error reporting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When GHC is unable to solve a constraint and prints out an error message, it +will print out what given constraints are in scope to provide some context to +the programmer. But we shouldn't print out /every/ given, since some of them +are not terribly helpful to diagnose type errors. Consider this example: + + foo :: Int :~: Int -> a :~: b -> a :~: c + foo Refl Refl = Refl + +When reporting that GHC can't solve (a ~ c), there are two givens in scope: +(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e., +redundant), so it's not terribly useful to report it in an error message. +To accomplish this, we discard any Implications that do not bind any +equalities by filtering the `givens` selected in `misMatchOrCND` (based on +the `ic_no_eqs` field of the Implication). + +But this is not enough to avoid all redundant givens! Consider this example, +from #15361: + + goo :: forall (a :: Type) (b :: Type) (c :: Type). + a :~~: b -> a :~~: c + goo HRefl = HRefl + +Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope. +The (* ~ *) part arises due the kinds of (:~~:) being unified. More +importantly, (* ~ *) is redundant, so we'd like not to report it. However, +the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its +ic_no_eqs field), so the test above will keep it wholesale. + +To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b) +part. This works because mkMinimalBySCs eliminates reflexive equalities in +addition to superclasses (see Note [Remove redundant provided dicts] +in GHC.Tc.TyCl.PatSyn). +-} + +extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc +-- Add on extra info about skolem constants +-- NB: The types themselves are already tidied +extraTyVarEqInfo ctxt tv1 ty2 + = extraTyVarInfo ctxt tv1 $$ ty_extra ty2 + where + ty_extra ty = case tcGetCastedTyVar_maybe ty of + Just (tv, _) -> extraTyVarInfo ctxt tv + Nothing -> empty + +extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc +extraTyVarInfo ctxt tv + = ASSERT2( isTyVar tv, ppr tv ) + case tcTyVarDetails tv of + SkolemTv {} -> pprSkols ctxt [tv] + RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" + MetaTv {} -> empty + +suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc +-- See Note [Suggest adding a type signature] +suggestAddSig ctxt ty1 ty2 + | null inferred_bndrs + = empty + | [bndr] <- inferred_bndrs + = text "Possible fix: add a type signature for" <+> quotes (ppr bndr) + | otherwise + = text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs) + where + inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2) + get_inf ty | Just tv <- tcGetTyVar_maybe ty + , isSkolemTyVar tv + , ((InferSkol prs, _) : _) <- getSkolemInfo (cec_encl ctxt) [tv] + = map fst prs + | otherwise + = [] + +-------------------- +misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc +-- Types are already tidy +-- If oriented then ty1 is actual, ty2 is expected +misMatchMsg ct oriented ty1 ty2 + | Just NotSwapped <- oriented + = misMatchMsg ct (Just IsSwapped) ty2 ty1 + + -- These next two cases are when we're about to report, e.g., that + -- 'LiftedRep doesn't match 'VoidRep. Much better just to say + -- lifted vs. unlifted + | isLiftedRuntimeRep ty1 + = lifted_vs_unlifted + + | isLiftedRuntimeRep ty2 + = lifted_vs_unlifted + + | otherwise -- So now we have Nothing or (Just IsSwapped) + -- For some reason we treat Nothing like IsSwapped + = addArising orig $ + pprWithExplicitKindsWhenMismatch ty1 ty2 (ctOrigin ct) $ + sep [ text herald1 <+> quotes (ppr ty1) + , nest padding $ + text herald2 <+> quotes (ppr ty2) + , sameOccExtra ty2 ty1 ] + where + herald1 = conc [ "Couldn't match" + , if is_repr then "representation of" else "" + , if is_oriented then "expected" else "" + , what ] + herald2 = conc [ "with" + , if is_repr then "that of" else "" + , if is_oriented then ("actual " ++ what) else "" ] + padding = length herald1 - length herald2 + + is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False } + is_oriented = isJust oriented + + orig = ctOrigin ct + what = case ctLocTypeOrKind_maybe (ctLoc ct) of + Just KindLevel -> "kind" + _ -> "type" + + conc :: [String] -> String + conc = foldr1 add_space + + add_space :: String -> String -> String + add_space s1 s2 | null s1 = s2 + | null s2 = s1 + | otherwise = s1 ++ (' ' : s2) + + lifted_vs_unlifted + = addArising orig $ + text "Couldn't match a lifted type with an unlifted type" + +-- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a +-- type mismatch occurs to due invisible kind arguments. +-- +-- This function first checks to see if the 'CtOrigin' argument is a +-- 'TypeEqOrigin', and if so, uses the expected/actual types from that to +-- check for a kind mismatch (as these types typically have more surrounding +-- types and are likelier to be able to glean information about whether a +-- mismatch occurred in an invisible argument position or not). If the +-- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types +-- themselves. +pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin + -> SDoc -> SDoc +pprWithExplicitKindsWhenMismatch ty1 ty2 ct + = pprWithExplicitKindsWhen show_kinds + where + (act_ty, exp_ty) = case ct of + TypeEqOrigin { uo_actual = act + , uo_expected = exp } -> (act, exp) + _ -> (ty1, ty2) + show_kinds = tcEqTypeVis act_ty exp_ty + -- True when the visible bit of the types look the same, + -- so we want to show the kinds in the displayed type + +mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool + -> (Bool, Maybe SwapFlag, SDoc) +-- NotSwapped means (actual, expected), IsSwapped is the reverse +-- First return val is whether or not to print a herald above this msg +mkExpectedActualMsg ty1 ty2 ct@(TypeEqOrigin { uo_actual = act + , uo_expected = exp + , uo_thing = maybe_thing }) + m_level printExpanded + | KindLevel <- level, occurs_check_error = (True, Nothing, empty) + | isUnliftedTypeKind act, isLiftedTypeKind exp = (False, Nothing, msg2) + | isLiftedTypeKind act, isUnliftedTypeKind exp = (False, Nothing, msg3) + | tcIsLiftedTypeKind exp = (False, Nothing, msg4) + | Just msg <- num_args_msg = (False, Nothing, msg $$ msg1) + | KindLevel <- level, Just th <- maybe_thing = (False, Nothing, msg5 th) + | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (True, Just NotSwapped, empty) + | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (True, Just IsSwapped, empty) + | otherwise = (True, Nothing, msg1) + where + level = m_level `orElse` TypeLevel + + occurs_check_error + | Just tv <- tcGetTyVar_maybe ty1 + , tv `elemVarSet` tyCoVarsOfType ty2 + = True + | Just tv <- tcGetTyVar_maybe ty2 + , tv `elemVarSet` tyCoVarsOfType ty1 + = True + | otherwise + = False + + sort = case level of + TypeLevel -> text "type" + KindLevel -> text "kind" + + msg1 = case level of + KindLevel + | Just th <- maybe_thing + -> msg5 th + + _ | not (act `pickyEqType` exp) + -> pprWithExplicitKindsWhenMismatch ty1 ty2 ct $ + vcat [ text "Expected" <+> sort <> colon <+> ppr exp + , text " Actual" <+> sort <> colon <+> ppr act + , if printExpanded then expandedTys else empty ] + + | otherwise + -> empty + + thing_msg = case maybe_thing of + Just thing -> \_ levity -> + quotes thing <+> text "is" <+> levity + Nothing -> \vowel levity -> + text "got a" <> + (if vowel then char 'n' else empty) <+> + levity <+> + text "type" + msg2 = sep [ text "Expecting a lifted type, but" + , thing_msg True (text "unlifted") ] + msg3 = sep [ text "Expecting an unlifted type, but" + , thing_msg False (text "lifted") ] + msg4 = maybe_num_args_msg $$ + sep [ text "Expected a type, but" + , maybe (text "found something with kind") + (\thing -> quotes thing <+> text "has kind") + maybe_thing + , quotes (pprWithTYPE act) ] + + msg5 th = pprWithExplicitKindsWhenMismatch ty1 ty2 ct $ + hang (text "Expected" <+> kind_desc <> comma) + 2 (text "but" <+> quotes th <+> text "has kind" <+> + quotes (ppr act)) + where + kind_desc | tcIsConstraintKind exp = text "a constraint" + + -- TYPE t0 + | Just arg <- kindRep_maybe exp + , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case + True -> text "kind" <+> quotes (ppr exp) + False -> text "a type" + + | otherwise = text "kind" <+> quotes (ppr exp) + + num_args_msg = case level of + KindLevel + | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act) + -- if one is a meta-tyvar, then it's possible that the user + -- has asked for something impredicative, and we couldn't unify. + -- Don't bother with counting arguments. + -> let n_act = count_args act + n_exp = count_args exp in + case n_act - n_exp of + n | n > 0 -- we don't know how many args there are, so don't + -- recommend removing args that aren't + , Just thing <- maybe_thing + -> Just $ text "Expecting" <+> speakN (abs n) <+> + more <+> quotes thing + where + more + | n == 1 = text "more argument to" + | otherwise = text "more arguments to" -- n > 1 + _ -> Nothing + + _ -> Nothing + + maybe_num_args_msg = case num_args_msg of + Nothing -> empty + Just m -> m + + count_args ty = count isVisibleBinder $ fst $ splitPiTys ty + + expandedTys = + ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat + [ text "Type synonyms expanded:" + , text "Expected type:" <+> ppr expTy1 + , text " Actual type:" <+> ppr expTy2 + ] + + (expTy1, expTy2) = expandSynonymsToMatch exp act + +mkExpectedActualMsg _ _ _ _ _ = panic "mkExpectedAcutalMsg" + +{- Note [Insoluble occurs check wins] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 + Cannot solve a ~ [a] from given constraints a ~ [a] + +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 (isInsolubleOccursCheck) +then report it first. + +(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't +want to be as draconian with them.) + +Note [Expanding type synonyms to make types similar] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In type error messages, if -fprint-expanded-types is used, we want to expand +type synonyms to make expected and found types as similar as possible, but we +shouldn't expand types too much to make type messages even more verbose and +harder to understand. The whole point here is to make the difference in expected +and found types clearer. + +`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms +only as much as necessary. Given two types t1 and t2: + + * If they're already same, it just returns the types. + + * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are + type constructors), it expands C1 and C2 if they're different type synonyms. + Then it recursively does the same thing on expanded types. If C1 and C2 are + same, then it applies the same procedure to arguments of C1 and arguments of + C2 to make them as similar as possible. + + Most important thing here is to keep number of synonym expansions at + minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, + Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and + `T (T3, T3, Bool)`. + + * Otherwise types don't have same shapes and so the difference is clearly + visible. It doesn't do any expansions and show these types. + +Note that we only expand top-layer type synonyms. Only when top-layer +constructors are the same we start expanding inner type synonyms. + +Suppose top-layer type synonyms of t1 and t2 can expand N and M times, +respectively. If their type-synonym-expanded forms will meet at some point (i.e. +will have same shapes according to `sameShapes` function), it's possible to find +where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) +comparisons. We first collect all the top-layer expansions of t1 and t2 in two +lists, then drop the prefix of the longer list so that they have same lengths. +Then we search through both lists in parallel, and return the first pair of +types that have same shapes. Inner types of these two types with same shapes +are then expanded using the same algorithm. + +In case they don't meet, we return the last pair of types in the lists, which +has top-layer type synonyms completely expanded. (in this case the inner types +are not expanded at all, as the current form already shows the type error) +-} + +-- | Expand type synonyms in given types only enough to make them as similar as +-- possible. Returned types are the same in terms of used type synonyms. +-- +-- To expand all synonyms, see 'Type.expandTypeSynonyms'. +-- +-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for +-- some examples of how this should work. +expandSynonymsToMatch :: Type -> Type -> (Type, Type) +expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) + where + (ty1_ret, ty2_ret) = go ty1 ty2 + + -- | Returns (type synonym expanded version of first type, + -- type synonym expanded version of second type) + go :: Type -> Type -> (Type, Type) + go t1 t2 + | t1 `pickyEqType` t2 = + -- Types are same, nothing to do + (t1, t2) + + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + | tc1 == tc2 + , tys1 `equalLength` tys2 = + -- Type constructors are same. They may be synonyms, but we don't + -- expand further. The lengths of tys1 and tys2 must be equal; + -- for example, with type S a = a, we don't want + -- to zip (S Monad Int) and (S Bool). + let (tys1', tys2') = + unzip (zipWithEqual "expandSynonymsToMatch" go tys1 tys2) + in (TyConApp tc1 tys1', TyConApp tc2 tys2') + + go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = + let (t1_1', t2_1') = go t1_1 t2_1 + (t1_2', t2_2') = go t1_2 t2_2 + in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') + + go ty1@(FunTy _ t1_1 t1_2) ty2@(FunTy _ t2_1 t2_2) = + let (t1_1', t2_1') = go t1_1 t2_1 + (t1_2', t2_2') = go t1_2 t2_2 + in ( ty1 { ft_arg = t1_1', ft_res = t1_2' } + , ty2 { ft_arg = t2_1', ft_res = t2_2' }) + + go (ForAllTy b1 t1) (ForAllTy b2 t2) = + -- NOTE: We may have a bug here, but we just can't reproduce it easily. + -- See D1016 comments for details and our attempts at producing a test + -- case. Short version: We probably need RnEnv2 to really get this right. + let (t1', t2') = go t1 t2 + in (ForAllTy b1 t1', ForAllTy b2 t2') + + go (CastTy ty1 _) ty2 = go ty1 ty2 + go ty1 (CastTy ty2 _) = go ty1 ty2 + + go t1 t2 = + -- See Note [Expanding type synonyms to make types similar] for how this + -- works + let + t1_exp_tys = t1 : tyExpansions t1 + t2_exp_tys = t2 : tyExpansions t2 + t1_exps = length t1_exp_tys + t2_exps = length t2_exp_tys + dif = abs (t1_exps - t2_exps) + in + followExpansions $ + zipEqual "expandSynonymsToMatch.go" + (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys) + (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys) + + -- | Expand the top layer type synonyms repeatedly, collect expansions in a + -- list. The list does not include the original type. + -- + -- Example, if you have: + -- + -- type T10 = T9 + -- type T9 = T8 + -- ... + -- type T0 = Int + -- + -- `tyExpansions T10` returns [T9, T8, T7, ... Int] + -- + -- This only expands the top layer, so if you have: + -- + -- type M a = Maybe a + -- + -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) + tyExpansions :: Type -> [Type] + tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t) + + -- | Drop the type pairs until types in a pair look alike (i.e. the outer + -- constructors are the same). + followExpansions :: [(Type, Type)] -> (Type, Type) + followExpansions [] = pprPanic "followExpansions" empty + followExpansions [(t1, t2)] + | sameShapes t1 t2 = go t1 t2 -- expand subtrees + | otherwise = (t1, t2) -- the difference is already visible + followExpansions ((t1, t2) : tss) + -- Traverse subtrees when the outer shapes are the same + | sameShapes t1 t2 = go t1 t2 + -- Otherwise follow the expansions until they look alike + | otherwise = followExpansions tss + + sameShapes :: Type -> Type -> Bool + sameShapes AppTy{} AppTy{} = True + sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 + sameShapes (FunTy {}) (FunTy {}) = True + sameShapes (ForAllTy {}) (ForAllTy {}) = True + sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 + sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 + sameShapes _ _ = False + +sameOccExtra :: TcType -> TcType -> SDoc +-- See Note [Disambiguating (X ~ X) errors] +sameOccExtra ty1 ty2 + | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 + , Just (tc2, _) <- tcSplitTyConApp_maybe ty2 + , let n1 = tyConName tc1 + n2 = tyConName tc2 + same_occ = nameOccName n1 == nameOccName n2 + same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2) + , n1 /= n2 -- Different Names + , same_occ -- but same OccName + = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) + | otherwise + = empty + where + ppr_from same_pkg nm + | isGoodSrcSpan loc + = hang (quotes (ppr nm) <+> text "is defined at") + 2 (ppr loc) + | otherwise -- Imported things have an UnhelpfulSrcSpan + = hang (quotes (ppr nm)) + 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) + , ppUnless (same_pkg || pkg == mainUnitId) $ + nest 4 $ text "in package" <+> quotes (ppr pkg) ]) + where + pkg = moduleUnit mod + mod = nameModule nm + loc = nameSrcSpan nm + +{- +Note [Suggest adding a type signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The OutsideIn algorithm rejects GADT programs that don't have a principal +type, and indeed some that do. Example: + data T a where + MkT :: Int -> T Int + + f (MkT n) = n + +Does this have type f :: T a -> a, or f :: T a -> Int? +The error that shows up tends to be an attempt to unify an +untouchable type variable. So suggestAddSig sees if the offending +type variable is bound by an *inferred* signature, and suggests +adding a declared signature instead. + +This initially came up in #8968, concerning pattern synonyms. + +Note [Disambiguating (X ~ X) errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #8278 + +Note [Reporting occurs-check errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied +type signature, then the best thing is to report that we can't unify +a with [a], because a is a skolem variable. That avoids the confusing +"occur-check" error message. + +But nowadays when inferring the type of a function with no type signature, +even if there are errors inside, we still generalise its signature and +carry on. For example + f x = x:x +Here we will infer something like + f :: forall a. a -> [a] +with a deferred error of (a ~ [a]). So in the deferred unsolved constraint +'a' is now a skolem, but not one bound by the programmer in the context! +Here we really should report an occurs check. + +So isUserSkolem distinguishes the two. + +Note [Non-injective type functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very confusing to get a message like + Couldn't match expected type `Depend s' + against inferred type `Depend s1' +so mkTyFunInfoMsg adds: + NB: `Depend' is type function, and hence may not be injective + +Warn of loopy local equalities that were dropped. + + +************************************************************************ +* * + Type-class errors +* * +************************************************************************ +-} + +mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkDictErr ctxt cts + = ASSERT( not (null cts) ) + do { inst_envs <- tcGetInstEnvs + ; let (ct1:_) = cts -- ct1 just for its location + min_cts = elim_superclasses cts + lookups = map (lookup_cls_inst inst_envs) min_cts + (no_inst_cts, overlap_cts) = partition is_no_inst lookups + + -- Report definite no-instance errors, + -- or (iff there are none) overlap errors + -- But we report only one of them (hence 'head') because they all + -- have the same source-location origin, to try avoid a cascade + -- of error from one location + ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) + ; mkErrorMsgFromCt ctxt ct1 (important err) } + where + no_givens = null (getUserGivens ctxt) + + is_no_inst (ct, (matches, unifiers, _)) + = no_givens + && null matches + && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) + + lookup_cls_inst inst_envs ct + -- Note [Flattening in error message generation] + = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys)) + where + (clas, tys) = getClassPredTys (ctPred ct) + + + -- 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 cts = mkMinimalBySCs ctPred cts + +mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) + -> TcM (ReportErrCtxt, SDoc) +-- Report an overlap error if this class constraint results +-- from an overlap (returning Left clas), otherwise return (Right pred) +mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped)) + | null matches -- No matches but perhaps several unifiers + = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct + ; candidate_insts <- get_candidate_instances + ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) } + + | null unsafe_overlapped -- Some matches => overlap errors + = return (ctxt, overlap_msg) + + | otherwise + = return (ctxt, safe_haskell_msg) + where + orig = ctOrigin ct + pred = ctPred ct + (clas, tys) = getClassPredTys pred + ispecs = [ispec | (ispec, _) <- matches] + unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped] + useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) + -- useful_givens are the enclosing implications with non-empty givens, + -- modulo the horrid discardProvCtxtGivens + + get_candidate_instances :: TcM [ClsInst] + -- See Note [Report candidate instances] + get_candidate_instances + | [ty] <- tys -- Only try for single-parameter classes + = do { instEnvs <- tcGetInstEnvs + ; return (filter (is_candidate_inst ty) + (classInstances instEnvs clas)) } + | otherwise = return [] + + is_candidate_inst ty inst -- See Note [Report candidate instances] + | [other_ty] <- is_tys inst + , Just (tc1, _) <- tcSplitTyConApp_maybe ty + , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty + = let n1 = tyConName tc1 + n2 = tyConName tc2 + different_names = n1 /= n2 + same_occ_names = nameOccName n1 == nameOccName n2 + in different_names && same_occ_names + | otherwise = False + + cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc + cannot_resolve_msg ct candidate_insts binds_msg + = vcat [ no_inst_msg + , nest 2 extra_note + , vcat (pp_givens useful_givens) + , mb_patsyn_prov `orElse` empty + , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens)) + (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ]) + + , ppWhen (isNothing mb_patsyn_prov) $ + -- Don't suggest fixes for the provided context of a pattern + -- synonym; the right fix is to bind more in the pattern + show_fixes (ctxtFixes has_ambig_tvs pred implics + ++ drv_fixes) + , ppWhen (not (null candidate_insts)) + (hang (text "There are instances for similar types:") + 2 (vcat (map ppr candidate_insts))) ] + -- See Note [Report candidate instances] + where + orig = ctOrigin ct + -- See Note [Highlighting ambiguous type variables] + lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs) + && not (null unifiers) && null useful_givens + + (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct + ambig_tvs = uncurry (++) (getAmbigTkvs ct) + + no_inst_msg + | lead_with_ambig + = ambig_msg <+> pprArising orig + $$ text "prevents the constraint" <+> quotes (pprParendType pred) + <+> text "from being solved." + + | null useful_givens + = addArising orig $ text "No instance for" + <+> pprParendType pred + + | otherwise + = addArising orig $ text "Could not deduce" + <+> pprParendType pred + + potential_msg + = ppWhen (not (null unifiers) && want_potential orig) $ + sdocOption sdocPrintPotentialInstances $ \print_insts -> + getPprStyle $ \sty -> + pprPotentials (PrintPotentialInstances print_insts) sty potential_hdr unifiers + + potential_hdr + = vcat [ ppWhen lead_with_ambig $ + text "Probable fix: use a type annotation to specify what" + <+> pprQuotedList ambig_tvs <+> text "should be." + , text "These potential instance" <> plural unifiers + <+> text "exist:"] + + mb_patsyn_prov :: Maybe SDoc + mb_patsyn_prov + | not lead_with_ambig + , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig + = Just (vcat [ text "In other words, a successful match on the pattern" + , nest 2 $ ppr pat + , text "does not provide the constraint" <+> pprParendType pred ]) + | otherwise = Nothing + + -- Report "potential instances" only when the constraint arises + -- directly from the user's use of an overloaded function + want_potential (TypeEqOrigin {}) = False + want_potential _ = True + + extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) + = text "(maybe you haven't applied a function to enough arguments?)" + | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) + , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) + , Just (tc,_) <- tcSplitTyConApp_maybe ty + , not (isTypeFamilyTyCon tc) + = hang (text "GHC can't yet do polykinded") + 2 (text "Typeable" <+> + parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty))) + | otherwise + = empty + + drv_fixes = case orig of + DerivClauseOrigin -> [drv_fix False] + StandAloneDerivOrigin -> [drv_fix True] + DerivOriginDC _ _ standalone -> [drv_fix standalone] + DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone] + _ -> [] + + drv_fix standalone_wildcard + | standalone_wildcard + = text "fill in the wildcard constraint yourself" + | otherwise + = hang (text "use a standalone 'deriving instance' declaration,") + 2 (text "so you can specify the instance context yourself") + + -- Normal overlap error + overlap_msg + = ASSERT( not (null matches) ) + vcat [ addArising orig (text "Overlapping instances for" + <+> pprType (mkClassPred clas tys)) + + , ppUnless (null matching_givens) $ + sep [text "Matching givens (or their superclasses):" + , nest 2 (vcat matching_givens)] + + , sdocOption sdocPrintPotentialInstances $ \print_insts -> + getPprStyle $ \sty -> + pprPotentials (PrintPotentialInstances print_insts) sty (text "Matching instances:") $ + ispecs ++ unifiers + + , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ + -- Intuitively, some given matched the wanted in their + -- flattened or rewritten (from given equalities) form + -- but the matcher can't figure that out because the + -- constraints are non-flat and non-rewritten so we + -- simply report back the whole given + -- context. Accelerate Smart.hs showed this problem. + sep [ text "There exists a (perhaps superclass) match:" + , nest 2 (vcat (pp_givens useful_givens))] + + , ppWhen (isSingleton matches) $ + parens (vcat [ text "The choice depends on the instantiation of" <+> + quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys)) + , ppWhen (null (matching_givens)) $ + vcat [ text "To pick the first instance above, use IncoherentInstances" + , text "when compiling the other instance declarations"] + ])] + + matching_givens = mapMaybe matchable useful_givens + + matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) + = case ev_vars_matching of + [] -> Nothing + _ -> Just $ hang (pprTheta ev_vars_matching) + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> + ppr (tcl_loc (ic_env implic)) ]) + where ev_vars_matching = [ pred + | ev_var <- evvars + , let pred = evVarPred ev_var + , any can_match (pred : transSuperClasses pred) ] + can_match pred + = case getClassPredTys_maybe pred of + Just (clas', tys') -> clas' == clas + && isJust (tcMatchTys tys tys') + Nothing -> False + + -- Overlap error because of Safe Haskell (first + -- match should be the most specific match) + safe_haskell_msg + = ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) ) + vcat [ addArising orig (text "Unsafe overlapping instances for" + <+> pprType (mkClassPred clas tys)) + , sep [text "The matching instance is:", + nest 2 (pprInstance $ head ispecs)] + , vcat [ text "It is compiled in a Safe module and as such can only" + , text "overlap instances from the same module, however it" + , text "overlaps the following instances from different" <+> + text "modules:" + , nest 2 (vcat [pprInstances $ unsafe_ispecs]) + ] + ] + + +ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc] +ctxtFixes has_ambig_tvs pred implics + | not has_ambig_tvs + , isTyVarClassPred pred + , (skol:skols) <- usefulContext implics pred + , let what | null skols + , SigSkol (PatSynCtxt {}) _ _ <- skol + = text "\"required\"" + | otherwise + = empty + = [sep [ text "add" <+> pprParendType pred + <+> text "to the" <+> what <+> text "context of" + , nest 2 $ ppr_skol skol $$ + vcat [ text "or" <+> ppr_skol skol + | skol <- skols ] ] ] + | otherwise = [] + where + ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc) + ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) + ppr_skol skol_info = ppr skol_info + +discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] +discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] + | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig + = filterOut (discard name) givens + | otherwise + = givens + where + discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' + discard _ _ = False + +usefulContext :: [Implication] -> PredType -> [SkolemInfo] +-- usefulContext picks out the implications whose context +-- the programmer might plausibly augment to solve 'pred' +usefulContext implics pred + = go implics + where + pred_tvs = tyCoVarsOfType pred + go [] = [] + go (ic : ics) + | implausible ic = rest + | otherwise = ic_info ic : rest + where + -- Stop when the context binds a variable free in the predicate + rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] + | otherwise = go ics + + implausible ic + | null (ic_skols ic) = True + | implausible_info (ic_info ic) = True + | otherwise = False + + implausible_info (SigSkol (InfSigCtxt {}) _ _) = True + implausible_info _ = False + -- Do not suggest adding constraints to an *inferred* type signature + +{- Note [Report candidate instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an unsolved (Num Int), where `Int` is not the Prelude Int, +but comes from some other module, then it may be helpful to point out +that there are some similarly named instances elsewhere. So we get +something like + No instance for (Num Int) arising from the literal ‘3’ + There are instances for similar types: + instance Num GHC.Types.Int -- Defined in ‘GHC.Num’ +Discussion in #9611. + +Note [Highlighting ambiguous type variables] +~------------------------------------------- +When we encounter ambiguous type variables (i.e. type variables +that remain metavariables after type inference), we need a few more +conditions before we can reason that *ambiguity* prevents constraints +from being solved: + - We can't have any givens, as encountering a typeclass error + with given constraints just means we couldn't deduce + a solution satisfying those constraints and as such couldn't + bind the type variable to a known type. + - If we don't have any unifiers, we don't even have potential + instances from which an ambiguity could arise. + - Lastly, I don't want to mess with error reporting for + unknown runtime types so we just fall back to the old message there. +Once these conditions are satisfied, we can safely say that ambiguity prevents +the constraint from being solved. + +Note [discardProvCtxtGivens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In most situations we call all enclosing implications "useful". There is one +exception, and that is when the constraint that causes the error is from the +"provided" context of a pattern synonym declaration: + + pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a + -- required => provided => type + pattern Pat x <- (Just x, 4) + +When checking the pattern RHS we must check that it does actually bind all +the claimed "provided" constraints; in this case, does the pattern (Just x, 4) +bind the (Show a) constraint. Answer: no! + +But the implication we generate for this will look like + forall a. (Num a, Eq a) => [W] Show a +because when checking the pattern we must make the required +constraints available, since they are needed to match the pattern (in +this case the literal '4' needs (Num a, Eq a)). + +BUT we don't want to suggest adding (Show a) to the "required" constraints +of the pattern synonym, thus: + pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a +It would then typecheck but it's silly. We want the /pattern/ to bind +the alleged "provided" constraints, Show a. + +So we suppress that Implication in discardProvCtxtGivens. It's +painfully ad-hoc but the truth is that adding it to the "required" +constraints would work. Suppressing it solves two problems. First, +we never tell the user that we could not deduce a "provided" +constraint from the "required" context. Second, we never give a +possible fix that suggests to add a "provided" constraint to the +"required" context. + +For example, without this distinction the above code gives a bad error +message (showing both problems): + + error: Could not deduce (Show a) ... from the context: (Eq a) + ... Possible fix: add (Show a) to the context of + the signature for pattern synonym `Pat' ... + +-} + +show_fixes :: [SDoc] -> SDoc +show_fixes [] = empty +show_fixes (f:fs) = sep [ text "Possible fix:" + , nest 2 (vcat (f : map (text "or" <+>) fs))] + + +-- Avoid boolean blindness +newtype PrintPotentialInstances = PrintPotentialInstances Bool + +pprPotentials :: PrintPotentialInstances -> PprStyle -> SDoc -> [ClsInst] -> SDoc +-- See Note [Displaying potential instances] +pprPotentials (PrintPotentialInstances show_potentials) sty herald insts + | null insts + = empty + + | null show_these + = hang herald + 2 (vcat [ not_in_scope_msg empty + , flag_hint ]) + + | otherwise + = hang herald + 2 (vcat [ pprInstances show_these + , ppWhen (n_in_scope_hidden > 0) $ + text "...plus" + <+> speakNOf n_in_scope_hidden (text "other") + , not_in_scope_msg (text "...plus") + , flag_hint ]) + where + n_show = 3 :: Int + + (in_scope, not_in_scope) = partition inst_in_scope insts + sorted = sortBy fuzzyClsInstCmp in_scope + show_these | show_potentials = sorted + | otherwise = take n_show sorted + n_in_scope_hidden = length sorted - length show_these + + -- "in scope" means that all the type constructors + -- are lexically in scope; these instances are likely + -- to be more useful + inst_in_scope :: ClsInst -> Bool + inst_in_scope cls_inst = nameSetAll name_in_scope $ + orphNamesOfTypes (is_tys cls_inst) + + name_in_scope name + | isBuiltInSyntax name + = True -- E.g. (->) + | Just mod <- nameModule_maybe name + = qual_in_scope (qualName sty mod (nameOccName name)) + | otherwise + = True + + qual_in_scope :: QualifyName -> Bool + qual_in_scope NameUnqual = True + qual_in_scope (NameQual {}) = True + qual_in_scope _ = False + + not_in_scope_msg herald + | null not_in_scope + = empty + | otherwise + = hang (herald <+> speakNOf (length not_in_scope) (text "instance") + <+> text "involving out-of-scope types") + 2 (ppWhen show_potentials (pprInstances not_in_scope)) + + flag_hint = ppUnless (show_potentials || equalLength show_these insts) $ + text "(use -fprint-potential-instances to see them all)" + +{- Note [Displaying potential instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When showing a list of instances for + - overlapping instances (show ones that match) + - no such instance (show ones that could match) +we want to give it a bit of structure. Here's the plan + +* Say that an instance is "in scope" if all of the + type constructors it mentions are lexically in scope. + These are the ones most likely to be useful to the programmer. + +* Show at most n_show in-scope instances, + and summarise the rest ("plus 3 others") + +* Summarise the not-in-scope instances ("plus 4 not in scope") + +* Add the flag -fshow-potential-instances which replaces the + summary with the full list +-} + +{- +Note [Flattening in error message generation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (C (Maybe (F x))), where F is a type function, and we have +instances + C (Maybe Int) and C (Maybe a) +Since (F x) might turn into Int, this is an overlap situation, and +indeed (because of flattening) the main solver will have refrained +from solving. But by the time we get to error message generation, we've +un-flattened the constraint. So we must *re*-flatten it before looking +up in the instance environment, lest we only report one matching +instance when in fact there are two. + +Re-flattening is pretty easy, because we don't need to keep track of +evidence. We don't re-use the code in GHC.Tc.Solver.Canonical because that's in +the TcS monad, and we are in TcM here. + +Note [Kind arguments in error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be terribly confusing to get an error message like (#9171) + + Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ + with actual type ‘GetParam Base (GetParam Base Int)’ + +The reason may be that the kinds don't match up. Typically you'll get +more useful information, but not when it's as a result of ambiguity. + +To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag +whenever any error message arises due to a kind mismatch. This means that +the above error message would instead be displayed as: + + Couldn't match expected type + ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’ + with actual type + ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’ + +Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. +-} + +mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence + -> Ct -> (Bool, SDoc) +mkAmbigMsg prepend_msg ct + | null ambig_kvs && null ambig_tvs = (False, empty) + | otherwise = (True, msg) + where + (ambig_kvs, ambig_tvs) = getAmbigTkvs ct + + msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] + || any isRuntimeUnkSkol ambig_tvs + = vcat [ text "Cannot resolve unknown runtime type" + <> plural ambig_tvs <+> pprQuotedList ambig_tvs + , text "Use :print or :force to determine these types"] + + | not (null ambig_tvs) + = pp_ambig (text "type") ambig_tvs + + | otherwise + = pp_ambig (text "kind") ambig_kvs + + pp_ambig what tkvs + | prepend_msg -- "Ambiguous type variable 't0'" + = text "Ambiguous" <+> what <+> text "variable" + <> plural tkvs <+> pprQuotedList tkvs + + | otherwise -- "The type variable 't0' is ambiguous" + = text "The" <+> what <+> text "variable" <> plural tkvs + <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" + +pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc +pprSkols ctxt tvs + = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs)) + where + pp_one (UnkSkol, tvs) + = hang (pprQuotedList tvs) + 2 (is_or_are tvs "an" "unknown") + pp_one (RuntimeUnkSkol, tvs) + = hang (pprQuotedList tvs) + 2 (is_or_are tvs "an" "unknown runtime") + pp_one (skol_info, tvs) + = vcat [ hang (pprQuotedList tvs) + 2 (is_or_are tvs "a" "rigid" <+> text "bound by") + , nest 2 (pprSkolInfo skol_info) + , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ] + + is_or_are [_] article adjective = text "is" <+> text article <+> text adjective + <+> text "type variable" + is_or_are _ _ adjective = text "are" <+> text adjective + <+> text "type variables" + +getAmbigTkvs :: Ct -> ([Var],[Var]) +getAmbigTkvs ct + = partition (`elemVarSet` dep_tkv_set) ambig_tkvs + where + tkvs = tyCoVarsOfCtList ct + ambig_tkvs = filter isAmbiguousTyVar tkvs + dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) + +getSkolemInfo :: [Implication] -> [TcTyVar] + -> [(SkolemInfo, [TcTyVar])] -- #14628 +-- Get the skolem info for some type variables +-- from the implication constraints that bind them. +-- +-- In the returned (skolem, tvs) pairs, the 'tvs' part is non-empty +getSkolemInfo _ [] + = [] + +getSkolemInfo [] tvs + | all isRuntimeUnkSkol tvs = [(RuntimeUnkSkol, tvs)] -- #14628 + | otherwise = pprPanic "No skolem info:" (ppr tvs) + +getSkolemInfo (implic:implics) tvs + | null tvs_here = getSkolemInfo implics tvs + | otherwise = (ic_info implic, tvs_here) : getSkolemInfo implics tvs_other + where + (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs + +----------------------- +-- relevantBindings looks at the value environment and finds values whose +-- types mention any of the offending type variables. It has to be +-- careful to zonk the Id's type first, so it has to be in the monad. +-- We must be careful to pass it a zonked type variable, too. +-- +-- We always remove closed top-level bindings, though, +-- since they are never relevant (cf #8233) + +relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering + -- See #8191 + -> ReportErrCtxt -> Ct + -> TcM (ReportErrCtxt, SDoc, Ct) +-- Also returns the zonked and tidied CtOrigin of the constraint +relevantBindings want_filtering ctxt ct + = do { dflags <- getDynFlags + ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) + ; let ct_tvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs + + -- For *kind* errors, report the relevant bindings of the + -- enclosing *type* equality, because that's more useful for the programmer + extra_tvs = case tidy_orig of + KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $ + t1 : maybeToList m_t2 + _ -> emptyVarSet + ; traceTc "relevantBindings" $ + vcat [ ppr ct + , pprCtOrigin (ctLocOrigin loc) + , ppr ct_tvs + , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id) + | TcIdBndr id _ <- tcl_bndrs lcl_env ] + , pprWithCommas id + [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] + + ; (tidy_env', docs, discards) + <- go dflags env1 ct_tvs (maxRelevantBinds dflags) + emptyVarSet [] False + (removeBindingShadowing $ tcl_bndrs lcl_env) + -- tcl_bndrs has the innermost bindings first, + -- which are probably the most relevant ones + + ; let doc = ppUnless (null docs) $ + hang (text "Relevant bindings include") + 2 (vcat docs $$ ppWhen discards discardMsg) + + -- Put a zonked, tidied CtOrigin into the Ct + loc' = setCtLocOrigin loc tidy_orig + ct' = setCtLoc ct loc' + ctxt' = ctxt { cec_tidy = tidy_env' } + + ; return (ctxt', doc, ct') } + where + ev = ctEvidence ct + loc = ctEvLoc ev + lcl_env = ctLocEnv loc + + run_out :: Maybe Int -> Bool + run_out Nothing = False + run_out (Just n) = n <= 0 + + dec_max :: Maybe Int -> Maybe Int + dec_max = fmap (\n -> n - 1) + + + go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc] + -> Bool -- True <=> some filtered out due to lack of fuel + -> [TcBinder] + -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out + -- because of lack of fuel + go _ tidy_env _ _ _ docs discards [] + = return (tidy_env, reverse docs, discards) + go dflags tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs) + = case tc_bndr of + TcTvBndr {} -> discard_it + TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl + TcIdBndr_ExpType name et top_lvl -> + do { mb_ty <- 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 + -- Or we are reporting errors from the ambiguity check on + -- a local type signature + ; case mb_ty of + Just ty -> go2 name ty top_lvl + Nothing -> discard_it -- No info; discard + } + where + discard_it = go dflags tidy_env ct_tvs n_left tvs_seen docs + discards tc_bndrs + go2 id_name id_type top_lvl + = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type + ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) + ; let id_tvs = tyCoVarsOfType tidy_ty + doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty + , nest 2 (parens (text "bound at" + <+> ppr (getSrcLoc id_name)))] + new_seen = tvs_seen `unionVarSet` id_tvs + + ; if (want_filtering && not (hasPprDebug dflags) + && id_tvs `disjointVarSet` ct_tvs) + -- We want to filter out this binding anyway + -- so discard it silently + then discard_it + + else if isTopLevel top_lvl && not (isNothing n_left) + -- It's a top-level binding and we have not specified + -- -fno-max-relevant-bindings, so discard it silently + then discard_it + + else if run_out n_left && id_tvs `subVarSet` tvs_seen + -- We've run out of n_left fuel and this binding only + -- mentions already-seen type variables, so discard it + then go dflags tidy_env ct_tvs n_left tvs_seen docs + True -- Record that we have now discarded something + tc_bndrs + + -- Keep this binding, decrement fuel + else go dflags tidy_env' ct_tvs (dec_max n_left) new_seen + (doc:docs) discards tc_bndrs } + + +discardMsg :: SDoc +discardMsg = text "(Some bindings suppressed;" <+> + text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" + +----------------------- +warnDefaulting :: [Ct] -> Type -> TcM () +warnDefaulting wanteds default_ty + = do { warn_default <- woptM Opt_WarnTypeDefaults + ; env0 <- tcInitTidyEnv + ; let tidy_env = tidyFreeTyCoVars env0 $ + tyCoVarsOfCtsList (listToBag wanteds) + tidy_wanteds = map (tidyCt tidy_env) wanteds + (loc, ppr_wanteds) = pprWithArising tidy_wanteds + warn_msg = + hang (hsep [ text "Defaulting the following" + , text "constraint" <> plural tidy_wanteds + , text "to type" + , quotes (ppr default_ty) ]) + 2 + ppr_wanteds + ; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg } + +{- +Note [Runtime skolems] +~~~~~~~~~~~~~~~~~~~~~~ +We want to give a reasonably helpful error message for ambiguity +arising from *runtime* skolems in the debugger. These +are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType. + +************************************************************************ +* * + Error from the canonicaliser + These ones are called *during* constraint simplification +* * +************************************************************************ +-} + +solverDepthErrorTcS :: CtLoc -> TcType -> TcM a +solverDepthErrorTcS loc ty + = setCtLocM loc $ + do { ty <- zonkTcType ty + ; env0 <- tcInitTidyEnv + ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) + tidy_ty = tidyType tidy_env ty + msg + = vcat [ text "Reduction stack overflow; size =" <+> ppr depth + , hang (text "When simplifying the following type:") + 2 (ppr tidy_ty) + , note ] + ; 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)" ] diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -0,0 +1,1004 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +module GHC.Tc.Errors.Hole + ( findValidHoleFits, tcFilterHoleFits + , tcCheckHoleFit, tcSubsumes + , withoutUnification + , fromPureHFPlugin + -- Re-exports for convenience + , hfIsLcl + , pprHoleFit, debugHoleFitDispConfig + + -- Re-exported from GHC.Tc.Errors.Hole.FitTypes + , TypedHole (..), HoleFit (..), HoleFitCandidate (..) + , CandPlugin, FitPlugin + , HoleFitPlugin (..), HoleFitPluginR (..) + ) +where + +import GHC.Prelude + +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Core.DataCon +import GHC.Types.Name +import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts ) +import GHC.Builtin.Names ( gHC_ERR ) +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Data.Bag +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Utils.Misc +import GHC.Tc.Utils.Env (tcLookup) +import GHC.Utils.Outputable +import GHC.Driver.Session +import GHC.Data.Maybe +import GHC.Utils.FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV ) + +import Control.Arrow ( (&&&) ) + +import Control.Monad ( filterM, replicateM, foldM ) +import Data.List ( partition, sort, sortOn, nubBy ) +import Data.Graph ( graphFromEdges, topSort ) + + +import GHC.Tc.Solver ( simpl_top, runTcSDeriveds ) +import GHC.Tc.Utils.Unify ( tcSubType_NC ) + +import GHC.HsToCore.Docs ( extractDocs ) +import qualified Data.Map as Map +import GHC.Hs.Doc ( unpackHDS, DeclDocMap(..) ) +import GHC.Driver.Types ( ModIface_(..) ) +import GHC.Iface.Load ( loadInterfaceForNameMaybe ) + +import GHC.Builtin.Utils (knownKeyNames) + +import GHC.Tc.Errors.Hole.FitTypes + + +{- +Note [Valid hole fits include ...] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`findValidHoleFits` returns the "Valid hole fits include ..." message. +For example, look at the following definitions in a file called test.hs: + + import Data.List (inits) + + f :: [String] + f = _ "hello, world" + +The hole in `f` would generate the message: + + • Found hole: _ :: [Char] -> [String] + • In the expression: _ + In the expression: _ "hello, world" + In an equation for ‘f’: f = _ "hello, world" + • Relevant bindings include f :: [String] (bound at test.hs:6:1) + Valid hole fits include + lines :: String -> [String] + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘base-4.11.0.0:Data.OldList’)) + words :: String -> [String] + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘base-4.11.0.0:Data.OldList’)) + inits :: forall a. [a] -> [[a]] + with inits @Char + (imported from ‘Data.List’ at mpt.hs:4:19-23 + (and originally defined in ‘base-4.11.0.0:Data.OldList’)) + repeat :: forall a. a -> [a] + with repeat @String + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.List’)) + fail :: forall (m :: * -> *). Monad m => forall a. String -> m a + with fail @[] @String + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.Base’)) + return :: forall (m :: * -> *). Monad m => forall a. a -> m a + with return @[] @String + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.Base’)) + pure :: forall (f :: * -> *). Applicative f => forall a. a -> f a + with pure @[] @String + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.Base’)) + read :: forall a. Read a => String -> a + with read @[String] + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘Text.Read’)) + mempty :: forall a. Monoid a => a + with mempty @([Char] -> [String]) + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.Base’)) + +Valid hole fits are found by checking top level identifiers and local bindings +in scope for whether their type can be instantiated to the the type of the hole. +Additionally, we also need to check whether all relevant constraints are solved +by choosing an identifier of that type as well, see Note [Relevant Constraints] + +Since checking for subsumption results in the side-effect of type variables +being unified by the simplifier, we need to take care to restore them after +to being flexible type variables after we've checked for subsumption. +This is to avoid affecting the hole and later checks by prematurely having +unified one of the free unification variables. + +When outputting, we sort the hole fits by the size of the types we'd need to +apply by type application to the type of the fit to to make it fit. This is done +in order to display "more relevant" suggestions first. Another option is to +sort by building a subsumption graph of fits, i.e. a graph of which fits subsume +what other fits, and then outputting those fits which are are subsumed by other +fits (i.e. those more specific than other fits) first. This results in the ones +"closest" to the type of the hole to be displayed first. + +To help users understand how the suggested fit works, we also display the values +that the quantified type variables would take if that fit is used, like +`mempty @([Char] -> [String])` and `pure @[] @String` in the example above. +If -XTypeApplications is enabled, this can even be copied verbatim as a +replacement for the hole. + + +Note [Nested implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For the simplifier to be able to use any givens present in the enclosing +implications to solve relevant constraints, we nest the wanted subsumption +constraints and relevant constraints within the enclosing implications. + +As an example, let's look at the following code: + + f :: Show a => a -> String + f x = show _ + +The hole will result in the hole constraint: + + [WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_)) + +Here the nested implications are just one level deep, namely: + + [Implic { + TcLevel = 2 + Skolems = a_a1pa[sk:2] + No-eqs = True + Status = Unsolved + Given = $dShow_a1pc :: Show a_a1pa[sk:2] + Wanted = + WC {wc_simple = + [WD] __a1ph {0}:: a_a1pd[tau:2] (CHoleCan: ExprHole(_)) + [WD] $dShow_a1pe {0}:: Show a_a1pd[tau:2] (CDictCan(psc))} + Binds = EvBindsVar + Needed inner = [] + Needed outer = [] + the type signature for: + f :: forall a. Show a => a -> String }] + +As we can see, the givens say that the information about the skolem +`a_a1pa[sk:2]` fulfills the Show constraint. + +The simples are: + + [[WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_)), + [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)] + +I.e. the hole `a0_a1pd[tau:2]` and the constraint that the type of the hole must +fulfill `Show a0_a1pd[tau:2])`. + +So when we run the check, we need to make sure that the + + [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical) + +Constraint gets solved. When we now check for whether `x :: a0_a1pd[tau:2]` fits +the hole in `tcCheckHoleFit`, the call to `tcSubType` will end up writing the +meta type variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted +constraints needed by tcSubType_NC and the relevant constraints (see +Note [Relevant Constraints] for more details) in the nested implications, we +can pass the information in the givens along to the simplifier. For our example, +we end up needing to check whether the following constraints are soluble. + + WC {wc_impl = + Implic { + TcLevel = 2 + Skolems = a_a1pa[sk:2] + No-eqs = True + Status = Unsolved + Given = $dShow_a1pc :: Show a_a1pa[sk:2] + Wanted = + WC {wc_simple = + [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)} + Binds = EvBindsVar + Needed inner = [] + Needed outer = [] + the type signature for: + f :: forall a. Show a => a -> String }} + +But since `a0_a1pd[tau:2] := a_a1pa[sk:2]` and we have from the nested +implications that Show a_a1pa[sk:2] is a given, this is trivial, and we end up +with a final WC of WC {}, confirming x :: a0_a1pd[tau:2] as a match. + +To avoid side-effects on the nested implications, we create a new EvBindsVar so +that any changes to the ev binds during a check remains localised to that check. + + +Note [Valid refinement hole fits include ...] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the `-frefinement-level-hole-fits=N` flag is given, we additionally look +for "valid refinement hole fits"", i.e. valid hole fits with up to N +additional holes in them. + +With `-frefinement-level-hole-fits=0` (the default), GHC will find all +identifiers 'f' (top-level or nested) that will fit in the hole. + +With `-frefinement-level-hole-fits=1`, GHC will additionally find all +applications 'f _' that will fit in the hole, where 'f' is an in-scope +identifier, applied to single argument. It will also report the type of the +needed argument (a new hole). + +And similarly as the number of arguments increases + +As an example, let's look at the following code: + + f :: [Integer] -> Integer + f = _ + +with `-frefinement-level-hole-fits=1`, we'd get: + + Valid refinement hole fits include + + foldl1 (_ :: Integer -> Integer -> Integer) + with foldl1 @[] @Integer + where foldl1 :: forall (t :: * -> *). + Foldable t => + forall a. (a -> a -> a) -> t a -> a + foldr1 (_ :: Integer -> Integer -> Integer) + with foldr1 @[] @Integer + where foldr1 :: forall (t :: * -> *). + Foldable t => + forall a. (a -> a -> a) -> t a -> a + const (_ :: Integer) + with const @Integer @[Integer] + where const :: forall a b. a -> b -> a + ($) (_ :: [Integer] -> Integer) + with ($) @'GHC.Types.LiftedRep @[Integer] @Integer + where ($) :: forall a b. (a -> b) -> a -> b + fail (_ :: String) + with fail @((->) [Integer]) @Integer + where fail :: forall (m :: * -> *). + Monad m => + forall a. String -> m a + return (_ :: Integer) + with return @((->) [Integer]) @Integer + where return :: forall (m :: * -> *). Monad m => forall a. a -> m a + (Some refinement hole fits suppressed; + use -fmax-refinement-hole-fits=N or -fno-max-refinement-hole-fits) + +Which are hole fits with holes in them. This allows e.g. beginners to +discover the fold functions and similar, but also allows for advanced users +to figure out the valid functions in the Free monad, e.g. + + instance Functor f => Monad (Free f) where + Pure a >>= f = f a + Free f >>= g = Free (fmap _a f) + +Will output (with -frefinment-level-hole-fits=1): + Found hole: _a :: Free f a -> Free f b + Where: ‘a’, ‘b’ are rigid type variables bound by + the type signature for: + (>>=) :: forall a b. Free f a -> (a -> Free f b) -> Free f b + at fms.hs:25:12-14 + ‘f’ is a rigid type variable bound by + ... + Relevant bindings include + g :: a -> Free f b (bound at fms.hs:27:16) + f :: f (Free f a) (bound at fms.hs:27:10) + (>>=) :: Free f a -> (a -> Free f b) -> Free f b + (bound at fms.hs:25:12) + ... + Valid refinement hole fits include + ... + (=<<) (_ :: a -> Free f b) + with (=<<) @(Free f) @a @b + where (=<<) :: forall (m :: * -> *) a b. + Monad m => + (a -> m b) -> m a -> m b + (imported from ‘Prelude’ at fms.hs:5:18-22 + (and originally defined in ‘GHC.Base’)) + ... + +Where `(=<<) _` is precisely the function we want (we ultimately want `>>= g`). + +We find these refinement suggestions by considering hole fits that don't +fit the type of the hole, but ones that would fit if given an additional +argument. We do this by creating a new type variable with `newOpenFlexiTyVar` +(e.g. `t_a1/m[tau:1]`), and then considering hole fits of the type +`t_a1/m[tau:1] -> v` where `v` is the type of the hole. + +Since the simplifier is free to unify this new type variable with any type, we +can discover any identifiers that would fit if given another identifier of a +suitable type. This is then generalized so that we can consider any number of +additional arguments by setting the `-frefinement-level-hole-fits` flag to any +number, and then considering hole fits like e.g. `foldl _ _` with two additional +arguments. + +To make sure that the refinement hole fits are useful, we check that the types +of the additional holes have a concrete value and not just an invented type +variable. This eliminates suggestions such as `head (_ :: [t0 -> a]) (_ :: t0)`, +and limits the number of less than useful refinement hole fits. + +Additionally, to further aid the user in their implementation, we show the +types of the holes the binding would have to be applied to in order to work. +In the free monad example above, this is demonstrated with +`(=<<) (_ :: a -> Free f b)`, which tells the user that the `(=<<)` needs to +be applied to an expression of type `a -> Free f b` in order to match. +If -XScopedTypeVariables is enabled, this hole fit can even be copied verbatim. + + +Note [Relevant Constraints] +~~~~~~~~~~~~~~~~~~~ + +As highlighted by #14273, we need to check any relevant constraints as well +as checking for subsumption. Relevant constraints are the simple constraints +whose free unification variables are mentioned in the type of the hole. + +In the simplest case, these are all non-hole constraints in the simples, such +as is the case in + + f :: String + f = show _ + +Where the simples will be : + + [[WD] __a1kz {0}:: a0_a1kv[tau:1] (CHoleCan: ExprHole(_)), + [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)] + +However, when there are multiple holes, we need to be more careful. As an +example, Let's take a look at the following code: + + f :: Show a => a -> String + f x = show (_b (show _a)) + +Here there are two holes, `_a` and `_b`, and the simple constraints passed to +findValidHoleFits are: + + [[WD] _a_a1pi {0}:: String + -> a0_a1pd[tau:2] (CHoleCan: ExprHole(_b)), + [WD] _b_a1ps {0}:: a1_a1po[tau:2] (CHoleCan: ExprHole(_a)), + [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical), + [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)] + + +Here we have the two hole constraints for `_a` and `_b`, but also additional +constraints that these holes must fulfill. When we are looking for a match for +the hole `_a`, we filter the simple constraints to the "Relevant constraints", +by throwing out all hole constraints and any constraints which do not mention +a variable mentioned in the type of the hole. For hole `_a`, we will then +only require that the `$dShow_a1pp` constraint is solved, since that is +the only non-hole constraint that mentions any free type variables mentioned in +the hole constraint for `_a`, namely `a_a1pd[tau:2]` , and similarly for the +hole `_b` we only require that the `$dShow_a1pe` constraint is solved. + +Note [Leaking errors] +~~~~~~~~~~~~~~~~~~~ + +When considering candidates, GHC believes that we're checking for validity in +actual source. However, As evidenced by #15321, #15007 and #15202, this can +cause bewildering error messages. The solution here is simple: if a candidate +would cause the type checker to error, it is not a valid hole fit, and thus it +is discarded. + +-} + + +data HoleFitDispConfig = HFDC { showWrap :: Bool + , showWrapVars :: Bool + , showType :: Bool + , showProv :: Bool + , showMatches :: Bool } + +debugHoleFitDispConfig :: HoleFitDispConfig +debugHoleFitDispConfig = HFDC True True True False False + + +-- We read the various -no-show-*-of-hole-fits flags +-- and set the display config accordingly. +getHoleFitDispConfig :: TcM HoleFitDispConfig +getHoleFitDispConfig + = do { sWrap <- goptM Opt_ShowTypeAppOfHoleFits + ; sWrapVars <- goptM Opt_ShowTypeAppVarsOfHoleFits + ; sType <- goptM Opt_ShowTypeOfHoleFits + ; sProv <- goptM Opt_ShowProvOfHoleFits + ; sMatc <- goptM Opt_ShowMatchesOfHoleFits + ; return HFDC{ showWrap = sWrap, showWrapVars = sWrapVars + , showProv = sProv, showType = sType + , showMatches = sMatc } } + +-- Which sorting algorithm to use +data SortingAlg = NoSorting -- Do not sort the fits at all + | BySize -- Sort them by the size of the match + | BySubsumption -- Sort by full subsumption + deriving (Eq, Ord) + +getSortingAlg :: TcM SortingAlg +getSortingAlg = + do { shouldSort <- goptM Opt_SortValidHoleFits + ; subsumSort <- goptM Opt_SortBySubsumHoleFits + ; sizeSort <- goptM Opt_SortBySizeHoleFits + -- We default to sizeSort unless it has been explicitly turned off + -- or subsumption sorting has been turned on. + ; return $ if not shouldSort + then NoSorting + else if subsumSort + then BySubsumption + else if sizeSort + then BySize + else NoSorting } + +-- If enabled, we go through the fits and add any associated documentation, +-- by looking it up in the module or the environment (for local fits) +addDocs :: [HoleFit] -> TcM [HoleFit] +addDocs fits = + do { showDocs <- goptM Opt_ShowDocsOfHoleFits + ; if showDocs + then do { (_, DeclDocMap lclDocs, _) <- extractDocs <$> getGblEnv + ; mapM (upd lclDocs) fits } + else return fits } + where + msg = text "GHC.Tc.Errors.Hole addDocs" + lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap }) + = Map.lookup name dmap + upd lclDocs fit@(HoleFit {hfCand = cand}) = + do { let name = getName cand + ; doc <- if hfIsLcl fit + then pure (Map.lookup name lclDocs) + else do { mbIface <- loadInterfaceForNameMaybe msg name + ; return $ mbIface >>= lookupInIface name } + ; return $ fit {hfDoc = doc} } + upd _ fit = return fit + +-- For pretty printing hole fits, we display the name and type of the fit, +-- with added '_' to represent any extra arguments in case of a non-zero +-- refinement level. +pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc +pprHoleFit _ (RawHoleFit sd) = sd +pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = + hang display 2 provenance + where name = getName hfCand + tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap + where pprArg b arg = case binderArgFlag b of + Specified -> text "@" <> pprParendType arg + -- Do not print type application for inferred + -- variables (#16456) + Inferred -> empty + Required -> pprPanic "pprHoleFit: bad Required" + (ppr b <+> ppr arg) + tyAppVars = sep $ punctuate comma $ + zipWithEqual "pprHoleFit" (\v t -> ppr (binderVar v) <+> + text "~" <+> pprParendType t) + vars hfWrap + + vars = unwrapTypeVars hfType + where + -- Attempts to get all the quantified type variables in a type, + -- e.g. + -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a) + -- into [m, a] + unwrapTypeVars :: Type -> [TyCoVarBinder] + unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of + Just (_, unfunned) -> unwrapTypeVars unfunned + _ -> [] + where (vars, unforalled) = splitForAllVarBndrs t + holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches + holeDisp = if sMs then holeVs + else sep $ replicate (length hfMatches) $ text "_" + occDisp = pprPrefixOcc name + tyDisp = ppWhen sTy $ dcolon <+> ppr hfType + has = not . null + wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars)) + $ text "with" <+> if sWrp || not sTy + then occDisp <+> tyApp + else tyAppVars + docs = case hfDoc of + Just d -> text "{-^" <> + (vcat . map text . lines . unpackHDS) d + <> text "-}" + _ -> empty + funcInfo = ppWhen (has hfMatches && sTy) $ + text "where" <+> occDisp <+> tyDisp + subDisp = occDisp <+> if has hfMatches then holeDisp else tyDisp + display = subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp) + provenance = ppWhen sProv $ parens $ + case hfCand of + GreHFCand gre -> pprNameProvenance gre + _ -> text "bound at" <+> ppr (getSrcLoc name) + +getLocalBindings :: TidyEnv -> Ct -> TcM [Id] +getLocalBindings tidy_orig ct + = do { (env1, _) <- zonkTidyOrigin tidy_orig (ctLocOrigin loc) + ; go env1 [] (removeBindingShadowing $ tcl_bndrs lcl_env) } + where + loc = ctEvLoc (ctEvidence ct) + lcl_env = ctLocEnv loc + + go :: TidyEnv -> [Id] -> [TcBinder] -> TcM [Id] + go _ sofar [] = return (reverse sofar) + go env sofar (tc_bndr : tc_bndrs) = + case tc_bndr of + TcIdBndr id _ -> keep_it id + _ -> discard_it + where + discard_it = go env sofar tc_bndrs + keep_it id = go env (id:sofar) tc_bndrs + + + +-- See Note [Valid hole fits include ...] +findValidHoleFits :: TidyEnv -- ^ The tidy_env for zonking + -> [Implication] -- ^ Enclosing implications for givens + -> [Ct] + -- ^ The unsolved simple constraints in the implication for + -- the hole. + -> Ct -- ^ The hole constraint itself + -> TcM (TidyEnv, SDoc) +findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct = + do { rdr_env <- getGlobalRdrEnv + ; lclBinds <- getLocalBindings tidy_env ct + ; maxVSubs <- maxValidHoleFits <$> getDynFlags + ; hfdc <- getHoleFitDispConfig + ; sortingAlg <- getSortingAlg + ; dflags <- getDynFlags + ; hfPlugs <- tcg_hf_plugins <$> getGblEnv + ; let findVLimit = if sortingAlg > NoSorting then Nothing else maxVSubs + refLevel = refLevelHoleFits dflags + hole = TyH (listToBag relevantCts) implics (Just ct) + (candidatePlugins, fitPlugins) = + unzip $ map (\p-> ((candPlugin p) hole, (fitPlugin p) hole)) hfPlugs + ; traceTc "findingValidHoleFitsFor { " $ ppr hole + ; traceTc "hole_lvl is:" $ ppr hole_lvl + ; traceTc "simples are: " $ ppr simples + ; traceTc "locals are: " $ ppr lclBinds + ; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env) + -- We remove binding shadowings here, but only for the local level. + -- this is so we e.g. suggest the global fmap from the Functor class + -- even though there is a local definition as well, such as in the + -- Free monad example. + locals = removeBindingShadowing $ + map IdHFCand lclBinds ++ map GreHFCand lcl + globals = map GreHFCand gbl + syntax = map NameHFCand builtIns + to_check = locals ++ syntax ++ globals + ; cands <- foldM (flip ($)) to_check candidatePlugins + ; traceTc "numPlugins are:" $ ppr (length candidatePlugins) + ; (searchDiscards, subs) <- + tcFilterHoleFits findVLimit hole (hole_ty, []) cands + ; (tidy_env, tidy_subs) <- 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 + vDiscards = pVDisc || searchDiscards + ; subs_with_docs <- addDocs limited_subs + ; let vMsg = ppUnless (null subs_with_docs) $ + hang (text "Valid hole fits include") 2 $ + vcat (map (pprHoleFit hfdc) subs_with_docs) + $$ ppWhen vDiscards subsDiscardMsg + -- Refinement hole fits. See Note [Valid refinement hole fits include ...] + ; (tidy_env, refMsg) <- if refLevel >= Just 0 then + do { maxRSubs <- maxRefHoleFits <$> getDynFlags + -- We can use from just, since we know that Nothing >= _ is False. + ; let refLvls = [1..(fromJust refLevel)] + -- We make a new refinement type for each level of refinement, where + -- the level of refinement indicates number of additional arguments + -- to allow. + ; ref_tys <- mapM mkRefTy refLvls + ; traceTc "ref_tys are" $ ppr ref_tys + ; let findRLimit = if sortingAlg > NoSorting then Nothing + else maxRSubs + ; refDs <- mapM (flip (tcFilterHoleFits findRLimit hole) + cands) ref_tys + ; (tidy_env, tidy_rsubs) <- 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 + ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap + (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs + ; plugin_handled_rsubs <- foldM (flip ($)) + (not_exact ++ exact) fitPlugins + ; let (pRDisc, exact_last_rfits) = + possiblyDiscard maxRSubs $ plugin_handled_rsubs + rDiscards = pRDisc || any fst refDs + ; rsubs_with_docs <- addDocs exact_last_rfits + ; return (tidy_env, + ppUnless (null rsubs_with_docs) $ + hang (text "Valid refinement hole fits include") 2 $ + vcat (map (pprHoleFit hfdc) rsubs_with_docs) + $$ ppWhen rDiscards refSubsDiscardMsg) } + else return (tidy_env, empty) + ; traceTc "findingValidHoleFitsFor }" empty + ; return (tidy_env, vMsg $$ refMsg) } + where + -- We extract the type, the tcLevel and the types free variables + -- from from the constraint. + hole_ty :: TcPredType + hole_ty = ctPred ct + hole_fvs :: FV + hole_fvs = tyCoFVsOfType hole_ty + hole_lvl = ctLocLevel $ ctEvLoc $ ctEvidence ct + + -- BuiltInSyntax names like (:) and [] + builtIns :: [Name] + builtIns = filter isBuiltInSyntax knownKeyNames + + -- We make a refinement type by adding a new type variable in front + -- of the type of t h hole, going from e.g. [Integer] -> Integer + -- to t_a1/m[tau:1] -> [Integer] -> Integer. This allows the simplifier + -- to unify the new type variable with any type, allowing us + -- to suggest a "refinement hole fit", like `(foldl1 _)` instead + -- of only concrete hole fits like `sum`. + mkRefTy :: Int -> TcM (TcType, [TcTyVar]) + mkRefTy refLvl = (wrapWithVars &&& id) <$> newTyVars + where newTyVars = replicateM refLvl $ setLvl <$> + (newOpenTypeKind >>= newFlexiTyVar) + setLvl = flip setMetaTyVarTcLevel hole_lvl + wrapWithVars vars = mkVisFunTys (map mkTyVarTy vars) hole_ty + + sortFits :: SortingAlg -- How we should sort the hole fits + -> [HoleFit] -- The subs to sort + -> TcM [HoleFit] + sortFits NoSorting subs = return subs + sortFits BySize subs + = (++) <$> sortBySize (sort lclFits) + <*> sortBySize (sort gblFits) + where (lclFits, gblFits) = span hfIsLcl subs + + -- To sort by subsumption, we invoke the sortByGraph function, which + -- builds the subsumption graph for the fits and then sorts them using a + -- graph sort. Since we want locals to come first anyway, we can sort + -- them separately. The substitutions are already checked in local then + -- global order, so we can get away with using span here. + -- We use (<*>) to expose the parallelism, in case it becomes useful later. + sortFits BySubsumption subs + = (++) <$> sortByGraph (sort lclFits) + <*> sortByGraph (sort gblFits) + where (lclFits, gblFits) = span hfIsLcl subs + + -- See Note [Relevant Constraints] + relevantCts :: [Ct] + relevantCts = if isEmptyVarSet (fvVarSet hole_fvs) then [] + else filter isRelevant simples + where ctFreeVarSet :: Ct -> VarSet + ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred + hole_fv_set = fvVarSet hole_fvs + anyFVMentioned :: Ct -> Bool + anyFVMentioned ct = not $ isEmptyVarSet $ + ctFreeVarSet ct `intersectVarSet` hole_fv_set + -- We filter out those constraints that have no variables (since + -- they won't be solved by finding a type for the type variable + -- representing the hole) and also other holes, since we're not + -- trying to find hole fits for many holes at once. + isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct)) + && anyFVMentioned ct + && not (isHoleCt ct) + + -- We zonk the hole fits so that the output aligns with the rest + -- of the typed hole error message output. + zonkSubs :: TidyEnv -> [HoleFit] -> TcM (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 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, wrp') <- zonkTidyTcTypes env wrp + ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'} + ; return (env, zFit ) } + + -- Based on the flags, we might possibly discard some or all the + -- fits we've found. + possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit]) + possiblyDiscard (Just max) fits = (fits `lengthExceeds` max, take max fits) + possiblyDiscard Nothing fits = (False, fits) + + -- Sort by size uses as a measure for relevance the sizes of the + -- different types needed to instantiate the fit to the type of the hole. + -- This is much quicker than sorting by subsumption, and gives reasonable + -- results in most cases. + sortBySize :: [HoleFit] -> TcM [HoleFit] + sortBySize = return . sortOn sizeOfFit + where sizeOfFit :: HoleFit -> TypeSize + sizeOfFit = sizeTypes . nubBy tcEqType . hfWrap + + -- Based on a suggestion by phadej on #ghc, we can sort the found fits + -- by constructing a subsumption graph, and then do a topological sort of + -- the graph. This makes the most specific types appear first, which are + -- probably those most relevant. This takes a lot of work (but results in + -- much more useful output), and can be disabled by + -- '-fno-sort-valid-hole-fits'. + sortByGraph :: [HoleFit] -> TcM [HoleFit] + sortByGraph fits = go [] fits + where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool + tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty) + where fvs = tyCoFVsOfTypes [ht,ty] + go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit] + go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar + ; return $ uncurry (++) + $ partition hfIsLcl topSorted } + where toV (hf, adjs) = (hf, hfId hf, map hfId adjs) + (graph, fromV, _) = graphFromEdges $ map toV sofar + topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph + go sofar (hf:hfs) = + do { adjs <- + filterM (tcSubsumesWCloning (hfType hf) . hfType) fits + ; go ((hf, adjs):sofar) hfs } + +-- We don't (as of yet) handle holes in types, only in expressions. +findValidHoleFits env _ _ _ = return (env, empty) + + +-- | tcFilterHoleFits filters the candidates by whether, given the implications +-- and the relevant constraints, they can be made to match the type by +-- running the type checker. Stops after finding limit matches. +tcFilterHoleFits :: Maybe Int + -- ^ How many we should output, if limited + -> TypedHole -- ^ The hole to filter against + -> (TcType, [TcTyVar]) + -- ^ The type to check for fits and a list of refinement + -- variables (free type variables in the type) for emulating + -- additional holes. + -> [HoleFitCandidate] + -- ^ The candidates to check whether fit. + -> TcM (Bool, [HoleFit]) + -- ^ We return whether or not we stopped due to hitting the limit + -- and the fits we found. +tcFilterHoleFits (Just 0) _ _ _ = return (False, []) -- Stop right away on 0 +tcFilterHoleFits limit (TyH {..}) ht@(hole_ty, _) candidates = + do { traceTc "checkingFitsFor {" $ ppr hole_ty + ; (discards, subs) <- go [] emptyVarSet limit ht candidates + ; traceTc "checkingFitsFor }" empty + ; return (discards, subs) } + where + hole_fvs :: FV + hole_fvs = tyCoFVsOfType hole_ty + -- Kickoff the checking of the elements. + -- We iterate over the elements, checking each one in turn for whether + -- it fits, and adding it to the results if it does. + go :: [HoleFit] -- What we've found so far. + -> VarSet -- Ids we've already checked + -> Maybe Int -- How many we're allowed to find, if limited + -> (TcType, [TcTyVar]) -- The type, and its refinement variables. + -> [HoleFitCandidate] -- The elements we've yet to check. + -> TcM (Bool, [HoleFit]) + go subs _ _ _ [] = return (False, reverse subs) + go subs _ (Just 0) _ _ = return (True, reverse subs) + go subs seen maxleft ty (el:elts) = + -- See Note [Leaking errors] + tryTcDiscardingErrs discard_it $ + do { traceTc "lookingUp" $ ppr el + ; maybeThing <- lookup el + ; case maybeThing of + Just id | not_trivial id -> + do { fits <- fitsHole ty (idType id) + ; case fits of + Just (wrp, matches) -> keep_it id wrp matches + _ -> 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 + + lookup :: HoleFitCandidate -> TcM (Maybe Id) + lookup (IdHFCand id) = return (Just id) + lookup hfc = do { thing <- tcLookup name + ; return $ case thing of + ATcId {tct_id = id} -> Just id + AGlobal (AnId id) -> Just id + AGlobal (AConLike (RealDataCon con)) -> + Just (dataConWrapId con) + _ -> Nothing } + where name = case hfc of + IdHFCand id -> idName id + GreHFCand gre -> gre_name gre + NameHFCand name -> name + discard_it = go subs seen maxleft ty elts + keep_it eid wrp ms = go (fit:subs) (extendVarSet seen eid) + ((\n -> n - 1) <$> maxleft) ty elts + where + fit = HoleFit { hfId = eid, hfCand = el, hfType = (idType eid) + , hfRefLvl = length (snd ty) + , hfWrap = wrp, hfMatches = ms + , hfDoc = Nothing } + + + + + unfoldWrapper :: HsWrapper -> [Type] + unfoldWrapper = reverse . unfWrp' + where unfWrp' (WpTyApp ty) = [ty] + unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2 + unfWrp' _ = [] + + + -- The real work happens here, where we invoke the type checker using + -- tcCheckHoleFit to see whether the given type fits the hole. + fitsHole :: (TcType, [TcTyVar]) -- The type of the hole wrapped with the + -- refinement variables created to simulate + -- additional holes (if any), and the list + -- of those variables (possibly empty). + -- As an example: If the actual type of the + -- hole (as specified by the hole + -- constraint CHoleExpr passed to + -- findValidHoleFits) is t and we want to + -- simulate N additional holes, h_ty will + -- be r_1 -> ... -> r_N -> t, and + -- ref_vars will be [r_1, ... , r_N]. + -- In the base case with no additional + -- holes, h_ty will just be t and ref_vars + -- will be []. + -> TcType -- The type we're checking to whether it can be + -- instantiated to the type h_ty. + -> TcM (Maybe ([TcType], [TcType])) -- If it is not a match, we + -- return Nothing. Otherwise, + -- we Just return the list of + -- types that quantified type + -- variables in ty would take + -- if used in place of h_ty, + -- and the list types of any + -- additional holes simulated + -- with the refinement + -- variables in ref_vars. + fitsHole (h_ty, ref_vars) ty = + -- We wrap this with the withoutUnification to avoid having side-effects + -- beyond the check, but we rely on the side-effects when looking for + -- refinement hole fits, so we can't wrap the side-effects deeper than this. + withoutUnification fvs $ + do { traceTc "checkingFitOf {" $ ppr ty + ; (fits, wrp) <- tcCheckHoleFit hole h_ty ty + ; traceTc "Did it fit?" $ ppr fits + ; traceTc "wrap is: " $ ppr wrp + ; traceTc "checkingFitOf }" empty + ; z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp) + -- We'd like to avoid refinement suggestions like `id _ _` or + -- `head _ _`, and only suggest refinements where our all phantom + -- variables got unified during the checking. This can be disabled + -- with the `-fabstract-refinement-hole-fits` flag. + -- Here we do the additional handling when there are refinement + -- variables, i.e. zonk them to read their final value to check for + -- abstract refinements, and to report what the type of the simulated + -- holes must be for this to be a match. + ; if fits + then if null ref_vars + then return (Just (z_wrp_tys, [])) + else do { let -- To be concrete matches, matches have to + -- be more than just an invented type variable. + fvSet = fvVarSet fvs + notAbstract :: TcType -> Bool + notAbstract t = case getTyVar_maybe t of + Just tv -> tv `elemVarSet` fvSet + _ -> True + allConcrete = all notAbstract z_wrp_tys + ; z_vars <- zonkTcTyVars ref_vars + ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars + ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs + ; allowAbstract <- goptM Opt_AbstractRefHoleFits + ; if allowAbstract || (allFilled && allConcrete ) + then return $ Just (z_wrp_tys, z_vars) + else return Nothing } + else return Nothing } + where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty + hole = TyH tyHRelevantCts tyHImplics Nothing + + +subsDiscardMsg :: SDoc +subsDiscardMsg = + text "(Some hole fits suppressed;" <+> + text "use -fmax-valid-hole-fits=N" <+> + text "or -fno-max-valid-hole-fits)" + +refSubsDiscardMsg :: SDoc +refSubsDiscardMsg = + text "(Some refinement hole fits suppressed;" <+> + text "use -fmax-refinement-hole-fits=N" <+> + text "or -fno-max-refinement-hole-fits)" + + +-- | Checks whether a MetaTyVar is flexible or not. +isFlexiTyVar :: TcTyVar -> TcM Bool +isFlexiTyVar tv | isMetaTyVar tv = isFlexi <$> readMetaTyVar tv +isFlexiTyVar _ = return False + +-- | Takes a list of free variables and restores any Flexi type variables in +-- free_vars after the action is run. +withoutUnification :: FV -> TcM a -> TcM a +withoutUnification free_vars action = + do { flexis <- filterM isFlexiTyVar fuvs + ; result <- action + -- Reset any mutated free variables + ; mapM_ restore flexis + ; return result } + where restore = flip writeTcRef Flexi . metaTyVarRef + fuvs = fvVarList free_vars + +-- | Reports whether first type (ty_a) subsumes the second type (ty_b), +-- discarding any errors. Subsumption here means that the ty_b can fit into the +-- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a. +tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool +tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit dummyHole ty_a ty_b + where dummyHole = TyH emptyBag [] Nothing + +-- | A tcSubsumes which takes into account relevant constraints, to fix trac +-- #14273. This makes sure that when checking whether a type fits the hole, +-- the type has to be subsumed by type of the hole as well as fulfill all +-- constraints on the type of the hole. +-- Note: The simplifier may perform unification, so make sure to restore any +-- free type variables to avoid side-effects. +tcCheckHoleFit :: TypedHole -- ^ The hole to check against + -> TcSigmaType + -- ^ The type to check against (possibly modified, e.g. refined) + -> TcSigmaType -- ^ The type to check whether fits. + -> TcM (Bool, HsWrapper) + -- ^ Whether it was a match, and the wrapper from hole_ty to ty. +tcCheckHoleFit _ hole_ty ty | hole_ty `eqType` ty + = return (True, idHsWrapper) +tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $ + do { -- We wrap the subtype constraint in the implications to pass along the + -- givens, and so we must ensure that any nested implications and skolems + -- end up with the correct level. The implications are ordered so that + -- the innermost (the one with the highest level) is first, so it + -- suffices to get the level of the first one (or the current level, if + -- there are no implications involved). + innermost_lvl <- case tyHImplics of + [] -> getTcLevel + -- imp is the innermost implication + (imp:_) -> return (ic_tclvl imp) + ; (wrp, wanted) <- setTcLevel innermost_lvl $ captureConstraints $ + tcSubType_NC ExprSigCtxt ty hole_ty + ; traceTc "Checking hole fit {" empty + ; traceTc "wanteds are: " $ ppr wanted + ; if isEmptyWC wanted && isEmptyBag tyHRelevantCts + then traceTc "}" empty >> return (True, wrp) + else do { fresh_binds <- newTcEvBinds + -- The relevant constraints may contain HoleDests, so we must + -- take care to clone them as well (to avoid #15370). + ; cloned_relevants <- mapBagM cloneWanted tyHRelevantCts + -- We wrap the WC in the nested implications, see + -- Note [Nested Implications] + ; let outermost_first = reverse tyHImplics + setWC = setWCAndBinds fresh_binds + -- We add the cloned relevants to the wanteds generated by + -- the call to tcSubType_NC, see Note [Relevant Constraints] + -- There's no need to clone the wanteds, because they are + -- freshly generated by `tcSubtype_NC`. + w_rel_cts = addSimples wanted cloned_relevants + w_givens = foldr setWC w_rel_cts outermost_first + ; traceTc "w_givens are: " $ ppr w_givens + ; rem <- runTcSDeriveds $ simpl_top w_givens + -- We don't want any insoluble or simple constraints left, but + -- solved implications are ok (and necessary for e.g. undefined) + ; traceTc "rems was:" $ ppr rem + ; traceTc "}" empty + ; return (isSolvedWC rem, wrp) } } + where + setWCAndBinds :: EvBindsVar -- Fresh ev binds var. + -> Implication -- The implication to put WC in. + -> WantedConstraints -- The WC constraints to put implic. + -> WantedConstraints -- The new constraints. + setWCAndBinds binds imp wc + = WC { wc_simple = emptyBag + , wc_impl = unitBag $ imp { ic_wanted = wc , ic_binds = binds } } + +-- | Maps a plugin that needs no state to one with an empty one. +fromPureHFPlugin :: HoleFitPlugin -> HoleFitPluginR +fromPureHFPlugin plug = + HoleFitPluginR { hfPluginInit = newTcRef () + , hfPluginRun = const plug + , hfPluginStop = const $ return () } diff --git a/compiler/GHC/Tc/Errors/Hole.hs-boot b/compiler/GHC/Tc/Errors/Hole.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Errors/Hole.hs-boot @@ -0,0 +1,13 @@ +-- This boot file is in place to break the loop where: +-- + GHC.Tc.Solver calls 'GHC.Tc.Errors.reportUnsolved', +-- + which calls 'GHC.Tc.Errors.Hole.findValidHoleFits` +-- + which calls 'GHC.Tc.Solver.simpl_top' +module GHC.Tc.Errors.Hole where + +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.Constraint ( Ct, Implication ) +import GHC.Utils.Outputable ( SDoc ) +import GHC.Types.Var.Env ( TidyEnv ) + +findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct + -> TcM (TidyEnv, SDoc) diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Annotation.hs @@ -0,0 +1,70 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Typechecking annotations +module GHC.Tc.Gen.Annotation ( tcAnnotations, annCtxt ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runAnnotation ) +import GHC.Unit.Module +import GHC.Driver.Session +import Control.Monad ( when ) + +import GHC.Hs +import GHC.Types.Name +import GHC.Types.Annotations +import GHC.Tc.Utils.Monad +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Driver.Types + +-- Some platforms don't support the interpreter, and compilation on those +-- platforms shouldn't fail just due to annotations +tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation] +tcAnnotations anns = do + hsc_env <- getTopEnv + case hsc_interp hsc_env of + Just _ -> mapM tcAnnotation anns + Nothing -> warnAnns anns + +warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation] +--- No GHCI; emit a warning (not an error) and ignore. cf #4268 +warnAnns [] = return [] +warnAnns anns@(L loc _ : _) + = do { setSrcSpan loc $ addWarnTc NoReason $ + (text "Ignoring ANN annotation" <> plural anns <> comma + <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") + ; return [] } + +tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation +tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do + -- Work out what the full target of this annotation was + mod <- getModule + let target = annProvenanceToTarget mod provenance + + -- Run that annotation and construct the full Annotation data structure + setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do + -- See #10826 -- Annotations allow one to bypass Safe Haskell. + dflags <- getDynFlags + when (safeLanguageOn dflags) $ failWithTc safeHsErr + runAnnotation target expr + where + safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." + , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] + +annProvenanceToTarget :: Module -> AnnProvenance Name + -> AnnTarget Name +annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name +annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name +annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod + +annCtxt :: (OutputableBndrId p) => AnnDecl (GhcPass p) -> SDoc +annCtxt ann + = hang (text "In the annotation:") 2 (ppr ann) diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -0,0 +1,452 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE RankNTypes, TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typecheck arrow notation +module GHC.Tc.Gen.Arrow ( tcProc ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcLExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcCheckExpr ) + +import GHC.Hs +import GHC.Tc.Gen.Match +import GHC.Tc.Utils.Zonk( hsLPatType ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Gen.Bind +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Evidence +import GHC.Types.Id( mkLocalId ) +import GHC.Tc.Utils.Instantiate +import GHC.Builtin.Types +import GHC.Types.Var.Set +import GHC.Builtin.Types.Prim +import GHC.Types.Basic( Arity ) +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Utils.Misc + +import Control.Monad + +{- +Note [Arrow overview] +~~~~~~~~~~~~~~~~~~~~~ +Here's a summary of arrows and how they typecheck. First, here's +a cut-down syntax: + + expr ::= .... + | proc pat cmd + + cmd ::= cmd exp -- Arrow application + | \pat -> cmd -- Arrow abstraction + | (| exp cmd1 ... cmdn |) -- Arrow form, n>=0 + | ... -- If, case in the usual way + + cmd_type ::= carg_type --> type + + carg_type ::= () + | (type, carg_type) + +Note that + * The 'exp' in an arrow form can mention only + "arrow-local" variables + + * An "arrow-local" variable is bound by an enclosing + cmd binding form (eg arrow abstraction) + + * A cmd_type is here written with a funny arrow "-->", + The bit on the left is a carg_type (command argument type) + which itself is a nested tuple, finishing with () + + * The arrow-tail operator (e1 -< e2) means + (| e1 <<< arr snd |) e2 + + +************************************************************************ +* * + Proc +* * +************************************************************************ +-} + +tcProc :: LPat GhcRn -> LHsCmdTop GhcRn -- proc pat -> expr + -> ExpRhoType -- Expected type of whole proc expression + -> TcM (LPat GhcTc, LHsCmdTop GhcTcId, TcCoercion) + +tcProc pat cmd exp_ty + = newArrowScope $ + do { exp_ty <- expTypeToType exp_ty -- no higher-rank stuff with arrows + ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty + ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 + ; let cmd_env = CmdEnv { cmd_arr = arr_ty } + ; (pat', cmd') <- tcCheckPat ProcExpr pat arg_ty $ + tcCmdTop cmd_env cmd (unitTy, res_ty) + ; let res_co = mkTcTransCo co + (mkTcAppCo co1 (mkTcNomReflCo res_ty)) + ; return (pat', cmd', res_co) } + +{- +************************************************************************ +* * + Commands +* * +************************************************************************ +-} + +-- See Note [Arrow overview] +type CmdType = (CmdArgType, TcTauType) -- cmd_type +type CmdArgType = TcTauType -- carg_type, a nested tuple + +data CmdEnv + = CmdEnv { + cmd_arr :: TcType -- arrow type constructor, of kind *->*->* + } + +mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType +mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2] + +--------------------------------------- +tcCmdTop :: CmdEnv + -> LHsCmdTop GhcRn + -> CmdType + -> TcM (LHsCmdTop GhcTcId) + +tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty) + = setSrcSpan loc $ + do { cmd' <- tcCmd env cmd cmd_ty + ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names + ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') } + +---------------------------------------- +tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId) + -- The main recursive function +tcCmd env (L loc cmd) res_ty + = setSrcSpan loc $ do + { cmd' <- tc_cmd env cmd res_ty + ; return (L loc cmd') } + +tc_cmd :: CmdEnv -> HsCmd GhcRn -> CmdType -> TcM (HsCmd GhcTcId) +tc_cmd env (HsCmdPar x cmd) res_ty + = do { cmd' <- tcCmd env cmd res_ty + ; return (HsCmdPar x cmd') } + +tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty + = do { (binds', body') <- tcLocalBinds binds $ + setSrcSpan body_loc $ + tc_cmd env body res_ty + ; return (HsCmdLet x (L l binds') (L body_loc body')) } + +tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) + = addErrCtxt (cmdCtxt in_cmd) $ do + (scrut', scrut_ty) <- tcInferRho scrut + matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty) + return (HsCmdCase x scrut' matches') + +tc_cmd env in_cmd@(HsCmdLamCase x matches) (stk, res_ty) + = addErrCtxt (cmdCtxt in_cmd) $ do + (co, [scrut_ty], stk') <- matchExpectedCmdArgs 1 stk + matches' <- tcCmdMatches env scrut_ty matches (stk', res_ty) + return (mkHsCmdWrap (mkWpCastN co) (HsCmdLamCase x matches')) + +tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if' + = do { pred' <- tcLExpr pred (mkCheckExpType boolTy) + ; b1' <- tcCmd env b1 res_ty + ; b2' <- tcCmd env b2 res_ty + ; return (HsCmdIf x NoSyntaxExprTc pred' b1' b2') + } + +tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syntax for if + = do { pred_ty <- newOpenFlexiTyVarTy + -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r + -- because we're going to apply it to the environment, not + -- the return value. + ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] + ; let r_ty = mkTyVarTy r_tv + ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) + (text "Predicate type of `ifThenElse' depends on result type") + ; (pred', fun') + <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty]) + (mkCheckExpType r_ty) $ \ _ -> + tcLExpr pred (mkCheckExpType pred_ty) + + ; b1' <- tcCmd env b1 res_ty + ; b2' <- tcCmd env b2 res_ty + ; return (HsCmdIf x fun' pred' b1' b2') + } + +------------------------------------------- +-- Arrow application +-- (f -< a) or (f -<< a) +-- +-- D |- fun :: a t1 t2 +-- D,G |- arg :: t1 +-- ------------------------ +-- D;G |-a fun -< arg :: stk --> t2 +-- +-- D,G |- fun :: a t1 t2 +-- D,G |- arg :: t1 +-- ------------------------ +-- D;G |-a fun -<< arg :: stk --> t2 +-- +-- (plus -<< requires ArrowApply) + +tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty) + = addErrCtxt (cmdCtxt cmd) $ + do { arg_ty <- newOpenFlexiTyVarTy + ; let fun_ty = mkCmdArrTy env arg_ty res_ty + ; fun' <- select_arrow_scope (tcLExpr fun (mkCheckExpType fun_ty)) + + ; arg' <- tcLExpr arg (mkCheckExpType arg_ty) + + ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) } + where + -- Before type-checking f, use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside f. In the higher-order case (-<<), they are. + -- See Note [Escaping the arrow scope] in GHC.Tc.Types + select_arrow_scope tc = case ho_app of + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc + +------------------------------------------- +-- Command application +-- +-- D,G |- exp : t +-- D;G |-a cmd : (t,stk) --> res +-- ----------------------------- +-- D;G |-a cmd exp : stk --> res + +tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty) + = addErrCtxt (cmdCtxt cmd) $ + do { arg_ty <- newOpenFlexiTyVarTy + ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) + ; arg' <- tcLExpr arg (mkCheckExpType arg_ty) + ; return (HsCmdApp x fun' arg') } + +------------------------------------------- +-- Lambda +-- +-- D;G,x:t |-a cmd : stk --> res +-- ------------------------------ +-- D;G |-a (\x.cmd) : (t,stk) --> res + +tc_cmd env + (HsCmdLam x (MG { mg_alts = L l [L mtch_loc + (match@(Match { m_pats = pats, m_grhss = grhss }))], + mg_origin = origin })) + (cmd_stk, res_ty) + = addErrCtxt (pprMatchInCtxt match) $ + do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk + + -- Check the patterns, and the GRHSs inside + ; (pats', grhss') <- setSrcSpan mtch_loc $ + tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $ + tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) + + ; let match' = L mtch_loc (Match { m_ext = noExtField + , m_ctxt = LambdaExpr, m_pats = pats' + , m_grhss = grhss' }) + arg_tys = map hsLPatType pats' + cmd' = HsCmdLam x (MG { mg_alts = L l [match'] + , mg_ext = MatchGroupTc arg_tys res_ty + , mg_origin = origin }) + ; return (mkHsCmdWrap (mkWpCastN co) cmd') } + where + n_pats = length pats + match_ctxt = (LambdaExpr :: HsMatchContext GhcRn) -- Maybe KappaExpr? + pg_ctxt = PatGuard match_ctxt + + tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty + = do { (binds', grhss') <- tcLocalBinds binds $ + mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss + ; return (GRHSs x grhss' (L l binds')) } + + tc_grhs stk_ty res_ty (GRHS x guards body) + = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ + \ res_ty -> tcCmd env body + (stk_ty, checkingExpType "tc_grhs" res_ty) + ; return (GRHS x guards' rhs') } + +------------------------------------------- +-- Do notation + +tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty) + = do { co <- unifyType Nothing unitTy cmd_stk -- Expecting empty argument stack + ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty + ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) } + + +----------------------------------------------------------------- +-- Arrow ``forms'' (| e c1 .. cn |) +-- +-- D; G |-a1 c1 : stk1 --> r1 +-- ... +-- D; G |-an cn : stkn --> rn +-- D |- e :: forall e. a1 (e, stk1) t1 +-- ... +-- -> an (e, stkn) tn +-- -> a (e, stk) t +-- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) +-- ---------------------------------------------- +-- D; G |-a (| e c1 ... cn |) : stk --> t + +tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty) + = addErrCtxt (cmdCtxt cmd) $ + do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args + -- We use alphaTyVar for 'w' + ; let e_ty = mkInvForAllTy alphaTyVar $ + mkVisFunTys cmd_tys $ + mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty + ; expr' <- tcCheckExpr expr e_ty + ; return (HsCmdArrForm x expr' f fixity cmd_args') } + + where + tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType) + tc_cmd_arg cmd + = do { arr_ty <- newFlexiTyVarTy arrowTyConKind + ; stk_ty <- newFlexiTyVarTy liftedTypeKind + ; res_ty <- newFlexiTyVarTy liftedTypeKind + ; let env' = env { cmd_arr = arr_ty } + ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) + ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } + +----------------------------------------------------------------- +-- Base case for illegal commands +-- This is where expressions that aren't commands get rejected + +tc_cmd _ cmd _ + = failWithTc (vcat [text "The expression", nest 2 (ppr cmd), + text "was found where an arrow command was expected"]) + +-- | Typechecking for case command alternatives. Used for both +-- 'HsCmdCase' and 'HsCmdLamCase'. +tcCmdMatches :: CmdEnv + -> TcType -- ^ type of the scrutinee + -> MatchGroup GhcRn (LHsCmd GhcRn) -- ^ case alternatives + -> CmdType + -> TcM (MatchGroup GhcTcId (LHsCmd GhcTcId)) +tcCmdMatches env scrut_ty matches (stk, res_ty) + = tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty) + where + match_ctxt = MC { mc_what = CaseAlt, + mc_body = mc_body } + mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' + ; tcCmd env body (stk, res_ty') } + +matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType) +matchExpectedCmdArgs 0 ty + = return (mkTcNomReflCo ty, [], ty) +matchExpectedCmdArgs n ty + = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty + ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2 + ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) } + +{- +************************************************************************ +* * + Stmts +* * +************************************************************************ +-} + +-------------------------------- +-- Mdo-notation +-- The distinctive features here are +-- (a) RecStmts, and +-- (b) no rebindable syntax + +tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker +tcArrDoStmt env _ (LastStmt x rhs noret _) res_ty thing_inside + = do { rhs' <- tcCmd env rhs (unitTy, res_ty) + ; thing <- thing_inside (panic "tcArrDoStmt") + ; return (LastStmt x rhs' noret noSyntaxExpr, thing) } + +tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside + = do { (rhs', elt_ty) <- tc_arr_rhs env rhs + ; thing <- thing_inside res_ty + ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) } + +tcArrDoStmt env ctxt (BindStmt _ pat rhs) res_ty thing_inside + = do { (rhs', pat_ty) <- tc_arr_rhs env rhs + ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ + thing_inside res_ty + ; return (mkTcBindStmt pat' rhs', thing) } + +tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names + , recS_rec_ids = rec_names }) res_ty thing_inside + = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names + ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind + ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys + ; tcExtendIdEnv tup_ids $ do + { (stmts', tup_rets) + <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> + -- ToDo: res_ty not really right + zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys) + + ; thing <- thing_inside res_ty + -- NB: The rec_ids for the recursive things + -- already scope over this part. This binding may shadow + -- some of them with polymorphic things with the same Name + -- (see note [RecStmt] in GHC.Hs.Expr) + + ; let rec_ids = takeList rec_names tup_ids + ; later_ids <- tcLookupLocalIds later_names + + ; let rec_rets = takeList rec_names tup_rets + ; let ret_table = zip tup_ids tup_rets + ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j] + + ; return (emptyRecStmtId { recS_stmts = stmts' + , recS_later_ids = later_ids + , recS_rec_ids = rec_ids + , recS_ext = unitRecStmtTc + { recS_later_rets = later_rets + , recS_rec_rets = rec_rets + , recS_ret_ty = res_ty} }, thing) + }} + +tcArrDoStmt _ _ stmt _ _ + = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) + +tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType) +tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind + ; rhs' <- tcCmd env rhs (unitTy, ty) + ; return (rhs', ty) } + +{- +************************************************************************ +* * + Helpers +* * +************************************************************************ +-} + +mkPairTy :: Type -> Type -> Type +mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] + +arrowTyConKind :: Kind -- *->*->* +arrowTyConKind = mkVisFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind + +{- +************************************************************************ +* * + Errors +* * +************************************************************************ +-} + +cmdCtxt :: HsCmd GhcRn -> SDoc +cmdCtxt cmd = text "In the command:" <+> ppr cmd diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -0,0 +1,1731 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Tc.Gen.Bind + ( tcLocalBinds + , tcTopBinds + , tcValBinds + , tcHsBootSigs + , tcPolyCheck + , chooseInferredQuantifiers + , badBootDeclErr + ) +where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcMatchesFun ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcLExpr ) +import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) +import GHC.Core (Tickish (..)) +import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC)) +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Hs +import GHC.Tc.Gen.Sig +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Unify +import GHC.Tc.Solver +import GHC.Tc.Types.Evidence +import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.TcMType +import GHC.Core.FamInstEnv( normaliseType ) +import GHC.Tc.Instance.Family( tcGetFamInstEnvs ) +import GHC.Core.TyCon +import GHC.Tc.Utils.TcType +import GHC.Core.Type (mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy) +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types( mkBoxedTupleTy ) +import GHC.Types.Id +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env( TidyEnv ) +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.SrcLoc +import GHC.Data.Bag +import GHC.Utils.Error +import GHC.Data.Graph.Directed +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Types.Basic +import GHC.Utils.Outputable as Outputable +import GHC.Builtin.Names( ipClassName ) +import GHC.Tc.Validity (checkValidType) +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import qualified GHC.LanguageExtensions as LangExt +import GHC.Core.ConLike + +import Control.Monad +import Data.Foldable (find) + +#include "HsVersions.h" + +{- +************************************************************************ +* * +\subsection{Type-checking bindings} +* * +************************************************************************ + +@tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because +it needs to know something about the {\em usage} of the things bound, +so that it can create specialisations of them. So @tcBindsAndThen@ +takes a function which, given an extended environment, E, typechecks +the scope of the bindings returning a typechecked thing and (most +important) an LIE. It is this LIE which is then used as the basis for +specialising the things bound. + +@tcBindsAndThen@ also takes a "combiner" which glues together the +bindings and the "thing" to make a new "thing". + +The real work is done by @tcBindWithSigsAndThen@. + +Recursive and non-recursive binds are handled in essentially the same +way: because of uniques there are no scoping issues left. The only +difference is that non-recursive bindings can bind primitive values. + +Even for non-recursive binding groups we add typings for each binder +to the LVE for the following reason. When each individual binding is +checked the type of its LHS is unified with that of its RHS; and +type-checking the LHS of course requires that the binder is in scope. + +At the top-level the LIE is sure to contain nothing but constant +dictionaries, which we resolve at the module level. + +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The game plan for polymorphic recursion in the code above is + + * Bind any variable for which we have a type signature + to an Id with a polymorphic type. Then when type-checking + the RHSs we'll make a full polymorphic call. + +This fine, but if you aren't a bit careful you end up with a horrendous +amount of partial application and (worse) a huge space leak. For example: + + f :: Eq a => [a] -> [a] + f xs = ...f... + +If we don't take care, after typechecking we get + + f = /\a -> \d::Eq a -> let f' = f a d + in + \ys:[a] -> ...f'... + +Notice the stupid construction of (f a d), which is of course +identical to the function we're executing. In this case, the +polymorphic recursion isn't being used (but that's a very common case). +This can lead to a massive space leak, from the following top-level defn +(post-typechecking) + + ff :: [Int] -> [Int] + ff = f Int dEqInt + +Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but +f' is another thunk which evaluates to the same thing... and you end +up with a chain of identical values all hung onto by the CAF ff. + + ff = f Int dEqInt + + = let f' = f Int dEqInt in \ys. ...f'... + + = let f' = let f' = f Int dEqInt in \ys. ...f'... + in \ys. ...f'... + +Etc. + +NOTE: a bit of arity analysis would push the (f a d) inside the (\ys...), +which would make the space leak go away in this case + +Solution: when typechecking the RHSs we always have in hand the +*monomorphic* Ids for each binding. So we just need to make sure that +if (Method f a d) shows up in the constraints emerging from (...f...) +we just use the monomorphic Id. We achieve this by adding monomorphic Ids +to the "givens" when simplifying constraints. That's what the "lies_avail" +is doing. + +Then we get + + f = /\a -> \d::Eq a -> letrec + fm = \ys:[a] -> ...fm... + in + fm +-} + +tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] + -> TcM (TcGblEnv, TcLclEnv) +-- The TcGblEnv contains the new tcg_binds and tcg_spects +-- The TcLclEnv has an extended type envt for the new bindings +tcTopBinds binds sigs + = do { -- Pattern synonym bindings populate the global environment + (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $ + do { gbl <- getGblEnv + ; lcl <- getLclEnv + ; return (gbl, lcl) } + ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids + + ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs + ; traceTc "complete_matches" (ppr binds $$ ppr sigs) + ; traceTc "complete_matches" (ppr complete_matches) + + ; let { tcg_env' = tcg_env { tcg_imp_specs + = specs ++ tcg_imp_specs tcg_env + , tcg_complete_matches + = complete_matches + ++ tcg_complete_matches tcg_env } + `addTypecheckedBinds` map snd binds' } + + ; return (tcg_env', tcl_env) } + -- The top level bindings are flattened into a giant + -- implicitly-mutually-recursive LHsBinds + + +-- Note [Typechecking Complete Matches] +-- Much like when a user bundled a pattern synonym, the result types of +-- all the constructors in the match pragma must be consistent. +-- +-- If we allowed pragmas with inconsistent types then it would be +-- impossible to ever match every constructor in the list and so +-- the pragma would be useless. + + + + + +-- This is only used in `tcCompleteSig`. We fold over all the conlikes, +-- this accumulator keeps track of the first `ConLike` with a concrete +-- return type. After fixing the return type, all other constructors with +-- a fixed return type must agree with this. +-- +-- The fields of `Fixed` cache the first conlike and its return type so +-- that that we can compare all the other conlikes to it. The conlike is +-- stored for error messages. +-- +-- `Nothing` in the case that the type is fixed by a type signature +data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon + +tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch] +tcCompleteSigs sigs = + let + doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch) + doOne c@(CompleteMatchSig _ _ lns mtc) + = fmap Just $ do + addErrCtxt (text "In" <+> ppr c) $ + case mtc of + Nothing -> infer_complete_match + Just tc -> check_complete_match tc + where + + checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns) + + infer_complete_match = do + (res, cls) <- checkCLTypes AcceptAny + case res of + AcceptAny -> failWithTc ambiguousError + Fixed _ tc -> return $ mkMatch cls tc + + check_complete_match tc_name = do + ty_con <- tcLookupLocatedTyCon tc_name + (_, cls) <- checkCLTypes (Fixed Nothing ty_con) + return $ mkMatch cls ty_con + + mkMatch :: [ConLike] -> TyCon -> CompleteMatch + mkMatch cls ty_con = CompleteMatch { + -- foldM is a left-fold and will have accumulated the ConLikes in + -- the reverse order. foldrM would accumulate in the correct order, + -- but would type-check the last ConLike first, which might also be + -- confusing from the user's perspective. Hence reverse here. + completeMatchConLikes = reverse (map conLikeName cls), + completeMatchTyCon = tyConName ty_con + } + doOne _ = return Nothing + + ambiguousError :: SDoc + ambiguousError = + text "A type signature must be provided for a set of polymorphic" + <+> text "pattern synonyms." + + + -- See note [Typechecking Complete Matches] + checkCLType :: (CompleteSigType, [ConLike]) -> Located Name + -> TcM (CompleteSigType, [ConLike]) + checkCLType (cst, cs) n = do + cl <- addLocM tcLookupConLike n + let (_,_,_,_,_,_, res_ty) = conLikeFullSig cl + res_ty_con = fst <$> splitTyConApp_maybe res_ty + case (cst, res_ty_con) of + (AcceptAny, Nothing) -> return (AcceptAny, cl:cs) + (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs) + (Fixed mfcl tc, Nothing) -> return (Fixed mfcl tc, cl:cs) + (Fixed mfcl tc, Just tc') -> + if tc == tc' + then return (Fixed mfcl tc, cl:cs) + else case mfcl of + Nothing -> + addErrCtxt (text "In" <+> ppr cl) $ + failWithTc typeSigErrMsg + Just cl -> failWithTc (errMsg cl) + where + typeSigErrMsg :: SDoc + typeSigErrMsg = + text "Couldn't match expected type" + <+> quotes (ppr tc) + <+> text "with" + <+> quotes (ppr tc') + + errMsg :: ConLike -> SDoc + errMsg fcl = + text "Cannot form a group of complete patterns from patterns" + <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl) + <+> text "as they match different type constructors" + <+> parens (quotes (ppr tc) + <+> text "resp." + <+> quotes (ppr tc')) + -- For some reason I haven't investigated further, the signatures come in + -- backwards wrt. declaration order. So we reverse them here, because it makes + -- a difference for incomplete match suggestions. + in mapMaybeM (addLocM doOne) (reverse sigs) -- process in declaration order + +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 +tcHsBootSigs binds sigs + = do { checkTc (null binds) badBootDeclErr + ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } + where + tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames + where + f (L _ name) + = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty + ; return (mkVanillaGlobal name sigma_ty) } + -- Notice that we make GlobalIds, not LocalIds + tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) + +badBootDeclErr :: MsgDoc +badBootDeclErr = text "Illegal declarations in an hs-boot file" + +------------------------ +tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing + -> TcM (HsLocalBinds GhcTcId, thing) + +tcLocalBinds (EmptyLocalBinds x) thing_inside + = do { thing <- thing_inside + ; return (EmptyLocalBinds x, thing) } + +tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside + = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside + ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) } +tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds" + +tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside + = do { ipClass <- tcLookupClass ipClassName + ; (given_ips, ip_binds') <- + mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds + + -- If the binding binds ?x = E, we must now + -- discharge any ?x constraints in expr_lie + -- See Note [Implicit parameter untouchables] + ; (ev_binds, result) <- checkConstraints (IPSkol ips) + [] given_ips thing_inside + + ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } + where + ips = [ip | (L _ (IPBind _ (Left (L _ ip)) _)) <- ip_binds] + + -- I wonder if we should do these one at a time + -- Consider ?x = 4 + -- ?y = ?x + 1 + tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr) + = do { ty <- newOpenFlexiTyVarTy + ; let p = mkStrLitTy $ hsIPNameFS ip + ; ip_id <- newDict ipClass [ p, ty ] + ; expr' <- tcLExpr expr (mkCheckExpType ty) + ; let d = toDict ipClass p ty `fmap` expr' + ; return (ip_id, (IPBind noExtField (Right ip_id) d)) } + tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind" + + -- Coerces a `t` into a dictionary for `IP "x" t`. + -- co : t -> IP "x" t + toDict ipClass x ty = mkHsWrap $ mkWpCastR $ + wrapIP $ mkClassPred ipClass [x,ty] + +{- Note [Implicit parameter untouchables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We add the type variables in the types of the implicit parameters +as untouchables, not so much because we really must not unify them, +but rather because we otherwise end up with constraints like this + Num alpha, Implic { wanted = alpha ~ Int } +The constraint solver solves alpha~Int by unification, but then +doesn't float that solved constraint out (it's not an unsolved +wanted). Result disaster: the (Num alpha) is again solved, this +time by defaulting. No no no. + +However [Oct 10] this is all handled automatically by the +untouchable-range idea. +-} + +tcValBinds :: TopLevelFlag + -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] + -> TcM thing + -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) + +tcValBinds top_lvl binds sigs thing_inside + = do { -- Typecheck the signatures + -- It's easier to do so now, once for all the SCCs together + -- because a single signature f,g :: + -- might relate to more than one SCC + ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $ + tcTySigs sigs + + -- Extend the envt right away with all the Ids + -- declared with complete type signatures + -- Do not extend the TcBinderStack; instead + -- we extend it on a per-rhs basis in tcExtendForRhs + ; tcExtendSigIds top_lvl poly_ids $ do + { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do + { thing <- thing_inside + -- See Note [Pattern synonym builders don't yield dependencies] + -- in GHC.Rename.Bind + ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns + ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ] + ; return (extra_binds, thing) } + ; return (binds' ++ extra_binds', thing) }} + where + patsyns = getPatSynBinds binds + prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds) + +------------------------ +tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv + -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing + -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) +-- Typecheck a whole lot of value bindings, +-- one strongly-connected component at a time +-- Here a "strongly connected component" has the straightforward +-- meaning of a group of bindings that mention each other, +-- ignoring type signatures (that part comes later) + +tcBindGroups _ _ _ [] thing_inside + = do { thing <- thing_inside + ; return ([], thing) } + +tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside + = do { -- See Note [Closed binder groups] + type_env <- getLclTypeEnv + ; let closed = isClosedBndrGroup type_env (snd group) + ; (group', (groups', thing)) + <- tc_group top_lvl sig_fn prag_fn group closed $ + tcBindGroups top_lvl sig_fn prag_fn groups thing_inside + ; return (group' ++ groups', thing) } + +-- Note [Closed binder groups] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- A mutually recursive group is "closed" if all of the free variables of +-- the bindings are closed. For example +-- +-- > h = \x -> let f = ...g... +-- > g = ....f...x... +-- > in ... +-- +-- Here @g@ is not closed because it mentions @x@; and hence neither is @f@ +-- closed. +-- +-- So we need to compute closed-ness on each strongly connected components, +-- before we sub-divide it based on what type signatures it has. +-- + +------------------------ +tc_group :: forall thing. + TopLevelFlag -> TcSigFun -> TcPragEnv + -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing + -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) + +-- Typecheck one strongly-connected component of the original program. +-- We get a list of groups back, because there may +-- be specialisations etc as well + +tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside + -- A single non-recursive binding + -- We want to keep non-recursive things non-recursive + -- so that we desugar unlifted bindings correctly + = do { let bind = case bagToList binds of + [bind] -> bind + [] -> panic "tc_group: empty list of binds" + _ -> panic "tc_group: NonRecursive binds is not a singleton bag" + ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed + thing_inside + ; return ( [(NonRecursive, bind')], thing) } + +tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside + = -- To maximise polymorphism, we do a new + -- strongly-connected-component analysis, this time omitting + -- any references to variables with type signatures. + -- (This used to be optional, but isn't now.) + -- See Note [Polymorphic recursion] in HsBinds. + do { traceTc "tc_group rec" (pprLHsBinds binds) + ; whenIsJust mbFirstPatSyn $ \lpat_syn -> + recursivePatSynErr (getLoc lpat_syn) binds + ; (binds1, thing) <- go sccs + ; return ([(Recursive, binds1)], thing) } + -- Rec them all together + where + mbFirstPatSyn = find (isPatSyn . unLoc) binds + isPatSyn PatSynBind{} = True + isPatSyn _ = False + + sccs :: [SCC (LHsBind GhcRn)] + sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds) + + go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, thing) + go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc + ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn + closed ids1 $ + go sccs + ; return (binds1 `unionBags` binds2, thing) } + go [] = do { thing <- thing_inside; return (emptyBag, thing) } + + tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind] + tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds + + tc_sub_group rec_tc binds = + tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds + +recursivePatSynErr :: + (OutputableBndrId p, CollectPass (GhcPass p)) + => SrcSpan -- ^ The location of the first pattern synonym binding + -- (for error reporting) + -> LHsBinds (GhcPass p) + -> TcM a +recursivePatSynErr loc binds + = failAt loc $ + hang (text "Recursive pattern synonym definition with following bindings:") + 2 (vcat $ map pprLBind . bagToList $ binds) + where + pprLoc loc = parens (text "defined at" <+> ppr loc) + pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) + <+> pprLoc loc + +tc_single :: forall thing. + TopLevelFlag -> TcSigFun -> TcPragEnv + -> LHsBind GhcRn -> IsGroupClosed -> TcM thing + -> TcM (LHsBinds GhcTcId, thing) +tc_single _top_lvl sig_fn _prag_fn + (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name })) + _ thing_inside + = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) + ; thing <- setGblEnv tcg_env thing_inside + ; return (aux_binds, thing) + } + +tc_single top_lvl sig_fn prag_fn lbind closed thing_inside + = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn + NonRecursive NonRecursive + closed + [lbind] + ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside + ; return (binds1, thing) } + +------------------------ +type BKey = Int -- Just number off the bindings + +mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)] +-- See Note [Polymorphic recursion] in HsBinds. +mkEdges sig_fn binds + = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)), + Just key <- [lookupNameEnv key_map n], no_sig n ] + | (bind, key) <- keyd_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. + where + bind_fvs (FunBind { fun_ext = fvs }) = fvs + bind_fvs (PatBind { pat_ext = fvs }) = fvs + bind_fvs _ = emptyNameSet + + no_sig :: Name -> Bool + no_sig n = not (hasCompleteSig sig_fn n) + + keyd_binds = bagToList binds `zip` [0::BKey ..] + + key_map :: NameEnv BKey -- Which binding it comes from + key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds + , bndr <- collectHsBindBinders bind ] + +------------------------ +tcPolyBinds :: TcSigFun -> TcPragEnv + -> RecFlag -- Whether the group is really recursive + -> RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> IsGroupClosed -- Whether the group is closed + -> [LHsBind GhcRn] -- None are PatSynBind + -> TcM (LHsBinds GhcTcId, [TcId]) + +-- Typechecks a single bunch of values bindings all together, +-- and generalises them. The bunch may be only part of a recursive +-- group, because we use type signatures to maximise polymorphism +-- +-- Returns a list because the input may be a single non-recursive binding, +-- in which case the dependency order of the resulting bindings is +-- important. +-- +-- Knows nothing about the scope of the bindings +-- None of the bindings are pattern synonyms + +tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list + = setSrcSpan loc $ + recoverM (recoveryCode binder_names sig_fn) $ do + -- Set up main recover; take advantage of any type sigs + + { traceTc "------------------------------------------------" Outputable.empty + ; traceTc "Bindings for {" (ppr binder_names) + ; dflags <- getDynFlags + ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn + ; traceTc "Generalisation plan" (ppr plan) + ; result@(_, poly_ids) <- case plan of + NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list + InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list + CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind + + ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group + , vcat [ppr id <+> ppr (idType id) | id <- poly_ids] + ]) + + ; return result } + where + binder_names = collectHsBindListBinders bind_list + loc = foldr1 combineSrcSpans (map getLoc bind_list) + -- The mbinds have been dependency analysed and + -- may no longer be adjacent; so find the narrowest + -- span that includes them all + +-------------- +-- If typechecking the binds fails, then return with each +-- signature-less binder given type (forall a.a), to minimise +-- subsequent error messages +recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTcId, [Id]) +recoveryCode binder_names sig_fn + = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) + ; let poly_ids = map mk_dummy binder_names + ; return (emptyBag, poly_ids) } + where + mk_dummy name + | Just sig <- sig_fn name + , Just poly_id <- completeSigPolyId_maybe sig + = poly_id + | otherwise + = mkLocalId name forall_a_a + +forall_a_a :: TcType +-- At one point I had (forall r (a :: TYPE r). a), but of course +-- that type is ill-formed: its mentions 'r' which escapes r's scope. +-- Another alternative would be (forall (a :: TYPE kappa). a), where +-- kappa is a unification variable. But I don't think we need that +-- complication here. I'm going to just use (forall (a::*). a). +-- See #15276 +forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy + +{- ********************************************************************* +* * + tcPolyNoGen +* * +********************************************************************* -} + +tcPolyNoGen -- No generalisation whatsoever + :: RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> TcPragEnv -> TcSigFun + -> [LHsBind GhcRn] + -> TcM (LHsBinds GhcTcId, [TcId]) + +tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list + = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn + (LetGblBndr prag_fn) + bind_list + ; mono_ids' <- mapM tc_mono_info mono_infos + ; return (binds', mono_ids') } + where + tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id }) + = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name) + ; return mono_id } + -- NB: tcPrags generates error messages for + -- specialisation pragmas for non-overloaded sigs + -- Indeed that is why we call it here! + -- So we can safely ignore _specs + + +{- ********************************************************************* +* * + tcPolyCheck +* * +********************************************************************* -} + +tcPolyCheck :: TcPragEnv + -> TcIdSigInfo -- Must be a complete signature + -> LHsBind GhcRn -- Must be a FunBind + -> TcM (LHsBinds GhcTcId, [TcId]) +-- There is just one binding, +-- it is a FunBind +-- it has a complete type signature, +tcPolyCheck prag_fn + (CompleteSig { sig_bndr = poly_id + , sig_ctxt = ctxt + , sig_loc = sig_loc }) + (L loc (FunBind { fun_id = (L nm_loc name) + , fun_matches = matches })) + = setSrcSpan sig_loc $ + do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) + ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id + -- See Note [Instantiate sig with fresh variables] + + ; mono_name <- newNameAt (nameOccName name) nm_loc + ; ev_vars <- newEvVars theta + ; let mono_id = mkLocalId mono_name tau + skol_info = SigSkol ctxt (idType poly_id) tv_prs + skol_tvs = map snd tv_prs + + ; (ev_binds, (co_fn, matches')) + <- checkConstraints skol_info skol_tvs ev_vars $ + tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ + tcExtendNameTyVarEnv tv_prs $ + setSrcSpan loc $ + tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau) + + ; let prag_sigs = lookupPragEnv prag_fn name + ; spec_prags <- tcSpecPrags poly_id prag_sigs + ; poly_id <- addInlinePrags poly_id prag_sigs + + ; mod <- getModule + ; tick <- funBindTicks nm_loc mono_id mod prag_sigs + ; let bind' = FunBind { fun_id = L nm_loc mono_id + , fun_matches = matches' + , fun_ext = co_fn + , fun_tick = tick } + + export = ABE { abe_ext = noExtField + , abe_wrap = idHsWrapper + , abe_poly = poly_id + , abe_mono = mono_id + , abe_prags = SpecPrags spec_prags } + + abs_bind = L loc $ + AbsBinds { abs_ext = noExtField + , abs_tvs = skol_tvs + , abs_ev_vars = ev_vars + , abs_ev_binds = [ev_binds] + , abs_exports = [export] + , abs_binds = unitBag (L loc bind') + , abs_sig = True } + + ; return (unitBag abs_bind, [poly_id]) } + +tcPolyCheck _prag_fn sig bind + = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind) + +funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] + -> TcM [Tickish TcId] +funBindTicks loc fun_id mod sigs + | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ] + -- this can only be a singleton list, as duplicate pragmas are rejected + -- by the renamer + , let cc_str + | Just cc_str <- mb_cc_str + = sl_fs $ unLoc cc_str + | otherwise + = getOccFS (Var.varName fun_id) + cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str + = do + flavour <- DeclCC <$> getCCIndexM cc_name + let cc = mkUserCC cc_name mod loc flavour + return [ProfNote cc True True] + | otherwise + = return [] + +{- Note [Instantiate sig with fresh variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's vital to instantiate a type signature with fresh variables. +For example: + type T = forall a. [a] -> [a] + f :: T; + f = g where { g :: T; g = } + + We must not use the same 'a' from the defn of T at both places!! +(Instantiation is only necessary because of type synonyms. Otherwise, +it's all cool; each signature has distinct type variables from the renamer.) +-} + + +{- ********************************************************************* +* * + tcPolyInfer +* * +********************************************************************* -} + +tcPolyInfer + :: RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> TcPragEnv -> TcSigFun + -> Bool -- True <=> apply the monomorphism restriction + -> [LHsBind GhcRn] + -> TcM (LHsBinds GhcTcId, [TcId]) +tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list + = do { (tclvl, wanted, (binds', mono_infos)) + <- pushLevelAndCaptureConstraints $ + tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list + + ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info)) + | info <- mono_infos ] + sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ] + infer_mode = if mono then ApplyMR else NoRestrictions + + ; mapM_ (checkOverloadedSig mono) sigs + + ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted) + ; (qtvs, givens, ev_binds, residual, insoluble) + <- simplifyInfer tclvl infer_mode sigs name_taus wanted + ; emitConstraints residual + + ; let inferred_theta = map evVarPred givens + ; exports <- checkNoErrs $ + mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos + + ; loc <- getSrcSpanM + ; let poly_ids = map abe_poly exports + abs_bind = L loc $ + AbsBinds { abs_ext = noExtField + , abs_tvs = qtvs + , abs_ev_vars = givens, abs_ev_binds = [ev_binds] + , abs_exports = exports, abs_binds = binds' + , abs_sig = False } + + ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids)) + ; return (unitBag abs_bind, poly_ids) } + -- poly_ids are guaranteed zonked by mkExport + +-------------- +mkExport :: TcPragEnv + -> Bool -- True <=> there was an insoluble type error + -- when typechecking the bindings + -> [TyVar] -> TcThetaType -- Both already zonked + -> MonoBindInfo + -> TcM (ABExport GhcTc) +-- Only called for generalisation plan InferGen, not by CheckGen or NoGen +-- +-- mkExport generates exports with +-- zonked type variables, +-- zonked poly_ids +-- The former is just because no further unifications will change +-- the quantified type variables, so we can fix their final form +-- right now. +-- The latter is needed because the poly_ids are used to extend the +-- type environment; see the invariant on GHC.Tc.Utils.Env.tcExtendIdEnv + +-- Pre-condition: the qtvs and theta are already zonked + +mkExport prag_fn insoluble qtvs theta + mono_info@(MBI { mbi_poly_name = poly_name + , mbi_sig = mb_sig + , mbi_mono_id = mono_id }) + = do { mono_ty <- zonkTcType (idType mono_id) + ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty + + -- NB: poly_id has a zonked type + ; poly_id <- addInlinePrags poly_id prag_sigs + ; spec_prags <- tcSpecPrags poly_id prag_sigs + -- tcPrags requires a zonked poly_id + + -- See Note [Impedance matching] + -- NB: we have already done checkValidType, including an ambiguity check, + -- on the type; either when we checked the sig or in mkInferredPolyId + ; let poly_ty = idType poly_id + sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty + -- This type is just going into tcSubType, + -- so Inferred vs. Specified doesn't matter + + ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility + 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 addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $ + tcSubType_NC sig_ctxt sel_poly_ty poly_ty + + ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures + ; when warn_missing_sigs $ + localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig + + ; return (ABE { abe_ext = noExtField + , abe_wrap = wrap + -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty) + , abe_poly = poly_id + , abe_mono = mono_id + , abe_prags = SpecPrags spec_prags }) } + where + prag_sigs = lookupPragEnv prag_fn poly_name + sig_ctxt = InfSigCtxt poly_name + +mkInferredPolyId :: Bool -- True <=> there was an insoluble error when + -- checking the binding group for this Id + -> [TyVar] -> TcThetaType + -> Name -> Maybe TcIdSigInst -> TcType + -> TcM TcId +mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty + | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst + , CompleteSig { sig_bndr = poly_id } <- sig + = return poly_id + + | otherwise -- Either no type sig or partial type sig + = checkNoErrs $ -- The checkNoErrs ensures that if the type is ambiguous + -- we don't carry on to the impedance matching, and generate + -- a duplicate ambiguity error. There is a similar + -- checkNoErrs for complete type signatures too. + do { fam_envs <- tcGetFamInstEnvs + ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty + -- Unification may not have normalised the type, + -- (see Note [Lazy flattening] in GHC.Tc.Solver.Flatten) so do it + -- here to make it as uncomplicated as possible. + -- Example: f :: [F Int] -> Bool + -- should be rewritten to f :: [Char] -> Bool, if possible + -- + -- We can discard the coercion _co, because we'll reconstruct + -- it in the call to tcSubType below + + ; (binders, theta') <- chooseInferredQuantifiers inferred_theta + (tyCoVarsOfType mono_ty') qtvs mb_sig_inst + + ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty') + + ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta' + , ppr inferred_poly_ty]) + ; unless insoluble $ + addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $ + 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. + + ; return (mkLocalId poly_name inferred_poly_ty) } + + +chooseInferredQuantifiers :: TcThetaType -- inferred + -> TcTyVarSet -- tvs free in tau type + -> [TcTyVar] -- inferred quantified tvs + -> Maybe TcIdSigInst + -> TcM ([TyVarBinder], TcThetaType) +chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing + = -- No type signature (partial or complete) for this binder, + do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs) + -- Include kind variables! #7916 + my_theta = pickCapturedPreds free_tvs inferred_theta + binders = [ mkTyVarBinder Inferred tv + | tv <- qtvs + , tv `elemVarSet` free_tvs ] + ; return (binders, my_theta) } + +chooseInferredQuantifiers inferred_theta tau_tvs qtvs + (Just (TISI { sig_inst_sig = sig -- Always PartialSig + , sig_inst_wcx = wcx + , sig_inst_theta = annotated_theta + , sig_inst_skols = annotated_tvs })) + = -- Choose quantifiers for a partial type signature + do { psig_qtv_prs <- zonkTyVarTyVarPairs annotated_tvs + + -- Check whether the quantified variables of the + -- partial signature have been unified together + -- See Note [Quantified variables in partial type signatures] + ; mapM_ report_dup_tyvar_tv_err (findDupTyVarTvs psig_qtv_prs) + + -- Check whether a quantified variable of the partial type + -- signature is not actually quantified. How can that happen? + -- See Note [Quantification and partial signatures] Wrinkle 4 + -- in GHC.Tc.Solver + ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs + , not (tv `elem` qtvs) ] + + ; let psig_qtvs = mkVarSet (map snd psig_qtv_prs) + + ; annotated_theta <- zonkTcTypes annotated_theta + ; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx + + ; let keep_me = free_tvs `unionVarSet` psig_qtvs + final_qtvs = [ mkTyVarBinder vis tv + | tv <- qtvs -- Pulling from qtvs maintains original order + , tv `elemVarSet` keep_me + , let vis | tv `elemVarSet` psig_qtvs = Specified + | otherwise = Inferred ] + + ; return (final_qtvs, my_theta) } + where + report_dup_tyvar_tv_err (n1,n2) + | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig + = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1) + <+> text "with" <+> quotes (ppr n2)) + 2 (hang (text "both bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) + + | otherwise -- Can't happen; by now we know it's a partial sig + = pprPanic "report_tyvar_tv_err" (ppr sig) + + report_mono_sig_tv_err n + | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig + = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n)) + 2 (hang (text "bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) + | otherwise -- Can't happen; by now we know it's a partial sig + = pprPanic "report_mono_sig_tv_err" (ppr sig) + + choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType + -> TcM (VarSet, TcThetaType) + choose_psig_context _ annotated_theta Nothing + = do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta + `unionVarSet` tau_tvs) + ; return (free_tvs, annotated_theta) } + + choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty) + = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs) + -- growThetaVars just like the no-type-sig case + -- Omitting this caused #12844 + seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there + `unionVarSet` tau_tvs -- by the user + + ; let keep_me = psig_qtvs `unionVarSet` free_tvs + my_theta = pickCapturedPreds keep_me inferred_theta + + -- Fill in the extra-constraints wildcard hole with inferred_theta, + -- so that the Hole constraint we have already emitted + -- (in tcHsPartialSigType) can report what filled it in. + -- NB: my_theta already includes all the annotated constraints + ; let inferred_diff = [ pred + | pred <- my_theta + , all (not . (`eqType` pred)) annotated_theta ] + ; ctuple <- mk_ctuple inferred_diff + + ; case tcGetCastedTyVar_maybe wc_var_ty of + -- 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 (ctuple `mkCastTy` mkTcSymCo wc_co) + Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty) + + ; traceTc "completeTheta" $ + vcat [ ppr sig + , ppr annotated_theta, ppr inferred_theta + , ppr inferred_diff ] + ; return (free_tvs, my_theta) } + + mk_ctuple preds = return (mkBoxedTupleTy preds) + -- Hack alert! See GHC.Tc.Gen.HsType: + -- Note [Extra-constraint holes in partial type signatures] + + +mk_impedance_match_msg :: MonoBindInfo + -> TcType -> TcType + -> TidyEnv -> TcM (TidyEnv, SDoc) +-- This is a rare but rather awkward error messages +mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig }) + inf_ty sig_ty tidy_env + = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty + ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty + ; let msg = vcat [ text "When checking that the inferred type" + , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty + , text "is as general as its" <+> what <+> text "signature" + , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ] + ; return (tidy_env2, msg) } + where + what = case mb_sig of + Nothing -> text "inferred" + Just sig | isPartialSig sig -> text "(partial)" + | otherwise -> empty + + +mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (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" + , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ] + ; return (tidy_env1, msg) } + + +-- | Warn the user about polymorphic local binders that lack type signatures. +localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM () +localSigWarn flag id mb_sig + | Just _ <- mb_sig = return () + | not (isSigmaTy (idType id)) = return () + | otherwise = warnMissingSignatures flag msg id + where + msg = text "Polymorphic local binding with no type signature:" + +warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM () +warnMissingSignatures flag msg id + = do { env0 <- tcInitTidyEnv + ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) + ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) } + where + mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ] + +checkOverloadedSig :: Bool -> TcIdSigInst -> 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 monomorphism_restriction_applies sig + | not (null (sig_inst_theta sig)) + , monomorphism_restriction_applies + , let orig_sig = sig_inst_sig sig + = setSrcSpan (sig_loc orig_sig) $ + failWith $ + hang (text "Overloaded signature conflicts with monomorphism restriction") + 2 (ppr orig_sig) + | otherwise + = return () + +{- Note [Partial type signatures and generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If /any/ of the signatures in the group is a partial type signature + f :: _ -> Int +then we *always* use the InferGen plan, and hence tcPolyInfer. +We do this even for a local binding with -XMonoLocalBinds, when +we normally use NoGen. + +Reasons: + * The TcSigInfo for 'f' has a unification variable for the '_', + whose TcLevel is one level deeper than the current level. + (See pushTcLevelM in tcTySig.) But NoGen doesn't increase + the TcLevel like InferGen, so we lose the level invariant. + + * The signature might be f :: forall a. _ -> a + so it really is polymorphic. It's not clear what it would + mean to use NoGen on this, and indeed the ASSERT in tcLhs, + in the (Just sig) case, checks that if there is a signature + then we are using LetLclBndr, and hence a nested AbsBinds with + increased TcLevel + +It might be possible to fix these difficulties somehow, but there +doesn't seem much point. Indeed, adding a partial type signature is a +way to get per-binding inferred generalisation. + +We apply the MR if /all/ of the partial signatures lack a context. +In particular (#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 + +Note [Quantified variables in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall a. a -> a -> _ + f x y = g x y + g :: forall b. b -> b -> _ + g x y = [x, y] + +Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b' +together, which is fine. So we bind 'a' and 'b' to TyVarTvs, which can then +unify with each other. + +But now consider: + f :: forall a b. a -> b -> _ + f x y = [x, y] + +We want to get an error from this, because 'a' and 'b' get unified. +So we make a test, one per partial signature, to check that the +explicitly-quantified type variables have not been unified together. +#14449 showed this up. + + +Note [Validity of inferred types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to check inferred type for validity, in case it uses language +extensions that are not turned on. The principle is that if the user +simply adds the inferred type to the program source, it'll compile fine. +See #8883. + +Examples that might fail: + - the type might be ambiguous + + - an inferred theta that requires type equalities e.g. (F a ~ G b) + or multi-parameter type classes + - an inferred type that includes unboxed tuples + + +Note [Impedance matching] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f 0 x = x + f n x = g [] (not x) + + g [] y = f 10 y + g _ y = f 9 y + +After typechecking we'll get + f_mono_ty :: a -> Bool -> Bool + g_mono_ty :: [b] -> Bool -> Bool +with constraints + (Eq a, Num a) + +Note that f is polymorphic in 'a' and g in 'b'; and these are not linked. +The types we really want for f and g are + f :: forall a. (Eq a, Num a) => a -> Bool -> Bool + g :: forall b. [b] -> Bool -> Bool + +We can get these by "impedance matching": + tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool) + tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono) + + f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f + g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g + +Suppose the shared quantified tyvars are qtvs and constraints theta. +Then we want to check that + 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. + +It also cleverly does an ambiguity check; for example, rejecting + f :: F a -> F a +where F is a non-injective type function. +-} + + +{- +Note [SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no point in a SPECIALISE pragma for a non-overloaded function: + reverse :: [a] -> [a] + {-# SPECIALISE reverse :: [Int] -> [Int] #-} + +But SPECIALISE INLINE *can* make sense for GADTS: + data Arr e where + ArrInt :: !Int -> ByteArray# -> Arr Int + ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2) + + (!:) :: Arr e -> Int -> e + {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-} + {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-} + (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i) + (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i) + +When (!:) is specialised it becomes non-recursive, and can usefully +be inlined. Scary! So we only warn for SPECIALISE *without* INLINE +for a non-overloaded function. + +************************************************************************ +* * + tcMonoBinds +* * +************************************************************************ + +@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. +The signatures have been dealt with already. +-} + +data MonoBindInfo = MBI { mbi_poly_name :: Name + , mbi_sig :: Maybe TcIdSigInst + , mbi_mono_id :: TcId } + +tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes + -- i.e. the binders are mentioned in their RHSs, and + -- we are not rescued by a type signature + -> TcSigFun -> LetBndrSpec + -> [LHsBind GhcRn] + -> TcM (LHsBinds GhcTcId, [MonoBindInfo]) +tcMonoBinds is_rec sig_fn no_gen + [ L b_loc (FunBind { fun_id = L nm_loc name + , fun_matches = matches })] + -- Single function binding, + | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS + , Nothing <- sig_fn name -- ...with no type signature + = -- Note [Single function non-recursive binding special-case] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- In this very special case we infer the type of the + -- right hand side first (it may have a higher-rank type) + -- and *then* make the monomorphic Id for the LHS + -- e.g. f = \(x::forall a. a->a) -> + -- We want to infer a higher-rank type for f + setSrcSpan b_loc $ + do { ((co_fn, matches'), rhs_ty) + <- tcInfer $ \ exp_ty -> + tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $ + -- We extend the error context even for a non-recursive + -- function so that in type error messages we show the + -- type of the thing whose rhs we are type checking + tcMatchesFun (L nm_loc name) matches exp_ty + + ; mono_id <- newLetBndr no_gen name rhs_ty + ; return (unitBag $ L b_loc $ + FunBind { fun_id = L nm_loc mono_id, + fun_matches = matches', + fun_ext = co_fn, fun_tick = [] }, + [MBI { mbi_poly_name = name + , mbi_sig = Nothing + , mbi_mono_id = mono_id }]) } + +tcMonoBinds _ sig_fn no_gen binds + = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds + + -- Bring the monomorphic Ids, into scope for the RHSs + ; let mono_infos = getMonoBindInfo tc_binds + rhs_id_env = [ (name, mono_id) + | MBI { mbi_poly_name = name + , mbi_sig = mb_sig + , mbi_mono_id = mono_id } <- mono_infos + , case mb_sig of + Just sig -> isPartialSig sig + Nothing -> True ] + -- A monomorphic binding for each term variable that lacks + -- a complete type sig. (Ones with a sig are already in scope.) + + ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) + | (n,id) <- rhs_id_env] + ; binds' <- tcExtendRecIds rhs_id_env $ + mapM (wrapLocM tcRhs) tc_binds + + ; return (listToBag binds', mono_infos) } + + +------------------------ +-- tcLhs typechecks the LHS of the bindings, to construct the environment in which +-- we typecheck the RHSs. Basically what we are doing is this: for each binder: +-- if there's a signature for it, use the instantiated signature type +-- otherwise invent a type variable +-- You see that quite directly in the FunBind case. +-- +-- But there's a complication for pattern bindings: +-- data T = MkT (forall a. a->a) +-- MkT f = e +-- Here we can guess a type variable for the entire LHS (which will be refined to T) +-- but we want to get (f::forall a. a->a) as the RHS environment. +-- The simplest way to do this is to typecheck the pattern, and then look up the +-- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing +-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't + +data TcMonoBind -- Half completed; LHS done, RHS not done + = TcFunBind MonoBindInfo SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn)) + | TcPatBind [MonoBindInfo] (LPat GhcTcId) (GRHSs GhcRn (LHsExpr GhcRn)) + TcSigmaType + +tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind +-- Only called with plan InferGen (LetBndrSpec = LetLclBndr) +-- or NoGen (LetBndrSpec = LetGblBndr) +-- CheckGen is used only for functions with a complete type signature, +-- and tcPolyCheck doesn't use tcMonoBinds at all + +tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name + , fun_matches = matches }) + | Just (TcIdSig sig) <- sig_fn name + = -- There is a type signature. + -- It must be partial; if complete we'd be in tcPolyCheck! + -- e.g. f :: _ -> _ + -- f x = ...g... + -- Just g = ...f... + -- Hence always typechecked with InferGen + do { mono_info <- tcLhsSigId no_gen (name, sig) + ; return (TcFunBind mono_info nm_loc matches) } + + | otherwise -- No type signature + = do { mono_ty <- newOpenFlexiTyVarTy + ; mono_id <- newLetBndr no_gen name mono_ty + ; let mono_info = MBI { mbi_poly_name = name + , mbi_sig = Nothing + , mbi_mono_id = mono_id } + ; return (TcFunBind mono_info nm_loc matches) } + +tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) + = -- See Note [Typechecking pattern bindings] + do { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names + + ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $ + [ (mbi_poly_name mbi, mbi_mono_id mbi) + | mbi <- sig_mbis ] + + -- See Note [Existentials in pattern bindings] + ; ((pat', nosig_mbis), pat_ty) + <- addErrCtxt (patMonoBindsCtxt pat grhss) $ + tcInfer $ \ exp_ty -> + tcLetPat inst_sig_fun no_gen pat exp_ty $ + mapM lookup_info nosig_names + + ; let mbis = sig_mbis ++ nosig_mbis + + ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id) + | mbi <- mbis, let id = mbi_mono_id mbi ] + $$ ppr no_gen) + + ; return (TcPatBind mbis pat' grhss pat_ty) } + where + bndr_names = collectPatBinders pat + (nosig_names, sig_names) = partitionWith find_sig bndr_names + + find_sig :: Name -> Either Name (Name, TcIdSigInfo) + find_sig name = case sig_fn name of + Just (TcIdSig sig) -> Right (name, sig) + _ -> Left name + + -- After typechecking the pattern, look up the binder + -- names that lack a signature, which the pattern has brought + -- into scope. + lookup_info :: Name -> TcM MonoBindInfo + lookup_info name + = do { mono_id <- tcLookupId name + ; return (MBI { mbi_poly_name = name + , mbi_sig = Nothing + , mbi_mono_id = mono_id }) } + +tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) + -- AbsBind, VarBind impossible + +------------------- +tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo +tcLhsSigId no_gen (name, sig) + = do { inst_sig <- tcInstSig sig + ; mono_id <- newSigLetBndr no_gen name inst_sig + ; return (MBI { mbi_poly_name = name + , mbi_sig = Just inst_sig + , mbi_mono_id = mono_id }) } + +------------ +newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId +newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig }) + | CompleteSig { sig_bndr = poly_id } <- id_sig + = addInlinePrags poly_id (lookupPragEnv prags name) +newSigLetBndr no_gen name (TISI { sig_inst_tau = tau }) + = newLetBndr no_gen name tau + +------------------- +tcRhs :: TcMonoBind -> TcM (HsBind GhcTcId) +tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) + loc matches) + = tcExtendIdBinderStackForRhs [info] $ + tcExtendTyVarEnvForRhs mb_sig $ + do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) + ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id)) + matches (mkCheckExpType $ idType mono_id) + ; return ( FunBind { fun_id = L loc mono_id + , fun_matches = matches' + , fun_ext = co_fn + , fun_tick = [] } ) } + +tcRhs (TcPatBind infos pat' grhss pat_ty) + = -- When we are doing pattern bindings we *don't* bring any scoped + -- type variables into scope unlike function bindings + -- Wny not? They are not completely rigid. + -- That's why we have the special case for a single FunBind in tcMonoBinds + tcExtendIdBinderStackForRhs infos $ + do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) + ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ + tcGRHSsPat grhss pat_ty + ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' + , pat_ext = NPatBindTc emptyNameSet pat_ty + , pat_ticks = ([],[]) } )} + +tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a +tcExtendTyVarEnvForRhs Nothing thing_inside + = thing_inside +tcExtendTyVarEnvForRhs (Just sig) thing_inside + = tcExtendTyVarEnvFromSig sig thing_inside + +tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a +tcExtendTyVarEnvFromSig sig_inst thing_inside + | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst + = tcExtendNameTyVarEnv wcs $ + tcExtendNameTyVarEnv skol_prs $ + thing_inside + +tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a +-- Extend the TcBinderStack for the RHS of the binding, with +-- the monomorphic Id. That way, if we have, say +-- f = \x -> blah +-- and something goes wrong in 'blah', we get a "relevant binding" +-- looking like f :: alpha -> beta +-- This applies if 'f' has a type signature too: +-- f :: forall a. [a] -> [a] +-- f x = True +-- We can't unify True with [a], and a relevant binding is f :: [a] -> [a] +-- If we had the *polymorphic* version of f in the TcBinderStack, it +-- would not be reported as relevant, because its type is closed +tcExtendIdBinderStackForRhs infos thing_inside + = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel + | MBI { mbi_mono_id = mono_id } <- infos ] + thing_inside + -- NotTopLevel: it's a monomorphic binding + +--------------------- +getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo] +getMonoBindInfo tc_binds + = foldr (get_info . unLoc) [] tc_binds + where + get_info (TcFunBind info _ _) rest = info : rest + get_info (TcPatBind infos _ _ _) rest = infos ++ rest + + +{- Note [Typechecking pattern bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Look at: + - typecheck/should_compile/ExPat + - #12427, typecheck/should_compile/T12427{a,b} + + data T where + MkT :: Integral a => a -> Int -> T + +and suppose t :: T. Which of these pattern bindings are ok? + + E1. let { MkT p _ = t } in + + E2. let { MkT _ q = t } in + + E3. let { MkT (toInteger -> r) _ = t } in + +* (E1) is clearly wrong because the existential 'a' escapes. + What type could 'p' possibly have? + +* (E2) is fine, despite the existential pattern, because + q::Int, and nothing escapes. + +* Even (E3) is fine. The existential pattern binds a dictionary + for (Integral a) which the view pattern can use to convert the + a-valued field to an Integer, so r :: Integer. + +An easy way to see all three is to imagine the desugaring. +For (E2) it would look like + let q = case t of MkT _ q' -> q' + in + + +We typecheck pattern bindings as follows. First tcLhs does this: + + 1. Take each type signature q :: ty, partial or complete, and + instantiate it (with tcLhsSigId) to get a MonoBindInfo. This + gives us a fresh "mono_id" qm :: instantiate(ty), where qm has + a fresh name. + + Any fresh unification variables in instantiate(ty) born here, not + deep under implications as would happen if we allocated them when + we encountered q during tcPat. + + 2. Build a little environment mapping "q" -> "qm" for those Ids + with signatures (inst_sig_fun) + + 3. Invoke tcLetPat to typecheck the pattern. + + - We pass in the current TcLevel. This is captured by + GHC.Tc.Gen.Pat.tcLetPat, and put into the pc_lvl field of PatCtxt, in + PatEnv. + + - When tcPat finds an existential constructor, it binds fresh + type variables and dictionaries as usual, increments the TcLevel, + and emits an implication constraint. + + - When we come to a binder (GHC.Tc.Gen.Pat.tcPatBndr), it looks it up + in the little environment (the pc_sig_fn field of PatCtxt). + + Success => There was a type signature, so just use it, + checking compatibility with the expected type. + + Failure => No type signature. + Infer case: (happens only outside any constructor pattern) + use a unification variable + at the outer level pc_lvl + + Check case: use promoteTcType to promote the type + to the outer level pc_lvl. This is the + place where we emit a constraint that'll blow + up if existential capture takes place + + Result: the type of the binder is always at pc_lvl. This is + crucial. + + 4. Throughout, when we are making up an Id for the pattern-bound variables + (newLetBndr), we have two cases: + + - If we are generalising (generalisation plan is InferGen or + CheckGen), then the let_bndr_spec will be LetLclBndr. In that case + we want to bind a cloned, local version of the variable, with the + type given by the pattern context, *not* by the signature (even if + there is one; see #7268). The mkExport part of the + generalisation step will do the checking and impedance matching + against the signature. + + - If for some some reason we are not generalising (plan = NoGen), the + LetBndrSpec will be LetGblBndr. In that case we must bind the + global version of the Id, and do so with precisely the type given + in the signature. (Then we unify with the type from the pattern + context type.) + + +And that's it! The implication constraints check for the skolem +escape. It's quite simple and neat, and more expressive than before +e.g. GHC 8.0 rejects (E2) and (E3). + +Example for (E1), starting at level 1. We generate + p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta) +The (a~beta) can't float (because of the 'a'), nor be solved (because +beta is untouchable.) + +Example for (E2), we generate + q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta) +The beta is untouchable, but floats out of the constraint and can +be solved absolutely fine. + + +************************************************************************ +* * + Generalisation +* * +********************************************************************* -} + +data GeneralisationPlan + = NoGen -- No generalisation, no AbsBinds + + | InferGen -- Implicit generalisation; there is an AbsBinds + Bool -- True <=> apply the MR; generalise only unconstrained type vars + + | CheckGen (LHsBind GhcRn) TcIdSigInfo + -- One FunBind with a signature + -- Explicit generalisation + +-- A consequence of the no-AbsBinds choice (NoGen) is that there is +-- no "polymorphic Id" and "monmomorphic Id"; there is just the one + +instance Outputable GeneralisationPlan where + ppr NoGen = text "NoGen" + ppr (InferGen b) = text "InferGen" <+> ppr b + ppr (CheckGen _ s) = text "CheckGen" <+> ppr s + +decideGeneralisationPlan + :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun + -> GeneralisationPlan +decideGeneralisationPlan dflags lbinds closed sig_fn + | has_partial_sigs = InferGen (and partial_sig_mrs) + | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig + | do_not_generalise closed = NoGen + | otherwise = InferGen mono_restriction + where + binds = map unLoc lbinds + + partial_sig_mrs :: [Bool] + -- One for each partial signature (so empty => no partial sigs) + -- The Bool is True if the signature has no constraint context + -- so we should apply the MR + -- See Note [Partial type signatures and generalisation] + partial_sig_mrs + = [ null theta + | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) + <- mapMaybe sig_fn (collectHsBindListBinders lbinds) + , let (_, L _ theta, _) = splitLHsSigmaTyInvis (hsSigWcType hs_ty) ] + + has_partial_sigs = not (null partial_sig_mrs) + + mono_restriction = xopt LangExt.MonomorphismRestriction dflags + && any restricted binds + + do_not_generalise (IsGroupClosed _ True) = False + -- The 'True' means that all of the group's + -- free vars have ClosedTypeId=True; so we can ignore + -- -XMonoLocalBinds, and generalise anyway + do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags + + -- With OutsideIn, all nested bindings are monomorphic + -- except a single function binding with a signature + one_funbind_with_sig + | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds + , Just (TcIdSig sig) <- sig_fn (unLoc v) + = Just (lbind, sig) + | otherwise + = Nothing + + -- The Haskell 98 monomorphism restriction + 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) + + restricted_match mg = matchGroupArity mg == 0 + -- No args => like a pattern binding + -- Some args => a function binding + + no_sig n = not (hasCompleteSig sig_fn n) + +isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed +isClosedBndrGroup type_env binds + = IsGroupClosed fv_env type_closed + where + type_closed = allUFM (nameSetAll is_closed_type_id) fv_env + + fv_env :: NameEnv NameSet + fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds + + bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)] + bindFvs (FunBind { fun_id = L _ f + , fun_ext = fvs }) + = let open_fvs = get_open_fvs fvs + in [(f, open_fvs)] + bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs }) + = let open_fvs = get_open_fvs fvs + in [(b, open_fvs) | b <- collectPatBinders pat] + bindFvs _ + = [] + + get_open_fvs fvs = filterNameSet (not . is_closed) fvs + + is_closed :: Name -> ClosedTypeId + is_closed name + | Just thing <- lookupNameEnv type_env name + = case thing of + AGlobal {} -> True + ATcId { tct_info = ClosedLet } -> True + _ -> False + + | otherwise + = True -- The free-var set for a top level binding mentions + + + is_closed_type_id :: Name -> Bool + -- We're already removed Global and ClosedLet Ids + is_closed_type_id name + | Just thing <- lookupNameEnv type_env name + = case thing of + ATcId { tct_info = NonClosedLet _ cl } -> cl + ATcId { tct_info = NotLetBound } -> False + ATyVar {} -> False + -- In-scope type variables are not closed! + _ -> pprPanic "is_closed_id" (ppr name) + + | otherwise + = True -- The free-var set for a top level binding mentions + -- imported things too, so that we can report unused imports + -- These won't be in the local type env. + -- Ditto class method etc from the current module + + +{- ********************************************************************* +* * + Error contexts and messages +* * +********************************************************************* -} + +-- This one is called on LHS, when pat and grhss are both Name +-- and on RHS, when pat is TcId and grhss is still Name +patMonoBindsCtxt :: (OutputableBndrId p, Outputable body) + => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc +patMonoBindsCtxt pat grhss + = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Default.hs @@ -0,0 +1,108 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} +{-# LANGUAGE TypeFamilies #-} + +-- | Typechecking @default@ declarations +module GHC.Tc.Gen.Default ( tcDefaults ) where + +import GHC.Prelude + +import GHC.Hs +import GHC.Core.Class +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.HsType +import GHC.Tc.Utils.Zonk +import GHC.Tc.Solver +import GHC.Tc.Validity +import GHC.Tc.Utils.TcType +import GHC.Builtin.Names +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Data.FastString +import qualified GHC.LanguageExtensions as LangExt + +tcDefaults :: [LDefaultDecl GhcRn] + -> TcM (Maybe [Type]) -- Defaulting types to heave + -- into Tc monad for later use + -- in Disambig. + +tcDefaults [] + = getDeclaredDefaultTys -- No default declaration, so get the + -- default types from the envt; + -- i.e. use the current ones + -- (the caller will put them back there) + -- It's important not to return defaultDefaultTys here (which + -- we used to do) because in a TH program, tcDefaults [] is called + -- repeatedly, once for each group of declarations between top-level + -- splices. We don't want to carefully set the default types in + -- one group, only for the next group to ignore them and install + -- defaultDefaultTys + +tcDefaults [L _ (DefaultDecl _ [])] + = return (Just []) -- Default declaration specifying no types + +tcDefaults [L locn (DefaultDecl _ mono_tys)] + = setSrcSpan locn $ + addErrCtxt defaultDeclCtxt $ + do { ovl_str <- xoptM LangExt.OverloadedStrings + ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules + ; num_class <- tcLookupClass numClassName + ; deflt_str <- if ovl_str + then mapM tcLookupClass [isStringClassName] + else return [] + ; deflt_interactive <- if ext_deflt + then mapM tcLookupClass interactiveClassNames + else return [] + ; let deflt_clss = num_class : deflt_str ++ deflt_interactive + + ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys + + ; return (Just tau_tys) } + +tcDefaults decls@(L locn (DefaultDecl _ _) : _) + = setSrcSpan locn $ + failWithTc (dupDefaultDeclErr decls) + + +tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type +tc_default_ty deflt_clss hs_ty + = do { (ty, _kind) <- solveEqualities $ + tcLHsType hs_ty + ; ty <- zonkTcTypeToType ty -- establish Type invariants + ; checkValidType DefaultDeclCtxt ty + + -- Check that the type is an instance of at least one of the deflt_clss + ; oks <- mapM (check_instance ty) deflt_clss + ; checkTc (or oks) (badDefaultTy ty deflt_clss) + ; return ty } + +check_instance :: Type -> Class -> TcM Bool + -- Check that ty is an instance of cls + -- We only care about whether it worked or not; return a boolean +check_instance ty cls + = do { (_, success) <- discardErrs $ + askNoErrs $ + simplifyDefault [mkClassPred cls [ty]] + ; return success } + +defaultDeclCtxt :: SDoc +defaultDeclCtxt = text "When checking the types in a default declaration" + +dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc +dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things) + = hang (text "Multiple default declarations") + 2 (vcat (map pp dup_things)) + where + pp :: Located (DefaultDecl GhcRn) -> SDoc + pp (L locn (DefaultDecl _ _)) + = text "here was another default declaration" <+> ppr locn +dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" + +badDefaultTy :: Type -> [Class] -> SDoc +badDefaultTy ty deflt_clss + = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of")) + 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -0,0 +1,855 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Tc.Gen.Export (tcRnExports, exports_from_avail) where + +import GHC.Prelude + +import GHC.Hs +import GHC.Builtin.Names +import GHC.Types.Name.Reader +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcType +import GHC.Rename.Names +import GHC.Rename.Env +import GHC.Rename.Unbound ( reportUnboundName ) +import GHC.Utils.Error +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Core.TyCon +import GHC.Types.SrcLoc as SrcLoc +import GHC.Driver.Types +import GHC.Utils.Outputable +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Data.Maybe +import GHC.Types.Unique.Set +import GHC.Utils.Misc (capitalise) +import GHC.Data.FastString (fsLit) + +import Control.Monad +import GHC.Driver.Session +import GHC.Rename.Doc ( rnHsDoc ) +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import Data.Either ( partitionEithers ) + +{- +************************************************************************ +* * +\subsection{Export list processing} +* * +************************************************************************ + +Processing the export list. + +You might think that we should record things that appear in the export +list as ``occurrences'' (using @addOccurrenceName@), but you'd be +wrong. We do check (here) that they are in scope, but there is no +need to slurp in their actual declaration (which is what +@addOccurrenceName@ forces). + +Indeed, doing so would big trouble when compiling @PrelBase@, because +it re-exports @GHC@, which includes @takeMVar#@, whose type includes +@ConcBase.StateAndSynchVar#@, and so on... + +Note [Exports of data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose you see (#5306) + module M where + import X( F ) + data instance F Int = FInt +What does M export? AvailTC F [FInt] + or AvailTC F [F,FInt]? +The former is strictly right because F isn't defined in this module. +But then you can never do an explicit import of M, thus + import M( F( FInt ) ) +because F isn't exported by M. Nor can you import FInt alone from here + import M( FInt ) +because we don't have syntax to support that. (It looks like an import of +the type FInt.) + +At one point I implemented a compromise: + * When constructing exports with no export list, or with module M( + module M ), we add the parent to the exports as well. + * But not when you see module M( f ), even if f is a + class method with a parent. + * Nor when you see module M( module N ), with N /= M. + +But the compromise seemed too much of a hack, so we backed it out. +You just have to use an explicit export list: + module M( F(..) ) where ... + +Note [Avails of associated data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose you have (#16077) + + {-# LANGUAGE TypeFamilies #-} + module A (module A) where + + class C a where { data T a } + instance C () where { data T () = D } + +Because @A@ is exported explicitly, GHC tries to produce an export list +from the @GlobalRdrEnv@. In this case, it pulls out the following: + + [ C defined at A.hs:4:1 + , T parent:C defined at A.hs:4:23 + , D parent:T defined at A.hs:5:35 ] + +If map these directly into avails, (via 'availFromGRE'), we get +@[C{C;}, C{T;}, T{D;}]@, which eventually gets merged into @[C{C, T;}, T{D;}]@. +That's not right, because @T{D;}@ violates the AvailTC invariant: @T@ is +exported, but it isn't the first entry in the avail! + +We work around this issue by expanding GREs where the parent and child +are both type constructors into two GRES. + + T parent:C defined at A.hs:4:23 + + => + + [ T parent:C defined at A.hs:4:23 + , T defined at A.hs:4:23 ] + +Then, we get @[C{C;}, C{T;}, T{T;}, T{D;}]@, which eventually gets merged +into @[C{C, T;}, T{T, D;}]@ (which satsifies the AvailTC invariant). +-} + +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 + +emptyExportAccum :: ExportAccum +emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet + +accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, 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) + +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 + -- that have the same occurrence name + +tcRnExports :: Bool -- False => no 'module M(..) where' header at all + -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list + -> TcGblEnv + -> RnM TcGblEnv + + -- Complains if two distinct exports have same OccName + -- Warns about identical exports. + -- Complains about exports items not in scope + +tcRnExports explicit_mod exports + tcg_env@TcGblEnv { tcg_mod = this_mod, + tcg_rdr_env = rdr_env, + tcg_imports = imports, + tcg_src = hsc_src } + = 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 { + ; dflags <- getDynFlags + ; let is_main_mod = mainModIs dflags == this_mod + ; let default_main = case mainFunIs dflags of + Just main_fun + | is_main_mod -> mkUnqual varName (fsLit main_fun) + _ -> main_RDR_Unqual + ; has_main <- (not . null) <$> lookupInfoOccRn default_main -- #17832 + -- If a module has no explicit header, and it has one or more main + -- functions in scope, then add a header like + -- "module Main(main) where ..." #13839 + -- See Note [Modules without a module header] + ; let real_exports + | explicit_mod = exports + | has_main + = Just (noLoc [noLoc (IEVar noExtField + (noLoc (IEName $ noLoc default_main)))]) + -- ToDo: the 'noLoc' here is unhelpful if 'main' + -- turns out to be out of scope + | otherwise = Nothing + + ; let do_it = exports_from_avail real_exports rdr_env imports this_mod + ; (rn_exports, final_avails) + <- if hsc_src == HsigFile + then do (mb_r, msgs) <- tryTc do_it + case mb_r of + Just r -> return r + Nothing -> addMessages msgs >> failM + else checkNoErrs do_it + ; let final_ns = availsToNameSetWithSelectors final_avails + + ; traceRn "rnExports: Exports:" (ppr final_avails) + + ; let new_tcg_env = + tcg_env { tcg_exports = final_avails, + tcg_rn_exports = case tcg_rn_exports tcg_env of + Nothing -> Nothing + Just _ -> rn_exports, + tcg_dus = tcg_dus tcg_env `plusDU` + usesOnly final_ns } + ; failIfErrsM + ; return new_tcg_env } + +exports_from_avail :: Maybe (Located [LIE GhcPs]) + -- ^ 'Nothing' means no explicit export list + -> GlobalRdrEnv + -> ImportAvails + -- ^ Imported modules; this is used to test if a + -- @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 + -- if explicit export list is present it contains + -- each renamed export item together with its exported + -- names. + +exports_from_avail Nothing rdr_env _imports _this_mod + -- The same as (module M) where M is the current module name, + -- so that's how we handle it, except we also export the data family + -- when a data instance is exported. + = do { + ; warnMissingExportList <- woptM Opt_WarnMissingExportList + ; warnIfFlag Opt_WarnMissingExportList + warnMissingExportList + (missingModuleExportWarn $ moduleName _this_mod) + ; let avails = + map fix_faminst . gresToAvailInfo + . filter isLocalGRE . globalRdrEnvElts $ rdr_env + ; return (Nothing, avails) } + where + -- #11164: when we define a data instance + -- but not data family, re-export the family + -- Even though we don't check whether this is actually a data family + -- only data families can locally define subordinate things (`ns` here) + -- without locally defining (and instead importing) the parent (`n`) + fix_faminst (AvailTC n ns flds) = + let new_ns = + case ns of + [] -> [n] + (p:_) -> if p == n then ns else n:ns + in AvailTC n new_ns flds + + fix_faminst avail = avail + + +exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod + = do ie_avails <- accumExports do_litem rdr_items + let final_exports = nubAvails (concatMap snd ie_avails) -- Combine families + return (Just ie_avails, final_exports) + where + do_litem :: ExportAccum -> LIE GhcPs + -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) + do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie) + + -- Maps a parent to its in-scope children + kids_env :: NameEnv [GlobalRdrElt] + kids_env = mkChildEnv (globalRdrEnvElts rdr_env) + + -- See Note [Avails of associated data families] + expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt] + expand_tyty_gre (gre@GRE { gre_name = me, gre_par = ParentIs p }) + | isTyConName p, isTyConName me = [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 { warnIfFlag Opt_WarnDuplicateExports True + (dupModuleExport mod) ; + return 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 + } + + ; checkErr exportValid (moduleNotImported mod) + ; warnIfFlag Opt_WarnDodgyExports + (exportValid && null gre_prs) + (nullModuleExport mod) + + ; traceRn "efa" (ppr mod $$ ppr all_gres) + ; addUsedGREs 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 ]) + + ; return (Just ( ExportAccum occs' mods + , ( L loc (IEModuleContents noExtField lmod) + , new_exports))) } + + exports_from_item acc@(ExportAccum occs mods) (L loc ie) + | isDoc ie + = do new_ie <- lookup_doc_ie ie + return (Just (acc, (L loc new_ie, []))) + + | otherwise + = do (new_ie, avail) <- lookup_ie ie + if isUnboundName (ieName new_ie) + then return Nothing -- Avoid error cascade + else do + + occs' <- check_occs ie occs [avail] + + return (Just ( ExportAccum occs' mods + , (L loc new_ie, [avail]))) + + ------------- + 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) + + lookup_ie (IEThingAbs _ (L l rdr)) + = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr + return (IEThingAbs noExtField (L l (replaceWrappedName rdr name)) + , avail) + + lookup_ie ie@(IEThingAll _ n') + = do + (n, avail, flds) <- lookup_ie_all ie n' + let name = unLoc n + return (IEThingAll noExtField (replaceLWrappedName n' (unLoc n)) + , AvailTC name (name:avail) flds) + + + 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 + return (IEThingWith noExtField (replaceLWrappedName l name) wc subs + (flds ++ (map noLoc all_flds)), + AvailTC name (name : avails ++ all_avail) + (map unLoc flds ++ all_flds)) + + + lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier + + + lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName] + -> RnM (Located Name, [LIEWrappedName Name], [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 l name, [], [name], []) + else return (L l name, non_flds + , map (ieWrappedName . unLoc) non_flds + , flds) + + lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName + -> 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 + warnDodgyExports <- woptM Opt_WarnDodgyExports + when (null gres) $ + if isTyConName name + then when warnDodgyExports $ + addWarn (Reason Opt_WarnDodgyExports) + (dodgyExportWarn name) + else -- This occurs when you export T(..), but + -- only import T abstractly, or T is a synonym. + addErr (exportItemErr ie) + return (L l name, non_flds, flds) + + ------------- + lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn) + lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc + return (IEGroup noExtField lev rn_doc) + lookup_doc_ie (IEDoc _ doc) = do rn_doc <- rnHsDoc doc + return (IEDoc noExtField rn_doc) + lookup_doc_ie (IEDocNamed _ str) = return (IEDocNamed noExtField str) + lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier + + -- 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 = partitionEithers . map classifyGRE + +classifyGRE :: GlobalRdrElt -> Either Name FieldLabel +classifyGRE gre = case gre_par gre of + FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n) + FldParent _ (Just lbl) -> Right (FieldLabel lbl True n) + _ -> Left n + where + n = gre_name gre + +isDoc :: IE GhcPs -> Bool +isDoc (IEDoc {}) = True +isDoc (IEDocNamed {}) = True +isDoc (IEGroup {}) = True +isDoc _ = False + +-- Renaming and typechecking of exports happens after everything else has +-- been typechecked. + +{- +Note [Modules without a module header] +-------------------------------------------------- + +The Haskell 2010 report says in section 5.1: + +>> An abbreviated form of module, consisting only of the module body, is +>> permitted. If this is used, the header is assumed to be +>> ‘module Main(main) where’. + +For modules without a module header, this is implemented the +following way: + +If the module has a main function in scope: + Then create a module header and export the main function, + as if a module header like ‘module Main(main) where...’ would exist. + This has the effect to mark the main function and all top level + functions called directly or indirectly via main as 'used', + and later on, unused top-level functions can be reported correctly. + There is no distinction between GHC and GHCi. +If the module has several main functions in scope: + Then generate a header as above. The ambiguity is reported later in + module `GHC.Tc.Module` function `check_main`. +If the module has NO main function: + Then export all top-level functions. This marks all top level + functions as 'used'. + In GHCi this has the effect, that we don't get any 'non-used' warnings. + In GHC, however, the 'has-main-module' check in GHC.Tc.Module.checkMain + fires, and we get the error: + The IO action ‘main’ is not defined in module ‘Main’ +-} + + +-- Renaming exports lists is a minefield. Five different things can appear in +-- children export lists ( T(A, B, C) ). +-- 1. Record selectors +-- 2. Type constructors +-- 3. Data constructors +-- 4. Pattern Synonyms +-- 5. Pattern Synonym Selectors +-- +-- However, things get put into weird name spaces. +-- 1. Some type constructors are parsed as variables (-.->) for example. +-- 2. All data constructors are parsed as type constructors +-- 3. When there is ambiguity, we default type constructors to data +-- constructors and require the explicit `type` keyword for type +-- constructors. +-- +-- This function first establishes the possible namespaces that an +-- identifier might be in (`choosePossibleNameSpaces`). +-- +-- Then for each namespace in turn, tries to find the correct identifier +-- there returning the first positive result or the first terminating +-- error. +-- + + + +lookupChildrenExport :: Name -> [LIEWrappedName RdrName] + -> RnM ([LIEWrappedName Name], [Located FieldLabel]) +lookupChildrenExport spec_parent rdr_items = + do + xs <- mapAndReportM doOne rdr_items + return $ partitionEithers xs + 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 RdrName + -> RnM (Either (LIEWrappedName Name) (Located FieldLabel)) + doOne n = do + + let bareName = (ieWrappedName . unLoc) n + lkup v = lookupSubBndrOcc_helper False True + spec_parent (setRdrNameSpace bareName v) + + name <- combineChildLookupResult $ map lkup $ + choosePossibleNamespaces (rdrNameSpace bareName) + 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 + + case name of + NameNotFound -> do { ub <- reportUnboundName unboundName + ; let l = getLoc n + ; return (Left (L l (IEName (L l ub))))} + FoundFL fls -> return $ Right (L (getLoc n) fls) + FoundName par name -> do { checkPatSynParent spec_parent par name + ; return + $ Left (replaceLWrappedName n name) } + IncorrectParent p g td gs -> failWithDcErr p g td gs + + +-- Note: [Typing Pattern Synonym Exports] +-- It proved quite a challenge to precisely specify which pattern synonyms +-- should be allowed to be bundled with which type constructors. +-- In the end it was decided to be quite liberal in what we allow. Below is +-- how Simon described the implementation. +-- +-- "Personally I think we should Keep It Simple. All this talk of +-- satisfiability makes me shiver. I suggest this: allow T( P ) in all +-- situations except where `P`'s type is ''visibly incompatible'' with +-- `T`. +-- +-- What does "visibly incompatible" mean? `P` is visibly incompatible +-- with +-- `T` if +-- * `P`'s type is of form `... -> S t1 t2` +-- * `S` is a data/newtype constructor distinct from `T` +-- +-- Nothing harmful happens if we allow `P` to be exported with +-- a type it can't possibly be useful for, but specifying a tighter +-- relationship is very awkward as you have discovered." +-- +-- Note that this allows *any* pattern synonym to be bundled with any +-- datatype type constructor. For example, the following pattern `P` can be +-- bundled with any type. +-- +-- ``` +-- pattern P :: (A ~ f) => f +-- ``` +-- +-- So we provide basic type checking in order to help the user out, most +-- pattern synonyms are defined with definite type constructors, but don't +-- actually prevent a library author completely confusing their users if +-- they want to. +-- +-- So, we check for exactly four things +-- 1. The name arises from a pattern synonym definition. (Either a pattern +-- synonym constructor or a pattern synonym selector) +-- 2. The pattern synonym is only bundled with a datatype or newtype. +-- 3. Check that the head of the result type constructor is an actual type +-- constructor and not a type variable. (See above example) +-- 4. Is so, check that this type constructor is the same as the parent +-- type constructor. +-- +-- +-- Note: [Types of TyCon] +-- +-- This check appears to be overlly complicated, Richard asked why it +-- is not simply just `isAlgTyCon`. The answer for this is that +-- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow. +-- (It is either a newtype or data depending on the number of methods) +-- + +-- | Given a resolved name in the children export list and a parent. Decide +-- whether we are allowed to export the child with the parent. +-- Invariant: gre_par == NoParent +-- See note [Typing Pattern Synonym Exports] +checkPatSynParent :: Name -- ^ Alleged parent type constructor + -- User wrote T( P, Q ) + -> Parent -- The parent of P we discovered + -> Name -- ^ Either a + -- a) Pattern Synonym Constructor + -- b) A pattern synonym selector + -> TcM () -- Fails if wrong parent +checkPatSynParent _ (ParentIs {}) _ + = return () + +checkPatSynParent _ (FldParent {}) _ + = return () + +checkPatSynParent parent NoParent mpat_syn + | isUnboundName parent -- Avoid an error cascade + = return () + + | otherwise + = do { parent_ty_con <- tcLookupTyCon parent + ; mpat_syn_thing <- tcLookupGlobal mpat_syn + + -- 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 i) parent_ty_con p + + AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p + + _ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] } + where + psErr = exportErrCtxt "pattern synonym" + selErr = exportErrCtxt "pattern synonym record selector" + + assocClassErr :: SDoc + assocClassErr = text "Pattern synonyms can be bundled only with datatypes." + + handle_pat_syn :: SDoc + -> TyCon -- ^ Parent TyCon + -> PatSyn -- ^ Corresponding bundled PatSyn + -- and pretty printed origin + -> TcM () + handle_pat_syn doc ty_con pat_syn + + -- 2. See note [Types of TyCon] + | not $ isTyConWithSrcDataCons ty_con + = addErrCtxt doc $ failWithTc assocClassErr + + -- 3. Is the head a type variable? + | Nothing <- mtycon + = return () + -- 4. Ok. Check they are actually the same type constructor. + + | Just p_ty_con <- mtycon, p_ty_con /= ty_con + = addErrCtxt doc $ failWithTc typeMismatchError + + -- 5. We passed! + | otherwise + = return () + + where + expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con)) + (_, _, _, _, _, res_ty) = patSynSig pat_syn + mtycon = fst <$> tcSplitTyConApp_maybe res_ty + typeMismatchError :: SDoc + typeMismatchError = + text "Pattern synonyms can only be bundled with matching type constructors" + $$ text "Couldn't match expected type of" + <+> quotes (ppr expected_res_ty) + <+> text "with actual type of" + <+> quotes (ppr res_ty) + + +{-===========================================================================-} +check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo] + -> RnM ExportOccMap +check_occs ie occs avails + -- 'names' and 'fls' are the entities specified by 'ie' + = foldlM check occs names_with_occs + where + -- Each Name specified by 'ie', paired with the OccName used to + -- refer to it in the GlobalRdrEnv + -- (see Note [Representing fields in AvailInfo] in GHC.Types.Avail). + -- + -- We check for export clashes using the selector Name, but need + -- the field label OccName for presenting error messages. + names_with_occs = availsNamesWithOccs avails + + check occs (name, occ) + = case lookupOccEnv occs name_occ of + Nothing -> return (extendOccEnv occs name_occ (name, ie)) + + Just (name', ie') + | name == name' -- Duplicate export + -- But we don't want to warn if the same thing is exported + -- by two different module exports. See ticket #4478. + -> do { warnIfFlag Opt_WarnDuplicateExports + (not (dupExport_ok name ie ie')) + (dupExportWarn occ ie ie') + ; return occs } + + | otherwise -- Same occ name but different names: an error + -> do { global_env <- getGlobalRdrEnv ; + addErr (exportClashErr global_env occ name' name ie' ie) ; + return occs } + where + name_occ = nameOccName name + + +dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool +-- The Name 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 } +-- +-- 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 + +dupExport_ok n ie1 ie2 + = not ( single ie1 || single ie2 + || (explicit_in ie1 && explicit_in ie2) ) + where + explicit_in (IEModuleContents {}) = False -- module M + explicit_in (IEThingAll _ r) + = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..) + explicit_in _ = True + + single IEVar {} = True + single IEThingAbs {} = True + single _ = False + + +dupModuleExport :: ModuleName -> SDoc +dupModuleExport mod + = hsep [text "Duplicate", + quotes (text "Module" <+> ppr mod), + text "in export list"] + +moduleNotImported :: ModuleName -> SDoc +moduleNotImported mod + = hsep [text "The export item", + quotes (text "module" <+> ppr mod), + text "is not imported"] + +nullModuleExport :: ModuleName -> SDoc +nullModuleExport mod + = hsep [text "The export item", + quotes (text "module" <+> ppr mod), + text "exports nothing"] + +missingModuleExportWarn :: ModuleName -> SDoc +missingModuleExportWarn mod + = hsep [text "The export item", + quotes (text "module" <+> ppr mod), + text "is missing an export list"] + + +dodgyExportWarn :: Name -> SDoc +dodgyExportWarn item + = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn) + +exportErrCtxt :: Outputable o => String -> o -> SDoc +exportErrCtxt herald exp = + text "In the" <+> text (herald ++ ":") <+> ppr exp + + +addExportErrCtxt :: (OutputableBndrId p) + => IE (GhcPass p) -> TcM a -> TcM a +addExportErrCtxt ie = addErrCtxt exportCtxt + where + exportCtxt = text "In the export:" <+> ppr ie + +exportItemErr :: IE GhcPs -> SDoc +exportItemErr export_item + = sep [ text "The export item" <+> quotes (ppr export_item), + text "attempts to export constructors or class methods that are not visible here" ] + + +dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc +dupExportWarn occ_name ie1 ie2 + = hsep [quotes (ppr occ_name), + text "is exported by", quotes (ppr ie1), + text "and", quotes (ppr ie2)] + +dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc +dcErrMsg ty_con what_is thing parents = + text "The type constructor" <+> quotes (ppr ty_con) + <+> text "is not the parent of the" <+> text what_is + <+> quotes thing <> char '.' + $$ text (capitalise what_is) + <> text "s can only be exported with their parent type constructor." + $$ (case parents of + [] -> empty + [_] -> text "Parent:" + _ -> text "Parents:") <+> fsep (punctuate comma parents) + +failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a +failWithDcErr parent thing thing_doc parents = do + ty_thing <- tcLookupGlobal thing + failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing) + thing_doc (map ppr parents) + where + tyThingCategory' :: TyThing -> String + tyThingCategory' (AnId i) + | isRecordSelector i = "record selector" + tyThingCategory' i = tyThingCategory i + + +exportClashErr :: GlobalRdrEnv -> OccName + -> Name -> Name + -> IE GhcPs -> IE GhcPs + -> MsgDoc +exportClashErr global_env occ name1 name2 ie1 ie2 + = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon + , ppr_export ie1' name1' + , ppr_export ie2' name2' ] + where + ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> + quotes (ppr_name name)) + 2 (pprNameProvenance (get_gre name))) + + -- DuplicateRecordFields means that nameOccName might be a mangled + -- $sel-prefixed thing, in which case show the correct OccName alone + ppr_name name + | nameOccName name == occ = ppr name + | otherwise = ppr occ + + -- get_gre finds a GRE for the Name, so that we can show its provenance + get_gre name + = fromMaybe (pprPanic "exportClashErr" (ppr name)) + (lookupGRE_Name_OccName global_env name occ) + get_loc name = greSrcSpan (get_gre name) + (name1', ie1', name2', ie2') = + case SrcLoc.leftmost_smallest (get_loc name1) (get_loc name2) of + LT -> (name1, ie1, name2, ie2) + GT -> (name2, ie2, name1, ie1) + EQ -> panic "exportClashErr: clashing exports have idential location" diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -0,0 +1,2960 @@ +{- +% +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies, DataKinds, TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Typecheck an expression +module GHC.Tc.Gen.Expr + ( tcCheckExpr + , tcLExpr, tcLExprNC, tcExpr + , tcInferSigma + , tcInferRho, tcInferRhoNC + , tcSyntaxOp, tcSyntaxOpGen + , SyntaxOpType(..) + , synKnownType + , tcCheckId + , addAmbiguousNameErr + , getFixedTyVars + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) +import GHC.Builtin.Names.TH( liftStringName, liftName ) + +import GHC.Hs +import GHC.Tc.Types.Constraint ( HoleSort(..) ) +import GHC.Tc.Utils.Zonk +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Unify +import GHC.Types.Basic +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Gen.Bind ( chooseInferredQuantifiers, tcLocalBinds ) +import GHC.Tc.Gen.Sig ( tcUserTypeSig, tcInstSig ) +import GHC.Tc.Solver ( simplifyInfer, InferMode(..) ) +import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst, tcLookupDataFamInst_maybe ) +import GHC.Core.FamInstEnv ( FamInstEnvs ) +import GHC.Rename.Env ( addUsedGRE ) +import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr ) +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Arrow +import GHC.Tc.Gen.Match +import GHC.Tc.Gen.HsType +import GHC.Tc.TyCl.PatSyn ( tcPatSynBuilderOcc, nonBidirectionalErr ) +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.TcMType +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.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Subst (substTyWithInScope) +import GHC.Core.Type +import GHC.Tc.Types.Evidence +import GHC.Types.Var.Set +import GHC.Builtin.Types +import GHC.Builtin.PrimOps( tagToEnumKey ) +import GHC.Builtin.Names +import GHC.Driver.Session +import GHC.Types.SrcLoc +import GHC.Utils.Misc +import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet ) +import GHC.Data.List.SetOps +import GHC.Data.Maybe +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import Control.Monad +import GHC.Core.Class(classTyCon) +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) +import qualified GHC.LanguageExtensions as LangExt + +import Data.Function +import Data.List (partition, sortBy, groupBy, intersect) +import qualified Data.Set as Set + +{- +************************************************************************ +* * +\subsection{Main wrappers} +* * +************************************************************************ +-} + +tcCheckExpr, tcCheckExprNC + :: LHsExpr GhcRn -- Expression to type check + -> TcSigmaType -- Expected type (could be a polytype) + -> TcM (LHsExpr GhcTc) -- Generalised expr with expected type + +-- tcCheckExpr is a convenient place (frequent but not too frequent) +-- place to add context information. +-- The NC version does not do so, usually because the caller wants +-- to do so himself. + +tcCheckExpr expr res_ty + = addExprCtxt expr $ + tcCheckExprNC expr res_ty + +tcCheckExprNC (L loc expr) res_ty + = setSrcSpan loc $ + do { traceTc "tcCheckExprNC" (ppr res_ty) + ; (wrap, expr') <- tcSkolemise GenSigCtxt res_ty $ \ _ res_ty -> + tcExpr expr (mkCheckExpType res_ty) + ; return $ L loc (mkHsWrap wrap expr') } + +--------------- +tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType) +-- Used by tcRnExpr to implement GHCi :type +-- It goes against the principle of eager instantiation, +-- so we expect very very few calls to this function +-- Most clients will want tcInferRho +tcInferSigma le@(L loc expr) + = addExprCtxt le $ setSrcSpan loc $ + do { (fun, args, ty) <- tcInferApp expr + ; return (L loc (applyHsArgs fun args), ty) } + +--------------- +tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) +-- Infer a *rho*-type. The return type is always instantiated. +tcInferRho le = addExprCtxt le (tcInferRhoNC le) + +tcInferRhoNC (L loc expr) + = setSrcSpan loc $ + do { (expr', rho) <- tcInfer (tcExpr expr) + ; return (L loc expr', rho) } + + +{- +************************************************************************ +* * + tcExpr: the main expression typechecker +* * +************************************************************************ + +NB: The res_ty is always deeply skolemised. +-} + +tcLExpr, tcLExprNC + :: LHsExpr GhcRn -- Expression to type check + -> ExpRhoType -- Expected type + -- Definitely no foralls at the top + -> TcM (LHsExpr GhcTc) + +tcLExpr expr res_ty + = addExprCtxt expr (tcLExprNC expr res_ty) + +tcLExprNC (L loc expr) res_ty + = setSrcSpan loc $ + do { expr' <- tcExpr expr res_ty + ; return (L loc expr') } + +tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) +tcExpr (HsVar _ (L _ name)) res_ty = tcCheckId name res_ty +tcExpr e@(HsUnboundVar _ uv) res_ty = tcUnboundId e uv res_ty + +tcExpr e@(HsApp {}) res_ty = tcApp e res_ty +tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty + +tcExpr e@(HsLit x lit) res_ty + = do { let lit_ty = hsLitType lit + ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } + +tcExpr (HsPar x expr) res_ty = do { expr' <- tcLExprNC expr res_ty + ; return (HsPar x expr') } + +tcExpr (HsPragE x prag expr) res_ty + = do { expr' <- tcLExpr expr res_ty + ; return (HsPragE x (tcExprPrag prag) expr') } + +tcExpr (HsOverLit x lit) res_ty + = do { lit' <- newOverloadedLit lit res_ty + ; return (HsOverLit x lit') } + +tcExpr (NegApp x expr neg_expr) res_ty + = do { (expr', neg_expr') + <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ + \[arg_ty] -> + tcLExpr expr (mkCheckExpType arg_ty) + ; return (NegApp x expr' neg_expr') } + +tcExpr e@(HsIPVar _ x) res_ty + = do { {- Implicit parameters must have a *tau-type* not a + type scheme. We enforce this by creating a fresh + type variable as its type. (Because res_ty may not + be a tau-type.) -} + ip_ty <- newOpenFlexiTyVarTy + ; let ip_name = mkStrLitTy (hsIPNameFS x) + ; ipClass <- tcLookupClass ipClassName + ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) + ; tcWrapResult e + (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLoc ip_var))) + ip_ty res_ty } + where + -- Coerces a dictionary for `IP "x" t` into `t`. + fromDict ipClass x ty = mkHsWrap $ mkWpCastR $ + unwrapIP $ mkClassPred ipClass [x,ty] + origin = IPOccOrigin x + +tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty + = do { -- See Note [Type-checking overloaded labels] + loc <- getSrcSpanM + ; case mb_fromLabel of + Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty + Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName + ; alpha <- newFlexiTyVarTy liftedTypeKind + ; let pred = mkClassPred isLabelClass [lbl, alpha] + ; loc <- getSrcSpanM + ; var <- emitWantedEvVar origin pred + ; tcWrapResult e + (fromDict pred (HsVar noExtField (L loc var))) + alpha res_ty } } + where + -- Coerces a dictionary for `IsLabel "x" t` into `t`, + -- or `HasField "x" r a into `r -> a`. + fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred + origin = OverLabelOrigin l + lbl = mkStrLitTy l + + applyFromLabel loc fromLabel = + HsAppType noExtField + (L loc (HsVar noExtField (L loc fromLabel))) + (mkEmptyWildCardBndrs (L loc (HsTyLit noExtField (HsStrTy NoSourceText l)))) + +tcExpr (HsLam x match) res_ty + = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty + ; return (mkHsWrap wrap (HsLam x match')) } + where + match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } + herald = sep [ text "The lambda expression" <+> + quotes (pprSetDepth (PartWay 1) $ + pprMatches match), + -- The pprSetDepth makes the abstraction print briefly + text "has"] + +tcExpr e@(HsLamCase x matches) res_ty + = do { (matches', wrap) + <- tcMatchLambda msg match_ctxt matches res_ty + -- The laziness annotation is because we don't want to fail here + -- if there are multiple arguments + ; return (mkHsWrap wrap $ HsLamCase x matches') } + where + msg = sep [ text "The function" <+> quotes (ppr e) + , text "requires"] + match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } + +tcExpr e@(ExprWithTySig _ expr hs_ty) res_ty + = do { (expr', poly_ty) <- tcExprWithSig expr hs_ty + ; tcWrapResult e expr' poly_ty res_ty } + +{- +Note [Type-checking overloaded labels] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall that we have + + module GHC.OverloadedLabels where + class IsLabel (x :: Symbol) a where + fromLabel :: a + +We translate `#foo` to `fromLabel @"foo"`, where we use + + * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not + * `GHC.OverloadedLabels.fromLabel`. + +In the `RebindableSyntax` case, the renamer will have filled in the +first field of `HsOverLabel` with the `fromLabel` function to use, and +we simply apply it to the appropriate visible type argument. + +In the `OverloadedLabels` case, when we see an overloaded label like +`#foo`, we generate a fresh variable `alpha` for the type and emit an +`IsLabel "foo" alpha` constraint. Because the `IsLabel` class has a +single method, it is represented by a newtype, so we can coerce +`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters). + +-} + + +{- +************************************************************************ +* * + Infix operators and sections +* * +************************************************************************ + +Note [Left sections] +~~~~~~~~~~~~~~~~~~~~ +Left sections, like (4 *), are equivalent to + \ x -> (*) 4 x, +or, if PostfixOperators is enabled, just + (*) 4 +With PostfixOperators we don't actually require the function to take +two arguments at all. For example, (x `not`) means (not x); you get +postfix operators! Not Haskell 98, but it's less work and kind of +useful. + +Note [Typing rule for ($)] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +People write + runST $ blah +so much, where + runST :: (forall s. ST s a) -> a +that I have finally given in and written a special type-checking +rule just for saturated applications of ($). + * Infer the type of the first argument + * Decompose it; should be of form (arg2_ty -> res_ty), + where arg2_ty might be a polytype + * Use arg2_ty to typecheck arg2 +-} + +tcExpr expr@(OpApp fix arg1 op arg2) res_ty + | (L loc (HsVar _ (L lv op_name))) <- op + , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] + = do { traceTc "Application rule" (ppr op) + ; (arg1', arg1_ty) <- addErrCtxt (funAppCtxt op arg1 1) $ + tcInferRhoNC arg1 + + ; let doc = text "The first argument of ($) takes" + orig1 = lexprCtOrigin arg1 + ; (wrap_arg1, [arg2_sigma], op_res_ty) <- + matchActualFunTys doc orig1 (Just (unLoc arg1)) 1 arg1_ty + + -- We have (arg1 $ arg2) + -- So: arg1_ty = arg2_ty -> op_res_ty + -- where arg2_sigma maybe polymorphic; that's the point + + ; arg2' <- tcArg nl_op arg2 arg2_sigma 2 + + -- Make sure that the argument type has kind '*' + -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b + -- Eg we do not want to allow (D# $ 4.0#) #5570 + -- (which gives a seg fault) + ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma)) + (tcTypeKind arg2_sigma) liftedTypeKind + -- Ignore the evidence. arg2_sigma must have type * or #, + -- because we know (arg2_sigma -> op_res_ty) is well-kinded + -- (because otherwise matchActualFunTys would fail) + -- So this 'unifyKind' will either succeed with Refl, or will + -- produce an insoluble constraint * ~ #, which we'll report later. + + -- NB: unlike the argument type, the *result* type, op_res_ty can + -- have any kind (#8739), so we don't need to check anything for that + + ; op_id <- tcLookupId op_name + ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep op_res_ty + , arg2_sigma + , op_res_ty]) + (HsVar noExtField (L lv op_id))) + -- arg1' :: arg1_ty + -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) + -- op' :: (a2_ty -> op_res_ty) -> a2_ty -> op_res_ty + + expr' = OpApp fix (mkLHsWrap wrap_arg1 arg1') op' arg2' + + ; tcWrapResult expr expr' op_res_ty res_ty } + + | L loc (HsRecFld _ (Ambiguous _ lbl)) <- op + , Just sig_ty <- obviousSig (unLoc arg1) + -- See Note [Disambiguating record fields] + = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty + ; sel_name <- disambiguateSelector lbl sig_tc_ty + ; let op' = L loc (HsRecFld noExtField (Unambiguous sel_name lbl)) + ; tcExpr (OpApp fix arg1 op' arg2) res_ty + } + + | otherwise + = do { traceTc "Non Application rule" (ppr op) + ; (op', op_ty) <- tcInferRhoNC op + + ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) + <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty + -- You might think we should use tcInferApp here, but there is + -- too much impedance-matching, because tcApp may return wrappers as + -- well as type-checked arguments. + + ; arg1' <- tcArg nl_op arg1 arg1_ty 1 + ; arg2' <- tcArg nl_op arg2 arg2_ty 2 + + ; let expr' = OpApp fix arg1' (mkLHsWrap wrap_fun op') arg2' + ; tcWrapResult expr expr' op_res_ty res_ty } + where + fn_orig = exprCtOrigin nl_op + nl_op = unLoc op + +-- Right sections, equivalent to \ x -> x `op` expr, or +-- \ x -> op x expr + +tcExpr expr@(SectionR x op arg2) res_ty + = do { (op', op_ty) <- tcInferRhoNC op + ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) + <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty + ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) + (mkVisFunTy arg1_ty op_res_ty) res_ty + ; arg2' <- tcArg (unLoc op) arg2 arg2_ty 2 + ; return ( mkHsWrap wrap_res $ + SectionR x (mkLHsWrap wrap_fun op') arg2' ) } + where + fn_orig = lexprCtOrigin op + -- It's important to use the origin of 'op', so that call-stacks + -- come out right; they are driven by the OccurrenceOf CtOrigin + -- See #13285 + +tcExpr expr@(SectionL x arg1 op) res_ty + = do { (op', op_ty) <- tcInferRhoNC op + ; dflags <- getDynFlags -- Note [Left sections] + ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1 + | otherwise = 2 + + ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty) + <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) + n_reqd_args op_ty + ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) + (mkVisFunTys arg_tys op_res_ty) res_ty + ; arg1' <- tcArg (unLoc op) arg1 arg1_ty 1 + ; return ( mkHsWrap wrap_res $ + SectionL x arg1' (mkLHsWrap wrap_fn op') ) } + where + fn_orig = lexprCtOrigin op + -- It's important to use the origin of 'op', so that call-stacks + -- come out right; they are driven by the OccurrenceOf CtOrigin + -- See #13285 + +tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty + | all tupArgPresent tup_args + = do { let arity = length tup_args + tup_tc = tupleTyCon boxity arity + -- NB: tupleTyCon doesn't flatten 1-tuples + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make + ; res_ty <- expTypeToType res_ty + ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty + -- Unboxed tuples have RuntimeRep vars, which we + -- don't care about here + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys + Boxed -> arg_tys + ; tup_args1 <- tcTupArgs tup_args arg_tys' + ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) } + + | otherwise + = -- The tup_args are a mixture of Present and Missing (for tuple sections) + do { let arity = length tup_args + + ; arg_tys <- case boxity of + { Boxed -> newFlexiTyVarTys arity liftedTypeKind + ; Unboxed -> replicateM arity newOpenFlexiTyVarTy } + ; let actual_res_ty + = mkVisFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args] + (mkTupleTy1 boxity arg_tys) + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make + + ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple") + (Just expr) + actual_res_ty res_ty + + -- Handle tuple sections where + ; tup_args1 <- tcTupArgs tup_args arg_tys + + ; return $ mkHsWrap wrap (ExplicitTuple x tup_args1 boxity) } + +tcExpr (ExplicitSum _ alt arity expr) res_ty + = do { let sum_tc = sumTyCon arity + ; res_ty <- expTypeToType res_ty + ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty + ; -- Drop levity vars, we don't care about them here + let arg_tys' = drop arity arg_tys + ; expr' <- tcCheckExpr expr (arg_tys' `getNth` (alt - 1)) + ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } + +-- This will see the empty list only when -XOverloadedLists. +-- See Note [Empty lists] in GHC.Hs.Expr. +tcExpr (ExplicitList _ witness exprs) res_ty + = case witness of + Nothing -> do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedListTy res_ty + ; exprs' <- mapM (tc_elt elt_ty) exprs + ; return $ + mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' } + + Just fln -> do { ((exprs', elt_ty), fln') + <- tcSyntaxOp ListOrigin fln + [synKnownType intTy, SynList] res_ty $ + \ [elt_ty] -> + do { exprs' <- + mapM (tc_elt elt_ty) exprs + ; return (exprs', elt_ty) } + + ; return $ ExplicitList elt_ty (Just fln') exprs' } + where tc_elt elt_ty expr = tcCheckExpr expr elt_ty + +{- +************************************************************************ +* * + Let, case, if, do +* * +************************************************************************ +-} + +tcExpr (HsLet x (L l binds) expr) res_ty + = do { (binds', expr') <- tcLocalBinds binds $ + tcLExpr expr res_ty + ; return (HsLet x (L l binds') expr') } + +tcExpr (HsCase x scrut matches) res_ty + = do { -- We used to typecheck the case alternatives first. + -- The case patterns tend to give good type info to use + -- when typechecking the scrutinee. For example + -- case (map f) of + -- (x:xs) -> ... + -- will report that map is applied to too few arguments + -- + -- But now, in the GADT world, we need to typecheck the scrutinee + -- first, to get type info that may be refined in the case alternatives + (scrut', scrut_ty) <- tcInferRho scrut + + ; traceTc "HsCase" (ppr scrut_ty) + ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty + ; return (HsCase x scrut' matches') } + where + match_ctxt = MC { mc_what = CaseAlt, + mc_body = tcBody } + +tcExpr (HsIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if' + = do { pred' <- tcLExpr pred (mkCheckExpType boolTy) + ; res_ty <- tauifyExpType res_ty + -- Just like Note [Case branches must never infer a non-tau type] + -- in GHC.Tc.Gen.Match (See #10619) + + ; b1' <- tcLExpr b1 res_ty + ; b2' <- tcLExpr b2 res_ty + ; return (HsIf x NoSyntaxExprTc pred' b1' b2') } + +tcExpr (HsIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty + = do { ((pred', b1', b2'), fun') + <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $ + \ [pred_ty, b1_ty, b2_ty] -> + do { pred' <- tcCheckExpr pred pred_ty + ; b1' <- tcCheckExpr b1 b1_ty + ; b2' <- tcCheckExpr b2 b2_ty + ; return (pred', b1', b2') } + ; return (HsIf x fun' pred' b1' b2') } + +tcExpr (HsMultiIf _ alts) res_ty + = do { res_ty <- if isSingleton alts + then return res_ty + else tauifyExpType res_ty + -- Just like GHC.Tc.Gen.Match + -- Note [Case branches must never infer a non-tau type] + + ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts + ; res_ty <- readExpType res_ty + ; return (HsMultiIf res_ty alts') } + where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } + +tcExpr (HsDo _ do_or_lc stmts) res_ty + = do { expr' <- tcDoStmts do_or_lc stmts res_ty + ; return expr' } + +tcExpr (HsProc x pat cmd) res_ty + = do { (pat', cmd', coi) <- tcProc pat cmd res_ty + ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } + +-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. +-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. +-- To type check +-- (static e) :: p a +-- we want to check (e :: a), +-- and wrap (static e) in a call to +-- fromStaticPtr :: IsStatic p => StaticPtr a -> p a + +tcExpr (HsStatic fvs expr) res_ty + = do { res_ty <- expTypeToType res_ty + ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty + ; (expr', lie) <- captureConstraints $ + addErrCtxt (hang (text "In the body of a static form:") + 2 (ppr expr) + ) $ + tcCheckExprNC expr expr_ty + + -- Check that the free variables of the static form are closed. + -- It's OK to use nonDetEltsUniqSet here as the only side effects of + -- checkClosedInStaticForm are error messages. + ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs + + -- Require the type of the argument to be Typeable. + -- The evidence is not used, but asking the constraint ensures that + -- the current implementation is as restrictive as future versions + -- of the StaticPointers extension. + ; typeableClass <- tcLookupClass typeableClassName + ; _ <- emitWantedEvVar StaticOrigin $ + mkTyConApp (classTyCon typeableClass) + [liftedTypeKind, expr_ty] + + -- Insert the constraints of the static form in a global list for later + -- validation. + ; emitStaticConstraints lie + + -- Wrap the static form with the 'fromStaticPtr' call. + ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName + [p_ty] + ; let wrap = mkWpTyApps [expr_ty] + ; loc <- getSrcSpanM + ; return $ mkHsWrapCo co $ HsApp noExtField + (L loc $ mkHsWrap wrap fromStaticPtr) + (L loc (HsStatic fvs expr')) + } + +{- +************************************************************************ +* * + Record construction and update +* * +************************************************************************ +-} + +tcExpr expr@(RecordCon { rcon_con_name = L loc con_name + , rcon_flds = rbinds }) res_ty + = do { con_like <- tcLookupConLike con_name + + -- Check for missing fields + ; checkMissingFields con_like rbinds + + ; (con_expr, con_sigma) <- tcInferId con_name + ; (con_wrap, con_tau) <- + topInstantiate (OccurrenceOf con_name) con_sigma + -- a shallow instantiation should really be enough for + -- a data constructor. + ; let arity = conLikeArity con_like + Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau + ; case conLikeWrapId_maybe con_like of + Nothing -> nonBidirectionalErr (conLikeName con_like) + Just con_id -> do { + res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon") + (Just expr) actual_res_ty res_ty + ; rbinds' <- tcRecordBinds con_like arg_tys rbinds + ; return $ + mkHsWrap res_wrap $ + RecordCon { rcon_ext = RecordConTc + { rcon_con_like = con_like + , rcon_con_expr = mkHsWrap con_wrap con_expr } + , rcon_con_name = L loc con_id + , rcon_flds = rbinds' } } } + +{- +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" + +-} + +tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty + = ASSERT( notNull rbnds ) + do { -- STEP -2: typecheck the record_expr, the record to be updated + (record_expr', record_rho) <- tcInferRho record_expr + + -- STEP -1 See Note [Disambiguating record fields] + -- After this we know that rbinds is unambiguous + ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty + ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds + upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds + sel_ids = map selectorAmbiguousFieldOcc upd_flds + -- 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 Selectors] + ; 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 + + mtycon :: Maybe TyCon + mtycon = case idDetails sel_id of + RecSelId (RecSelData tycon) _ -> Just tycon + _ -> Nothing + + 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 + ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes) + + -- Take apart a representative constructor + ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons + (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _) + = conLikeFullSig con1 + con1_flds = map flLabel $ conLikeFieldLabels con1 + con1_tv_tys = mkTyVarTys con1_tvs + con1_res_ty = case mtycon of + Just tc -> mkFamilyTyConApp tc con1_tv_tys + Nothing -> conLikeResTy con1 con1_tv_tys + + -- Check that we're not dealing with a unidirectional pattern + -- synonym + ; unless (isJust $ conLikeWrapId_maybe con1) + (nonBidirectionalErr (conLikeName con1)) + + -- STEP 3 Note [Criteria for update] + -- Check that each updated field is polymorphic; that is, its type + -- mentions only the universally-quantified variables of the data con + ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys + bad_upd_flds = filter bad_fld flds1_w_tys + con1_tv_set = mkVarSet con1_tvs + bad_fld (fld, ty) = fld `elem` upd_fld_occs && + not (tyCoVarsOfType ty `subVarSet` con1_tv_set) + ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds) + + -- STEP 4 Note [Type of a record update] + -- Figure out types for the scrutinee and result + -- Both are of form (T a b c), with fresh type variables, but with + -- common variables where the scrutinee and result must have the same type + -- These are variables that appear in *any* arg of *any* of the + -- relevant constructors *except* in the updated fields + -- + ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons + is_fixed_tv tv = tv `elemVarSet` fixed_tvs + + mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType) + -- Deals with instantiation of kind variables + -- c.f. GHC.Tc.Utils.TcMType.newMetaTyVars + mk_inst_ty subst (tv, result_inst_ty) + | is_fixed_tv tv -- Same as result type + = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) + | otherwise -- Fresh type, of correct kind + = do { (subst', new_tv) <- newMetaTyVarX subst tv + ; return (subst', mkTyVarTy new_tv) } + + ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs + ; let result_inst_tys = mkTyVarTys con1_tvs' + init_subst = mkEmptyTCvSubst (getTCvInScope result_subst) + + ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst + (con1_tvs `zip` result_inst_tys) + + ; let rec_res_ty = TcType.substTy result_subst con1_res_ty + scrut_ty = TcType.substTy scrut_subst con1_res_ty + con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys + + ; wrap_res <- tcSubTypeHR (exprCtOrigin expr) + (Just expr) rec_res_ty res_ty + ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty + -- NB: normal unification is OK here (as opposed to subsumption), + -- because for this to work out, both record_rho and scrut_ty have + -- to be normal datatypes -- no contravariant stuff can go on + + -- STEP 5 + -- Typecheck the bindings + ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds + + -- STEP 6: Deal with the stupid theta + ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1) + ; instStupidTheta RecordUpdOrigin theta' + + -- Step 7: make a cast for the scrutinee, in the + -- case that it's from a data family + ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty + fam_co | Just tycon <- mtycon + , Just co_con <- tyConFamilyCoercion_maybe tycon + = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys []) + | otherwise + = idHsWrapper + + -- Step 8: Check that the req constraints are satisfied + -- For normal data constructors req_theta is empty but we must do + -- this check for pattern synonyms. + ; let req_theta' = substThetaUnchecked scrut_subst req_theta + ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta' + + -- Phew! + ; return $ + mkHsWrap wrap_res $ + RecordUpd { rupd_expr + = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr') + , rupd_flds = rbinds' + , rupd_ext = RecordUpdTc + { rupd_cons = relevant_cons + , rupd_in_tys = scrut_inst_tys + , rupd_out_tys = result_inst_tys + , rupd_wrap = req_wrap }} } + +tcExpr e@(HsRecFld _ f) res_ty + = tcCheckRecSelId e f res_ty + +{- +************************************************************************ +* * + Arithmetic sequences e.g. [a,b..] + and their parallel-array counterparts e.g. [: a,b.. :] + +* * +************************************************************************ +-} + +tcExpr (ArithSeq _ witness seq) res_ty + = tcArithSeq witness seq res_ty + +{- +************************************************************************ +* * + Template Haskell +* * +************************************************************************ +-} + +-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceExpr'. +-- Here we get rid of it and add the finalizers to the global environment. +-- +-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. +tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr))) + res_ty + = do addModFinalizersWithLclEnv mod_finalizers + tcExpr expr res_ty +tcExpr (HsSpliceE _ splice) res_ty + = tcSpliceExpr splice res_ty +tcExpr e@(HsBracket _ brack) res_ty + = tcTypedBracket e brack res_ty +tcExpr e@(HsRnBracketOut _ brack ps) res_ty + = tcUntypedBracket e brack ps res_ty + +{- +************************************************************************ +* * + Catch-all +* * +************************************************************************ +-} + +tcExpr other _ = pprPanic "tcLExpr" (ppr other) + -- Include ArrForm, ArrApp, which shouldn't appear at all + -- Also HsTcBracketOut, HsQuasiQuoteE + + +{- ********************************************************************* +* * + Pragmas on expressions +* * +********************************************************************* -} + +tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc +tcExprPrag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann +tcExprPrag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl +tcExprPrag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo + + +{- ********************************************************************* +* * + Expression with type signature e::ty +* * +********************************************************************* -} + +tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn) + -> TcM (HsExpr GhcTc, TcSigmaType) +tcExprWithSig expr hs_ty + = do { sig_info <- checkNoErrs $ -- Avoid error cascade + tcUserTypeSig loc hs_ty Nothing + ; (expr', poly_ty) <- tcExprSig expr sig_info + ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) } + where + loc = getLoc (hsSigWcType hs_ty) + +{- +************************************************************************ +* * + Arithmetic sequences [a..b] etc +* * +************************************************************************ +-} + +tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType + -> TcM (HsExpr GhcTc) + +tcArithSeq witness seq@(From expr) res_ty + = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr' <- tcCheckExpr expr elt_ty + ; enum_from <- newMethodFromName (ArithSeqOrigin seq) + enumFromName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq enum_from wit' (From expr') } + +tcArithSeq witness seq@(FromThen expr1 expr2) res_ty + = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcCheckExpr expr1 elt_ty + ; expr2' <- tcCheckExpr expr2 elt_ty + ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq enum_from_then wit' (FromThen expr1' expr2') } + +tcArithSeq witness seq@(FromTo expr1 expr2) res_ty + = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcCheckExpr expr1 elt_ty + ; expr2' <- tcCheckExpr expr2 elt_ty + ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) + enumFromToName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq enum_from_to wit' (FromTo expr1' expr2') } + +tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty + = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcCheckExpr expr1 elt_ty + ; expr2' <- tcCheckExpr expr2 elt_ty + ; expr3' <- tcCheckExpr expr3 elt_ty + ; eft <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenToName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } + +----------------- +arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType + -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr GhcTc)) +arithSeqEltType Nothing res_ty + = do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedListTy res_ty + ; return (mkWpCastN coi, elt_ty, Nothing) } +arithSeqEltType (Just fl) res_ty + = do { (elt_ty, fl') + <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ + \ [elt_ty] -> return elt_ty + ; return (idHsWrapper, elt_ty, Just fl') } + +{- +************************************************************************ +* * + Applications +* * +************************************************************************ +-} + +{- Note [Typechecking applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We typecheck application chains (f e1 @ty e2) specially: + +* So we can report errors like "in the third arument of a call of f" + +* So we can do Visible Type Application (VTA), for which we must not + eagerly instantiate the function part of the application. + +* So that we can do Quick Look impredicativity. + +The idea is: + +* Use collectHsArgs, which peels off + HsApp, HsTypeApp, HsPrag, HsPar + returning the function in the corner and the arguments + +* Use tcInferAppHead to infer the type of the fuction, + as an (uninstantiated) TcSigmaType + There are special cases for + HsVar, HsREcFld, and ExprWithTySig + Otherwise, delegate back to tcExpr, which + infers an (instantiated) TcRhoType + +Some cases that /won't/ work: + +1. Consider this (which uses visible type application): + + (let { f :: forall a. a -> a; f x = x } in f) @Int + + Since 'let' is not among the special cases for tcInferAppHead, + we'll delegate back to tcExpr, which will instantiate f's type + and the type application to @Int will fail. Too bad! + +-} + +-- HsExprArg is a very local type, used only within this module. +-- It's really a zipper for an application chain +-- It's a GHC-specific type, so using TTG only where necessary +data HsExprArg id + = HsEValArg SrcSpan -- Of the function + (LHsExpr (GhcPass id)) + | HsETypeArg SrcSpan -- Of the function + (LHsWcType (NoGhcTc (GhcPass id))) + !(XExprTypeArg id) + | HsEPrag SrcSpan + (HsPragE (GhcPass id)) + | HsEPar SrcSpan -- Of the nested expr + | HsEWrap !(XArgWrap id) -- Wrapper, after typechecking only + +-- The outer location is the location of the application itself +type LHsExprArgIn = HsExprArg 'Renamed +type LHsExprArgOut = HsExprArg 'Typechecked + +instance OutputableBndrId id => Outputable (HsExprArg id) where + ppr (HsEValArg _ tm) = ppr tm + ppr (HsEPrag _ p) = text "HsPrag" <+> ppr p + ppr (HsETypeArg _ hs_ty _) = char '@' <> ppr hs_ty + ppr (HsEPar _) = text "HsEPar" + ppr (HsEWrap w) = case ghcPass @id of + GhcTc -> text "HsEWrap" <+> ppr w + _ -> empty + +type family XExprTypeArg id where + XExprTypeArg 'Parsed = NoExtField + XExprTypeArg 'Renamed = NoExtField + XExprTypeArg 'Typechecked = Type + +type family XArgWrap id where + XArgWrap 'Parsed = NoExtCon + XArgWrap 'Renamed = NoExtCon + XArgWrap 'Typechecked = HsWrapper + +addArgWrap :: HsWrapper -> [LHsExprArgOut] -> [LHsExprArgOut] +addArgWrap wrap args + | isIdHsWrapper wrap = args + | otherwise = HsEWrap wrap : args + +collectHsArgs :: HsExpr GhcRn -> (HsExpr GhcRn, [LHsExprArgIn]) +collectHsArgs e = go e [] + where + go (HsPar _ (L l fun)) args = go fun (HsEPar l : args) + go (HsPragE _ p (L l fun)) args = go fun (HsEPrag l p : args) + go (HsApp _ (L l fun) arg) args = go fun (HsEValArg l arg : args) + go (HsAppType _ (L l fun) hs_ty) args = go fun (HsETypeArg l hs_ty noExtField : args) + go e args = (e,args) + +applyHsArgs :: HsExpr GhcTc -> [LHsExprArgOut]-> HsExpr GhcTc +applyHsArgs fun args + = go fun args + where + go fun [] = fun + go fun (HsEWrap wrap : args) = go (mkHsWrap wrap fun) args + go fun (HsEValArg l arg : args) = go (HsApp noExtField (L l fun) arg) args + go fun (HsETypeArg l hs_ty ty : args) = go (HsAppType ty (L l fun) hs_ty) args + go fun (HsEPar l : args) = go (HsPar noExtField (L l fun)) args + go fun (HsEPrag l p : args) = go (HsPragE noExtField p (L l fun)) args + +isHsValArg :: HsExprArg id -> Bool +isHsValArg (HsEValArg {}) = True +isHsValArg _ = False + +isArgPar :: HsExprArg id -> Bool +isArgPar (HsEPar {}) = True +isArgPar _ = False + +getFunLoc :: [HsExprArg 'Renamed] -> Maybe SrcSpan +getFunLoc [] = Nothing +getFunLoc (a:_) = Just $ case a of + HsEValArg l _ -> l + HsETypeArg l _ _ -> l + HsEPrag l _ -> l + HsEPar l -> l + +--------------------------- +tcApp :: HsExpr GhcRn -- either HsApp or HsAppType + -> ExpRhoType -> TcM (HsExpr GhcTc) +-- See Note [Typechecking applications] +tcApp expr res_ty + = do { (fun, args, app_res_ty) <- tcInferApp expr + ; if isTagToEnum fun + then tcTagToEnum expr fun args app_res_ty res_ty + else -- The wildly common case + do { let expr' = applyHsArgs fun args + ; addFunResCtxt True fun app_res_ty res_ty $ + tcWrapResult expr expr' app_res_ty res_ty } } + +--------------------------- +tcInferApp :: HsExpr GhcRn + -> TcM ( HsExpr GhcTc -- Function + , [LHsExprArgOut] -- Arguments + , TcSigmaType) -- Inferred type: a sigma-type! +-- Also used by Module.tcRnExpr to implement GHCi :type +tcInferApp expr + | -- Gruesome special case for ambiguous record selectors + HsRecFld _ fld_lbl <- fun + , Ambiguous _ lbl <- fld_lbl -- Still ambiguous + , HsEValArg _ (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first + , Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates + = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty + ; sel_name <- disambiguateSelector lbl sig_tc_ty + ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl) + ; tcInferApp_finish fun tc_fun fun_ty args } + + | otherwise -- The wildly common case + = do { (tc_fun, fun_ty) <- set_fun_loc (tcInferAppHead fun) + ; tcInferApp_finish fun tc_fun fun_ty args } + where + (fun, args) = collectHsArgs expr + set_fun_loc thing_inside + = case getFunLoc args of + Nothing -> thing_inside -- Don't set the location twice + Just loc -> setSrcSpan loc thing_inside + +--------------------- +tcInferApp_finish + :: HsExpr GhcRn -- Renamed function + -> HsExpr GhcTc -> TcSigmaType -- Function and its type + -> [LHsExprArgIn] -- Arguments + -> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType) + +tcInferApp_finish rn_fun tc_fun fun_sigma rn_args + = do { traceTc "tcInferApp_finish" $ + vcat [ ppr rn_fun <+> dcolon <+> ppr fun_sigma, ppr rn_args ] + + ; (tc_args, actual_res_ty) <- tcArgs rn_fun fun_sigma rn_args + + ; return (tc_fun, tc_args, actual_res_ty) } + +mk_op_msg :: LHsExpr GhcRn -> SDoc +mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" + +---------------- +tcInferAppHead :: HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) +-- Infer type of the head of an application, returning a /SigmaType/ +-- i.e. the 'f' in (f e1 ... en) +-- We get back a SigmaType because we have special cases for +-- * A bare identifier (just look it up) +-- This case also covers a record selectro HsRecFld +-- * An expression with a type signature (e :: ty) +-- +-- Note that [] and (,,) are both HsVar: +-- see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr +-- +-- NB: 'e' cannot be HsApp, HsTyApp, HsPrag, HsPar, because those +-- cases are dealt with by collectHsArgs. +-- +-- See Note [Typechecking applications] +tcInferAppHead e + = case e of + HsVar _ (L _ nm) -> tcInferId nm + HsRecFld _ f -> tcInferRecSelId f + ExprWithTySig _ e hs_ty -> add_ctxt $ tcExprWithSig e hs_ty + _ -> add_ctxt $ tcInfer (tcExpr e) + where + add_ctxt thing = addErrCtxt (exprCtxt e) thing + +---------------- +-- | Type-check the arguments to a function, possibly including visible type +-- applications +tcArgs :: HsExpr GhcRn -- ^ The function itself (for err msgs only) + -> TcSigmaType -- ^ the (uninstantiated) type of the function + -> [LHsExprArgIn] -- ^ the args + -> TcM ([LHsExprArgOut], TcSigmaType) + -- ^ (a wrapper for the function, the tc'd args, result type) +tcArgs fun orig_fun_ty orig_args + = go 1 [] orig_fun_ty orig_args + where + fun_orig = exprCtOrigin fun + herald = sep [ text "The function" <+> quotes (ppr fun) + , text "is applied to"] + + -- Count value args only when complaining about a function + -- applied to too many value args + -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify. + n_val_args = count isHsValArg orig_args + + fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] + = case fun of + HsUnboundVar {} -> True + _ -> False + + go :: Int -- Which argment number this is (incl type args) + -> [TcSigmaType] -- Value args to which applied so far + -> TcSigmaType + -> [LHsExprArgIn] -> TcM ([LHsExprArgOut], TcSigmaType) + go _ _ fun_ty [] = traceTc "tcArgs:ret" (ppr fun_ty) >> return ([], fun_ty) + + go n so_far fun_ty (HsEPar sp : args) + = do { (args', res_ty) <- go n so_far fun_ty args + ; return (HsEPar sp : args', res_ty) } + + go n so_far fun_ty (HsEPrag sp prag : args) + = do { (args', res_ty) <- go n so_far fun_ty args + ; return (HsEPrag sp (tcExprPrag prag) : args', res_ty) } + + go n so_far fun_ty (HsETypeArg loc hs_ty_arg _ : args) + | fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] + = go (n+1) so_far fun_ty args + + | otherwise + = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty + -- wrap1 :: fun_ty "->" upsilon_ty + ; case tcSplitForAllTy_maybe upsilon_ty of + Just (tvb, inner_ty) + | binderArgFlag tvb == Specified -> + -- It really can't be Inferred, because we've justn + -- instantiated those. But, oddly, it might just be Required. + -- See Note [Required quantifiers in the type of a term] + do { let tv = binderVar tvb + kind = tyVarKind tv + ; ty_arg <- tcHsTypeApp hs_ty_arg kind + + ; inner_ty <- zonkTcType inner_ty + -- See Note [Visible type application zonk] + ; let in_scope = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg]) + insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty + -- NB: tv and ty_arg have the same kind, so this + -- substitution is kind-respecting + ; traceTc "VTA" (vcat [ppr tv, debugPprType kind + , debugPprType ty_arg + , debugPprType (tcTypeKind ty_arg) + , debugPprType inner_ty + , debugPprType insted_ty ]) + + ; (args', res_ty) <- go (n+1) so_far insted_ty args + ; return ( addArgWrap wrap1 $ HsETypeArg loc hs_ty_arg ty_arg : args' + , res_ty ) } + _ -> ty_app_err upsilon_ty hs_ty_arg } + + go n so_far fun_ty (HsEValArg loc arg : args) + = do { (wrap, [arg_ty], res_ty) + <- matchActualFunTysPart herald fun_orig (Just fun) + n_val_args so_far 1 fun_ty + ; arg' <- tcArg fun arg arg_ty n + ; (args', inner_res_ty) <- go (n+1) (arg_ty:so_far) res_ty args + ; return ( addArgWrap wrap $ HsEValArg loc arg' : args' + , inner_res_ty ) } + + ty_app_err ty arg + = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty + ; failWith $ + text "Cannot apply expression of type" <+> quotes (ppr ty) $$ + text "to a visible type argument" <+> quotes (ppr arg) } + +{- Note [Required quantifiers in the type of a term] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#15859) + + data A k :: k -> Type -- A :: forall k -> k -> Type + type KindOf (a :: k) = k -- KindOf :: forall k. k -> Type + a = (undefind :: KindOf A) @Int + +With ImpredicativeTypes (thin ice, I know), we instantiate +KindOf at type (forall k -> k -> Type), so + KindOf A = forall k -> k -> Type +whose first argument is Required + +We want to reject this type application to Int, but in earlier +GHCs we had an ASSERT that Required could not occur here. + +The ice is thin; c.f. Note [No Required TyCoBinder in terms] +in GHC.Core.TyCo.Rep. + +Note [VTA for out-of-scope functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose 'wurble' is not in scope, and we have + (wurble @Int @Bool True 'x') + +Then the renamer will make (HsUnboundVar "wurble) for 'wurble', +and the typechecker will typecheck it with tcUnboundId, giving it +a type 'alpha', and emitting a deferred CHoleCan constraint, to +be reported later. + +But then comes the visible type application. If we do nothing, we'll +generate an immediate failure (in tc_app_err), saying that a function +of type 'alpha' can't be applied to Bool. That's insane! And indeed +users complain bitterly (#13834, #17150.) + +The right error is the CHoleCan, which has /already/ been emitted by +tcUnboundId. It later reports 'wurble' as out of scope, and tries to +give its type. + +Fortunately in tcArgs we still have access to the function, so we can +check if it is a HsUnboundVar. We use this info to simply skip over +any visible type arguments. We've already inferred the type of the +function, so we'll /already/ have emitted a CHoleCan constraint; +failing preserves that constraint. + +We do /not/ want to fail altogether in this case (via failM) becuase +that may abandon an entire instance decl, which (in the presence of +-fdefer-type-errors) leads to leading to #17792. + +Downside; the typechecked term has lost its visible type arguments; we +don't even kind-check them. But let's jump that bridge if we come to +it. Meanwhile, let's not crash! + +Note [Visible type application zonk] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg). + +* tcHsTypeApp only guarantees that + - ty_arg is zonked + - kind(zonk(tv)) = kind(ty_arg) + (checkExpectedKind zonks as it goes). + +So we must zonk inner_ty as well, to guarantee consistency between zonk(tv) +and inner_ty. Otherwise we can build an ill-kinded type. An example was +#14158, where we had: + id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a +and we had the visible type application + id @(->) + +* We instantiated k := kappa, yielding + forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a +* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *). +* That instantiated (->) as ((->) q1 q1), and unified kappa := q1, + Here q1 :: RuntimeRep +* Now we substitute + cat :-> (->) q1 q1 :: TYPE q1 -> TYPE q1 -> * + but we must first zonk the inner_ty to get + forall (a :: TYPE q1). cat a a + so that the result of substitution is well-kinded + Failing to do so led to #14158. +-} + +---------------- +tcArg :: HsExpr GhcRn -- The function (for error messages) + -> LHsExpr GhcRn -- Actual arguments + -> TcSigmaType -- expected arg type + -> Int -- # of argument + -> TcM (LHsExpr GhcTc) -- Resulting argument +tcArg fun arg ty arg_no + = addErrCtxt (funAppCtxt fun arg arg_no) $ + do { traceTc "tcArg {" $ + vcat [ text "arg #" <> ppr arg_no <+> dcolon <+> ppr ty + , text "arg:" <+> ppr arg ] + ; arg' <- tcCheckExprNC arg ty + ; traceTc "tcArg }" empty + ; return arg' } + +---------------- +tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc] +tcTupArgs args tys + = ASSERT( equalLength args tys ) mapM go (args `zip` tys) + where + go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty)) + go (L l (Present x expr), arg_ty) = do { expr' <- tcCheckExpr expr arg_ty + ; return (L l (Present x expr')) } + +--------------------------- +-- See TcType.SyntaxOpType also for commentary +tcSyntaxOp :: CtOrigin + -> SyntaxExprRn + -> [SyntaxOpType] -- ^ shape of syntax operator arguments + -> ExpRhoType -- ^ overall result type + -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments + -> TcM (a, SyntaxExprTc) +-- ^ Typecheck a syntax operator +-- The operator is a variable or a lambda at this stage (i.e. renamer +-- output) +tcSyntaxOp orig expr arg_tys res_ty + = tcSyntaxOpGen orig expr arg_tys (SynType res_ty) + +-- | Slightly more general version of 'tcSyntaxOp' that allows the caller +-- to specify the shape of the result of the syntax operator +tcSyntaxOpGen :: CtOrigin + -> SyntaxExprRn + -> [SyntaxOpType] + -> SyntaxOpType + -> ([TcSigmaType] -> TcM a) + -> TcM (a, SyntaxExprTc) +tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside + = do { (expr, sigma) <- tcInferAppHead op + ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma) + ; (result, expr_wrap, arg_wraps, res_wrap) + <- tcSynArgA orig sigma arg_tys res_ty $ + thing_inside + ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma ) + ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) } +tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen" + +{- +Note [tcSynArg] +~~~~~~~~~~~~~~~ +Because of the rich structure of SyntaxOpType, we must do the +contra-/covariant thing when working down arrows, to get the +instantiation vs. skolemisation decisions correct (and, more +obviously, the orientation of the HsWrappers). We thus have +two tcSynArgs. +-} + +-- works on "expected" types, skolemising where necessary +-- See Note [tcSynArg] +tcSynArgE :: CtOrigin + -> TcSigmaType + -> SyntaxOpType -- ^ shape it is expected to have + -> ([TcSigmaType] -> TcM a) -- ^ check the arguments + -> TcM (a, HsWrapper) + -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) +tcSynArgE orig sigma_ty syn_ty thing_inside + = do { (skol_wrap, (result, ty_wrapper)) + <- tcSkolemise GenSigCtxt sigma_ty $ \ _ rho_ty -> + go rho_ty syn_ty + ; return (result, skol_wrap <.> ty_wrapper) } + where + go rho_ty SynAny + = do { result <- thing_inside [rho_ty] + ; return (result, idHsWrapper) } + + go rho_ty SynRho -- same as SynAny, because we skolemise eagerly + = do { result <- thing_inside [rho_ty] + ; return (result, idHsWrapper) } + + go rho_ty SynList + = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty + ; result <- thing_inside [elt_ty] + ; return (result, mkWpCastN list_co) } + + go rho_ty (SynFun arg_shape res_shape) + = do { ( ( ( (result, arg_ty, res_ty) + , res_wrapper ) -- :: res_ty_out "->" res_ty + , arg_wrapper1, [], arg_wrapper2 ) -- :: arg_ty "->" arg_ty_out + , match_wrapper ) -- :: (arg_ty -> res_ty) "->" rho_ty + <- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $ + \ [arg_ty] res_ty -> + do { arg_tc_ty <- expTypeToType arg_ty + ; res_tc_ty <- expTypeToType res_ty + + -- another nested arrow is too much for now, + -- but I bet we'll never need this + ; MASSERT2( case arg_shape of + SynFun {} -> False; + _ -> True + , text "Too many nested arrows in SyntaxOpType" $$ + pprCtOrigin orig ) + + ; tcSynArgA orig arg_tc_ty [] arg_shape $ + \ arg_results -> + tcSynArgE orig res_tc_ty res_shape $ + \ res_results -> + do { result <- thing_inside (arg_results ++ res_results) + ; return (result, arg_tc_ty, res_tc_ty) }} + + ; return ( result + , match_wrapper <.> + mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper + arg_ty res_ty doc ) } + where + herald = text "This rebindable syntax expects a function with" + doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig + + go rho_ty (SynType the_ty) + = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty + ; result <- thing_inside [] + ; return (result, wrap) } + +-- works on "actual" types, instantiating where necessary +-- See Note [tcSynArg] +tcSynArgA :: CtOrigin + -> TcSigmaType + -> [SyntaxOpType] -- ^ argument shapes + -> SyntaxOpType -- ^ result shape + -> ([TcSigmaType] -> TcM a) -- ^ check the arguments + -> TcM (a, HsWrapper, [HsWrapper], HsWrapper) + -- ^ returns a wrapper to be applied to the original function, + -- wrappers to be applied to arguments + -- and a wrapper to be applied to the overall expression +tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside + = do { (match_wrapper, arg_tys, res_ty) + <- matchActualFunTys herald orig Nothing (length arg_shapes) sigma_ty + -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) + ; ((result, res_wrapper), arg_wrappers) + <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results -> + tc_syn_arg res_ty res_shape $ \ res_results -> + thing_inside (arg_results ++ res_results) + ; return (result, match_wrapper, arg_wrappers, res_wrapper) } + where + herald = text "This rebindable syntax expects a function with" + + tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType] + -> ([TcSigmaType] -> TcM a) + -> TcM (a, [HsWrapper]) + -- the wrappers are for arguments + tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside + = do { ((result, arg_wraps), arg_wrap) + <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results -> + tc_syn_args_e arg_tys arg_shapes $ \ args_results -> + thing_inside (arg1_results ++ args_results) + ; return (result, arg_wrap : arg_wraps) } + tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] + + tc_syn_arg :: TcSigmaType -> SyntaxOpType + -> ([TcSigmaType] -> TcM a) + -> TcM (a, HsWrapper) + -- the wrapper applies to the overall result + tc_syn_arg res_ty SynAny thing_inside + = do { result <- thing_inside [res_ty] + ; return (result, idHsWrapper) } + tc_syn_arg res_ty SynRho thing_inside + = do { (inst_wrap, rho_ty) <- deeplyInstantiate orig res_ty + -- inst_wrap :: res_ty "->" rho_ty + ; result <- thing_inside [rho_ty] + ; return (result, inst_wrap) } + tc_syn_arg res_ty SynList thing_inside + = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty + -- inst_wrap :: res_ty "->" rho_ty + ; (list_co, elt_ty) <- matchExpectedListTy rho_ty + -- list_co :: [elt_ty] ~N rho_ty + ; result <- thing_inside [elt_ty] + ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) } + tc_syn_arg _ (SynFun {}) _ + = pprPanic "tcSynArgA hits a SynFun" (ppr orig) + tc_syn_arg res_ty (SynType the_ty) thing_inside + = do { wrap <- tcSubTypeO orig GenSigCtxt res_ty the_ty + ; result <- thing_inside [] + ; return (result, wrap) } + +{- +Note [Push result type in] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unify with expected result before type-checking the args so that the +info from res_ty percolates to args. This is when we might detect a +too-few args situation. (One can think of cases when the opposite +order would give a better error message.) +experimenting with putting this first. + +Here's an example where it actually makes a real difference + + class C t a b | t a -> b + instance C Char a Bool + + data P t a = forall b. (C t a b) => MkP b + data Q t = MkQ (forall a. P t a) + + f1, f2 :: Q Char; + f1 = MkQ (MkP True) + f2 = MkQ (MkP True :: forall a. P Char a) + +With the change, f1 will type-check, because the 'Char' info from +the signature is propagated into MkQ's argument. With the check +in the other order, the extra signature in f2 is reqd. + +************************************************************************ +* * + Expressions with a type signature + expr :: type +* * +********************************************************************* -} + +tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType) +tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) + = setSrcSpan loc $ -- Sets the location for the implication constraint + do { (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id + ; given <- newEvVars theta + ; traceTc "tcExprSig: CompleteSig" $ + vcat [ text "poly_id:" <+> ppr poly_id <+> dcolon <+> ppr (idType poly_id) + , text "tv_prs:" <+> ppr tv_prs ] + + ; let skol_info = SigSkol ExprSigCtxt (idType poly_id) tv_prs + skol_tvs = map snd tv_prs + ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $ + tcExtendNameTyVarEnv tv_prs $ + tcCheckExprNC expr tau + + ; let poly_wrap = mkWpTyLams skol_tvs + <.> mkWpLams given + <.> mkWpLet ev_binds + ; return (mkLHsWrap poly_wrap expr', idType poly_id) } + +tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) + = setSrcSpan loc $ -- Sets the location for the implication constraint + do { (tclvl, wanted, (expr', sig_inst)) + <- pushLevelAndCaptureConstraints $ + do { sig_inst <- tcInstSig sig + ; expr' <- tcExtendNameTyVarEnv (sig_inst_skols sig_inst) $ + tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $ + tcCheckExprNC expr (sig_inst_tau sig_inst) + ; return (expr', sig_inst) } + -- See Note [Partial expression signatures] + ; let tau = sig_inst_tau sig_inst + infer_mode | null (sig_inst_theta sig_inst) + , isNothing (sig_inst_wcx sig_inst) + = ApplyMR + | otherwise + = NoRestrictions + ; (qtvs, givens, ev_binds, residual, _) + <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted + ; emitConstraints residual + + ; tau <- zonkTcType tau + ; let inferred_theta = map evVarPred givens + tau_tvs = tyCoVarsOfType tau + ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta + tau_tvs qtvs (Just sig_inst) + ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau + my_sigma = mkForAllTys binders (mkPhiTy my_theta tau) + ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis. + then return idHsWrapper -- Fast path; also avoids complaint when we infer + -- an ambiguous type and have AllowAmbiguousType + -- e..g infer x :: forall a. F a -> Int + else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma + + ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) + ; let poly_wrap = wrap + <.> mkWpTyLams qtvs + <.> mkWpLams givens + <.> mkWpLet ev_binds + ; return (mkLHsWrap poly_wrap expr', my_sigma) } + + +{- Note [Partial expression signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Partial type signatures on expressions are easy to get wrong. But +here is a guiding principile + e :: ty +should behave like + let x :: ty + x = e + in x + +So for partial signatures we apply the MR if no context is given. So + e :: IO _ apply the MR + e :: _ => IO _ do not apply the MR +just like in GHC.Tc.Gen.Bind.decideGeneralisationPlan + +This makes a difference (#11670): + peek :: Ptr a -> IO CLong + peek ptr = peekElemOff undefined 0 :: _ +from (peekElemOff undefined 0) we get + type: IO w + constraints: Storable w + +We must NOT try to generalise over 'w' because the signature specifies +no constraints so we'll complain about not being able to solve +Storable w. Instead, don't generalise; then _ gets instantiated to +CLong, as it should. +-} + +{- ********************************************************************* +* * + tcInferId +* * +********************************************************************* -} + +tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc) +tcCheckId name res_ty + | name `hasKey` tagToEnumKey + = failWithTc (text "tagToEnum# must appear applied to one argument") + -- tcApp catches the case (tagToEnum# arg) + + | otherwise + = do { (expr, actual_res_ty) <- tcInferId name + ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) + ; addFunResCtxt False expr actual_res_ty res_ty $ + tcWrapResultO (OccurrenceOf name) (HsVar noExtField (noLoc name)) expr + actual_res_ty res_ty } + +tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) +tcCheckRecSelId rn_expr f@(Unambiguous {}) res_ty + = do { (expr, actual_res_ty) <- tcInferRecSelId f + ; tcWrapResult rn_expr expr actual_res_ty res_ty } +tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty + = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of + Nothing -> ambiguousSelector lbl + Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg + ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl) + res_ty } + +------------------------ +tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTc, TcRhoType) +tcInferRecSelId (Unambiguous sel (L _ lbl)) + = do { (expr', ty) <- tc_infer_id lbl sel + ; return (expr', ty) } +tcInferRecSelId (Ambiguous _ lbl) + = ambiguousSelector lbl + +------------------------ +tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType) +-- Look up an occurrence of an Id +-- Do not instantiate its type +tcInferId id_name + | id_name `hasKey` assertIdKey + = do { dflags <- getDynFlags + ; if gopt Opt_IgnoreAsserts dflags + then tc_infer_id (nameRdrName id_name) id_name + else tc_infer_assert id_name } + + | otherwise + = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name + ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty) + ; return (expr, ty) } + +tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType) +-- Deal with an occurrence of 'assert' +-- See Note [Adding the implicit parameter to 'assert'] +tc_infer_assert assert_name + = do { assert_error_id <- tcLookupId assertErrorName + ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) + (idType assert_error_id) + ; return (mkHsWrap wrap (HsVar noExtField (noLoc assert_error_id)), id_rho) + } + +tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTc, TcSigmaType) +tc_infer_id lbl id_name + = do { thing <- tcLookup id_name + ; case thing of + ATcId { tct_id = id } + -> do { check_naughty id -- Note [Local record selectors] + ; checkThLocalId id + ; return_id id } + + AGlobal (AnId id) + -> do { check_naughty id + ; return_id id } + -- A global cannot possibly be ill-staged + -- nor does it need the 'lifting' treatment + -- hence no checkTh stuff here + + AGlobal (AConLike cl) -> case cl of + RealDataCon con -> return_data_con con + PatSynCon ps -> tcPatSynBuilderOcc ps + + _ -> failWithTc $ + ppr thing <+> text "used where a value identifier was expected" } + where + return_id id = return (HsVar noExtField (noLoc id), idType id) + + return_data_con con + -- For data constructors, must perform the stupid-theta check + | null stupid_theta + = return (HsConLikeOut noExtField (RealDataCon con), con_ty) + + | otherwise + -- See Note [Instantiating stupid theta] + = do { let (tvs, theta, rho) = tcSplitSigmaTy con_ty + ; (subst, tvs') <- newMetaTyVars tvs + ; let tys' = mkTyVarTys tvs' + theta' = substTheta subst theta + rho' = substTy subst rho + ; wrap <- instCall (OccurrenceOf id_name) tys' theta' + ; addDataConStupidTheta con tys' + ; return ( mkHsWrap wrap (HsConLikeOut noExtField (RealDataCon con)) + , rho') } + + where + con_ty = dataConUserType con + stupid_theta = dataConStupidTheta con + + check_naughty id + | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) + | otherwise = return () + + +tcUnboundId :: HsExpr GhcRn -> OccName -> ExpRhoType -> TcM (HsExpr GhcTc) +-- Typecheck an occurrence of an unbound Id +-- +-- Some of these started life as a true expression hole "_". +-- Others might simply be variables that accidentally have no binding site +-- +-- We turn all of them into HsVar, since HsUnboundVar can't contain an +-- Id; and indeed the evidence for the CHoleCan does bind it, so it's +-- not unbound any more! +tcUnboundId rn_expr occ res_ty + = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531) + ; name <- newSysName occ + ; let ev = mkLocalId name ty + ; can <- newHoleCt ExprHole ev ty + ; emitInsoluble can + ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr + (HsVar noExtField (noLoc ev)) ty res_ty } + + +{- +Note [Adding the implicit parameter to 'assert'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The typechecker transforms (assert e1 e2) to (assertError e1 e2). +This isn't really the Right Thing because there's no way to "undo" +if you want to see the original source code in the typechecker +output. We'll have fix this in due course, when we care more about +being able to reconstruct the exact original program. + +Note [tagToEnum#] +~~~~~~~~~~~~~~~~~ +Nasty check to ensure that tagToEnum# is applied to a type that is an +enumeration TyCon. Unification may refine the type later, but this +check won't see that, alas. It's crude, because it relies on our +knowing *now* that the type is ok, which in turn relies on the +eager-unification part of the type checker pushing enough information +here. In theory the Right Thing to do is to have a new form of +constraint but I definitely cannot face that! And it works ok as-is. + +Here's are two cases that should fail + f :: forall a. a + f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable + + g :: Int + g = tagToEnum# 0 -- Int is not an enumeration + +When data type families are involved it's a bit more complicated. + data family F a + data instance F [Int] = A | B | C +Then we want to generate something like + tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int] +Usually that coercion is hidden inside the wrappers for +constructors of F [Int] but here we have to do it explicitly. + +It's all grotesquely complicated. + +Note [Instantiating stupid theta] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Normally, when we infer the type of an Id, we don't instantiate, +because we wish to allow for visible type application later on. +But if a datacon has a stupid theta, we're a bit stuck. We need +to emit the stupid theta constraints with instantiated types. It's +difficult to defer this to the lazy instantiation, because a stupid +theta has no spot to put it in a type. So we just instantiate eagerly +in this case. Thus, users cannot use visible type application with +a data constructor sporting a stupid theta. I won't feel so bad for +the users that complain. + +-} + +isTagToEnum :: HsExpr GhcTc -> Bool +isTagToEnum (HsVar _ (L _ fun_id)) = fun_id `hasKey` tagToEnumKey +isTagToEnum _ = False + +tcTagToEnum :: HsExpr GhcRn -> HsExpr GhcTc -> [LHsExprArgOut] + -> TcSigmaType -> ExpRhoType + -> TcM (HsExpr GhcTc) +-- tagToEnum# :: forall a. Int# -> a +-- See Note [tagToEnum#] Urgh! +tcTagToEnum expr fun args app_res_ty res_ty + = do { res_ty <- readExpType res_ty + ; ty' <- zonkTcType res_ty + + -- Check that the type is algebraic + ; case tcSplitTyConApp_maybe ty' of { + Nothing -> do { addErrTc (mk_error ty' doc1) + ; vanilla_result } ; + Just (tc, tc_args) -> + + do { -- Look through any type family + ; fam_envs <- tcGetFamInstEnvs + ; case tcLookupDataFamInst_maybe fam_envs tc tc_args of { + Nothing -> do { check_enumeration ty' tc + ; vanilla_result } ; + Just (rep_tc, rep_args, coi) -> + + do { -- coi :: tc tc_args ~R rep_tc rep_args + check_enumeration ty' rep_tc + ; let val_arg = dropWhile (not . isHsValArg) args + rep_ty = mkTyConApp rep_tc rep_args + fun' = mkHsWrap (WpTyApp rep_ty) fun + expr' = applyHsArgs fun' val_arg + df_wrap = mkWpCastR (mkTcSymCo coi) + ; return (mkHsWrap df_wrap expr') }}}}} + + where + vanilla_result + = do { let expr' = applyHsArgs fun args + ; tcWrapResult expr expr' app_res_ty res_ty } + + check_enumeration ty' tc + | isEnumerationTyCon tc = return () + | otherwise = addErrTc (mk_error ty' doc2) + + doc1 = vcat [ text "Specify the type by giving a type signature" + , text "e.g. (tagToEnum# x) :: Bool" ] + doc2 = text "Result type must be an enumeration type" + + mk_error :: TcType -> SDoc -> SDoc + mk_error ty what + = hang (text "Bad call to tagToEnum#" + <+> text "at type" <+> ppr ty) + 2 what + +{- +************************************************************************ +* * + Template Haskell checks +* * +************************************************************************ +-} + +checkThLocalId :: Id -> TcM () +-- The renamer has already done checkWellStaged, +-- in RnSplice.checkThLocalName, so don't repeat that here. +-- Here we just just add constraints fro cross-stage lifting +checkThLocalId id + = do { mb_local_use <- getStageAndBindLevel (idName id) + ; case mb_local_use of + Just (top_lvl, bind_lvl, use_stage) + | thLevel use_stage > bind_lvl + -> checkCrossStageLifting top_lvl id use_stage + _ -> return () -- Not a locally-bound thing, or + -- no cross-stage link + } + +-------------------------------------- +checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM () +-- If we are inside typed brackets, and (use_lvl > bind_lvl) +-- we must check whether there's a cross-stage lift to do +-- Examples \x -> [|| x ||] +-- [|| map ||] +-- +-- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but +-- this code is applied to *typed* brackets. + +checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) + | isTopLevel top_lvl + = when (isExternalName id_name) (keepAlive id_name) + -- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice + + | otherwise + = -- Nested identifiers, such as 'x' in + -- E.g. \x -> [|| h x ||] + -- We must behave as if the reference to x was + -- h $(lift x) + -- We use 'x' itself as the splice proxy, used by + -- the desugarer to stitch it all back together. + -- If 'x' occurs many times we may get many identical + -- 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) (polySpliceErr 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 + -- solve this, and it's probably unimportant, so I'm + -- just going to flag an error for now + + ; lift <- if isStringTy id_ty then + do { sid <- tcLookupId GHC.Builtin.Names.TH.liftStringName + -- See Note [Lifting strings] + ; return (HsVar noExtField (noLoc sid)) } + else + setConstraintVar lie_var $ + -- Put the 'lift' constraint into the right LIE + newMethodFromName (OccurrenceOf id_name) + GHC.Builtin.Names.TH.liftName + [getRuntimeRep id_ty, id_ty] + + -- Update the pending splices + ; ps <- readMutVar ps_var + ; let pending_splice = PendingTcSplice id_name + (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLoc lift)) + (nlHsVar id)) + ; writeMutVar ps_var (pending_splice : ps) + + ; return () } + where + id_name = idName id + +checkCrossStageLifting _ _ _ = return () + +polySpliceErr :: Id -> SDoc +polySpliceErr id + = text "Can't splice the polymorphic local variable" <+> quotes (ppr id) + +{- +Note [Lifting strings] +~~~~~~~~~~~~~~~~~~~~~~ +If we see $(... [| s |] ...) where s::String, we don't want to +generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. +So this conditional short-circuits the lifting mechanism to generate +(liftString "xy") in that case. I didn't want to use overlapping instances +for the Lift class in TH.Syntax, because that can lead to overlapping-instance +errors in a polymorphic situation. + +If this check fails (which isn't impossible) we get another chance; see +Note [Converting strings] in Convert.hs + +Local record selectors +~~~~~~~~~~~~~~~~~~~~~~ +Record selectors for TyCons in this module are ordinary local bindings, +which show up as ATcIds rather than AGlobals. So we need to check for +naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds. + + +************************************************************************ +* * +\subsection{Record bindings} +* * +************************************************************************ +-} + +getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet +-- These tyvars must not change across the updates +getFixedTyVars upd_fld_occs univ_tvs cons + = mkVarSet [tv1 | con <- cons + , let (u_tvs, _, eqspec, prov_theta + , req_theta, arg_tys, _) + = conLikeFullSig con + theta = eqSpecPreds eqspec + ++ prov_theta + ++ req_theta + flds = conLikeFieldLabels con + fixed_tvs = exactTyCoVarsOfTypes fixed_tys + -- fixed_tys: See Note [Type of a record update] + `unionVarSet` tyCoVarsOfTypes theta + -- Universally-quantified tyvars that + -- appear in any of the *implicit* + -- arguments to the constructor are fixed + -- See Note [Implicit type sharing] + + fixed_tys = [ty | (fl, ty) <- zip flds arg_tys + , not (flLabel fl `elem` upd_fld_occs)] + , (tv1,tv) <- univ_tvs `zip` u_tvs + , tv `elemVarSet` fixed_tvs ] + +{- +Note [Disambiguating record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the -XDuplicateRecordFields extension is used, and the renamer +encounters a record selector or update that it cannot immediately +disambiguate (because it involves fields that belong to multiple +datatypes), it will defer resolution of the ambiguity to the +typechecker. In this case, the `Ambiguous` constructor of +`AmbiguousFieldOcc` is used. + +Consider the following definitions: + + data S = MkS { foo :: Int } + data T = MkT { foo :: Int, bar :: Int } + data U = MkU { bar :: Int, baz :: Int } + +When the renamer sees `foo` as a selector or an update, it will not +know which parent datatype is in use. + +For selectors, there are two possible ways to disambiguate: + +1. Check if the pushed-in type is a function whose domain is a + datatype, for example: + + f s = (foo :: S -> Int) s + + g :: T -> Int + g = foo + + This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`. + +2. Check if the selector is applied to an argument that has a type + signature, for example: + + h = foo (s :: S) + + This is checked by `tcApp`. + + +Updates are slightly more complex. The `disambiguateRecordBinds` +function tries to determine the parent datatype in three ways: + +1. Check for types that have all the fields being updated. For example: + + f x = x { foo = 3, bar = 2 } + + Here `f` must be updating `T` because neither `S` nor `U` have + both fields. This may also discover that no possible type exists. + For example the following will be rejected: + + f' x = x { foo = 3, baz = 3 } + +2. Use the type being pushed in, if it is already a TyConApp. The + following are valid updates to `T`: + + g :: T -> T + g x = x { foo = 3 } + + g' x = x { foo = 3 } :: T + +3. Use the type signature of the record expression, if it exists and + is a TyConApp. Thus this is valid update to `T`: + + h x = (x :: T) { foo = 3 } + + +Note that we do not look up the types of variables being updated, and +no constraint-solving is performed, so for example the following will +be rejected as ambiguous: + + let bad (s :: S) = foo s + + let r :: T + r = blah + in r { foo = 3 } + + \r. (r { foo = 3 }, r :: T ) + +We could add further tests, of a more heuristic nature. For example, +rather than looking for an explicit signature, we could try to infer +the type of the argument to a selector or the record expression being +updated, in case we are lucky enough to get a TyConApp straight +away. However, it might be hard for programmers to predict whether a +particular update is sufficiently obvious for the signature to be +omitted. Moreover, this might change the behaviour of typechecker in +non-obvious ways. + +See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat. +-} + +-- Given a RdrName that refers to multiple record fields, and the type +-- of its argument, try to determine the name of the selector that is +-- meant. +disambiguateSelector :: Located RdrName -> Type -> TcM Name +disambiguateSelector lr@(L _ rdr) parent_type + = do { fam_inst_envs <- tcGetFamInstEnvs + ; case tyConOf fam_inst_envs parent_type of + Nothing -> ambiguousSelector lr + Just p -> + do { xs <- lookupParents rdr + ; let parent = RecSelData p + ; case lookup parent xs of + Just gre -> do { addUsedGRE True gre + ; return (gre_name gre) } + Nothing -> failWithTc (fieldNotInType parent rdr) } } + +-- This field name really is ambiguous, so add a suitable "ambiguous +-- occurrence" error, then give up. +ambiguousSelector :: Located RdrName -> TcM a +ambiguousSelector (L _ rdr) + = do { addAmbiguousNameErr rdr + ; failM } + +-- | This name really is ambiguous, so add a suitable "ambiguous +-- occurrence" error, then continue +addAmbiguousNameErr :: RdrName -> TcM () +addAmbiguousNameErr rdr + = do { env <- getGlobalRdrEnv + ; let gres = lookupGRE_RdrName rdr env + ; setErrCtxt [] $ addNameClashErrRn rdr gres} + +-- Disambiguate the fields in a record update. +-- See Note [Disambiguating record fields] +disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType + -> [LHsRecUpdField GhcRn] -> ExpRhoType + -> TcM [LHsRecField' (AmbiguousFieldOcc 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 } + where + -- Extract the selector name of a field update if it is unambiguous + isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name) + isUnambiguous x = case unLoc (hsRecFieldLbl (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 . 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 (noPossibleParents rbnds) + + -- Exactly one datatype with all the fields: use that + [p] -> return p + + -- 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 -> return (RecSelData p) + + -- 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 + -> return (RecSelData tc) + + -- Nothing else we can try... + _ -> failWithTc badOverloadedUpdate + + -- 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 (LHsRecField' (AmbiguousFieldOcc 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 _ = hsRecFieldLbl (unLoc upd) + setSrcSpan loc $ addUsedGRE True gre + ; lookupSelector (upd, gre_name 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, gre_name (snd (head xs))) } + + -- 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 (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) + lookupSelector (L l upd, n) + = do { i <- tcLookupId n + ; let L loc af = hsRecFieldLbl upd + lbl = rdrNameAmbiguousFieldOcc af + ; return $ L l upd { hsRecFieldLbl + = L loc (Unambiguous i (L loc lbl)) } } + + +-- Extract the outermost TyCon of a type, if there is one; for +-- data families this is the representation tycon (because that's +-- where the fields live). +tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon +tyConOf fam_inst_envs ty0 + = case tcSplitTyConApp_maybe ty of + Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys)) + Nothing -> Nothing + where + (_, _, ty) = tcSplitSigmaTy ty0 + +-- Variant of tyConOf that works for ExpTypes +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 :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)] +lookupParents rdr + = do { env <- getGlobalRdrEnv + ; let gres = lookupGRE_RdrName rdr env + ; mapM lookupParent gres } + where + lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) + lookupParent gre = do { id <- tcLookupId (gre_name gre) + ; if isRecordSelector id + then return (recordSelectorTyCon id, gre) + else failWithTc (notSelector (gre_name gre)) } + +-- A type signature on the argument of an ambiguous record selector or +-- the record expression in an update must be "obvious", i.e. the +-- outermost constructor ignoring parentheses. +obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) +obviousSig (ExprWithTySig _ _ ty) = Just ty +obviousSig (HsPar _ p) = obviousSig (unLoc p) +obviousSig _ = Nothing + + +{- +Game plan for record bindings +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Find the TyCon for the bindings, from the first field label. + +2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. + +For each binding field = value + +3. Instantiate the field type (from the field label) using the type + envt from step 2. + +4 Type check the value using tcArg, passing the field type as + the expected argument type. + +This extends OK when the field types are universally quantified. +-} + +tcRecordBinds + :: ConLike + -> [TcType] -- Expected type for each field + -> HsRecordBinds GhcRn + -> TcM (HsRecordBinds GhcTc) + +tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) + = do { mb_binds <- mapM do_bind rbinds + ; return (HsRecFields (catMaybes mb_binds) dd) } + where + fields = map flSelector $ conLikeFieldLabels con_like + flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys + + do_bind :: LHsRecField GhcRn (LHsExpr GhcRn) + -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc))) + do_bind (L l fld@(HsRecField { hsRecFieldLbl = f + , hsRecFieldArg = rhs })) + + = do { mb <- tcRecordField con_like flds_w_tys f rhs + ; case mb of + Nothing -> return Nothing + Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f' + , hsRecFieldArg = rhs' }))) } + +tcRecordUpd + :: ConLike + -> [TcType] -- Expected type for each field + -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] + -> TcM [LHsRecUpdField GhcTc] + +tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds + where + fields = map flSelector $ conLikeFieldLabels con_like + flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys + + do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) + -> TcM (Maybe (LHsRecUpdField GhcTc)) + do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af + , hsRecFieldArg = rhs })) + = do { let lbl = rdrNameAmbiguousFieldOcc af + sel_id = selectorAmbiguousFieldOcc af + f = L loc (FieldOcc (idName sel_id) (L loc lbl)) + ; mb <- tcRecordField con_like flds_w_tys f rhs + ; case mb of + Nothing -> return Nothing + Just (f', rhs') -> + return (Just + (L l (fld { hsRecFieldLbl + = L loc (Unambiguous + (extFieldOcc (unLoc f')) + (L loc lbl)) + , hsRecFieldArg = rhs' }))) } + +tcRecordField :: ConLike -> Assoc Name Type + -> LFieldOcc GhcRn -> LHsExpr GhcRn + -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) +tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs + | Just field_ty <- assocMaybe flds_w_tys sel_name + = addErrCtxt (fieldCtxt field_lbl) $ + do { rhs' <- tcCheckExprNC rhs field_ty + ; let field_id = mkUserLocal (nameOccName sel_name) + (nameUnique sel_name) + field_ty loc + -- Yuk: the field_id has the *unique* of the selector Id + -- (so we can find it easily) + -- but is a LocalId with the appropriate type of the RHS + -- (so the desugarer knows the type of local binder to make) + ; return (Just (L loc (FieldOcc field_id lbl), rhs')) } + | otherwise + = do { addErrTc (badFieldCon con_like field_lbl) + ; return Nothing } + where + field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) + + +checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM () +checkMissingFields con_like rbinds + | null field_labels -- Not declared as a record; + -- But C{} is still valid if no strict fields + = if any isBanged field_strs then + -- Illegal if any arg is strict + addErrTc (missingStrictFields con_like []) + else do + warn <- woptM Opt_WarnMissingFields + when (warn && notNull field_strs && null field_labels) + (warnTc (Reason Opt_WarnMissingFields) True + (missingFields con_like [])) + + | otherwise = do -- A record + unless (null missing_s_fields) + (addErrTc (missingStrictFields con_like missing_s_fields)) + + warn <- woptM Opt_WarnMissingFields + when (warn && notNull missing_ns_fields) + (warnTc (Reason Opt_WarnMissingFields) True + (missingFields con_like missing_ns_fields)) + + where + missing_s_fields + = [ flLabel fl | (fl, str) <- field_info, + isBanged str, + not (fl `elemField` field_names_used) + ] + missing_ns_fields + = [ flLabel fl | (fl, str) <- field_info, + not (isBanged str), + not (fl `elemField` field_names_used) + ] + + field_names_used = hsRecFields rbinds + field_labels = conLikeFieldLabels con_like + + field_info = zipEqual "missingFields" + field_labels + field_strs + + 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) <+> ptext (sLit "field of a record") + +addExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a +addExprCtxt e thing_inside = addErrCtxt (exprCtxt (unLoc e)) thing_inside + +exprCtxt :: HsExpr GhcRn -> SDoc +exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr)) + +addFunResCtxt :: Bool -- There is at least one argument + -> HsExpr GhcTc -> TcType -> ExpRhoType + -> TcM a -> TcM a +-- When we have a mis-match in the return type of a function +-- try to give a helpful message about too many/few arguments +-- +-- Used for naked variables too; but with has_args = False +addFunResCtxt has_args fun fun_res_ty env_ty + = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg) + -- NB: use a landmark error context, so that an empty context + -- doesn't suppress some more useful context + where + mk_msg + = 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 } + ; let -- See Note [Splitting nested sigma types in mismatched + -- function types] + (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res' + -- No need to call tcSplitNestedSigmaTys here, since env_ty is + -- an ExpRhoTy, i.e., it's already deeply instantiated. + (_, _, env_tau) = tcSplitSigmaTy env' + (args_fun, res_fun) = tcSplitFunTys fun_tau + (args_env, res_env) = tcSplitFunTys env_tau + n_fun = length args_fun + n_env = length args_env + info | n_fun == n_env = Outputable.empty + | n_fun > n_env + , not_fun res_env + = text "Probable cause:" <+> quotes (ppr fun) + <+> text "is applied to too few arguments" + + | has_args + , not_fun res_fun + = text "Possible cause:" <+> quotes (ppr fun) + <+> text "is applied to too many arguments" + + | otherwise + = Outputable.empty -- Never suggest that a naked variable is -- applied to too many args! + ; return info } + where + not_fun ty -- ty is definitely not an arrow type, + -- and cannot conceivably become one + = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> isAlgTyCon tc + Nothing -> False + +{- +Note [Splitting nested sigma types in mismatched function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When one applies a function to too few arguments, GHC tries to determine this +fact if possible so that it may give a helpful error message. It accomplishes +this by checking if the type of the applied function has more argument types +than supplied arguments. + +Previously, GHC computed the number of argument types through tcSplitSigmaTy. +This is incorrect in the face of nested foralls, however! This caused Trac +#13311, for instance: + + f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b + +If one uses `f` like so: + + do { f; putChar 'a' } + +Then tcSplitSigmaTy will decompose the type of `f` into: + + Tyvars: [a] + Context: (Monoid a) + Argument types: [] + Return type: forall b. Monoid b => Maybe a -> Maybe b + +That is, it will conclude that there are *no* argument types, and since `f` +was given no arguments, it won't print a helpful error message. On the other +hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to: + + Tyvars: [a, b] + Context: (Monoid a, Monoid b) + Argument types: [Maybe a] + Return type: Maybe b + +So now GHC recognizes that `f` has one more argument type than it was actually +provided. +-} + +badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc +badFieldTypes prs + = hang (text "Record update for insufficiently polymorphic field" + <> plural prs <> colon) + 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) + +badFieldsUpd + :: [LHsRecField' (AmbiguousFieldOcc 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 + -> SDoc +badFieldsUpd rbinds data_cons + = hang (text "No constructor has all these fields:") + 2 (pprQuotedList 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 (Set.member fld) fieldLabelSets)) $ + map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds + + fieldLabelSets :: [Set.Set FieldLabelString] + fieldLabelSets = map (Set.fromList . 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. +-} + +naughtyRecordSel :: RdrName -> SDoc +naughtyRecordSel sel_id + = text "Cannot use record selector" <+> quotes (ppr sel_id) <+> + text "as a function due to escaped type variables" $$ + text "Probable fix: use pattern-matching syntax instead" + +notSelector :: Name -> SDoc +notSelector field + = hsep [quotes (ppr field), text "is not a record selector"] + +mixedSelectors :: [Id] -> [Id] -> SDoc +mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) + = ptext + (sLit "Cannot use a mixture of pattern synonym and record selectors") $$ + text "Record selectors defined by" + <+> quotes (ppr (tyConName rep_dc)) + <> text ":" + <+> pprWithCommas ppr data_sels $$ + text "Pattern synonym selectors defined by" + <+> quotes (ppr (patSynName rep_ps)) + <> text ":" + <+> pprWithCommas ppr 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" + + +missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc +missingStrictFields con fields + = header <> rest + where + rest | null fields = Outputable.empty -- Happens for non-record constructors + -- with strict fields + | otherwise = colon <+> pprWithCommas ppr fields + + header = text "Constructor" <+> quotes (ppr con) <+> + text "does not have the required strict field(s)" + +missingFields :: ConLike -> [FieldLabelString] -> SDoc +missingFields con fields + = header <> rest + where + rest | null fields = Outputable.empty + | otherwise = colon <+> pprWithCommas ppr fields + header = text "Fields of" <+> quotes (ppr con) <+> + text "not initialised" + +-- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args)) + +noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc +noPossibleParents rbinds + = hang (text "No type has all these fields:") + 2 (pprQuotedList fields) + where + fields = map (hsRecFieldLbl . unLoc) rbinds + +badOverloadedUpdate :: SDoc +badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature" + +fieldNotInType :: RecSelParent -> RdrName -> SDoc +fieldNotInType p rdr + = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr + +{- +************************************************************************ +* * +\subsection{Static Pointers} +* * +************************************************************************ +-} + +-- | A data type to describe why a variable is not closed. +data NotClosedReason = NotLetBoundReason + | NotTypeClosed VarSet + | NotClosed Name NotClosedReason + +-- | Checks if the given name is closed and emits an error if not. +-- +-- See Note [Not-closed error messages]. +checkClosedInStaticForm :: Name -> TcM () +checkClosedInStaticForm name = do + type_env <- getLclTypeEnv + case checkClosed type_env name of + Nothing -> return () + Just reason -> addErrTc $ explain name reason + where + -- See Note [Checking closedness]. + checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason + checkClosed type_env n = checkLoop type_env (unitNameSet n) n + + checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason + checkLoop type_env visited n = do + -- The @visited@ set is an accumulating parameter that contains the set of + -- visited nodes, so we avoid repeating cycles in the traversal. + case lookupNameEnv type_env n of + Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of + ClosedLet -> Nothing + NotLetBound -> Just NotLetBoundReason + NonClosedLet fvs type_closed -> listToMaybe $ + -- Look for a non-closed variable in fvs + [ NotClosed n' reason + | n' <- nameSetElemsStable fvs + , not (elemNameSet n' visited) + , Just reason <- [checkLoop type_env (extendNameSet visited n') n'] + ] ++ + if type_closed then + [] + else + -- We consider non-let-bound variables easier to figure out than + -- non-closed types, so we report non-closed types to the user + -- only if we cannot spot the former. + [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ] + -- The binding is closed. + _ -> Nothing + + -- Converts a reason into a human-readable sentence. + -- + -- @explain name reason@ starts with + -- + -- " is used in a static form but it is not closed because it" + -- + -- and then follows a list of causes. For each id in the path, the text + -- + -- "uses which" + -- + -- is appended, yielding something like + -- + -- "uses which uses which uses which" + -- + -- until the end of the path is reached, which is reported as either + -- + -- "is not let-bound" + -- + -- when the final node is not let-bound, or + -- + -- "has a non-closed type because it contains the type variables: + -- v1, v2, v3" + -- + -- when the final node has a non-closed type. + -- + explain :: Name -> NotClosedReason -> SDoc + explain name reason = + quotes (ppr name) <+> text "is used in a static form but it is not closed" + <+> text "because it" + $$ + sep (causes reason) + + causes :: NotClosedReason -> [SDoc] + causes NotLetBoundReason = [text "is not let-bound."] + causes (NotTypeClosed vs) = + [ text "has a non-closed type because it contains the" + , text "type variables:" <+> + pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) + ] + causes (NotClosed n reason) = + let msg = text "uses" <+> quotes (ppr n) <+> text "which" + in case reason of + NotClosed _ _ -> msg : causes reason + _ -> let (xs0, xs1) = splitAt 1 $ causes reason + in fmap (msg <+>) xs0 ++ xs1 + +-- Note [Not-closed error messages] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- When variables in a static form are not closed, we go through the trouble +-- of explaining why they aren't. +-- +-- Thus, the following program +-- +-- > {-# LANGUAGE StaticPointers #-} +-- > module M where +-- > +-- > f x = static g +-- > where +-- > g = h +-- > h = x +-- +-- produces the error +-- +-- 'g' is used in a static form but it is not closed because it +-- uses 'h' which uses 'x' which is not let-bound. +-- +-- And a program like +-- +-- > {-# LANGUAGE StaticPointers #-} +-- > module M where +-- > +-- > import Data.Typeable +-- > import GHC.StaticPtr +-- > +-- > f :: Typeable a => a -> StaticPtr TypeRep +-- > f x = const (static (g undefined)) (h x) +-- > where +-- > g = h +-- > h = typeOf +-- +-- produces the error +-- +-- 'g' is used in a static form but it is not closed because it +-- uses 'h' which has a non-closed type because it contains the +-- type variables: 'a' +-- + +-- Note [Checking closedness] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- @checkClosed@ checks if a binding is closed and returns a reason if it is +-- not. +-- +-- The bindings define a graph where the nodes are ids, and there is an edge +-- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free +-- variables. +-- +-- When @n@ is not closed, it has to exist in the graph some node reachable +-- from @n@ that it is not a let-bound variable or that it has a non-closed +-- type. Thus, the "reason" is a path from @n@ to this offending node. +-- +-- When @n@ is not closed, we traverse the graph reachable from @n@ to build +-- the reason. +-- diff --git a/compiler/GHC/Tc/Gen/Expr.hs-boot b/compiler/GHC/Tc/Gen/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Expr.hs-boot @@ -0,0 +1,35 @@ +module GHC.Tc.Gen.Expr where +import GHC.Types.Name +import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn, SyntaxExprTc ) +import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.Origin ( CtOrigin ) +import GHC.Hs.Extension ( GhcRn, GhcTcId ) + +tcCheckExpr :: LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId) + +tcLExpr, tcLExprNC + :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId) +tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) + +tcInferRho, tcInferRhoNC + :: LHsExpr GhcRn-> TcM (LHsExpr GhcTcId, TcRhoType) + +tcInferSigma :: LHsExpr GhcRn-> TcM (LHsExpr GhcTcId, TcSigmaType) + +tcSyntaxOp :: CtOrigin + -> SyntaxExprRn + -> [SyntaxOpType] -- ^ shape of syntax operator arguments + -> ExpType -- ^ overall result type + -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments + -> TcM (a, SyntaxExprTc) + +tcSyntaxOpGen :: CtOrigin + -> SyntaxExprRn + -> [SyntaxOpType] + -> SyntaxOpType + -> ([TcSigmaType] -> TcM a) + -> TcM (a, SyntaxExprTc) + + +tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId) diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -0,0 +1,571 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Typechecking \tr{foreign} declarations +-- +-- A foreign declaration is used to either give an externally +-- implemented function a Haskell type (and calling interface) or +-- give a Haskell function an external calling interface. Either way, +-- the range of argument and result types these functions can accommodate +-- is restricted to what the outside world understands (read C), and this +-- module checks to see if a foreign declaration has got a legal type. +module GHC.Tc.Gen.Foreign + ( tcForeignImports + , tcForeignExports + + -- Low-level exports for hooks + , isForeignImport, isForeignExport + , tcFImport, tcFExport + , tcForeignImports' + , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes + , normaliseFfiType + , nonIOok, mustBeIO + , checkSafe, noCheckSafe + , tcForeignExports' + , tcCheckFEType + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs + +import GHC.Tc.Utils.Monad +import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Expr +import GHC.Tc.Utils.Env + +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Core.Coercion +import GHC.Core.Type +import GHC.Types.ForeignCall +import GHC.Utils.Error +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Tc.Utils.TcType +import GHC.Builtin.Names +import GHC.Driver.Session +import GHC.Utils.Outputable as Outputable +import GHC.Platform +import GHC.Types.SrcLoc +import GHC.Data.Bag +import GHC.Driver.Hooks +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad + +-- Defines a binding +isForeignImport :: LForeignDecl name -> Bool +isForeignImport (L _ (ForeignImport {})) = True +isForeignImport _ = False + +-- Exports a binding +isForeignExport :: LForeignDecl name -> Bool +isForeignExport (L _ (ForeignExport {})) = True +isForeignExport _ = False + +{- +Note [Don't recur in normaliseFfiType'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +normaliseFfiType' is the workhorse for normalising a type used in a foreign +declaration. If we have + +newtype Age = MkAge Int + +we want to see that Age -> IO () is the same as Int -> IO (). But, we don't +need to recur on any type parameters, because no paramaterized types (with +interesting parameters) are marshalable! The full list of marshalable types +is in the body of boxedMarshalableTyCon in GHC.Tc.Utils.TcType. The only members of that +list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled +the same way regardless of type parameter. So, no need to recur into +parameters. + +Similarly, we don't need to look in AppTy's, because nothing headed by +an AppTy will be marshalable. + +Note [FFI type roles] +~~~~~~~~~~~~~~~~~~~~~ +The 'go' helper function within normaliseFfiType' always produces +representational coercions. But, in the "children_only" case, we need to +use these coercions in a TyConAppCo. Accordingly, the roles on the coercions +must be twiddled to match the expectation of the enclosing TyCon. However, +we cannot easily go from an R coercion to an N one, so we forbid N roles +on FFI type constructors. Currently, only two such type constructors exist: +IO and FunPtr. Thus, this is not an onerous burden. + +If we ever want to lift this restriction, we would need to make 'go' take +the target role as a parameter. This wouldn't be hard, but it's a complication +not yet necessary and so is not yet implemented. +-} + +-- normaliseFfiType takes the type from an FFI declaration, and +-- evaluates any type synonyms, type functions, and newtypes. However, +-- we are only allowed to look through newtypes if the constructor is +-- in scope. We return a bag of all the newtype constructors thus found. +-- Always returns a Representational coercion +normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt) +normaliseFfiType ty + = do fam_envs <- tcGetFamInstEnvs + normaliseFfiType' fam_envs ty + +normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) +normaliseFfiType' env ty0 = go initRecTc ty0 + where + go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) + go rec_nts ty + | Just ty' <- tcView ty -- Expand synonyms + = go rec_nts ty' + + | Just (tc, tys) <- splitTyConApp_maybe ty + = go_tc_app rec_nts tc tys + + | (bndrs, inner_ty) <- splitForAllVarBndrs ty + , not (null bndrs) + = do (coi, nty1, gres1) <- go rec_nts inner_ty + return ( mkHomoForAllCos (binderVars bndrs) coi + , mkForAllTys bndrs nty1, gres1 ) + + | otherwise -- see Note [Don't recur in normaliseFfiType'] + = return (mkRepReflCo ty, ty, emptyBag) + + go_tc_app :: RecTcChecker -> TyCon -> [Type] + -> TcM (Coercion, Type, Bag GlobalRdrElt) + go_tc_app rec_nts tc tys + -- We don't want to look through the IO newtype, even if it is + -- in scope, so we have a special case for it: + | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey] + -- These *must not* have nominal roles on their parameters! + -- See Note [FFI type roles] + = children_only + + | isNewTyCon tc -- Expand newtypes + , Just rec_nts' <- checkRecTc rec_nts tc + -- See Note [Expanding newtypes] in GHC.Core.TyCon + -- We can't just use isRecursiveTyCon; sometimes recursion is ok: + -- newtype T = T (Ptr T) + -- Here, we don't reject the type for being recursive. + -- If this is a recursive newtype then it will normally + -- be rejected later as not being a valid FFI type. + = do { rdr_env <- getGlobalRdrEnv + ; case checkNewtypeFFI rdr_env tc of + Nothing -> nothing + Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs + ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } } + + | isFamilyTyCon tc -- Expand open tycons + , (co, ty) <- normaliseTcApp env Representational tc tys + , not (isReflexiveCo co) + = do (co', ty', gres) <- go rec_nts ty + return (mkTransCo co co', ty', gres) + + | otherwise + = nothing -- see Note [Don't recur in normaliseFfiType'] + where + tc_key = getUnique tc + children_only + = do xs <- mapM (go rec_nts) tys + let (cos, tys', gres) = unzip3 xs + -- the (repeat Representational) is because 'go' always + -- returns R coercions + cos' = zipWith3 downgradeRole (tyConRoles tc) + (repeat Representational) cos + return ( mkTyConAppCo Representational tc cos' + , mkTyConApp tc tys', unionManyBags gres) + nt_co = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys [] + nt_rhs = newTyConInstRhs tc tys + + ty = mkTyConApp tc tys + nothing = return (mkRepReflCo ty, ty, emptyBag) + +checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt +checkNewtypeFFI rdr_env tc + | Just con <- tyConSingleDataCon_maybe tc + , Just gre <- lookupGRE_Name rdr_env (dataConName con) + = Just gre -- See Note [Newtype constructor usage in foreign declarations] + | otherwise + = Nothing + +{- +Note [Newtype constructor usage in foreign declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC automatically "unwraps" newtype constructors in foreign import/export +declarations. In effect that means that a newtype data constructor is +used even though it is not mentioned expclitly in the source, so we don't +want to report it as "defined but not used" or "imported but not used". +eg newtype D = MkD Int + foreign import foo :: D -> IO () +Here 'MkD' us used. See #7408. + +GHC also expands type functions during this process, so it's not enough +just to look at the free variables of the declaration. +eg type instance F Bool = D + foreign import bar :: F Bool -> IO () +Here again 'MkD' is used. + +So we really have wait until the type checker to decide what is used. +That's why tcForeignImports and tecForeignExports return a (Bag GRE) +for the newtype constructors they see. Then GHC.Tc.Module can add them +to the module's usages. + + +************************************************************************ +* * +\subsection{Imports} +* * +************************************************************************ +-} + +tcForeignImports :: [LForeignDecl GhcRn] + -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) +tcForeignImports decls + = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls) + +tcForeignImports' :: [LForeignDecl GhcRn] + -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) +-- For the (Bag GlobalRdrElt) result, +-- see Note [Newtype constructor usage in foreign declarations] +tcForeignImports' decls + = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $ + filter isForeignImport decls + ; return (ids, decls, unionManyBags gres) } + +tcFImport :: LForeignDecl GhcRn + -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt) +tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty + , fd_fi = imp_decl })) + = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo) $ + do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty + ; let + -- Drop the foralls before inspecting the + -- structure of the foreign type. + (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty) + id = mkLocalId nm 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). + + ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl + -- Can't use sig_ty here because sig_ty :: Type and + -- we need HsType Id hence the undefined + ; let fi_decl = ForeignImport { fd_name = L nloc id + , fd_sig_ty = undefined + , fd_i_ext = mkSymCo norm_co + , fd_fi = imp_decl' } + ; return (id, L dloc fi_decl, gres) } +tcFImport d = pprPanic "tcFImport" (ppr d) + +-- ------------ Checking types for foreign import ---------------------- + +tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport + +tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src) + -- Foreign import label + = do checkCg checkCOrAsmOrLlvmOrInterp + -- NB check res_ty not sig_ty! + -- In case sig_ty is (forall a. ForeignPtr a) + check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty) + cconv' <- checkCConv cconv + return (CImport (L lc cconv') safety mh l src) + +tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do + -- Foreign wrapper (former f.e.d.) + -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid + -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. + -- The use of the latter form is DEPRECATED, though. + checkCg checkCOrAsmOrLlvmOrInterp + cconv' <- checkCConv cconv + case arg_tys of + [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys + checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty + checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty + where + (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty + _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected")) + return (CImport (L lc cconv') safety mh CWrapper src) + +tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh + (CFunction target) src) + | isDynamicTarget target = do -- Foreign import dynamic + checkCg checkCOrAsmOrLlvmOrInterp + cconv' <- checkCConv cconv + case arg_tys of -- The first arg must be Ptr or FunPtr + [] -> + addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected")) + (arg1_ty:arg_tys) -> do + dflags <- getDynFlags + let curried_res_ty = mkVisFunTys arg_tys res_ty + check (isFFIDynTy curried_res_ty arg1_ty) + (illegalForeignTyErr argument) + checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys + checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty + return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src + | cconv == PrimCallConv = do + dflags <- getDynFlags + checkTc (xopt LangExt.GHCForeignImportPrim dflags) + (text "Use GHCForeignImportPrim to allow `foreign import prim'.") + checkCg checkCOrAsmOrLlvmOrInterp + checkCTarget target + checkTc (playSafe safety) + (text "The safe/unsafe annotation should not be used with `foreign import prim'.") + checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys + -- prim import result is more liberal, allows (#,,#) + checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty + return idecl + | otherwise = do -- Normal foreign import + checkCg checkCOrAsmOrLlvmOrInterp + cconv' <- checkCConv cconv + checkCTarget target + dflags <- getDynFlags + checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys + checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty + checkMissingAmpersand dflags arg_tys res_ty + case target of + StaticTarget _ _ _ False + | not (null arg_tys) -> + addErrTc (text "`value' imports cannot have function types") + _ -> return () + return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src + + +-- This makes a convenient place to check +-- that the C identifier is valid for C +checkCTarget :: CCallTarget -> TcM () +checkCTarget (StaticTarget _ str _ _) = do + checkCg checkCOrAsmOrLlvmOrInterp + checkTc (isCLabelString str) (badCName str) + +checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" + + +checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () +checkMissingAmpersand dflags arg_tys res_ty + | null arg_tys && isFunPtrTy res_ty && + wopt Opt_WarnDodgyForeignImports dflags + = addWarn (Reason Opt_WarnDodgyForeignImports) + (text "possible missing & in foreign import of FunPtr") + | otherwise + = return () + +{- +************************************************************************ +* * +\subsection{Exports} +* * +************************************************************************ +-} + +tcForeignExports :: [LForeignDecl GhcRn] + -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt) +tcForeignExports decls = + getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls) + +tcForeignExports' :: [LForeignDecl GhcRn] + -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt) +-- For the (Bag GlobalRdrElt) result, +-- see Note [Newtype constructor usage in foreign declarations] +tcForeignExports' decls + = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls) + where + combine (binds, fs, gres1) (L loc fe) = do + (b, f, gres2) <- setSrcSpan loc (tcFExport fe) + return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) + +tcFExport :: ForeignDecl GhcRn + -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt) +tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec }) + = addErrCtxt (foreignDeclCtxt fo) $ do + + sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + rhs <- tcCheckExpr (nlHsVar nm) sig_ty + + (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty + + spec' <- tcCheckFEType norm_sig_ty spec + + -- we're exporting a function, but at a type possibly more + -- constrained than its declared/inferred type. Hence the need + -- to create a local binding which will call the exported function + -- at a particular type (and, maybe, overloading). + + + -- We need to give a name to the new top-level binding that + -- is *stable* (i.e. the compiler won't change it later), + -- because this name will be referred to by the C code stub. + id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc + return ( mkVarBind id rhs + , ForeignExport { fd_name = L loc id + , fd_sig_ty = undefined + , fd_e_ext = norm_co, fd_fe = spec' } + , gres) +tcFExport d = pprPanic "tcFExport" (ppr d) + +-- ------------ Checking argument types for foreign export ---------------------- + +tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport +tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do + checkCg checkCOrAsmOrLlvm + checkTc (isCLabelString str) (badCName str) + cconv' <- checkCConv cconv + checkForeignArgs isFFIExternalTy arg_tys + checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty + return (CExport (L l (CExportStatic esrc str cconv')) src) + where + -- Drop the foralls before inspecting + -- the structure of the foreign type. + (arg_tys, res_ty) = tcSplitFunTys (dropForAlls sig_ty) + +{- +************************************************************************ +* * +\subsection{Miscellaneous} +* * +************************************************************************ +-} + +------------ Checking argument types for foreign import ---------------------- +checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM () +checkForeignArgs pred tys = mapM_ go tys + where + go ty = check (pred ty) (illegalForeignTyErr argument) + +------------ Checking result types for foreign calls ---------------------- +-- | Check that the type has the form +-- (IO t) or (t) , and that t satisfies the given predicate. +-- When calling this function, any newtype wrappers (should) have been +-- already dealt with by normaliseFfiType. +-- +-- We also check that the Safe Haskell condition of FFI imports having +-- results in the IO monad holds. +-- +checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM () +checkForeignRes non_io_result_ok check_safe pred_res_ty ty + | Just (_, res_ty) <- tcSplitIOType_maybe ty + = -- Got an IO result type, that's always fine! + check (pred_res_ty res_ty) (illegalForeignTyErr result) + + -- We disallow nested foralls in foreign types + -- (at least, for the time being). See #16702. + | tcIsForAllTy ty + = addErrTc $ illegalForeignTyErr result (text "Unexpected nested forall") + + -- Case for non-IO result type with FFI Import + | not non_io_result_ok + = addErrTc $ illegalForeignTyErr result (text "IO result type expected") + + | otherwise + = do { dflags <- getDynFlags + ; case pred_res_ty ty of + -- Handle normal typecheck fail, we want to handle this first and + -- only report safe haskell errors if the normal type check is OK. + NotValid msg -> addErrTc $ illegalForeignTyErr result msg + + -- handle safe infer fail + _ | check_safe && safeInferOn dflags + -> recordUnsafeInfer emptyBag + + -- handle safe language typecheck fail + _ | check_safe && safeLanguageOn dflags + -> addErrTc (illegalForeignTyErr result safeHsErr) + + -- success! non-IO return is fine + _ -> return () } + where + safeHsErr = + text "Safe Haskell is on, all FFI imports must be in the IO monad" + +nonIOok, mustBeIO :: Bool +nonIOok = True +mustBeIO = False + +checkSafe, noCheckSafe :: Bool +checkSafe = True +noCheckSafe = False + +-- Checking a supported backend is in use + +checkCOrAsmOrLlvm :: HscTarget -> Validity +checkCOrAsmOrLlvm HscC = IsValid +checkCOrAsmOrLlvm HscAsm = IsValid +checkCOrAsmOrLlvm HscLlvm = IsValid +checkCOrAsmOrLlvm _ + = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)") + +checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity +checkCOrAsmOrLlvmOrInterp HscC = IsValid +checkCOrAsmOrLlvmOrInterp HscAsm = IsValid +checkCOrAsmOrLlvmOrInterp HscLlvm = IsValid +checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid +checkCOrAsmOrLlvmOrInterp _ + = NotValid (text "requires interpreted, unregisterised, llvm or native code generation") + +checkCg :: (HscTarget -> Validity) -> TcM () +checkCg check = do + dflags <- getDynFlags + let target = hscTarget dflags + case target of + HscNothing -> return () + _ -> + case check target of + IsValid -> return () + NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err) + +-- Calling conventions + +checkCConv :: CCallConv -> TcM CCallConv +checkCConv CCallConv = return CCallConv +checkCConv CApiConv = return CApiConv +checkCConv StdCallConv = do dflags <- getDynFlags + let platform = targetPlatform dflags + if platformArch platform == ArchX86 + then return StdCallConv + else do -- This is a warning, not an error. see #3336 + when (wopt Opt_WarnUnsupportedCallingConventions dflags) $ + addWarnTc (Reason Opt_WarnUnsupportedCallingConventions) + (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") + return CCallConv +checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") + return PrimCallConv +checkCConv JavaScriptCallConv = do dflags <- getDynFlags + if platformArch (targetPlatform dflags) == ArchJavaScript + then return JavaScriptCallConv + else do addErrTc (text "The `javascript' calling convention is unsupported on this platform") + return JavaScriptCallConv + +-- Warnings + +check :: Validity -> (MsgDoc -> MsgDoc) -> TcM () +check IsValid _ = return () +check (NotValid doc) err_fn = addErrTc (err_fn doc) + +illegalForeignTyErr :: SDoc -> SDoc -> SDoc +illegalForeignTyErr arg_or_res extra + = hang msg 2 extra + where + msg = hsep [ text "Unacceptable", arg_or_res + , text "type in foreign declaration:"] + +-- Used for 'arg_or_res' argument to illegalForeignTyErr +argument, result :: SDoc +argument = text "argument" +result = text "result" + +badCName :: CLabelString -> MsgDoc +badCName target + = sep [quotes (ppr target) <+> text "is not a valid C identifier"] + +foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc +foreignDeclCtxt fo + = hang (text "When checking declaration:") + 2 (ppr fo) diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -0,0 +1,3541 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Typechecking user-specified @MonoTypes@ +module GHC.Tc.Gen.HsType ( + -- Type signatures + kcClassSigType, tcClassSigType, + tcHsSigType, tcHsSigWcType, + tcHsPartialSigType, + tcStandaloneKindSig, + funsSigCtxt, addSigCtxt, pprSigCtxt, + + tcHsClsInstType, + tcHsDeriv, tcDerivStrategy, + tcHsTypeApp, + UserTypeCtxt(..), + bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol, + bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol, + bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol, + bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol, + ContextKind(..), + + -- Type checking type and class decls + bindTyClTyVars, + etaExpandAlgTyCon, tcbVisibilities, + + -- tyvars + zonkAndScopedSort, + + -- Kind-checking types + -- No kind generalisation, no checkValidType + InitialKindStrategy(..), + SAKS_or_CUSK(..), + kcDeclHeader, + tcNamedWildCardBinders, + tcHsLiftedType, tcHsOpenType, + tcHsLiftedTypeNC, tcHsOpenTypeNC, + tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType, + tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps, + failIfEmitsConstraints, + solveEqualities, -- useful re-export + + typeLevelMode, kindLevelMode, + + kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone, + + -- Sort-checking kinds + tcLHsKindSig, checkDataKindSig, DataSort(..), + checkClassKindSig, + + -- Pattern type signatures + tcHsPatSigType, + + -- Error messages + funAppCtxt, addTyConFlavCtxt + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Core.Predicate +import GHC.Tc.Types.Constraint +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Validity +import GHC.Tc.Utils.Unify +import GHC.IfaceToCore +import GHC.Tc.Solver +import GHC.Tc.Utils.Zonk +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Tc.Errors ( reportAllUnsolved ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder ) +import GHC.Core.Type +import GHC.Builtin.Types.Prim +import GHC.Types.Name.Reader( lookupLocalRdrOcc ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Core.TyCon +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.Class +import GHC.Types.Name +-- import GHC.Types.Name.Set +import GHC.Types.Var.Env +import GHC.Builtin.Types +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Settings.Constants ( mAX_CTUPLE_SIZE ) +import GHC.Utils.Error( MsgDoc ) +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Utils.Misc +import GHC.Types.Unique.Supply +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Builtin.Names hiding ( wildCardName ) +import GHC.Driver.Session +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.Maybe +import Data.List ( find ) +import Control.Monad + +{- + ---------------------------- + General notes + ---------------------------- + +Unlike with expressions, type-checking types both does some checking and +desugars at the same time. This is necessary because we often want to perform +equality checks on the types right away, and it would be incredibly painful +to do this on un-desugared types. Luckily, desugared types are close enough +to HsTypes to make the error messages sane. + +During type-checking, we perform as little validity checking as possible. +Generally, after type-checking, you will want to do validity checking, say +with GHC.Tc.Validity.checkValidType. + +Validity checking +~~~~~~~~~~~~~~~~~ +Some of the validity check could in principle be done by the kind checker, +but not all: + +- During desugaring, we normalise by expanding type synonyms. Only + after this step can we check things like type-synonym saturation + e.g. type T k = k Int + type S a = a + Then (T S) is ok, because T is saturated; (T S) expands to (S Int); + and then S is saturated. This is a GHC extension. + +- Similarly, also a GHC extension, we look through synonyms before complaining + about the form of a class or instance declaration + +- Ambiguity checks involve functional dependencies + +Also, in a mutually recursive group of types, we can't look at the TyCon until we've +finished building the loop. So to keep things simple, we postpone most validity +checking until step (3). + +%************************************************************************ +%* * + Check types AND do validity checking +* * +************************************************************************ +-} + +funsSigCtxt :: [Located Name] -> UserTypeCtxt +-- Returns FunSigCtxt, with no redundant-context-reporting, +-- form a list of located names +funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False +funsSigCtxt [] = panic "funSigCtxt" + +addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a +addSigCtxt ctxt hs_ty thing_inside + = setSrcSpan (getLoc hs_ty) $ + addErrCtxt (pprSigCtxt ctxt hs_ty) $ + thing_inside + +pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc +-- (pprSigCtxt ctxt ) +-- prints In the type signature for 'f': +-- f :: +-- The is either empty or "the ambiguity check for" +pprSigCtxt ctxt hs_ty + | Just n <- isSigMaybe ctxt + = hang (text "In the type signature:") + 2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty) + + | otherwise + = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon) + 2 (ppr hs_ty) + +tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type +-- This one is used when we have a LHsSigWcType, but in +-- a place where wildcards aren't allowed. The renamer has +-- already checked this, so we can simply ignore it. +tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) + +kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM () +-- This is a special form of tcClassSigType that is used during the +-- kind-checking phase to infer the kind of class variables. Cf. tc_hs_sig_type. +-- Importantly, this does *not* kind-generalize. Consider +-- class SC f where +-- 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. +kcClassSigType skol_info names (HsIB { hsib_ext = sig_vars + , hsib_body = hs_ty }) + = addSigCtxt (funsSigCtxt names) hs_ty $ + do { (tc_lvl, (wanted, (spec_tkvs, _))) + <- pushTcLevelM $ + solveLocalEqualitiesX "kcClassSigType" $ + bindImplicitTKBndrs_Skol sig_vars $ + tc_lhs_type typeLevelMode hs_ty liftedTypeKind + + ; emitResidualTvConstraint skol_info Nothing spec_tkvs + tc_lvl wanted } + +tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type +-- Does not do validity checking +tcClassSigType skol_info names sig_ty + = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $ + snd <$> tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind) + -- Do not zonk-to-Type, nor perform a validity check + -- We are in a knot with the class and associated types + -- Zonking and validity checking is done by tcClassDecl + -- No need to fail here if the type has an error: + -- If we're in the kind-checking phase, the solveEqualities + -- in kcTyClGroup catches the error + -- If we're in the type-checking phase, the solveEqualities + -- in tcClassDecl1 gets it + -- Failing fast here degrades the error message in, e.g., tcfail135: + -- class Foo f where + -- baa :: f a -> f + -- If we fail fast, we're told that f has kind `k1` when we wanted `*`. + -- It should be that f has kind `k2 -> *`, but we never get a chance + -- to run the solver where the kind of f is touchable. This is + -- painfully delicate. + +tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type +-- Does validity checking +-- See Note [Recipe for checking a signature] +tcHsSigType ctxt sig_ty + = addSigCtxt ctxt (hsSigType sig_ty) $ + do { traceTc "tcHsSigType {" (ppr sig_ty) + + -- Generalise here: see Note [Kind generalisation] + ; (insol, ty) <- tc_hs_sig_type skol_info sig_ty + (expectedKindInCtxt ctxt) + ; ty <- zonkTcType ty + + ; when insol failM + -- See Note [Fail fast if there are insoluble kind equalities] in GHC.Tc.Solver + + ; checkValidType ctxt ty + ; traceTc "end tcHsSigType }" (ppr ty) + ; return ty } + where + skol_info = SigTypeSkol ctxt + +-- Does validity checking and zonking. +tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind) +tcStandaloneKindSig (L _ kisig) = case kisig of + StandaloneKindSig _ (L _ name) ksig -> + let ctxt = StandaloneKindSigCtxt name in + addSigCtxt ctxt (hsSigType ksig) $ + do { kind <- tcTopLHsType kindLevelMode ksig (expectedKindInCtxt ctxt) + ; checkValidType ctxt kind + ; return (name, kind) } + +tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn + -> ContextKind -> TcM (Bool, TcType) +-- Kind-checks/desugars an 'LHsSigType', +-- solve equalities, +-- and then kind-generalizes. +-- This will never emit constraints, as it uses solveEqualities internally. +-- No validity checking or zonking +-- Returns also a Bool indicating whether the type induced an insoluble constraint; +-- True <=> constraint is insoluble +tc_hs_sig_type skol_info hs_sig_type ctxt_kind + | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type + = do { (tc_lvl, (wanted, (spec_tkvs, ty))) + <- pushTcLevelM $ + solveLocalEqualitiesX "tc_hs_sig_type" $ + bindImplicitTKBndrs_Skol sig_vars $ + do { kind <- newExpectedKind ctxt_kind + ; tc_lhs_type typeLevelMode hs_ty kind } + -- Any remaining variables (unsolved in the solveLocalEqualities) + -- should be in the global tyvars, and therefore won't be quantified + + ; spec_tkvs <- zonkAndScopedSort spec_tkvs + ; let ty1 = mkSpecForAllTys spec_tkvs ty + + -- This bit is very much like decideMonoTyVars in GHC.Tc.Solver, + -- but constraints are so much simpler in kinds, it is much + -- easier here. (In particular, we never quantify over a + -- constraint in a type.) + ; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted) + ; let should_gen = not . (`elemVarSet` constrained) + + ; kvs <- kindGeneralizeSome should_gen ty1 + ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs) + tc_lvl wanted + + ; return (insolubleWC wanted, mkInvForAllTys kvs ty1) } + +tcTopLHsType :: TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type +-- tcTopLHsType is used for kind-checking top-level HsType where +-- we want to fully solve /all/ equalities, and report errors +-- Does zonking, but not validity checking because it's used +-- for things (like deriving and instances) that aren't +-- ordinary types +tcTopLHsType mode hs_sig_type ctxt_kind + | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type + = do { traceTc "tcTopLHsType {" (ppr hs_ty) + ; (spec_tkvs, ty) + <- pushTcLevelM_ $ + solveEqualities $ + bindImplicitTKBndrs_Skol sig_vars $ + do { kind <- newExpectedKind ctxt_kind + ; tc_lhs_type mode hs_ty kind } + + ; spec_tkvs <- zonkAndScopedSort spec_tkvs + ; let ty1 = mkSpecForAllTys spec_tkvs ty + ; kvs <- kindGeneralizeAll ty1 -- "All" because it's a top-level type + ; final_ty <- zonkTcTypeToType (mkInvForAllTys kvs ty1) + ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty]) + ; return final_ty} + +----------------- +tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) +-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause +-- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments +-- E.g. class C (a::*) (b::k->k) +-- data T a b = ... deriving( C Int ) +-- returns ([k], C, [k, Int], [k->k]) +-- Return values are fully zonked +tcHsDeriv hs_ty + = do { ty <- checkNoErrs $ -- Avoid redundant error report + -- with "illegal deriving", below + tcTopLHsType typeLevelMode hs_ty AnyKind + ; let (tvs, pred) = splitForAllTys ty + (kind_args, _) = splitFunTys (tcTypeKind pred) + ; case getClassPredTys_maybe pred of + Just (cls, tys) -> return (tvs, cls, tys, kind_args) + Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } + +-- | Typecheck a deriving strategy. For most deriving strategies, this is a +-- no-op, but for the @via@ strategy, this requires typechecking the @via@ type. +tcDerivStrategy :: + Maybe (LDerivStrategy GhcRn) + -- ^ The deriving strategy + -> TcM (Maybe (LDerivStrategy GhcTc), [TyVar]) + -- ^ The typechecked deriving strategy and the tyvars that it binds + -- (if using 'ViaStrategy'). +tcDerivStrategy mb_lds + = case mb_lds of + Nothing -> boring_case Nothing + Just (L loc ds) -> + setSrcSpan loc $ do + (ds', tvs) <- tc_deriv_strategy ds + pure (Just (L loc ds'), tvs) + where + tc_deriv_strategy :: DerivStrategy GhcRn + -> TcM (DerivStrategy GhcTc, [TyVar]) + tc_deriv_strategy StockStrategy = boring_case StockStrategy + tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy + tc_deriv_strategy NewtypeStrategy = boring_case NewtypeStrategy + tc_deriv_strategy (ViaStrategy ty) = do + ty' <- checkNoErrs $ tcTopLHsType typeLevelMode ty AnyKind + let (via_tvs, via_pred) = splitForAllTys ty' + pure (ViaStrategy via_pred, via_tvs) + + boring_case :: ds -> TcM (ds, [TyVar]) + boring_case ds = pure (ds, []) + +tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt + -> LHsSigType GhcRn + -> TcM Type +-- Like tcHsSigType, but for a class instance declaration +tcHsClsInstType user_ctxt hs_inst_ty + = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $ + do { -- Fail eagerly if tcTopLHsType fails. We are at top level so + -- these constraints will never be solved later. And failing + -- eagerly avoids follow-on errors when checkValidInstance + -- sees an unsolved coercion hole + inst_ty <- checkNoErrs $ + tcTopLHsType typeLevelMode hs_inst_ty (TheKind constraintKind) + ; checkValidInstance user_ctxt hs_inst_ty inst_ty + ; return inst_ty } + +---------------------------------------------- +-- | Type-check a visible type application +tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type +-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType +tcHsTypeApp wc_ty kind + | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty + = do { ty <- solveLocalEqualities "tcHsTypeApp" $ + -- We are looking at a user-written type, very like a + -- signature so we want to solve its equalities right now + unsetWOptM Opt_WarnPartialTypeSignatures $ + setXOptM LangExt.PartialTypeSignatures $ + -- See Note [Wildcards in visible type application] + tcNamedWildCardBinders sig_wcs $ \ _ -> + tcCheckLHsType hs_ty (TheKind kind) + -- We do not kind-generalize type applications: we just + -- instantiate with exactly what the user says. + -- See Note [No generalization in type application] + -- We still must call kindGeneralizeNone, though, according + -- to Note [Recipe for checking a signature] + ; kindGeneralizeNone ty + ; ty <- zonkTcType ty + ; checkValidType TypeAppCtxt ty + ; return ty } + +{- Note [Wildcards in visible type application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so +any unnamed wildcards stay unchanged in hswc_body. When called in +tcHsTypeApp, tcCheckLHsType will call emitAnonWildCardHoleConstraint +on these anonymous wildcards. However, this would trigger +error/warning when an anonymous wildcard is passed in as a visible type +argument, which we do not want because users should be able to write +@_ to skip a instantiating a type variable variable without fuss. The +solution is to switch the PartialTypeSignatures flags here to let the +typechecker know that it's checking a '@_' and do not emit hole +constraints on it. See related Note [Wildcards in visible kind +application] and Note [The wildcard story for types] in GHC.Hs.Types + +Ugh! + +Note [No generalization in type application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not kind-generalize type applications. Imagine + + id @(Proxy Nothing) + +If we kind-generalized, we would get + + id @(forall {k}. Proxy @(Maybe k) (Nothing @k)) + +which is very sneakily impredicative instantiation. + +There is also the possibility of mentioning a wildcard +(`id @(Proxy _)`), which definitely should not be kind-generalized. + +-} + +{- +************************************************************************ +* * + The main kind checker: no validity checks here +* * +************************************************************************ +-} + +--------------------------- +tcHsOpenType, tcHsLiftedType, + tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType +-- Used for type signatures +-- Do not do validity checking +tcHsOpenType ty = addTypeCtxt ty $ tcHsOpenTypeNC ty +tcHsLiftedType ty = addTypeCtxt ty $ tcHsLiftedTypeNC ty + +tcHsOpenTypeNC ty = do { ek <- newOpenTypeKind + ; tc_lhs_type typeLevelMode ty ek } +tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind + +-- Like tcHsType, but takes an expected kind +tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType +tcCheckLHsType hs_ty exp_kind + = addTypeCtxt hs_ty $ + do { ek <- newExpectedKind exp_kind + ; tc_lhs_type typeLevelMode hs_ty ek } + +tcLHsType :: LHsType GhcRn -> TcM (TcType, TcKind) +-- Called from outside: set the context +tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty) + +-- Like tcLHsType, but use it in a context where type synonyms and type families +-- do not need to be saturated, like in a GHCi :kind call +tcLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind) +tcLHsTypeUnsaturated hs_ty + | Just (hs_fun_ty, hs_args) <- splitHsAppTys (unLoc hs_ty) + = addTypeCtxt hs_ty $ + do { (fun_ty, _ki) <- tcInferAppHead mode hs_fun_ty + ; tcInferApps_nosat mode hs_fun_ty fun_ty hs_args } + -- Notice the 'nosat'; do not instantiate trailing + -- invisible arguments of a type family. + -- See Note [Dealing with :kind] + + | otherwise + = addTypeCtxt hs_ty $ + tc_infer_lhs_type mode hs_ty + + where + mode = typeLevelMode + +{- Note [Dealing with :kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this GHCi command + ghci> type family F :: Either j k + ghci> :kind F + F :: forall {j,k}. Either j k + +We will only get the 'forall' if we /refrain/ from saturating those +invisible binders. But generally we /do/ saturate those invisible +binders (see tcInferApps), and we want to do so for nested application +even in GHCi. Consider for example (#16287) + ghci> type family F :: k + ghci> data T :: (forall k. k) -> Type + ghci> :kind T F +We want to reject this. It's just at the very top level that we want +to switch off saturation. + +So tcLHsTypeUnsaturated does a little special case for top level +applications. Actually the common case is a bare variable, as above. + + +************************************************************************ +* * + Type-checking modes +* * +************************************************************************ + +The kind-checker is parameterised by a TcTyMode, which contains some +information about where we're checking a type. + +The renamer issues errors about what it can. All errors issued here must +concern things that the renamer can't handle. + +-} + +-- | Info about the context in which we're checking a type. Currently, +-- differentiates only between types and kinds, but this will likely +-- grow, at least to include the distinction between patterns and +-- not-patterns. +-- +-- To find out where the mode is used, search for 'mode_level' +data TcTyMode = TcTyMode { mode_level :: TypeOrKind } + +typeLevelMode :: TcTyMode +typeLevelMode = TcTyMode { mode_level = TypeLevel } + +kindLevelMode :: TcTyMode +kindLevelMode = TcTyMode { mode_level = KindLevel } + +-- switch to kind level +kindLevel :: TcTyMode -> TcTyMode +kindLevel mode = mode { mode_level = KindLevel } + +instance Outputable TcTyMode where + ppr = ppr . mode_level + +{- +Note [Bidirectional type checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In expressions, whenever we see a polymorphic identifier, say `id`, we are +free to instantiate it with metavariables, knowing that we can always +re-generalize with type-lambdas when necessary. For example: + + rank2 :: (forall a. a -> a) -> () + x = rank2 id + +When checking the body of `x`, we can instantiate `id` with a metavariable. +Then, when we're checking the application of `rank2`, we notice that we really +need a polymorphic `id`, and then re-generalize over the unconstrained +metavariable. + +In types, however, we're not so lucky, because *we cannot re-generalize*! +There is no lambda. So, we must be careful only to instantiate at the last +possible moment, when we're sure we're never going to want the lost polymorphism +again. This is done in calls to tcInstInvisibleTyBinders. + +To implement this behavior, we use bidirectional type checking, where we +explicitly think about whether we know the kind of the type we're checking +or not. Note that there is a difference between not knowing a kind and +knowing a metavariable kind: the metavariables are TauTvs, and cannot become +forall-quantified kinds. Previously (before dependent types), there were +no higher-rank kinds, and so we could instantiate early and be sure that +no types would have polymorphic kinds, and so we could always assume that +the kind of a type was a fresh metavariable. Not so anymore, thus the +need for two algorithms. + +For HsType forms that can never be kind-polymorphic, we implement only the +"down" direction, where we safely assume a metavariable kind. For HsType forms +that *can* be kind-polymorphic, we implement just the "up" (functions with +"infer" in their name) version, as we gain nothing by also implementing the +"down" version. + +Note [Future-proofing the type checker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As discussed in Note [Bidirectional type checking], each HsType form is +handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions +are mutually recursive, so that either one can work for any type former. +But, we want to make sure that our pattern-matches are complete. So, +we have a bunch of repetitive code just so that we get warnings if we're +missing any patterns. + +-} + +------------------------------------------ +-- | Check and desugar a type, returning the core type and its +-- possibly-polymorphic kind. Much like 'tcInferRho' at the expression +-- level. +tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) +tc_infer_lhs_type mode (L span ty) + = setSrcSpan span $ + tc_infer_hs_type mode ty + +--------------------------- +-- | Call 'tc_infer_hs_type' and check its result against an expected kind. +tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType +tc_infer_hs_type_ek mode hs_ty ek + = do { (ty, k) <- tc_infer_hs_type mode hs_ty + ; checkExpectedKind hs_ty ty k ek } + +--------------------------- +-- | Infer the kind of a type and desugar. This is the "up" type-checker, +-- as described in Note [Bidirectional type checking] +tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) + +tc_infer_hs_type mode (HsParTy _ t) + = tc_infer_lhs_type mode t + +tc_infer_hs_type mode ty + | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty + = do { (fun_ty, _ki) <- tcInferAppHead mode hs_fun_ty + ; tcInferApps mode hs_fun_ty fun_ty hs_args } + +tc_infer_hs_type mode (HsKindSig _ ty sig) + = do { sig' <- tcLHsKindSig KindSigCtxt sig + -- We must typecheck the kind signature, and solve all + -- its equalities etc; from this point on we may do + -- 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' + ; return (ty', sig') } + +-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate +-- the splice location to the typechecker. Here we skip over it in order to have +-- the same kind inferred for a given expression whether it was produced from +-- splices or not. +-- +-- See Note [Delaying modFinalizers in untyped splices]. +tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty))) + = tc_infer_hs_type mode ty + +tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty +tc_infer_hs_type _ (XHsType (NHsCoreTy ty)) + = return (ty, tcTypeKind ty) + +tc_infer_hs_type _ (HsExplicitListTy _ _ tys) + | null tys -- this is so that we can use visible kind application with '[] + -- e.g ... '[] @Bool + = return (mkTyConTy promotedNilDataCon, + mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy) + +tc_infer_hs_type mode other_ty + = do { kv <- newMetaKindVar + ; ty' <- tc_hs_type mode other_ty kv + ; return (ty', kv) } + +------------------------------------------ +tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType +tc_lhs_type mode (L span ty) exp_kind + = setSrcSpan span $ + tc_hs_type mode ty exp_kind + +tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType +-- See Note [Bidirectional type checking] + +tc_hs_type mode (HsParTy _ ty) exp_kind = tc_lhs_type mode ty exp_kind +tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind +tc_hs_type _ ty@(HsBangTy _ bang _) _ + -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), + -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of + -- bangs are invalid, so fail. (#7210, #14761) + = do { let bangError err = failWith $ + text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ + text err <+> text "annotation cannot appear nested inside a type" + ; case bang of + HsSrcBang _ SrcUnpack _ -> bangError "UNPACK" + HsSrcBang _ SrcNoUnpack _ -> bangError "NOUNPACK" + HsSrcBang _ NoSrcUnpack SrcLazy -> bangError "laziness" + HsSrcBang _ _ _ -> bangError "strictness" } +tc_hs_type _ ty@(HsRecTy {}) _ + -- Record types (which only show up temporarily in constructor + -- signatures) should have been removed by now + = failWithTc (text "Record syntax is illegal here:" <+> ppr 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 +-- while capturing the local environment. +-- +-- See Note [Delaying modFinalizers in untyped splices]. +tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty))) + exp_kind + = do addModFinalizersWithLclEnv mod_finalizers + tc_hs_type mode ty exp_kind + +-- This should never happen; type splices are expanded by the renamer +tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind + = failWithTc (text "Unexpected type splice:" <+> ppr ty) + +---------- Functions and applications +tc_hs_type mode (HsFunTy _ ty1 ty2) exp_kind + = tc_fun_type mode ty1 ty2 exp_kind + +tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind + | op `hasKey` funTyConKey + = tc_fun_type mode ty1 ty2 exp_kind + +--------- Foralls +tc_hs_type mode forall@(HsForAllTy { hst_fvf = fvf, hst_bndrs = hs_tvs + , hst_body = ty }) exp_kind + = do { (tclvl, wanted, (tvs', ty')) + <- pushLevelAndCaptureConstraints $ + bindExplicitTKBndrs_Skol hs_tvs $ + tc_lhs_type mode ty exp_kind + -- Do not kind-generalise here! See Note [Kind generalisation] + -- Why exp_kind? See Note [Body kind of HsForAllTy] + ; let argf = case fvf of + ForallVis -> Required + ForallInvis -> Specified + bndrs = mkTyVarBinders argf tvs' + skol_info = ForAllSkol (ppr forall) + m_telescope = Just (sep (map ppr hs_tvs)) + + ; emitResidualTvConstraint skol_info m_telescope tvs' tclvl wanted + -- See Note [Skolem escape and forall-types] + + ; return (mkForAllTys bndrs ty') } + +tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind + | null (unLoc ctxt) + = tc_lhs_type mode rn_ty exp_kind + + -- See Note [Body kind of a HsQualTy] + | tcIsConstraintKind exp_kind + = do { ctxt' <- tc_hs_context mode ctxt + ; ty' <- tc_lhs_type mode rn_ty constraintKind + ; return (mkPhiTy ctxt' ty') } + + | otherwise + = do { ctxt' <- tc_hs_context mode ctxt + + ; ek <- newOpenTypeKind -- The body kind (result of the function) can + -- be TYPE r, for any r, hence newOpenTypeKind + ; ty' <- tc_lhs_type mode rn_ty ek + ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty') + liftedTypeKind exp_kind } + +--------- Lists, arrays, and tuples +tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind + = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind + ; checkWiredInTyCon listTyCon + ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } + +-- See Note [Distinguishing tuple kinds] in GHC.Hs.Types +-- See Note [Inferring tuple kinds] +tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind + -- (NB: not zonking before looking at exp_k, to avoid left-right bias) + | Just tup_sort <- tupKindSort_maybe exp_kind + = traceTc "tc_hs_type tuple" (ppr hs_tys) >> + tc_tuple rn_ty mode tup_sort hs_tys exp_kind + | 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 + -- 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 + -- "the second argument of a tuple should have kind *->*" + + ; let (arg_kind, tup_sort) + = case [ (k,s) | k <- kinds + , Just s <- [tupKindSort_maybe k] ] of + ((k,s) : _) -> (k,s) + [] -> (liftedTypeKind, BoxedTuple) + -- In the [] case, it's not clear what the kind is, so guess * + + ; tys' <- sequence [ setSrcSpan loc $ + checkExpectedKind hs_ty ty kind arg_kind + | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ] + + ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind } + + +tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind + = tc_tuple rn_ty mode tup_sort tys exp_kind + where + tup_sort = case hs_tup_sort of -- Fourth case dealt with above + HsUnboxedTuple -> UnboxedTuple + HsBoxedTuple -> BoxedTuple + HsConstraintTuple -> ConstraintTuple + _ -> panic "tc_hs_type HsTupleTy" + +tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind + = do { let arity = length hs_tys + ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys + ; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds + ; let arg_reps = map kindRep arg_kinds + arg_tys = arg_reps ++ tau_tys + sum_ty = mkTyConApp (sumTyCon arity) arg_tys + sum_kind = unboxedSumKind arg_reps + ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind + } + +--------- Promoted lists and tuples +tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind + = do { tks <- mapM (tc_infer_lhs_type mode) tys + ; (taus', kind) <- unifyKinds tys tks + ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') + ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind } + where + mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b] + mk_nil k = mkTyConApp (promoteDataCon nilDataCon) [k] + +tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind + -- using newMetaKindVar means that we force instantiations of any polykinded + -- types. At first, I just used tc_infer_lhs_type, but that led to #11255. + = do { ks <- replicateM arity newMetaKindVar + ; taus <- zipWithM (tc_lhs_type mode) tys ks + ; let kind_con = tupleTyCon Boxed arity + ty_con = promotedTupleDataCon Boxed arity + tup_k = mkTyConApp kind_con ks + ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind } + where + arity = length tys + +--------- Constraint types +tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind + = do { MASSERT( isTypeLevel (mode_level mode) ) + ; ty' <- tc_lhs_type mode ty liftedTypeKind + ; let n' = mkStrLitTy $ hsIPNameFS n + ; ipClass <- tcLookupClass ipClassName + ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty']) + constraintKind exp_kind } + +tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind + -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to + -- handle it in 'coreView' and 'tcView'. + = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind + +--------- Literals +tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind + = do { checkWiredInTyCon typeNatKindCon + ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind } + +tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind + = do { checkWiredInTyCon typeSymbolKindCon + ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind } + +--------- Potentially kind-polymorphic types: call the "up" checker +-- See Note [Future-proofing the type checker] +tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsAppTy {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsAppKindTy{}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type _ wc@(HsWildCardTy _) ek = tcAnonWildCardOcc wc ek + +------------------------------------------ +tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind + -> TcM TcType +tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of + TypeLevel -> + do { arg_k <- newOpenTypeKind + ; res_k <- newOpenTypeKind + ; ty1' <- tc_lhs_type mode ty1 arg_k + ; ty2' <- tc_lhs_type mode ty2 res_k + ; checkExpectedKind (HsFunTy noExtField ty1 ty2) (mkVisFunTy ty1' ty2') + liftedTypeKind exp_kind } + KindLevel -> -- no representation polymorphism in kinds. yet. + do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind + ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind + ; checkExpectedKind (HsFunTy noExtField ty1 ty2) (mkVisFunTy ty1' ty2') + liftedTypeKind exp_kind } + +--------------------------- +tcAnonWildCardOcc :: HsType GhcRn -> Kind -> TcM TcType +tcAnonWildCardOcc wc exp_kind + = do { wc_tv <- newWildTyVar -- The wildcard's kind will be an un-filled-in meta tyvar + + ; part_tysig <- xoptM LangExt.PartialTypeSignatures + ; warning <- woptM Opt_WarnPartialTypeSignatures + + ; unless (part_tysig && not warning) $ + emitAnonWildCardHoleConstraint wc_tv + -- Why the 'unless' guard? + -- See Note [Wildcards in visible kind application] + + ; checkExpectedKind wc (mkTyVarTy wc_tv) + (tyVarKind wc_tv) exp_kind } + +{- Note [Wildcards in visible kind application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are cases where users might want to pass in a wildcard as a visible kind +argument, for instance: + +data T :: forall k1 k2. k1 → k2 → Type where + MkT :: T a b +x :: T @_ @Nat False n +x = MkT + +So we should allow '@_' without emitting any hole constraints, and +regardless of whether PartialTypeSignatures is enabled or not. But how would +the typechecker know which '_' is being used in VKA and which is not when it +calls emitNamedWildCardHoleConstraints in tcHsPartialSigType on all HsWildCardBndrs? +The solution then is to neither rename nor include unnamed wildcards in HsWildCardBndrs, +but instead give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc. +And whenever we see a '@', we automatically turn on PartialTypeSignatures and +turn off hole constraint warnings, and do not call emitAnonWildCardHoleConstraint +under these conditions. +See related Note [Wildcards in visible type application] here and +Note [The wildcard story for types] in GHC.Hs.Types + +Note [Skolem escape and forall-types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> () + +The Proxy '[a,b] forces a and b to have the same kind. But a's +kind must be bound outside the 'forall a', and hence escapes. +We discover this by building an implication constraint for +each forall. So the inner implication constraint will look like + forall kb (b::kb). kb ~ ka +where ka is a's kind. We can't unify these two, /even/ if ka is +unification variable, because it would be untouchable inside +this inner implication. + +That's what the pushLevelAndCaptureConstraints, plus subsequent +emitResidualTvConstraint is all about, when kind-checking +HsForAllTy. + +Note that we don't need to /simplify/ the constraints here +because we aren't generalising. We just capture them. +-} + +{- ********************************************************************* +* * + Tuples +* * +********************************************************************* -} + +--------------------------- +tupKindSort_maybe :: TcKind -> Maybe TupleSort +tupKindSort_maybe k + | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k' + | Just k' <- tcView k = tupKindSort_maybe k' + | tcIsConstraintKind k = Just ConstraintTuple + | tcIsLiftedTypeKind k = Just BoxedTuple + | otherwise = Nothing + +tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType +tc_tuple rn_ty mode tup_sort tys exp_kind + = do { arg_kinds <- case tup_sort of + BoxedTuple -> return (replicate arity liftedTypeKind) + UnboxedTuple -> replicateM arity newOpenTypeKind + ConstraintTuple -> return (replicate arity constraintKind) + ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds + ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind } + where + arity = length tys + +finish_tuple :: HsType GhcRn + -> TupleSort + -> [TcType] -- ^ argument types + -> [TcKind] -- ^ of these kinds + -> TcKind -- ^ expected kind of the whole tuple + -> TcM TcType +finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do + traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind) + case tup_sort of + ConstraintTuple + | [tau_ty] <- tau_tys + -- Drop any uses of 1-tuple constraints here. + -- See Note [Ignore unary constraint tuples] + -> check_expected_kind tau_ty constraintKind + | arity > mAX_CTUPLE_SIZE + -> failWith (bigConstraintTuple arity) + | otherwise + -> do tycon <- tcLookupTyCon (cTupleTyConName arity) + check_expected_kind (mkTyConApp tycon tau_tys) constraintKind + BoxedTuple -> do + let tycon = tupleTyCon Boxed arity + checkWiredInTyCon tycon + check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind + UnboxedTuple -> + let tycon = tupleTyCon Unboxed arity + tau_reps = map kindRep tau_kinds + -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + arg_tys = tau_reps ++ tau_tys + res_kind = unboxedTupleKind tau_reps in + check_expected_kind (mkTyConApp tycon arg_tys) res_kind + where + arity = length tau_tys + check_expected_kind ty act_kind = + checkExpectedKind rn_ty ty act_kind exp_kind + +bigConstraintTuple :: Arity -> MsgDoc +bigConstraintTuple arity + = hang (text "Constraint tuple arity too large:" <+> int arity + <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE)) + 2 (text "Instead, use a nested tuple") + +{- +Note [Ignore unary constraint tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in +GHC.Builtin.Types) but does *not* provide unary constraint tuples. Why? First, +recall the definition of a unary tuple data type: + + data Unit a = Unit a + +Note that `Unit a` is *not* the same thing as `a`, since Unit is boxed and +lazy. Therefore, the presence of `Unit` matters semantically. On the other +hand, suppose we had a unary constraint tuple: + + class a => Unit% a + +This compiles down a newtype (i.e., a cast) in Core, so `Unit% a` is +semantically equivalent to `a`. Therefore, a 1-tuple constraint would have +no user-visible impact, nor would it allow you to express anything that +you couldn't otherwise. + +We could simply add Unit% for consistency with tuples (Unit) and unboxed +tuples (Unit#), but that would require even more magic to wire in another +magical class, so we opt not to do so. We must be careful, however, since +one can try to sneak in uses of unary constraint tuples through Template +Haskell, such as in this program (from #17511): + + f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)] + (ConT ''String))) + -- f :: Unit% (Show Int) => String + f = "abc" + +This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1, +and since it is used in a Constraint position, GHC will attempt to treat +it as thought it were a constraint tuple, which can potentially lead to +trouble if one attempts to look up the name of a constraint tuple of arity +1 (as it won't exist). To avoid this trouble, we simply take any unary +constraint tuples discovered when typechecking and drop them—i.e., treat +"Unit% a" as though the user had written "a". This is always safe to do +since the two constraints should be semantically equivalent. +-} + +{- ********************************************************************* +* * + Type applications +* * +********************************************************************* -} + +splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn]) +splitHsAppTys hs_ty + | is_app hs_ty = Just (go (noLoc hs_ty) []) + | otherwise = Nothing + where + is_app :: HsType GhcRn -> Bool + is_app (HsAppKindTy {}) = True + is_app (HsAppTy {}) = True + is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey) + -- I'm not sure why this funTyConKey test is necessary + -- Can it even happen? Perhaps for t1 `(->)` t2 + -- but then maybe it's ok to treat that like a normal + -- application rather than using the special rule for HsFunTy + is_app (HsTyVar {}) = True + is_app (HsParTy _ (L _ ty)) = is_app ty + is_app _ = False + + 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 sp (HsParTy _ f)) as = go f (HsArgPar sp : as) + go (L _ (HsOpTy _ l op@(L sp _) r)) as + = ( L sp (HsTyVar noExtField NotPromoted op) + , HsValArg l : HsValArg r : as ) + go f as = (f, as) + +--------------------------- +tcInferAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) +-- Version of tc_infer_lhs_type specialised for the head of an +-- application. In particular, for a HsTyVar (which includes type +-- constructors, it does not zoom off into tcInferApps and family +-- saturation +tcInferAppHead mode (L _ (HsTyVar _ _ (L _ tv))) + = tcTyVar mode tv +tcInferAppHead mode ty + = tc_infer_lhs_type mode ty + +--------------------------- +-- | Apply a type of a given kind to a list of arguments. This instantiates +-- invisible parameters as necessary. Always consumes all the arguments, +-- using matchExpectedFunKind as necessary. +-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.- +-- These kinds should be used to instantiate invisible kind variables; +-- they come from an enclosing class for an associated type/data family. +-- +-- tcInferApps also arranges to saturate any trailing invisible arguments +-- of a type-family application, which is usually the right thing to do +-- tcInferApps_nosat does not do this saturation; it is used only +-- by ":kind" in GHCi +tcInferApps, tcInferApps_nosat + :: TcTyMode + -> LHsType GhcRn -- ^ Function (for printing only) + -> TcType -- ^ Function + -> [LHsTypeArg GhcRn] -- ^ Args + -> TcM (TcType, TcKind) -- ^ (f args, args, result kind) +tcInferApps mode hs_ty fun hs_args + = do { (f_args, res_k) <- tcInferApps_nosat mode hs_ty fun hs_args + ; saturateFamApp f_args res_k } + +tcInferApps_nosat mode orig_hs_ty fun orig_hs_args + = do { traceTc "tcInferApps {" (ppr orig_hs_ty $$ ppr orig_hs_args) + ; (f_args, res_k) <- go_init 1 fun orig_hs_args + ; traceTc "tcInferApps }" (ppr f_args <+> dcolon <+> ppr res_k) + ; return (f_args, res_k) } + where + + -- go_init just initialises the auxiliary + -- arguments of the 'go' loop + go_init n fun all_args + = go n fun empty_subst fun_ki all_args + where + fun_ki = tcTypeKind fun + -- We do (tcTypeKind fun) here, even though the caller + -- knows the function kind, to absolutely guarantee + -- INVARIANT for 'go' + -- Note that in a typical application (F t1 t2 t3), + -- the 'fun' is just a TyCon, so tcTypeKind is fast + + empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfType fun_ki + + go :: Int -- The # of the next argument + -> TcType -- Function applied to some args + -> TCvSubst -- Applies to function kind + -> TcKind -- Function kind + -> [LHsTypeArg GhcRn] -- Un-type-checked args + -> TcM (TcType, TcKind) -- Result type and its kind + -- INVARIANT: in any call (go n fun subst fun_ki args) + -- tcTypeKind fun = subst(fun_ki) + -- So the 'subst' and 'fun_ki' arguments are simply + -- there to avoid repeatedly calling tcTypeKind. + -- + -- Reason for INVARIANT: to support the Purely Kinded Type Invariant + -- it's important that if fun_ki has a forall, then so does + -- (tcTypeKind fun), because the next thing we are going to do + -- is apply 'fun' to an argument type. + + -- Dispatch on all_args first, for performance reasons + go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of + + ---------------- No user-written args left. We're done! + ([], _) -> return (fun, substTy subst fun_ki) + + ---------------- HsArgPar: We don't care about parens here + (HsArgPar _ : args, _) -> go n fun subst fun_ki args + + ---------------- HsTypeArg: a kind application (fun @ki) + (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) -> + case ki_binder of + + -- FunTy with PredTy on LHS, or ForAllTy with Inferred + Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki + Anon InvisArg _ -> instantiate ki_binder inner_ki + + Named (Bndr _ Specified) -> -- Visible kind application + do { traceTc "tcInferApps (vis kind app)" + (vcat [ ppr ki_binder, ppr hs_ki_arg + , ppr (tyBinderType ki_binder) + , ppr subst ]) + + ; let exp_kind = substTy subst $ tyBinderType ki_binder + + ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $ + unsetWOptM Opt_WarnPartialTypeSignatures $ + setXOptM LangExt.PartialTypeSignatures $ + -- Urgh! see Note [Wildcards in visible kind application] + -- ToDo: must kill this ridiculous messing with DynFlags + tc_lhs_type (kindLevel mode) hs_ki_arg exp_kind + + ; traceTc "tcInferApps (vis kind app)" (ppr exp_kind) + ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg + ; go (n+1) fun' subst' inner_ki hs_args } + + -- Attempted visible kind application (fun @ki), but fun_ki is + -- forall k -> blah or k1 -> k2 + -- So we need a normal application. Error. + _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki + + -- No binder; try applying the substitution, or fail if that's not possible + (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $ + ty_app_err ki_arg substed_fun_ki + + ---------------- HsValArg: a normal argument (fun ty) + (HsValArg arg : args, Just (ki_binder, inner_ki)) + -- next binder is invisible; need to instantiate it + | isInvisibleBinder ki_binder -- FunTy with InvisArg on LHS; + -- or ForAllTy with Inferred or Specified + -> instantiate ki_binder inner_ki + + -- "normal" case + | otherwise + -> do { traceTc "tcInferApps (vis normal app)" + (vcat [ ppr ki_binder + , ppr arg + , ppr (tyBinderType ki_binder) + , ppr subst ]) + ; let exp_kind = substTy subst $ tyBinderType ki_binder + ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $ + tc_lhs_type mode arg exp_kind + ; traceTc "tcInferApps (vis normal app) 2" (ppr exp_kind) + ; (subst', fun') <- mkAppTyM subst fun ki_binder arg' + ; go (n+1) fun' subst' inner_ki args } + + -- no binder; try applying the substitution, or infer another arrow in fun kind + (HsValArg _ : _, Nothing) + -> try_again_after_substing_or $ + do { let arrows_needed = n_initial_val_args all_args + ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki + + ; fun' <- zonkTcType (fun `mkTcCastTy` co) + -- This zonk is essential, to expose the fruits + -- of matchExpectedFunKind to the 'go' loop + + ; traceTc "tcInferApps (no binder)" $ + vcat [ ppr fun <+> dcolon <+> ppr fun_ki + , ppr arrows_needed + , ppr co + , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')] + ; go_init n fun' all_args } + -- Use go_init to establish go's INVARIANT + where + instantiate ki_binder inner_ki + = do { traceTc "tcInferApps (need to instantiate)" + (vcat [ ppr ki_binder, ppr subst]) + ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder + ; go n (mkAppTy fun arg') subst' inner_ki all_args } + -- Because tcInvisibleTyBinder instantiate ki_binder, + -- the kind of arg' will have the same shape as the kind + -- of ki_binder. So we don't need mkAppTyM here. + + try_again_after_substing_or fallthrough + | not (isEmptyTCvSubst subst) + = go n fun zapped_subst substed_fun_ki all_args + | otherwise + = fallthrough + + zapped_subst = zapTCvSubst subst + 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 + -- 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 + n_initial_val_args _ = 0 + + ty_app_err arg ty + = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty) + $$ text "to visible kind argument" <+> quotes (ppr arg) + + +mkAppTyM :: TCvSubst + -> TcType -> TyCoBinder -- fun, plus its top-level binder + -> TcType -- arg + -> TcM (TCvSubst, TcType) -- Extended subst, plus (fun arg) +-- Precondition: the application (fun arg) is well-kinded after zonking +-- That is, the application makes sense +-- +-- Precondition: for (mkAppTyM subst fun bndr arg) +-- tcTypeKind fun = Pi bndr. body +-- That is, fun always has a ForAllTy or FunTy at the top +-- and 'bndr' is fun's pi-binder +-- +-- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type +-- invariant, then so does the result type (fun arg) +-- +-- We do not require that +-- tcTypeKind arg = tyVarKind (binderVar bndr) +-- This must be true after zonking (precondition 1), but it's not +-- required for the (PKTI). +mkAppTyM subst fun ki_binder arg + | -- See Note [mkAppTyM]: Nasty case 2 + TyConApp tc args <- fun + , 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 + ; let subst' = case ki_binder of + Anon {} -> subst + Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg' + ; return (subst', mkTyConApp tc (args' ++ [arg'])) } + + +mkAppTyM subst fun (Anon {}) arg + = return (subst, mk_app_ty fun arg) + +mkAppTyM subst fun (Named (Bndr tv _)) arg + = do { arg' <- if isTrickyTvBinder tv + then -- See Note [mkAppTyM]: Nasty case 1 + zonkTcType arg + else return arg + ; return ( extendTvSubstAndInScope subst tv arg' + , mk_app_ty fun arg' ) } + +mk_app_ty :: TcType -> TcType -> TcType +-- This function just adds an ASSERT for mkAppTyM's precondition +mk_app_ty fun arg + = ASSERT2( isPiTy fun_kind + , ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg ) + mkAppTy fun arg + where + fun_kind = tcTypeKind fun + +isTrickyTvBinder :: TcTyVar -> Bool +-- NB: isTrickyTvBinder is just an optimisation +-- It would be absolutely sound to return True always +isTrickyTvBinder tv = isPiTy (tyVarKind tv) + +{- Note [The Purely Kinded Type Invariant (PKTI)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During type inference, we maintain this invariant + + (PKTI) It is legal to call 'tcTypeKind' on any Type ty, + on any sub-term of ty, /without/ zonking ty + + Moreover, any such returned kind + will itself satisfy (PKTI) + +By "legal to call tcTypeKind" we mean "tcTypeKind will not crash". +The way in which tcTypeKind can crash is in applications + (a t1 t2 .. tn) +if 'a' is a type variable whose kind doesn't have enough arrows +or foralls. (The crash is in piResultTys.) + +The loop in tcInferApps has to be very careful to maintain the (PKTI). +For example, suppose + kappa is a unification variable + We have already unified kappa := Type + yielding co :: Refl (Type -> Type) + a :: kappa +then consider the type + (a Int) +If we call tcTypeKind on that, we'll crash, because the (un-zonked) +kind of 'a' is just kappa, not an arrow kind. So we must zonk first. + +So the type inference engine is very careful when building applications. +This happens in tcInferApps. Suppose we are kind-checking the type (a Int), +where (a :: kappa). Then in tcInferApps we'll run out of binders on +a's kind, so we'll call matchExpectedFunKind, and unify + kappa := kappa1 -> kappa2, with evidence co :: kappa ~ (kappa1 ~ kappa2) +At this point we must zonk the function type to expose the arrrow, so +that (a Int) will satisfy (PKTI). + +The absence of this caused #14174 and #14520. + +The calls to mkAppTyM is the other place we are very careful. + +Note [mkAppTyM] +~~~~~~~~~~~~~~~ +mkAppTyM is trying to guarantee the Purely Kinded Type Invariant +(PKTI) for its result type (fun arg). There are two ways it can go wrong: + +* Nasty case 1: forall types (polykinds/T14174a) + T :: forall (p :: *->*). p Int -> p Bool + Now kind-check (T x), where x::kappa. + Well, T and x both satisfy the PKTI, but + T x :: x Int -> x Bool + and (x Int) does /not/ satisfy the PKTI. + +* Nasty case 2: type synonyms + type S f a = f a + Even though (S ff aa) would satisfy the (PKTI) if S was a data type + (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI) + if S is a type synonym, because the /expansion/ of (S ff aa) is + (ff aa), and /that/ does not satisfy (PKTI). E.g. perhaps + (ff :: kappa), where 'kappa' has already been unified with (*->*). + + We check for nasty case 2 on the final argument of a type synonym. + +Notice that in both cases the trickiness only happens if the +bound variable has a pi-type. Hence isTrickyTvBinder. +-} + + +saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) +-- Precondition for (saturateFamApp ty kind): +-- tcTypeKind ty = kind +-- +-- If 'ty' is an unsaturated family application with trailing +-- invisible arguments, instanttiate them. +-- See Note [saturateFamApp] + +saturateFamApp ty kind + | Just (tc, args) <- tcSplitTyConApp_maybe ty + , mustBeSaturated tc + , let n_to_inst = tyConArity tc - length args + = do { (extra_args, ki') <- tcInstInvisibleTyBinders n_to_inst kind + ; return (ty `mkTcAppTys` extra_args, ki') } + | otherwise + = return (ty, kind) + +{- Note [saturateFamApp] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type family F :: Either j k + type instance F @Type = Right Maybe + type instance F @Type = Right Either``` + +Then F :: forall {j,k}. Either j k + +The two type instances do a visible kind application that instantiates +'j' but not 'k'. But we want to end up with instances that look like + type instance F @Type @(*->*) = Right @Type @(*->*) Maybe + +so that F has arity 2. We must instantiate that trailing invisible +binder. In general, Invisible binders precede Specified and Required, +so this is only going to bite for apparently-nullary families. + +Note that + type family F2 :: forall k. k -> * +is quite different and really does have arity 0. + +It's not just type instances where we need to saturate those +unsaturated arguments: see #11246. Hence doing this in tcInferApps. +-} + +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 + + +{- ********************************************************************* +* * + checkExpectedKind +* * +********************************************************************* -} + +-- | This instantiates invisible arguments for the type being checked if it must +-- be saturated and is not yet saturated. It then calls and uses the result +-- from checkExpectedKindX to build the final type +checkExpectedKind :: HasDebugCallStack + => HsType GhcRn -- ^ type we're checking (for printing) + -> TcType -- ^ type we're checking + -> TcKind -- ^ the known kind of that type + -> TcKind -- ^ the expected kind + -> TcM TcType +-- Just a convenience wrapper to save calls to 'ppr' +checkExpectedKind hs_ty ty act_kind exp_kind + = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind) + + ; (new_args, act_kind') <- tcInstInvisibleTyBinders n_to_inst act_kind + + ; let origin = TypeEqOrigin { uo_actual = act_kind' + , uo_expected = exp_kind + , uo_thing = Just (ppr hs_ty) + , uo_visible = True } -- the hs_ty is visible + + ; traceTc "checkExpectedKindX" $ + vcat [ ppr hs_ty + , text "act_kind':" <+> ppr act_kind' + , text "exp_kind:" <+> ppr exp_kind ] + + ; let res_ty = ty `mkTcAppTys` new_args + + ; 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 + ; traceTc "checkExpectedKind" (vcat [ ppr act_kind + , ppr exp_kind + , ppr co_k ]) + ; return (res_ty `mkTcCastTy` co_k) } } + where + -- We need to make sure that both kinds have the same number of implicit + -- foralls out front. If the actual kind has more, instantiate accordingly. + -- Otherwise, just pass the type & kind through: the errors are caught + -- in unifyType. + n_exp_invis_bndrs = invisibleTyBndrCount exp_kind + n_act_invis_bndrs = invisibleTyBndrCount act_kind + n_to_inst = n_act_invis_bndrs - n_exp_invis_bndrs + +--------------------------- +tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType] +tcHsMbContext Nothing = return [] +tcHsMbContext (Just cxt) = tcHsContext cxt + +tcHsContext :: LHsContext GhcRn -> TcM [PredType] +tcHsContext = tc_hs_context typeLevelMode + +tcLHsPredType :: LHsType GhcRn -> TcM PredType +tcLHsPredType = tc_lhs_pred typeLevelMode + +tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType] +tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt) + +tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType +tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind + +--------------------------- +tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind) +-- See Note [Type checking recursive type and class declarations] +-- in GHC.Tc.TyCl +tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon + = do { traceTc "lk1" (ppr name) + ; thing <- tcLookup name + ; case thing of + ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) + + ATcTyCon tc_tc + -> do { -- See Note [GADT kind self-reference] + unless (isTypeLevel (mode_level mode)) + (promotionErr name TyConPE) + ; check_tc tc_tc + ; return (mkTyConTy tc_tc, tyConKind tc_tc) } + + AGlobal (ATyCon tc) + -> do { check_tc tc + ; return (mkTyConTy tc, tyConKind tc) } + + AGlobal (AConLike (RealDataCon dc)) + -> do { data_kinds <- xoptM LangExt.DataKinds + ; unless (data_kinds || specialPromotedDc dc) $ + promotionErr name NoDataKindsDC + ; when (isFamInstTyCon (dataConTyCon dc)) $ + -- 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 () + ; let tc = promoteDataCon dc + ; return (mkTyConApp tc [], tyConKind tc) } + + APromotionErr err -> promotionErr name err + + _ -> wrongThingErr "type" thing name } + where + check_tc :: TyCon -> TcM () + check_tc tc = do { data_kinds <- xoptM LangExt.DataKinds + ; unless (isTypeLevel (mode_level mode) || + data_kinds || + isKindTyCon tc) $ + promotionErr name NoDataKindsTC } + + -- 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) + +{- +Note [GADT kind self-reference] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A promoted type cannot be used in the body of that type's declaration. +#11554 shows this example, which made GHC loop: + + import Data.Kind + data P (x :: k) = Q + data A :: Type where + B :: forall (a :: A). P a -> A + +In order to check the constructor B, we need to have the promoted type A, but in +order to get that promoted type, B must first be checked. To prevent looping, a +TyConPE promotion error is given when tcTyVar checks an ATcTyCon in kind mode. +Any ATcTyCon is a TyCon being defined in the current recursive group (see data +type decl for TcTyThing), and all such TyCons are illegal in kinds. + +#11962 proposes checking the head of a data declaration separately from +its constructors. This would allow the example above to pass. + +Note [Body kind of a HsForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The body of a forall is usually a type, but in principle +there's no reason to prohibit *unlifted* types. +In fact, GHC can itself construct a function with an +unboxed tuple inside a for-all (via CPR analysis; see +typecheck/should_compile/tc170). + +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 +wrong. For example: + + class C a b + newtype N = Mk Foo deriving (C a) + +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. + +Note [Body kind of a HsQualTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If ctxt is non-empty, the HsQualTy really is a /function/, so the +kind of the result really is '*', and in that case the kind of the +body-type can be lifted or unlifted. + +However, consider + instance Eq a => Eq [a] where ... +or + f :: (Eq a => Eq [a]) => blah +Here both body-kind of the HsQualTy is Constraint rather than *. +Rather crudely we tell the difference by looking at exp_kind. It's +very convenient to typecheck instance types like any other HsSigType. + +Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's +better to reject in checkValidType. If we say that the body kind +should be '*' we risk getting TWO error messages, one saying that Eq +[a] doesn't have kind '*', and one saying that we need a Constraint to +the left of the outer (=>). + +How do we figure out the right body kind? Well, it's a bit of a +kludge: I just look at the expected kind. If it's Constraint, we +must be in this instance situation context. It's a kludge because it +wouldn't work if any unification was involved to compute that result +kind -- but it isn't. (The true way might be to use the 'mode' +parameter, but that seemed like a sledgehammer to crack a nut.) + +Note [Inferring tuple kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple, +we try to figure out whether it's a tuple of kind * or Constraint. + Step 1: look at the expected kind + Step 2: infer argument kinds + +If after Step 2 it's not clear from the arguments that it's +Constraint, then it must be *. Once having decided that we re-check +the arguments to give good error messages in + e.g. (Maybe, Maybe) + +Note that we will still fail to infer the correct kind in this case: + + type T a = ((a,a), D a) + type family D :: Constraint -> Constraint + +While kind checking T, we do not yet know the kind of D, so we will default the +kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. + +Note [Desugaring types] +~~~~~~~~~~~~~~~~~~~~~~~ +The type desugarer is phase 2 of dealing with HsTypes. Specifically: + + * It transforms from HsType to Type + + * 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. + - 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 + it will never subsequently be zonked. + +You might worry about nested scopes: + ..a:kappa in scope.. + let f :: forall b. T '[a,b] -> Int +In this case, f's type could have a mutable kind variable kappa in it; +and we might then default it to (Any *) when dealing with f's type +signature. But we don't expect this to happen because we can't get a +lexically scoped type variable with a mutable kind variable in it. A +delicate point, this. If it becomes an issue we might need to +distinguish top-level from nested uses. + +Moreover + * it cannot fail, + * it does no unifications + * it does no validity checking, except for structural matters, such as + (a) spurious ! annotations. + (b) a class used as a type + +Note [Kind of a type splice] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these terms, each with TH type splice inside: + [| e1 :: Maybe $(..blah..) |] + [| e2 :: $(..blah..) |] +When kind-checking the type signature, we'll kind-check the splice +$(..blah..); we want to give it a kind that can fit in any context, +as if $(..blah..) :: forall k. k. + +In the e1 example, the context of the splice fixes kappa to *. But +in the e2 example, we'll desugar the type, zonking the kind unification +variables as we go. When we encounter the unconstrained kappa, we +want to default it to '*', not to (Any *). + +Help functions for type applications +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-} + +addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a + -- Wrap a context around only if we want to show that contexts. + -- Omit invisible ones and ones user's won't grok +addTypeCtxt (L _ (HsWildCardTy _)) thing = thing -- "In the type '_'" just isn't helpful. +addTypeCtxt (L _ ty) thing + = addErrCtxt doc thing + where + doc = text "In the type" <+> quotes (ppr ty) + +{- +************************************************************************ +* * + Type-variable binders +%* * +%************************************************************************ + +Note [Keeping implicitly quantified variables in order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the user implicitly quantifies over variables (say, in a type +signature), we need to come up with some ordering on these variables. +This is done by bumping the TcLevel, bringing the tyvars into scope, +and then type-checking the thing_inside. The constraints are all +wrapped in an implication, which is then solved. Finally, we can +zonk all the binders and then order them with scopedSort. + +It's critical to solve before zonking and ordering in order to uncover +any unifications. You might worry that this eager solving could cause +trouble elsewhere. I don't think it will. Because it will solve only +in an increased TcLevel, it can't unify anything that was mentioned +elsewhere. Additionally, we require that the order of implicitly +quantified variables is manifest by the scope of these variables, so +we're not going to learn more information later that will help order +these variables. + +Note [Recipe for checking a signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Checking a user-written signature requires several steps: + + 1. Generate constraints. + 2. Solve constraints. + 3. Promote tyvars and/or kind-generalize. + 4. Zonk. + 5. Check validity. + +There may be some surprises in here: + +Step 2 is necessary for two reasons: most signatures also bring +implicitly quantified variables into scope, and solving is necessary +to get these in the right order (see Note [Keeping implicitly +quantified variables in order]). Additionally, solving is necessary in +order to kind-generalize correctly: otherwise, we do not know which +metavariables are left unsolved. + +Step 3 is done by a call to candidateQTyVarsOfType, followed by a call to +kindGeneralize{All,Some,None}. Here, we have to deal with the fact that +metatyvars generated in the type may have a bumped TcLevel, because explicit +foralls raise the TcLevel. To avoid these variables from ever being visible in +the surrounding context, we must obey the following dictum: + + Every metavariable in a type must either be + (A) generalized, or + (B) promoted, or See Note [Promotion in signatures] + (C) a cause to error See Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType + +The kindGeneralize functions do not require pre-zonking; they zonk as they +go. + +If you are actually doing kind-generalization, you need to bump the level +before generating constraints, as we will only generalize variables with +a TcLevel higher than the ambient one. + +After promoting/generalizing, we need to zonk again because both +promoting and generalizing fill in metavariables. + +Note [Promotion in signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If an unsolved metavariable in a signature is not generalized +(because we're not generalizing the construct -- e.g., pattern +sig -- or because the metavars are constrained -- see kindGeneralizeSome) +we need to promote to maintain (WantedTvInv) of Note [TcLevel and untouchable type variables] +in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing +and the reinstantiating with a fresh metavariable at the current level. +So in some sense, we generalize *all* variables, but then re-instantiate +some of them. + +Here is an example of why we must promote: + foo (x :: forall a. a -> Proxy b) = ... + +In the pattern signature, `b` is unbound, and will thus be brought into +scope. We do not know its kind: it will be assigned kappa[2]. Note that +kappa is at TcLevel 2, because it is invented under a forall. (A priori, +the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel +than the surrounding context.) This kappa cannot be solved for while checking +the pattern signature (which is not kind-generalized). When we are checking +the *body* of foo, though, we need to unify the type of x with the argument +type of bar. At this point, the ambient TcLevel is 1, and spotting a +matavariable with level 2 would violate the (WantedTvInv) invariant of +Note [TcLevel and untouchable type variables]. So, instead of kind-generalizing, +we promote the metavariable to level 1. This is all done in kindGeneralizeNone. + +-} + +tcNamedWildCardBinders :: [Name] + -> ([(Name, TcTyVar)] -> TcM a) + -> TcM a +-- Bring into scope the /named/ wildcard binders. Remember that +-- plain wildcards _ are anonymous and dealt with by HsWildCardTy +-- Soe Note [The wildcard story for types] in GHC.Hs.Types +tcNamedWildCardBinders wc_names thing_inside + = do { wcs <- mapM (const newWildTyVar) wc_names + ; let wc_prs = wc_names `zip` wcs + ; tcExtendNameTyVarEnv wc_prs $ + thing_inside wc_prs } + +newWildTyVar :: TcM TcTyVar +-- ^ New unification variable '_' for a wildcard +newWildTyVar + = do { kind <- newMetaKindVar + ; uniq <- newUnique + ; details <- newMetaDetails TauTv + ; let name = mkSysTvName uniq (fsLit "_") + tyvar = mkTcTyVar name kind details + ; traceTc "newWildTyVar" (ppr tyvar) + ; return tyvar } + +{- ********************************************************************* +* * + Kind inference for type declarations +* * +********************************************************************* -} + +-- See Note [kcCheckDeclHeader vs kcInferDeclHeader] +data InitialKindStrategy + = InitialKindCheck SAKS_or_CUSK + | InitialKindInfer + +-- Does the declaration have a standalone kind signature (SAKS) or a complete +-- user-specified kind (CUSK)? +data SAKS_or_CUSK + = SAKS Kind -- Standalone kind signature, fully zonked! (zonkTcTypeToType) + | CUSK -- Complete user-specified kind (CUSK) + +instance Outputable SAKS_or_CUSK where + ppr (SAKS k) = text "SAKS" <+> ppr k + ppr CUSK = text "CUSK" + +-- 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 +kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig +kcDeclHeader InitialKindInfer = kcInferDeclHeader + +{- Note [kcCheckDeclHeader vs kcInferDeclHeader] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind +of a type constructor. + +* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that + case, find the full, final, poly-kinded kind of the TyCon. It's very like a + term-level binding where we have a complete type signature for the function. + +* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a + CUSK. Find a monomorphic kind, with unification variables in it; they will be + generalised later. It's very like a term-level binding where we do not have a + type signature (or, more accurately, where we have a partial type signature), + so we infer the type and generalise. +-} + +------------------------------ +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 TcTyCon -- ^ 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 TcTyCon -- ^ A suitably-kinded generalized TcTyCon +kcCheckDeclHeader_cusk name flav + (HsQTvs { hsq_ext = kv_ns + , hsq_explicit = hs_tvs }) kc_res_ki + -- CUSK case + -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + = addTyConFlavCtxt name flav $ + do { (scoped_kvs, (tc_tvs, res_kind)) + <- pushTcLevelM_ $ + solveEqualities $ + bindImplicitTKBndrs_Q_Skol kv_ns $ + bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $ + newExpectedKind =<< kc_res_ki + + -- Now, because we're in a CUSK, + -- we quantify over the mentioned kind vars + ; let spec_req_tkvs = scoped_kvs ++ tc_tvs + all_kinds = res_kind : map tyVarKind spec_req_tkvs + + ; candidates' <- candidateQTyVarsOfKinds all_kinds + -- 'candidates' are all the variables that we are going to + -- skolemise and then quantify over. We do not include spec_req_tvs + -- because they are /already/ skolems + + ; let non_tc_candidates = filter (not . isTcTyVar) (nonDetEltsUniqSet (tyCoVarsOfTypes all_kinds)) + candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates } + inf_candidates = candidates `delCandidates` spec_req_tkvs + + ; inferred <- quantifyTyVars inf_candidates + -- NB: 'inferred' comes back sorted in dependency order + + ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs + ; tc_tvs <- mapM zonkTyCoVarKind tc_tvs + ; res_kind <- zonkTcType res_kind + + ; let mentioned_kv_set = candidateKindVars candidates + specified = scopedSort scoped_kvs + -- NB: maintain the L-R order of scoped_kvs + + final_tc_binders = mkNamedTyConBinders Inferred inferred + ++ mkNamedTyConBinders Specified specified + ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs + + all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) + tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs + True -- it is generalised + flav + -- If the ordering from + -- Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + -- doesn't work, we catch it here, before an error cascade + ; checkTyConTelescope tycon + + ; traceTc "kcCheckDeclHeader_cusk " $ + vcat [ text "name" <+> ppr name + , text "kv_ns" <+> ppr kv_ns + , text "hs_tvs" <+> ppr hs_tvs + , text "scoped_kvs" <+> ppr scoped_kvs + , text "tc_tvs" <+> ppr tc_tvs + , text "res_kind" <+> ppr res_kind + , text "candidates" <+> ppr candidates + , text "inferred" <+> ppr inferred + , text "specified" <+> ppr specified + , text "final_tc_binders" <+> ppr final_tc_binders + , text "mkTyConKind final_tc_bndrs res_kind" + <+> ppr (mkTyConKind final_tc_binders res_kind) + , text "all_tv_prs" <+> ppr all_tv_prs ] + + ; return tycon } + where + ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind + | otherwise = AnyKind + +-- | 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 + -> LHsQTyVars GhcRn + -> TcM ContextKind -- ^ The result kind + -> TcM TcTyCon -- ^ A suitably-kinded non-generalized TcTyCon +kcInferDeclHeader name flav + (HsQTvs { hsq_ext = kv_ns + , hsq_explicit = hs_tvs }) kc_res_ki + -- No standalane 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)) + -- 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 $ + newExpectedKind =<< kc_res_ki + -- Why "_Tv" not "_Skol"? See third wrinkle in + -- Note [Inferring kinds for type declarations] in GHC.Tc.TyCl, + + ; let -- NB: Don't add scoped_kvs to tyConTyVars, because they + -- might unify with kind vars in other types in a mutually + -- recursive group. + -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + + tc_binders = mkAnonTyConBinders VisArg 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 + -- + -- mkAnonTyConBinder: see Note [No polymorphic recursion] + + all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) + -- NB: bindExplicitTKBndrs_Q_Tv does not clone; + -- ditto Implicit + -- See Note [Non-cloning for tyvar binders] + + tycon = mkTcTyCon name tc_binders res_kind all_tv_prs + False -- not yet generalised + flav + + ; traceTc "kcInferDeclHeader: not-cusk" $ + vcat [ ppr name, ppr kv_ns, ppr hs_tvs + , ppr scoped_kvs + , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ] + ; return tycon } + where + ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind + | otherwise = AnyKind + +-- | Kind-check a declaration header against a standalone kind signature. +-- See Note [Arity inference in 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 TcTyCon -- ^ A suitably-kinded TcTyCon +kcCheckDeclHeader_sig kisig name flav + (HsQTvs { hsq_ext = implicit_nms + , hsq_explicit = explicit_nms }) kc_res_ki + = addTyConFlavCtxt name flav $ + do { -- Step 1: zip user-written binders with quantifiers from the kind signature. + -- For example: + -- + -- type F :: forall k -> k -> forall j. j -> Type + -- data F i a b = ... + -- + -- Results in the following 'zipped_binders': + -- + -- TyBinder LHsTyVarBndr + -- --------------------------------------- + -- ZippedBinder forall k -> i + -- ZippedBinder k -> a + -- ZippedBinder forall j. + -- ZippedBinder j -> b + -- + let (zipped_binders, excess_bndrs, kisig') = zipBinders kisig explicit_nms + + -- Report binders that don't have a corresponding quantifier. + -- For example: + -- + -- type T :: Type -> Type + -- data T b1 b2 b3 = ... + -- + -- Here, b1 is zipped with Type->, while b2 and b3 are excess binders. + -- + ; unless (null excess_bndrs) $ failWithTc (tooManyBindersErr kisig' excess_bndrs) + + -- Convert each ZippedBinder to TyConBinder for tyConBinders + -- and to [(Name, TcTyVar)] for tcTyConScopedTyVars + ; (vis_tcbs, concat -> explicit_tv_prs) <- mapAndUnzipM zipped_to_tcb zipped_binders + + ; (implicit_tvs, (invis_binders, r_ki)) + <- pushTcLevelM_ $ + solveEqualities $ -- #16687 + bindImplicitTKBndrs_Tv implicit_nms $ + tcExtendNameTyVarEnv explicit_tv_prs $ + do { -- Check that inline kind annotations on binders are valid. + -- For example: + -- + -- type T :: Maybe k -> Type + -- data T (a :: Maybe j) = ... + -- + -- Here we unify Maybe k ~ Maybe j + mapM_ check_zipped_binder zipped_binders + + -- 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'. + ; ctx_k <- kc_res_ki + ; m_res_ki <- case ctx_k of + AnyKind -> return Nothing + _ -> Just <$> newExpectedKind ctx_k + + -- Step 2: split off invisible binders. + -- For example: + -- + -- type F :: forall k1 k2. (k1, k2) -> Type + -- type family F + -- + -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'? + -- See Note [Arity inference in kcCheckDeclHeader_sig] + ; let (invis_binders, r_ki) = split_invis kisig' m_res_ki + + -- Check that the inline result kind annotation is valid. + -- For example: + -- + -- type T :: Type -> Maybe k + -- type family T a :: Maybe j where + -- + -- Here we unify Maybe k ~ Maybe j + ; whenIsJust m_res_ki $ \res_ki -> + discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] + unifyKind Nothing r_ki res_ki + + ; return (invis_binders, r_ki) } + + -- Zonk the implicitly quantified variables. + ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs + + -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders. + ; invis_tcbs <- mapM invis_to_tcb invis_binders + + -- Build the final, generalized TcTyCon + ; let tcbs = vis_tcbs ++ invis_tcbs + implicit_tv_prs = implicit_nms `zip` implicit_tvs + all_tv_prs = implicit_tv_prs ++ explicit_tv_prs + tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav + + ; traceTc "kcCheckDeclHeader_sig done:" $ vcat + [ text "tyConName = " <+> ppr (tyConName tc) + , text "kisig =" <+> debugPprType kisig + , text "tyConKind =" <+> debugPprType (tyConKind tc) + , text "tyConBinders = " <+> ppr (tyConBinders tc) + , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc) + , text "tyConResKind" <+> debugPprType (tyConResKind tc) + ] + ; return tc } + where + -- Consider this declaration: + -- + -- type T :: forall a. forall b -> (a~b) => Proxy a -> Type + -- data T x p = MkT + -- + -- Here, we have every possible variant of ZippedBinder: + -- + -- TyBinder LHsTyVarBndr + -- ---------------------------------------------- + -- ZippedBinder forall {k}. + -- ZippedBinder forall (a::k). + -- ZippedBinder forall (b::k) -> x + -- ZippedBinder (a~b) => + -- ZippedBinder Proxy a -> p + -- + -- Given a ZippedBinder zipped_to_tcb produces: + -- + -- * TyConBinder for tyConBinders + -- * (Name, TcTyVar) for tcTyConScopedTyVars, if there's a user-written LHsTyVarBndr + -- + zipped_to_tcb :: ZippedBinder -> TcM (TyConBinder, [(Name, TcTyVar)]) + zipped_to_tcb zb = case zb of + + -- Inferred variable, no user-written binder. + -- Example: forall {k}. + ZippedBinder (Named (Bndr v Specified)) Nothing -> + return (mkNamedTyConBinder Specified v, []) + + -- Specified variable, no user-written binder. + -- Example: forall (a::k). + ZippedBinder (Named (Bndr v Inferred)) Nothing -> + return (mkNamedTyConBinder Inferred v, []) + + -- Constraint, no user-written binder. + -- Example: (a~b) => + ZippedBinder (Anon InvisArg bndr_ki) Nothing -> do + name <- newSysName (mkTyVarOccFS (fsLit "ev")) + let tv = mkTyVar name bndr_ki + return (mkAnonTyConBinder InvisArg tv, []) + + -- Non-dependent visible argument with a user-written binder. + -- Example: Proxy a -> + ZippedBinder (Anon VisArg bndr_ki) (Just b) -> + return $ + let v_name = getName b + tv = mkTyVar v_name bndr_ki + tcb = mkAnonTyConBinder VisArg tv + in (tcb, [(v_name, tv)]) + + -- Dependent visible argument with a user-written binder. + -- Example: forall (b::k) -> + ZippedBinder (Named (Bndr v Required)) (Just b) -> + return $ + let v_name = getName b + tcb = mkNamedTyConBinder Required v + in (tcb, [(v_name, v)]) + + -- 'zipBinders' does not produce any other variants of ZippedBinder. + _ -> panic "goVis: invalid ZippedBinder" + + -- Given an invisible binder that comes from 'split_invis', + -- convert it to TyConBinder. + invis_to_tcb :: TyCoBinder -> TcM TyConBinder + invis_to_tcb tb = do + (tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing) + MASSERT(null stv) + return tcb + + -- Check that the inline kind annotation on a binder is valid + -- by unifying it with the kind of the quantifier. + check_zipped_binder :: ZippedBinder -> TcM () + check_zipped_binder (ZippedBinder _ Nothing) = return () + check_zipped_binder (ZippedBinder tb (Just b)) = + case unLoc b of + UserTyVar _ _ -> return () + KindedTyVar _ v v_hs_ki -> do + v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki + discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] + unifyKind (Just (HsTyVar noExtField NotPromoted v)) + (tyBinderType tb) + v_ki + + -- Split the invisible binders that should become a part of 'tyConBinders' + -- rather than 'tyConResKind'. + -- See Note [Arity inference in kcCheckDeclHeader_sig] + split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind) + split_invis sig_ki Nothing = + -- instantiate all invisible binders + splitPiTysInvisible sig_ki + split_invis sig_ki (Just res_ki) = + -- subtraction a la checkExpectedKind + let n_res_invis_bndrs = invisibleTyBndrCount res_ki + n_sig_invis_bndrs = invisibleTyBndrCount sig_ki + n_inst = n_sig_invis_bndrs - n_res_invis_bndrs + in splitPiTysInvisibleN n_inst sig_ki + +-- A quantifier from a kind signature zipped with a user-written binder for it. +data ZippedBinder = + ZippedBinder TyBinder (Maybe (LHsTyVarBndr GhcRn)) + +-- See Note [Arity inference in kcCheckDeclHeader_sig] +zipBinders + :: Kind -- kind signature + -> [LHsTyVarBndr GhcRn] -- user-written binders + -> ([ZippedBinder], -- zipped binders + [LHsTyVarBndr GhcRn], -- remaining user-written binders + Kind) -- remainder of the kind signature +zipBinders = zip_binders [] + where + zip_binders acc ki [] = (reverse acc, [], ki) + zip_binders acc ki (b:bs) = + case tcSplitPiTy_maybe ki of + Nothing -> (reverse acc, b:bs, ki) + Just (tb, ki') -> + let + (zb, bs') | zippable = (ZippedBinder tb (Just b), bs) + | otherwise = (ZippedBinder tb Nothing, b:bs) + zippable = + case tb of + Named (Bndr _ Specified) -> False + Named (Bndr _ Inferred) -> False + Named (Bndr _ Required) -> True + Anon InvisArg _ -> False + Anon VisArg _ -> True + in + zip_binders (zb:acc) ki' bs' + +tooManyBindersErr :: Kind -> [LHsTyVarBndr GhcRn] -> SDoc +tooManyBindersErr ki bndrs = + hang (text "Not a function kind:") + 4 (ppr ki) $$ + hang (text "but extra binders found:") + 4 (fsep (map ppr bndrs)) + +{- Note [Arity inference in kcCheckDeclHeader_sig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig +verifies that the declaration conforms to the signature. The end result is a +TcTyCon 'tc' such that: + + tyConKind tc == kisig + +This TcTyCon would be rather easy to produce if we didn't have to worry about +arity. Consider these declarations: + + type family S1 :: forall k. k -> Type + type family S2 (a :: k) :: Type + +Both S1 and S2 can be given the same standalone kind signature: + + type S2 :: forall k. k -> Type + +And, indeed, tyConKind S1 == tyConKind S2. However, tyConKind is built from +tyConBinders and tyConResKind, such that + + tyConKind tc == mkTyConKind (tyConBinders tc) (tyConResKind tc) + +For S1 and S2, tyConBinders and tyConResKind are different: + + tyConBinders S1 == [] + tyConResKind S1 == forall k. k -> Type + tyConKind S1 == forall k. k -> Type + + tyConBinders S2 == [spec k, anon-vis (a :: k)] + tyConResKind S2 == Type + tyConKind S1 == forall k. k -> Type + +This difference determines the arity: + + tyConArity tc == length (tyConBinders tc) + +That is, the arity of S1 is 0, while the arity of S2 is 2. + +'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone +kind signature into binders and the result kind. It does so in two rounds: + +1. zip user-written binders (vis_tcbs) +2. split off invisible binders (invis_tcbs) + +Consider the following declarations: + + type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type + type family F a b + + type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type + type family G a b :: forall r2. (r1, r2) -> Type + +In step 1 (zip user-written binders), we zip the quantifiers in the signature +with the binders in the header using 'zipBinders'. In both F and G, this results in +the following zipped binders: + + TyBinder LHsTyVarBndr + --------------------------------------- + ZippedBinder Type -> a + ZippedBinder forall j. + ZippedBinder j -> b + + +At this point, we have accumulated three zipped binders which correspond to a +prefix of the standalone kind signature: + + Type -> forall j. j -> ... + +In step 2 (split off invisible binders), we have to decide how much remaining +invisible binders of the standalone kind signature to split off: + + forall k1 k2. (k1, k2) -> Type + ^^^^^^^^^^^^^ + split off or not? + +This decision is made in 'split_invis': + +* If a user-written result kind signature is not provided, as in F, + then split off all invisible binders. This is why we need special treatment + for AnyKind. +* If a user-written result kind signature is provided, as in G, + then do as checkExpectedKind does and split off (n_sig - n_res) binders. + That is, split off such an amount of binders that the remainder of the + standalone kind signature and the user-written result kind signature have the + same amount of invisible quantifiers. + +For F, split_invis splits away all invisible binders, and we have 2: + + forall k1 k2. (k1, k2) -> Type + ^^^^^^^^^^^^^ + split away both binders + +The resulting arity of F is 3+2=5. (length vis_tcbs = 3, + length invis_tcbs = 2, + length tcbs = 5) + +For G, split_invis decides to split off 1 invisible binder, so that we have the +same amount of invisible quantifiers left: + + res_ki = forall r2. (r1, r2) -> Type + kisig = forall k1 k2. (k1, k2) -> Type + ^^^ + split off this one. + +The resulting arity of G is 3+1=4. (length vis_tcbs = 3, + length invis_tcbs = 1, + length tcbs = 4) + +-} + +{- Note [discardResult in kcCheckDeclHeader_sig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use 'unifyKind' to check inline kind annotations in declaration headers +against the signature. + + type T :: [i] -> Maybe j -> Type + data T (a :: [k1]) (b :: Maybe k2) :: Type where ... + +Here, we will unify: + + [k1] ~ [i] + Maybe k2 ~ Maybe j + Type ~ Type + +The end result is that we fill in unification variables k1, k2: + + k1 := i + k2 := j + +We also validate that the user isn't confused: + + type T :: Type -> Type + data T (a :: Bool) = ... + +This will report that (Type ~ Bool) failed to unify. + +Now, consider the following example: + + type family Id a where Id x = x + type T :: Bool -> Type + type T (a :: Id Bool) = ... + +We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion. +However, we are free to discard it, as the kind of 'T' is determined by the +signature, not by the inline kind annotation: + + we have T :: Bool -> Type + rather than T :: Id Bool -> Type + +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-checking tyvar binders for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When kind-checking the type-variable binders for associated + data/newtype decls + family decls +we behave specially for type variables that are already in scope; +that is, bound by the enclosing class decl. This is done in +kcLHsQTyVarBndrs: + * The use of tcImplicitQTKBndrs + * The tcLookupLocal_maybe code in kc_hs_tv + +See Note [Associated type tyvar names] in GHC.Core.Class and + Note [TyVar binders for associated decls] in GHC.Hs.Decls + +We must do the same for family instance decls, where the in-scope +variables may be bound by the enclosing class instance decl. +Hence the use of tcImplicitQTKBndrs in tcFamTyPatsAndGen. + +Note [Kind variable ordering for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should be the kind of `T` in the following example? (#15591) + + class C (a :: Type) where + type T (x :: f a) + +As per Note [Ordering of implicit variables] in GHC.Rename.HsType, we want to quantify +the kind variables in left-to-right order of first occurrence in order to +support visible kind application. But we cannot perform this analysis on just +T alone, since its variable `a` actually occurs /before/ `f` if you consider +the fact that `a` was previously bound by the parent class `C`. That is to say, +the kind of `T` should end up being: + + T :: forall a f. f a -> Type + +(It wouldn't necessarily be /wrong/ if the kind ended up being, say, +forall f a. f a -> Type, but that would not be as predictable for users of +visible kind application.) + +In contrast, if `T` were redefined to be a top-level type family, like `T2` +below: + + type family T2 (x :: f (a :: Type)) + +Then `a` first appears /after/ `f`, so the kind of `T2` should be: + + T2 :: forall f a. f a -> Type + +In order to make this distinction, we need to know (in kcCheckDeclHeader) which +type variables have been bound by the parent class (if there is one). With +the class-bound variables in hand, we can ensure that we always quantify +these first. +-} + + +{- ********************************************************************* +* * + Expected kinds +* * +********************************************************************* -} + +-- | Describes the kind expected in a certain context. +data ContextKind = TheKind Kind -- ^ a specific kind + | AnyKind -- ^ any kind will do + | OpenKind -- ^ something of the form @TYPE _@ + +----------------------- +newExpectedKind :: ContextKind -> TcM Kind +newExpectedKind (TheKind k) = return k +newExpectedKind AnyKind = newMetaKindVar +newExpectedKind OpenKind = newOpenTypeKind + +----------------------- +expectedKindInCtxt :: UserTypeCtxt -> ContextKind +-- Depending on the context, we might accept any kind (for instance, in a TH +-- splice), or only certain kinds (like in type signatures). +expectedKindInCtxt (TySynCtxt _) = AnyKind +expectedKindInCtxt ThBrackCtxt = AnyKind +expectedKindInCtxt (GhciCtxt {}) = AnyKind +-- The types in a 'default' decl can have varying kinds +-- See Note [Extended defaults]" in GHC.Tc.Utils.Env +expectedKindInCtxt DefaultDeclCtxt = AnyKind +expectedKindInCtxt TypeAppCtxt = AnyKind +expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind +expectedKindInCtxt (InstDeclCtxt {}) = TheKind constraintKind +expectedKindInCtxt SpecInstCtxt = TheKind constraintKind +expectedKindInCtxt _ = OpenKind + + +{- ********************************************************************* +* * + Bringing type variables into scope +* * +********************************************************************* -} + +{- Note [Non-cloning for tyvar binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +bindExplictTKBndrs_Q_Skol, bindExplictTKBndrs_Skol, do not clone; +and nor do the Implicit versions. There is no need. + +bindExplictTKBndrs_Q_Tv does not clone; and similarly Implicit. +We take advantage of this in kcInferDeclHeader: + all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) +If we cloned, we'd need to take a bit more care here; not hard. + +The main payoff is that avoidng gratuitious cloning means that we can +almost always take the fast path in swizzleTcTyConBndrs. "Almost +always" means not the case of mutual recursion with polymorphic kinds. + + +Note [Cloning for tyvar binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +bindExplicitTKBndrs_Tv does cloning, making up a Name with a fresh Unique, +unlike bindExplicitTKBndrs_Q_Tv. (Nor do the Skol variants clone.) +And similarly for bindImplicit... + +This for a narrow and tricky reason which, alas, I couldn't find a +simpler way round. #16221 is the poster child: + + data SameKind :: k -> k -> * + data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int + +When kind-checking T, we give (a :: kappa1). Then: + +- In kcConDecl we make a TyVarTv unification variable kappa2 for k2 + (as described in Note [Kind-checking for GADTs], even though this + example is an existential) +- So we get (b :: kappa2) via bindExplicitTKBndrs_Tv +- We end up unifying kappa1 := kappa2, because of the (SameKind a b) + +Now we generalise over kappa2. But if kappa2's Name is precisely k2 +(i.e. we did not clone) we'll end up giving T the utterlly final kind + T :: forall k2. k2 -> * +Nothing directly wrong with that but when we typecheck the data constructor +we have k2 in scope; but then it's brought into scope /again/ when we find +the forall k2. This is chaotic, and we end up giving it the type + MkT :: forall k2 (a :: k2) k2 (b :: k2). + SameKind @k2 a b -> Int -> T @{k2} a +which is bogus -- because of the shadowing of k2, we can't +apply T to the kind or a! + +And there no reason /not/ to clone the Name when making a unification +variable. So that's what we do. +-} + +-------------------------------------- +-- Implicit binders +-------------------------------------- + +bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv, + bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv + :: [Name] -> TcM a -> TcM ([TcTyVar], a) +bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedSkolemTyVar) +bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedTyVarTyVar) +bindImplicitTKBndrs_Skol = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar +bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX cloneFlexiKindedTyVarTyVar + -- newFlexiKinded... see Note [Non-cloning for tyvar binders] + -- cloneFlexiKindedTyVarTyVar: see Note [Cloning for tyvar binders] + +bindImplicitTKBndrsX + :: (Name -> TcM TcTyVar) -- new_tv function + -> [Name] + -> TcM a + -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence + -- with the passed in [Name] +bindImplicitTKBndrsX new_tv tv_names thing_inside + = do { tkvs <- mapM new_tv tv_names + ; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs) + ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs) + thing_inside + ; return (tkvs, res) } + +newImplicitTyVarQ :: (Name -> TcM TcTyVar) -> Name -> TcM TcTyVar +-- Behave like new_tv, except that if the tyvar is in scope, use it +newImplicitTyVarQ new_tv name + = do { mb_tv <- tcLookupLcl_maybe name + ; case mb_tv of + Just (ATyVar _ tv) -> return tv + _ -> new_tv name } + +newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar +newFlexiKindedTyVar new_tv name + = do { kind <- newMetaKindVar + ; new_tv name kind } + +newFlexiKindedSkolemTyVar :: Name -> TcM TyVar +newFlexiKindedSkolemTyVar = newFlexiKindedTyVar newSkolemTyVar + +newFlexiKindedTyVarTyVar :: Name -> TcM TyVar +newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar + +cloneFlexiKindedTyVarTyVar :: Name -> TcM TyVar +cloneFlexiKindedTyVarTyVar = newFlexiKindedTyVar cloneTyVarTyVar + -- See Note [Cloning for tyvar binders] + +-------------------------------------- +-- Explicit binders +-------------------------------------- + +bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv + :: [LHsTyVarBndr GhcRn] + -> TcM a + -> TcM ([TcTyVar], a) + +bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar) +bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (tcHsTyVarBndr cloneTyVarTyVar) + -- newSkolemTyVar: see Note [Non-cloning for tyvar binders] + -- cloneTyVarTyVar: see Note [Cloning for tyvar binders] + +bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv + :: ContextKind + -> [LHsTyVarBndr GhcRn] + -> TcM a + -> TcM ([TcTyVar], a) + +bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar) +bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar) + -- See Note [Non-cloning for tyvar binders] + + +bindExplicitTKBndrsX + :: (HsTyVarBndr GhcRn -> TcM TcTyVar) + -> [LHsTyVarBndr GhcRn] + -> TcM a + -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence + -- with the passed-in [LHsTyVarBndr] +bindExplicitTKBndrsX tc_tv hs_tvs thing_inside + = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs) + ; go hs_tvs } + where + go [] = do { res <- thing_inside + ; return ([], res) } + go (L _ hs_tv : hs_tvs) + = do { tv <- tc_tv hs_tv + -- Extend the environment as we go, in case a binder + -- is mentioned in the kind of a later binder + -- e.g. forall k (a::k). blah + -- NB: tv's Name may differ from hs_tv's + -- See GHC.Tc.Utils.TcMType Note [Cloning for tyvar binders] + ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $ + go hs_tvs + ; return (tv:tvs, res) } + +----------------- +tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar) + -> HsTyVarBndr GhcRn -> TcM TcTyVar +tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm)) + = do { kind <- newMetaKindVar + ; new_tv tv_nm kind } +tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) + = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind + ; new_tv tv_nm kind } + +----------------- +tcHsQTyVarBndr :: ContextKind + -> (Name -> Kind -> TcM TyVar) + -> HsTyVarBndr GhcRn -> TcM TcTyVar +-- Just like tcHsTyVarBndr, but also +-- - uses the in-scope TyVar from class, if it exists +-- - takes a ContextKind to use for the no-sig case +tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ (L _ tv_nm)) + = do { mb_tv <- tcLookupLcl_maybe tv_nm + ; case mb_tv of + Just (ATyVar _ tv) -> return tv + _ -> do { kind <- newExpectedKind ctxt_kind + ; new_tv tv_nm kind } } + +tcHsQTyVarBndr _ new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) + = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind + ; mb_tv <- tcLookupLcl_maybe tv_nm + ; case mb_tv of + Just (ATyVar _ tv) + -> do { discardResult $ unifyKind (Just hs_tv) + kind (tyVarKind tv) + -- This unify rejects: + -- class C (m :: * -> *) where + -- type F (m :: *) = ... + ; return tv } + + _ -> new_tv tv_nm kind } + where + hs_tv = HsTyVar noExtField NotPromoted (noLoc tv_nm) + -- Used for error messages only + +-------------------------------------- +-- Binding type/class variables in the +-- kind-checking and typechecking phases +-------------------------------------- + +bindTyClTyVars :: Name + -> (TcTyCon -> [TyConBinder] -> Kind -> TcM a) -> TcM a +-- ^ Used for the type variables of a type or class decl +-- in the "kind checking" and "type checking" pass, +-- but not in the initial-kind run. +bindTyClTyVars tycon_name thing_inside + = do { tycon <- tcLookupTcTyCon tycon_name + ; let scoped_prs = tcTyConScopedTyVars tycon + res_kind = tyConResKind tycon + binders = tyConBinders tycon + ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs) + ; tcExtendNameTyVarEnv scoped_prs $ + thing_inside tycon binders res_kind } + + +{- ********************************************************************* +* * + Kind generalisation +* * +********************************************************************* -} + +zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] +zonkAndScopedSort spec_tkvs + = do { spec_tkvs <- mapM zonkAndSkolemise spec_tkvs + -- Use zonkAndSkolemise because a skol_tv might be a TyVarTv + + -- Do a stable topological sort, following + -- Note [Ordering of implicit variables] in GHC.Rename.HsType + ; return (scopedSort spec_tkvs) } + +-- | Generalize some of the free variables in the given type. +-- All such variables should be *kind* variables; any type variables +-- should be explicitly quantified (with a `forall`) before now. +-- The supplied predicate says which free variables to quantify. +-- But in all cases, +-- generalize only those variables whose TcLevel is strictly greater +-- than the ambient level. This "strictly greater than" means that +-- you likely need to push the level before creating whatever type +-- gets passed here. Any variable whose level is greater than the +-- ambient level but is not selected to be generalized will be +-- promoted. (See [Promoting unification variables] in GHC.Tc.Solver +-- and Note [Recipe for checking a signature].) +-- The resulting KindVar are the variables to +-- quantify over, in the correct, well-scoped order. They should +-- generally be Inferred, not Specified, but that's really up to +-- the caller of this function. +kindGeneralizeSome :: (TcTyVar -> Bool) + -> TcType -- ^ needn't be zonked + -> TcM [KindVar] +kindGeneralizeSome should_gen kind_or_type + = do { traceTc "kindGeneralizeSome {" (ppr kind_or_type) + + -- use the "Kind" variant here, as any types we see + -- here will already have all type variables quantified; + -- thus, every free variable is really a kv, never a tv. + ; dvs <- candidateQTyVarsOfKind kind_or_type + + -- So 'dvs' are the variables free in kind_or_type, with a level greater + -- than the ambient level, hence candidates for quantification + -- Next: filter out the ones we don't want to generalize (specified by should_gen) + -- and promote them instead + + ; let (to_promote, dvs') = partitionCandidates dvs (not . should_gen) + + ; (_, promoted) <- promoteTyVarSet (dVarSetToVarSet to_promote) + ; qkvs <- quantifyTyVars dvs' + + ; traceTc "kindGeneralizeSome }" $ + vcat [ text "Kind or type:" <+> ppr kind_or_type + , text "dvs:" <+> ppr dvs + , text "dvs':" <+> ppr dvs' + , text "to_promote:" <+> pprTyVars (dVarSetElems to_promote) + , text "promoted:" <+> pprTyVars (nonDetEltsUniqSet promoted) + , text "qkvs:" <+> pprTyVars qkvs ] + + ; return qkvs } + +-- | Specialized version of 'kindGeneralizeSome', but where all variables +-- can be generalized. Use this variant when you can be sure that no more +-- constraints on the type's metavariables will arise or be solved. +kindGeneralizeAll :: TcType -- needn't be zonked + -> TcM [KindVar] +kindGeneralizeAll ty = do { traceTc "kindGeneralizeAll" empty + ; kindGeneralizeSome (const True) ty } + +-- | Specialized version of 'kindGeneralizeSome', but where no variables +-- can be generalized, but perhaps some may neeed to be promoted. +-- Use this variant when it is unknowable whether metavariables might +-- later be constrained. +-- +-- To see why this promotion is needed, see +-- Note [Recipe for checking a signature], and especially +-- Note [Promotion in signatures]. +kindGeneralizeNone :: TcType -- needn't be zonked + -> TcM () +kindGeneralizeNone ty + = do { traceTc "kindGeneralizeNone" empty + ; kvs <- kindGeneralizeSome (const False) ty + ; MASSERT( null kvs ) + } + +{- Note [Levels and generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = e +with no type signature. We are currently at level i. +We must + * Push the level to level (i+1) + * Allocate a fresh alpha[i+1] for the result type + * Check that e :: alpha[i+1], gathering constraint WC + * Solve WC as far as possible + * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i] + * Find the free variables with level > i, in this case gamma[i] + * Skolemise those free variables and quantify over them, giving + f :: forall g. beta[i-1] -> g + * Emit the residiual constraint wrapped in an implication for g, + thus forall g. WC + +All of this happens for types too. Consider + f :: Int -> (forall a. Proxy a -> Int) + +Note [Kind generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do kind generalisation only at the outer level of a type signature. +For example, consider + T :: forall k. k -> * + f :: (forall a. T a -> Int) -> Int +When kind-checking f's type signature we generalise the kind at +the outermost level, thus: + f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES! +and *not* at the inner forall: + f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO! +Reason: same as for HM inference on value level declarations, +we want to infer the most general type. The f2 type signature +would be *less applicable* than f1, because it requires a more +polymorphic argument. + +NB: There are no explicit kind variables written in f's signature. +When there are, the renamer adds these kind variables to the list of +variables bound by the forall, so you can indeed have a type that's +higher-rank in its kind. But only by explicit request. + +Note [Kinds of quantified type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcTyVarBndrsGen quantifies over a specified list of type variables, +*and* over the kind variables mentioned in the kinds of those tyvars. + +Note that we must zonk those kinds (obviously) but less obviously, we +must return type variables whose kinds are zonked too. Example + (a :: k7) where k7 := k9 -> k9 +We must return + [k9, a:k9->k9] +and NOT + [k9, a:k7] +Reason: we're going to turn this into a for-all type, + forall k9. forall (a:k7). blah +which the type checker will then instantiate, and instantiate does not +look through unification variables! + +Hence using zonked_kinds when forming tvs'. + +-} + +----------------------------------- +etaExpandAlgTyCon :: [TyConBinder] + -> Kind -- must be zonked + -> TcM ([TyConBinder], Kind) +-- GADT decls can have a (perhaps partial) kind signature +-- e.g. data T a :: * -> * -> * where ... +-- This function makes up suitable (kinded) TyConBinders for the +-- argument kinds. E.g. in this case it might return +-- ([b::*, c::*], *) +-- Never emits constraints. +-- It's a little trickier than you might think: see +-- Note [TyConBinders for the result kind signature of a data type] +-- See Note [Datatype return kinds] in GHC.Tc.TyCl +etaExpandAlgTyCon tc_bndrs kind + = do { loc <- getSrcSpanM + ; uniqs <- newUniqueSupply + ; rdr_env <- getLocalRdrEnv + ; let new_occs = [ occ + | str <- allNameStrings + , let occ = mkOccName tvName str + , isNothing (lookupLocalRdrOcc rdr_env occ) + -- Note [Avoid name clashes for associated data types] + , not (occ `elem` lhs_occs) ] + new_uniqs = uniqsFromSupply uniqs + subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs)) + ; return (go loc new_occs new_uniqs subst [] kind) } + where + lhs_tvs = map binderVar tc_bndrs + lhs_occs = map getOccName lhs_tvs + + go loc occs uniqs subst acc kind + = case splitPiTy_maybe kind of + Nothing -> (reverse acc, substTy subst kind) + + Just (Anon af arg, kind') + -> go loc occs' uniqs' subst' (tcb : acc) kind' + where + arg' = substTy subst arg + tv = mkTyVar (mkInternalName uniq occ loc) arg' + subst' = extendTCvInScope subst tv + tcb = Bndr tv (AnonTCB af) + (uniq:uniqs') = uniqs + (occ:occs') = occs + + Just (Named (Bndr tv vis), kind') + -> go loc occs uniqs subst' (tcb : acc) kind' + where + (subst', tv') = substTyVarBndr subst tv + tcb = Bndr tv' (NamedTCB vis) + +-- | A description of whether something is a +-- +-- * @data@ or @newtype@ ('DataDeclSort') +-- +-- * @data instance@ or @newtype instance@ ('DataInstanceSort') +-- +-- * @data family@ ('DataFamilySort') +-- +-- At present, this data type is only consumed by 'checkDataKindSig'. +data DataSort + = DataDeclSort NewOrData + | DataInstanceSort NewOrData + | DataFamilySort + +-- | Checks that the return kind in a data declaration's kind signature is +-- permissible. There are three cases: +-- +-- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@ +-- declaration, check that the return kind is @Type@. +-- +-- If the declaration is a @newtype@ or @newtype instance@ and the +-- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so +-- that a return kind of the form @TYPE r@ (for some @r@) is permitted. +-- See @Note [Implementation of UnliftedNewtypes]@ in "GHC.Tc.TyCl". +-- +-- If dealing with a @data family@ declaration, check that the return kind is +-- either of the form: +-- +-- 1. @TYPE r@ (for some @r@), or +-- +-- 2. @k@ (where @k@ is a bare kind variable; see #12369) +-- +-- See also Note [Datatype return kinds] in GHC.Tc.TyCl +checkDataKindSig :: DataSort -> Kind -> TcM () +checkDataKindSig data_sort kind = do + dflags <- getDynFlags + checkTc (is_TYPE_or_Type dflags || is_kind_var) (err_msg dflags) + where + pp_dec :: SDoc + pp_dec = text $ + case data_sort of + DataDeclSort DataType -> "Data type" + DataDeclSort NewType -> "Newtype" + DataInstanceSort DataType -> "Data instance" + DataInstanceSort NewType -> "Newtype instance" + DataFamilySort -> "Data family" + + is_newtype :: Bool + is_newtype = + case data_sort of + DataDeclSort new_or_data -> new_or_data == NewType + DataInstanceSort new_or_data -> new_or_data == NewType + DataFamilySort -> False + + is_data_family :: Bool + is_data_family = + case data_sort of + DataDeclSort{} -> False + DataInstanceSort{} -> False + DataFamilySort -> True + + tYPE_ok :: DynFlags -> Bool + tYPE_ok dflags = + (is_newtype && xopt LangExt.UnliftedNewtypes dflags) + -- With UnliftedNewtypes, we allow kinds other than Type, but they + -- must still be of the form `TYPE r` since we don't want to accept + -- Constraint or Nat. + -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl. + || is_data_family + -- If this is a `data family` declaration, we don't need to check if + -- UnliftedNewtypes is enabled, since data family declarations can + -- have return kind `TYPE r` unconditionally (#16827). + + is_TYPE :: Bool + is_TYPE = tcIsRuntimeTypeKind kind + + is_TYPE_or_Type :: DynFlags -> Bool + is_TYPE_or_Type dflags | tYPE_ok dflags = is_TYPE + | otherwise = tcIsLiftedTypeKind kind + + -- In the particular case of a data family, permit a return kind of the + -- form `:: k` (where `k` is a bare kind variable). + is_kind_var :: Bool + is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe kind) + | otherwise = False + + err_msg :: DynFlags -> SDoc + err_msg dflags = + sep [ (sep [ pp_dec <+> + text "has non-" <> + (if tYPE_ok dflags then text "TYPE" else ppr liftedTypeKind) + , (if is_data_family then text "and non-variable" else empty) <+> + text "return kind" <+> quotes (ppr kind) ]) + , if not (tYPE_ok dflags) && is_TYPE && is_newtype && + not (xopt LangExt.UnliftedNewtypes dflags) + then text "Perhaps you intended to use UnliftedNewtypes" + else empty ] + +-- | Checks that the result kind of a class is exactly `Constraint`, rejecting +-- type synonyms and type families that reduce to `Constraint`. See #16826. +checkClassKindSig :: Kind -> TcM () +checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg + where + err_msg :: SDoc + err_msg = + text "Kind signature on a class must end with" <+> ppr constraintKind $$ + text "unobscured by type families" + +tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] +-- Result is in 1-1 correspondence with orig_args +tcbVisibilities tc orig_args + = go (tyConKind tc) init_subst orig_args + where + init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args)) + go _ _ [] + = [] + + 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 + Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args + where + subst' = extendTCvSubst subst tv arg + + | not (isEmptyTCvSubst subst) + = go (substTy subst fun_kind) init_subst all_args + + | otherwise + = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args) + + +{- Note [TyConBinders for the result kind signature of a data type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given + data T (a::*) :: * -> forall k. k -> * +we want to generate the extra TyConBinders for T, so we finally get + (a::*) (b::*) (k::*) (c::k) +The function etaExpandAlgTyCon generates these extra TyConBinders from +the result kind signature. + +We need to take care to give the TyConBinders + (a) OccNames that are fresh (because the TyConBinders of a TyCon + must have distinct OccNames + + (b) Uniques that are fresh (obviously) + +For (a) we need to avoid clashes with the tyvars declared by +the user before the "::"; in the above example that is 'a'. +And also see Note [Avoid name clashes for associated data types]. + +For (b) suppose we have + data T :: forall k. k -> forall k. k -> * +where the two k's are identical even up to their uniques. Surprisingly, +this can happen: see #14515. + +It's reasonably easy to solve all this; just run down the list with a +substitution; hence the recursive 'go' function. But it has to be +done. + +Note [Avoid name clashes for associated data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider class C a b where + data D b :: * -> * +When typechecking the decl for D, we'll invent an extra type variable +for D, to fill out its kind. Ideally we don't want this type variable +to be 'a', because when pretty printing we'll get + class C a b where + data D b a0 +(NB: the tidying happens in the conversion to Iface syntax, which happens +as part of pretty-printing a TyThing.) + +That's why we look in the LocalRdrEnv to see what's in scope. This is +important only to get nice-looking output when doing ":info C" in GHCi. +It isn't essential for correctness. + + +************************************************************************ +* * + Partial signatures +* * +************************************************************************ + +-} + +tcHsPartialSigType + :: UserTypeCtxt + -> LHsSigWcType GhcRn -- The type signature + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , Maybe TcType -- Extra-constraints wildcard + , [(Name,TcTyVar)] -- Original tyvar names, in correspondence with + -- the implicitly and explicitly bound type variables + , TcThetaType -- Theta part + , TcType ) -- Tau part +-- See Note [Checking partial type signatures] +tcHsPartialSigType ctxt sig_ty + | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty + , HsIB { hsib_ext = implicit_hs_tvs + , hsib_body = hs_ty } <- ib_ty + , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTyInvis hs_ty + = addSigCtxt ctxt hs_ty $ + do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau))) + <- solveLocalEqualities "tcHsPartialSigType" $ + -- This solveLocalEqualiltes fails fast if there are + -- insoluble equalities. See GHC.Tc.Solver + -- Note [Fail fast if there are insoluble kind equalities] + tcNamedWildCardBinders sig_wcs $ \ wcs -> + bindImplicitTKBndrs_Tv implicit_hs_tvs $ + bindExplicitTKBndrs_Tv explicit_hs_tvs $ + do { -- Instantiate the type-class context; but if there + -- is an extra-constraints wildcard, just discard it here + (theta, wcx) <- tcPartialContext hs_ctxt + + ; tau <- tcHsOpenType hs_tau + + ; return (wcs, wcx, theta, tau) } + + -- No kind-generalization here, but perhaps some promotion + ; kindGeneralizeNone (mkSpecForAllTys implicit_tvs $ + mkSpecForAllTys explicit_tvs $ + mkPhiTy theta $ + tau) + + -- Spit out the wildcards (including the extra-constraints one) + -- as "hole" constraints, so that they'll be reported if necessary + -- See Note [Extra-constraint holes in partial type signatures] + ; emitNamedWildCardHoleConstraints wcs + + -- Zonk, so that any nested foralls can "see" their occurrences + -- See Note [Checking partial type signatures], in + -- the bullet on Nested foralls. + ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs + ; explicit_tvs <- mapM zonkTcTyVarToTyVar explicit_tvs + ; theta <- mapM zonkTcType theta + ; tau <- zonkTcType tau + + -- We return a proper (Name,TyVar) environment, to be sure that + -- we bring the right name into scope in the function body. + -- Test case: partial-sigs/should_compile/LocalDefinitionBug + ; let tv_prs = (implicit_hs_tvs `zip` implicit_tvs) + ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvs) + + -- NB: checkValidType on the final inferred type will be + -- done later by checkInferredPolyId. We can't do it + -- here because we don't have a complete type to check + + ; traceTc "tcHsPartialSigType" (ppr tv_prs) + ; return (wcs, wcx, tv_prs, theta, tau) } + +tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType) +tcPartialContext hs_theta + | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta + , L wc_loc wc@(HsWildCardTy _) <- ignoreParens hs_ctxt_last + = do { wc_tv_ty <- setSrcSpan wc_loc $ + tcAnonWildCardOcc wc constraintKind + ; theta <- mapM tcLHsPredType hs_theta1 + ; return (theta, Just wc_tv_ty) } + | otherwise + = do { theta <- mapM tcLHsPredType hs_theta + ; return (theta, Nothing) } + +{- Note [Checking partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note is about tcHsPartialSigType. See also +Note [Recipe for checking a signature] + +When we have a partial signature like + f :: forall a. a -> _ +we do the following + +* tcHsPartialSigType does not make quantified type (forall a. blah) + and then instantiate it -- it makes no sense to instantiate a type + with wildcards in it. Rather, tcHsPartialSigType just returns the + 'a' and the 'blah' separately. + + Nor, for the same reason, do we push a level in tcHsPartialSigType. + +* We instantiate 'a' to a unification variable, a TyVarTv, and /not/ + a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv. Consider + f :: forall a. a -> _ + g :: forall b. _ -> b + f = g + g = f + They are typechecked as a recursive group, with monomorphic types, + so 'a' and 'b' will get unified together. Very like kind inference + for mutually recursive data types (sans CUSKs or SAKS); see + Note [Cloning for tyvar binders] in GHC.Tc.Gen.HsType + +* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike + the companion CompleteSig) contains the original, as-yet-unchecked + source-code LHsSigWcType + +* Then, for f and g /separately/, we call tcInstSig, which in turn + call tchsPartialSig (defined near this Note). It kind-checks the + LHsSigWcType, creating fresh unification variables for each "_" + wildcard. It's important that the wildcards for f and g are distinct + because they might get instantiated completely differently. E.g. + f,g :: forall a. a -> _ + f x = a + g x = True + It's really as if we'd written two distinct signatures. + +* Nested foralls. Consider + f :: forall b. (forall a. a -> _) -> b + We do /not/ allow the "_" to be instantiated to 'a'; but we do + (as before) allow it to be instantiated to the (top level) 'b'. + Why not? Because suppose + f x = (x True, x 'c') + We must instantiate that (forall a. a -> _) when typechecking + f's body, so we must know precisely where all the a's are; they + must not be hidden under (filled-in) unification variables! + + We achieve this in the usual way: we push a level at a forall, + so now the unification variable for the "_" can't unify with + 'a'. + +* Just as for ordinary signatures, we must zonk the type after + kind-checking it, to ensure that all the nested forall binders can + see their occurrenceds + + Just as for ordinary signatures, this zonk also gets any Refl casts + out of the way of instantiation. Example: #18008 had + foo :: (forall a. (Show a => blah) |> Refl) -> _ + and that Refl cast messed things up. See #18062. + +Note [Extra-constraint holes in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: (_) => a -> a + f x = ... + +* The renamer leaves '_' untouched. + +* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in + tcWildCardBinders. + +* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar + with the inferred constraints, e.g. (Eq a, Show a) + +* GHC.Tc.Errors.mkHoleError finally reports the error. + +An annoying difficulty happens if there are more than 62 inferred +constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple. +Where do we find the TyCon? For good reasons we only have constraint +tuples up to 62 (see Note [How tuples work] in GHC.Builtin.Types). So how +can we make a 70-tuple? This was the root cause of #14217. + +It's incredibly tiresome, because we only need this type to fill +in the hole, to communicate to the error reporting machinery. Nothing +more. So I use a HACK: + +* I make an /ordinary/ tuple of the constraints, in + GHC.Tc.Gen.Bind.chooseInferredQuantifiers. This is ill-kinded because + ordinary tuples can't contain constraints, but it works fine. And for + ordinary tuples we don't have the same limit as for constraint + tuples (which need selectors and an associated class). + +* Because it is ill-kinded, it trips an assert in writeMetaTyVar, + so now I disable the assertion if we are writing a type of + kind Constraint. (That seldom/never normally happens so we aren't + losing much.) + +Result works fine, but it may eventually bite us. + + +************************************************************************ +* * + Pattern signatures (i.e signatures that occur in patterns) +* * +********************************************************************* -} + +tcHsPatSigType :: UserTypeCtxt + -> LHsSigWcType GhcRn -- The type signature + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , [(Name, TcTyVar)] -- The new bit of type environment, binding + -- the scoped type variables + , TcType) -- The type +-- Used for type-checking type signatures in +-- (a) patterns e.g f (x::Int) = e +-- (b) RULE forall bndrs e.g. forall (x::Int). f x = x +-- +-- This may emit constraints +-- See Note [Recipe for checking a signature] +tcHsPatSigType ctxt sig_ty + | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty + , HsIB { hsib_ext = sig_ns + , hsib_body = hs_ty } <- ib_ty + = addSigCtxt ctxt hs_ty $ + do { sig_tkv_prs <- mapM new_implicit_tv sig_ns + ; (wcs, sig_ty) + <- solveLocalEqualities "tcHsPatSigType" $ + -- Always solve local equalities if possible, + -- else casts get in the way of deep skolemisation + -- (#16033) + tcNamedWildCardBinders sig_wcs $ \ wcs -> + tcExtendNameTyVarEnv sig_tkv_prs $ + do { sig_ty <- tcHsOpenType hs_ty + ; return (wcs, sig_ty) } + + ; emitNamedWildCardHoleConstraints wcs + + -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty + -- contains a forall). Promote these. + -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ... + -- When we instantiate x, we have to compare the kind of the argument + -- to a's kind, which will be a metavariable. + -- kindGeneralizeNone does this: + ; kindGeneralizeNone sig_ty + ; sig_ty <- zonkTcType sig_ty + ; checkValidType ctxt sig_ty + + ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs) + ; return (wcs, sig_tkv_prs, sig_ty) } + where + new_implicit_tv name + = do { kind <- newMetaKindVar + ; tv <- case ctxt of + RuleSigCtxt {} -> newSkolemTyVar name kind + _ -> newPatSigTyVar name kind + -- See Note [Pattern signature binders] + -- NB: tv's Name may be fresh (in the case of newPatSigTyVar) + ; return (name, tv) } + +{- Note [Pattern signature binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Type variables in the type environment] in GHC.Tc.Utils. +Consider + + data T where + MkT :: forall a. a -> (a -> Int) -> T + + f :: T -> ... + f (MkT x (f :: b -> c)) = + +Here + * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk', + It must be a skolem so that that it retains its identity, and + GHC.Tc.Errors.getSkolemInfo can thereby find the binding site for the skolem. + + * The type signature pattern (f :: b -> c) makes freshs meta-tyvars + beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the + environment + + * Then unification makes beta := a_sk, gamma := Int + That's why we must make beta and gamma a MetaTv, + not a SkolemTv, so that it can unify to a_sk (or Int, respectively). + + * Finally, in '' we have the envt "b" :-> beta, "c" :-> gamma, + so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType, + +Another example (#13881): + fl :: forall (l :: [a]). Sing l -> Sing l + fl (SNil :: Sing (l :: [y])) = SNil +When we reach the pattern signature, 'l' is in scope from the +outer 'forall': + "a" :-> a_sk :: * + "l" :-> l_sk :: [a_sk] +We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check +the pattern signature + Sing (l :: [y]) +That unifies y_sig := a_sk. We return from tcHsPatSigType with +the pair ("y" :-> y_sig). + +For RULE binders, though, things are a bit different (yuk). + RULE "foo" forall (x::a) (y::[a]). f x y = ... +Here this really is the binding site of the type variable so we'd like +to use a skolem, so that we get a complaint if we unify two of them +together. Hence the new_tv function in tcHsPatSigType. + + +************************************************************************ +* * + Checking kinds +* * +************************************************************************ + +-} + +unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind) +unifyKinds rn_tys act_kinds + = do { kind <- newMetaKindVar + ; let check rn_ty (ty, act_kind) + = checkExpectedKind (unLoc rn_ty) ty act_kind kind + ; tys' <- zipWithM check rn_tys act_kinds + ; return (tys', kind) } + +{- +************************************************************************ +* * + Sort checking kinds +* * +************************************************************************ + +tcLHsKindSig converts a user-written kind to an internal, sort-checked kind. +It does sort checking and desugaring at the same time, in one single pass. +-} + +tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind +tcLHsKindSig ctxt hs_kind +-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType +-- Result is zonked + = do { kind <- solveLocalEqualities "tcLHsKindSig" $ + tc_lhs_kind kindLevelMode hs_kind + ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind) + -- No generalization: + ; kindGeneralizeNone kind + ; kind <- zonkTcType kind + -- This zonk is very important in the case of higher rank kinds + -- E.g. #13879 f :: forall (p :: forall z (y::z). ). + -- + -- When instantiating p's kind at occurrences of p in + -- it's crucial that the kind we instantiate is fully zonked, + -- else we may fail to substitute properly + + ; checkValidType ctxt kind + ; traceTc "tcLHsKindSig2" (ppr kind) + ; return kind } + +tc_lhs_kind :: TcTyMode -> LHsKind GhcRn -> TcM Kind +tc_lhs_kind mode k + = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $ + tc_lhs_type (kindLevel mode) k liftedTypeKind + +promotionErr :: Name -> PromotionErr -> TcM a +promotionErr name err + = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") + 2 (parens reason)) + where + reason = case err of + ConstrainedDataConPE pred + -> text "it has an unpromotable context" + <+> quotes (ppr pred) + FamDataConPE -> text "it comes from a data family instance" + NoDataKindsTC -> text "perhaps you intended to use DataKinds" + NoDataKindsDC -> text "perhaps you intended to use DataKinds" + PatSynPE -> text "pattern synonyms cannot be promoted" + _ -> text "it is defined and used in the same recursive group" + +{- +************************************************************************ +* * + Error messages and such +* * +************************************************************************ +-} + + +-- | If the inner action emits constraints, report them as errors and fail; +-- otherwise, propagates the return value. Useful as a wrapper around +-- 'tcImplicitTKBndrs', which uses solveLocalEqualities, when there won't be +-- another chance to solve constraints +failIfEmitsConstraints :: TcM a -> TcM a +failIfEmitsConstraints thing_inside + = checkNoErrs $ -- We say that we fail if there are constraints! + -- c.f same checkNoErrs in solveEqualities + do { (res, lie) <- captureConstraints thing_inside + ; reportAllUnsolved lie + ; return res + } + +-- | Make an appropriate message for an error in a function argument. +-- Used for both expressions and types. +funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc +funAppCtxt fun arg arg_no + = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"), + quotes (ppr fun) <> text ", namely"]) + 2 (quotes (ppr arg)) + +-- | Add a "In the data declaration for T" or some such. +addTyConFlavCtxt :: Name -> TyConFlavour -> 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 new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -0,0 +1,1127 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Typecheck some @Matches@ +module GHC.Tc.Gen.Match + ( tcMatchesFun + , tcGRHS + , tcGRHSsPat + , tcMatchesCase + , tcMatchLambda + , TcMatchCtxt(..) + , TcStmtChecker + , TcExprStmtChecker + , TcCmdStmtChecker + , tcStmts + , tcStmtsAndThen + , tcDoStmts + , tcBody + , tcDoStmt + , tcGuardStmt + ) +where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRhoNC, tcInferRho + , tcCheckId, tcLExpr, tcLExprNC, tcExpr + , tcCheckExpr ) + +import GHC.Types.Basic (LexicalFixity(..)) +import GHC.Hs +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Gen.Bind +import GHC.Tc.Utils.Unify +import GHC.Tc.Types.Origin +import GHC.Types.Name +import GHC.Builtin.Types +import GHC.Types.Id +import GHC.Core.TyCon +import GHC.Builtin.Types.Prim +import GHC.Tc.Types.Evidence +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.SrcLoc + +-- Create chunkified tuple tybes for monad comprehensions +import GHC.Core.Make + +import Control.Monad +import Control.Arrow ( second ) + +#include "HsVersions.h" + +{- +************************************************************************ +* * +\subsection{tcMatchesFun, tcMatchesCase} +* * +************************************************************************ + +@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a +@FunMonoBind@. The second argument is the name of the function, which +is used in error messages. It checks that all the equations have the +same number of arguments before using @tcMatches@ to do the work. + +Note [Polymorphic expected type for tcMatchesFun] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcMatchesFun may be given a *sigma* (polymorphic) type +so it must be prepared to use tcSkolemise to skolemise it. +See Note [sig_tau may be polymorphic] in GHC.Tc.Gen.Pat. +-} + +tcMatchesFun :: Located Name + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> ExpSigmaType -- Expected type of function + -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)) + -- Returns type of body +tcMatchesFun fn@(L _ fun_name) matches exp_ty + = do { -- Check that they all have the same no of arguments + -- Location is in the monad, set the caller so that + -- any inter-equation error messages get some vaguely + -- sensible location. Note: we have to do this odd + -- ann-grabbing, because we don't always have annotations in + -- hand when we call tcMatchesFun... + traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty) + ; checkArgs fun_name matches + + ; (wrap_gen, (wrap_fun, group)) + <- tcSkolemiseET (FunSigCtxt fun_name True) exp_ty $ \ exp_rho -> + -- Note [Polymorphic expected type for tcMatchesFun] + do { (matches', wrap_fun) + <- matchExpectedFunTys herald arity exp_rho $ + \ pat_tys rhs_ty -> + tcMatches match_ctxt pat_tys rhs_ty matches + ; return (wrap_fun, matches') } + ; return (wrap_gen <.> wrap_fun, group) } + where + arity = matchGroupArity matches + herald = text "The equation(s) for" + <+> quotes (ppr fun_name) <+> text "have" + what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness } + match_ctxt = MC { mc_what = what, mc_body = tcBody } + strictness + | [L _ match] <- unLoc $ mg_alts matches + , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match + = SrcStrict + | otherwise + = NoSrcStrict + +{- +@tcMatchesCase@ doesn't do the argument-count check because the +parser guarantees that each equation has exactly one argument. +-} + +tcMatchesCase :: (Outputable (body GhcRn)) => + TcMatchCtxt body -- Case context + -> TcSigmaType -- Type of scrutinee + -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives + -> ExpRhoType -- Type of whole case expressions + -> TcM (MatchGroup GhcTcId (Located (body GhcTcId))) + -- Translated alternatives + -- wrapper goes from MatchGroup's ty to expected ty + +tcMatchesCase ctxt scrut_ty matches res_ty + = tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches + +tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify + -> TcMatchCtxt HsExpr + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> ExpRhoType -- deeply skolemised + -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper) +tcMatchLambda herald match_ctxt match res_ty + = matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty -> + tcMatches match_ctxt pat_tys rhs_ty match + where + n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case + | otherwise = matchGroupArity match + +-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. + +tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType + -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId)) +-- Used for pattern bindings +tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty) + where + match_ctxt = MC { mc_what = PatBindRhs, + mc_body = tcBody } + +{- +************************************************************************ +* * +\subsection{tcMatch} +* * +************************************************************************ + +Note [Case branches must never infer a non-tau type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + case ... of + ... -> \(x :: forall a. a -> a) -> x + ... -> \y -> y + +Should that type-check? The problem is that, if we check the second branch +first, then we'll get a type (b -> b) for the branches, which won't unify +with the polytype in the first branch. If we check the first branch first, +then everything is OK. This order-dependency is terrible. So we want only +proper tau-types in branches (unless a sigma-type is pushed down). +This is what expTypeToType ensures: it replaces an Infer with a fresh +tau-type. + +An even trickier case looks like + + f x True = x undefined + f x False = x () + +Here, we see that the arguments must also be non-Infer. Thus, we must +use expTypeToType on the output of matchExpectedFunTys, not the input. + +But we make a special case for a one-branch case. This is so that + + f = \(x :: forall a. a -> a) -> x + +still gets assigned a polytype. +-} + +-- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the +-- expected type into TauTvs. +-- See Note [Case branches must never infer a non-tau type] +tauifyMultipleMatches :: [LMatch id body] + -> [ExpType] -> TcM [ExpType] +tauifyMultipleMatches group exp_tys + | isSingletonMatchGroup group = return exp_tys + | otherwise = mapM tauifyExpType exp_tys + -- NB: In the empty-match case, this ensures we fill in the ExpType + +-- | Type-check a MatchGroup. +tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body + -> [ExpSigmaType] -- Expected pattern types + -> ExpRhoType -- Expected result-type of the Match. + -> MatchGroup GhcRn (Located (body GhcRn)) + -> TcM (MatchGroup GhcTcId (Located (body GhcTcId))) + +data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module + = MC { mc_what :: HsMatchContext GhcRn, -- What kind of thing this is + mc_body :: Located (body GhcRn) -- Type checker for a body of + -- an alternative + -> ExpRhoType + -> TcM (Located (body GhcTcId)) } + +tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches + , mg_origin = origin }) + = do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys) + -- See Note [Case branches must never infer a non-tau type] + + ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches + ; pat_tys <- mapM readExpType pat_tys + ; rhs_ty <- readExpType rhs_ty + ; return (MG { mg_alts = L l matches' + , mg_ext = MatchGroupTc pat_tys rhs_ty + , mg_origin = origin }) } + +------------- +tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body + -> [ExpSigmaType] -- Expected pattern types + -> ExpRhoType -- Expected result-type of the Match. + -> LMatch GhcRn (Located (body GhcRn)) + -> TcM (LMatch GhcTcId (Located (body GhcTcId))) + +tcMatch ctxt pat_tys rhs_ty match + = wrapLocM (tc_match ctxt pat_tys rhs_ty) match + where + tc_match ctxt pat_tys rhs_ty + match@(Match { m_pats = pats, m_grhss = grhss }) + = add_match_ctxt match $ + do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ + tcGRHSs ctxt grhss rhs_ty + ; return (Match { m_ext = noExtField + , m_ctxt = mc_what ctxt, m_pats = pats' + , m_grhss = grhss' }) } + + -- For (\x -> e), tcExpr has already said "In the expression \x->e" + -- so we don't want to add "In the lambda abstraction \x->e" + add_match_ctxt match thing_inside + = case mc_what ctxt of + LambdaExpr -> thing_inside + _ -> addErrCtxt (pprMatchInCtxt match) thing_inside + +------------- +tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType + -> TcM (GRHSs GhcTcId (Located (body GhcTcId))) + +-- Notice that we pass in the full res_ty, so that we get +-- good inference from simple things like +-- f = \(x::forall a.a->a) -> +-- We used to force it to be a monotype when there was more than one guard +-- but we don't need to do that any more + +tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty + = do { (binds', grhss') + <- tcLocalBinds binds $ + mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss + + ; return (GRHSs noExtField grhss' (L l binds')) } + +------------- +tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn)) + -> TcM (GRHS GhcTcId (Located (body GhcTcId))) + +tcGRHS ctxt res_ty (GRHS _ guards rhs) + = do { (guards', rhs') + <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ + mc_body ctxt rhs + ; return (GRHS noExtField guards' rhs') } + where + stmt_ctxt = PatGuard (mc_what ctxt) + +{- +************************************************************************ +* * +\subsection{@tcDoStmts@ typechecks a {\em list} of do statements} +* * +************************************************************************ +-} + +tcDoStmts :: HsStmtContext GhcRn + -> Located [LStmt GhcRn (LHsExpr GhcRn)] + -> ExpRhoType + -> TcM (HsExpr GhcTcId) -- Returns a HsDo +tcDoStmts ListComp (L l stmts) res_ty + = do { res_ty <- expTypeToType res_ty + ; (co, elt_ty) <- matchExpectedListTy res_ty + ; let list_ty = mkListTy elt_ty + ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts + (mkCheckExpType elt_ty) + ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) } + +tcDoStmts DoExpr (L l stmts) res_ty + = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty + ; res_ty <- readExpType res_ty + ; return (HsDo res_ty DoExpr (L l stmts')) } + +tcDoStmts MDoExpr (L l stmts) res_ty + = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty + ; res_ty <- readExpType res_ty + ; return (HsDo res_ty MDoExpr (L l stmts')) } + +tcDoStmts MonadComp (L l stmts) res_ty + = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty + ; res_ty <- readExpType res_ty + ; return (HsDo res_ty MonadComp (L l stmts')) } + +tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) + +tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId) +tcBody body res_ty + = do { traceTc "tcBody" (ppr res_ty) + ; tcLExpr body res_ty + } + +{- +************************************************************************ +* * +\subsection{tcStmts} +* * +************************************************************************ +-} + +type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType +type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType + +type TcStmtChecker body rho_type + = forall thing. HsStmtContext GhcRn + -> Stmt GhcRn (Located (body GhcRn)) + -> rho_type -- Result type for comprehension + -> (rho_type -> TcM thing) -- Checker for what follows the stmt + -> TcM (Stmt GhcTcId (Located (body GhcTcId)), thing) + +tcStmts :: (Outputable (body GhcRn)) => HsStmtContext GhcRn + -> TcStmtChecker body rho_type -- NB: higher-rank type + -> [LStmt GhcRn (Located (body GhcRn))] + -> rho_type + -> TcM [LStmt GhcTcId (Located (body GhcTcId))] +tcStmts ctxt stmt_chk stmts res_ty + = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ + const (return ()) + ; return stmts' } + +tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext GhcRn + -> TcStmtChecker body rho_type -- NB: higher-rank type + -> [LStmt GhcRn (Located (body GhcRn))] + -> rho_type + -> (rho_type -> TcM thing) + -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing) + +-- Note the higher-rank type. stmt_chk is applied at different +-- types in the equations for tcStmts + +tcStmtsAndThen _ _ [] res_ty thing_inside + = do { thing <- thing_inside res_ty + ; return ([], thing) } + +-- LetStmts are handled uniformly, regardless of context +tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts) + res_ty thing_inside + = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ + tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside + ; return (L loc (LetStmt x (L l binds')) : stmts', thing) } + +-- Don't set the error context for an ApplicativeStmt. It ought to be +-- possible to do this with a popErrCtxt in the tcStmt case for +-- ApplicativeStmt, but it did something strange and broke a test (ado002). +tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside + | ApplicativeStmt{} <- stmt + = do { (stmt', (stmts', thing)) <- + stmt_chk ctxt stmt res_ty $ \ res_ty' -> + tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ + thing_inside + ; return (L loc stmt' : stmts', thing) } + + -- For the vanilla case, handle the location-setting part + | otherwise + = do { (stmt', (stmts', thing)) <- + setSrcSpan loc $ + addErrCtxt (pprStmtInCtxt ctxt stmt) $ + stmt_chk ctxt stmt res_ty $ \ res_ty' -> + popErrCtxt $ + tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ + thing_inside + ; return (L loc stmt' : stmts', thing) } + +--------------------------------------------------- +-- Pattern guards +--------------------------------------------------- + +tcGuardStmt :: TcExprStmtChecker +tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside + = do { guard' <- tcLExpr guard (mkCheckExpType boolTy) + ; thing <- thing_inside res_ty + ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) } + +tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside + = do { (rhs', rhs_ty) <- tcInferRhoNC rhs + -- Stmt has a context already + ; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) + pat rhs_ty $ + thing_inside res_ty + ; return (mkTcBindStmt pat' rhs', thing) } + +tcGuardStmt _ stmt _ _ + = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- List comprehensions +-- (no rebindable syntax) +--------------------------------------------------- + +-- Dealt with separately, rather than by tcMcStmt, because +-- a) We have special desugaring rules for list comprehensions, +-- which avoid creating intermediate lists. They in turn +-- assume that the bind/return operations are the regular +-- polymorphic ones, and in particular don't have any +-- coercion matching stuff in them. It's hard to avoid the +-- potential for non-trivial coercions in tcMcStmt + +tcLcStmt :: TyCon -- The list type constructor ([]) + -> TcExprStmtChecker + +tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside + = do { body' <- tcLExprNC body elt_ty + ; thing <- thing_inside (panic "tcLcStmt: thing_inside") + ; return (LastStmt x body' noret noSyntaxExpr, thing) } + +-- A generator, pat <- rhs +tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside + = do { pat_ty <- newFlexiTyVarTy liftedTypeKind + ; rhs' <- tcLExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty]) + ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ + thing_inside elt_ty + ; return (mkTcBindStmt pat' rhs', thing) } + +-- A boolean guard +tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside + = do { rhs' <- tcLExpr rhs (mkCheckExpType boolTy) + ; thing <- thing_inside elt_ty + ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) } + +-- ParStmt: See notes with tcMcStmt +tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside + = do { (pairs', thing) <- loop bndr_stmts_s + ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) } + where + -- loop :: [([LStmt GhcRn], [GhcRn])] + -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing) + loop [] = do { thing <- thing_inside elt_ty + ; return ([], thing) } -- matching in the branches + + loop (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 + ; return (ids, pairs', thing) } + ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) } + +tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts + , trS_bndrs = bindersMap + , trS_by = by, trS_using = using }) elt_ty thing_inside + = do { let (bndr_names, n_bndr_names) = unzip bindersMap + unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap) + -- The inner 'stmts' lack a LastStmt, so the element type + -- passed in to tcStmtsAndThen is never looked at + ; (stmts', (bndr_ids, by')) + <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do + { by' <- traverse tcInferRho by + ; bndr_ids <- tcLookupLocalIds bndr_names + ; return (bndr_ids, by') } + + ; let m_app ty = mkTyConApp m_tc [ty] + + --------------- Typecheck the 'using' function ------------- + -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm) + -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm) + + -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm + ; let n_app = case form of + ThenForm -> (\ty -> ty) + _ -> m_app + + by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present + by_arrow = case by' of + Nothing -> \ty -> ty + Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTy` e_ty) `mkVisFunTy` ty + + tup_ty = mkBigCoreVarTupTy bndr_ids + poly_arg_ty = m_app alphaTy + poly_res_ty = m_app (n_app alphaTy) + using_poly_ty = mkInvForAllTy alphaTyVar $ + by_arrow $ + poly_arg_ty `mkVisFunTy` poly_res_ty + + ; using' <- tcCheckExpr using using_poly_ty + ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' + + -- 'stmts' returns a result of type (m1_ty tuple_ty), + -- typically something like [(Int,Bool,Int)] + -- We don't know what tuple_ty is yet, so we use a variable + ; let mk_n_bndr :: Name -> TcId -> TcId + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) + + -- Ensure that every old binder of type `b` is linked up with its + -- new binder which should have type `n b` + -- See Note [GroupStmt binder map] in GHC.Hs.Expr + n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids + bindersMap' = bndr_ids `zip` n_bndr_ids + + -- Type check the thing in the environment with + -- these new binders and return the result + ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty) + + ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' + , trS_by = fmap fst by', trS_using = final_using + , trS_ret = noSyntaxExpr + , trS_bind = noSyntaxExpr + , trS_fmap = noExpr + , trS_ext = unitTy + , trS_form = form }, thing) } + +tcLcStmt _ _ stmt _ _ + = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- Monad comprehensions +-- (supports rebindable syntax) +--------------------------------------------------- + +tcMcStmt :: TcExprStmtChecker + +tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside + = do { (body', return_op') + <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $ + \ [a_ty] -> + tcLExprNC body (mkCheckExpType a_ty) + ; thing <- thing_inside (panic "tcMcStmt: thing_inside") + ; return (LastStmt x body' noret return_op', thing) } + +-- Generators for monad comprehensions ( pat <- rhs ) +-- +-- [ body | q <- gen ] -> gen :: m a +-- q :: a +-- + +tcMcStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside + -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty + = do { ((rhs', pat', thing, new_res_ty), bind_op') + <- tcSyntaxOp MCompOrigin (xbsrn_bindOp xbsrn) + [SynRho, SynFun SynAny SynRho] res_ty $ + \ [rhs_ty, pat_ty, new_res_ty] -> + do { rhs' <- tcLExprNC rhs (mkCheckExpType rhs_ty) + ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ + thing_inside (mkCheckExpType new_res_ty) + ; return (rhs', pat', thing, new_res_ty) } + + -- If (but only if) the pattern can fail, typecheck the 'fail' operator + ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail -> + tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty + + ; let xbstc = XBindStmtTc + { xbstc_bindOp = bind_op' + , xbstc_boundResultType = new_res_ty + , xbstc_failOp = fail_op' + } + ; return (BindStmt xbstc pat' rhs', thing) } + +-- Boolean expressions. +-- +-- [ body | stmts, expr ] -> expr :: m Bool +-- +tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside + = do { -- Deal with rebindable syntax: + -- guard_op :: test_ty -> rhs_ty + -- then_op :: rhs_ty -> new_res_ty -> res_ty + -- Where test_ty is, for example, Bool + ; ((thing, rhs', rhs_ty, guard_op'), then_op') + <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $ + \ [rhs_ty, new_res_ty] -> + do { (rhs', guard_op') + <- tcSyntaxOp MCompOrigin guard_op [SynAny] + (mkCheckExpType rhs_ty) $ + \ [test_ty] -> + tcLExpr rhs (mkCheckExpType test_ty) + ; thing <- thing_inside (mkCheckExpType new_res_ty) + ; return (thing, rhs', rhs_ty, guard_op') } + ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) } + +-- Grouping statements +-- +-- [ body | stmts, then group by e using f ] +-- -> e :: t +-- f :: forall a. (a -> t) -> m a -> m (m a) +-- [ body | stmts, then group using f ] +-- -> f :: forall a. m a -> m (m a) + +-- We type [ body | (stmts, group by e using f), ... ] +-- f [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body.... +-- +-- We type the functions as follows: +-- f :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm) +-- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm) +-- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm) +-- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm) +-- +tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap + , trS_by = by, trS_using = using, trS_form = form + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op }) res_ty thing_inside + = do { m1_ty <- newFlexiTyVarTy typeToTypeKind + ; m2_ty <- newFlexiTyVarTy typeToTypeKind + ; tup_ty <- newFlexiTyVarTy liftedTypeKind + ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any) + + -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm + ; n_app <- case form of + ThenForm -> return (\ty -> ty) + _ -> do { n_ty <- newFlexiTyVarTy typeToTypeKind + ; return (n_ty `mkAppTy`) } + ; let by_arrow :: Type -> Type + -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present) + -- or res ('by' absent) + by_arrow = case by of + Nothing -> \res -> res + Just {} -> \res -> (alphaTy `mkVisFunTy` by_e_ty) `mkVisFunTy` res + + poly_arg_ty = m1_ty `mkAppTy` alphaTy + using_arg_ty = m1_ty `mkAppTy` tup_ty + poly_res_ty = m2_ty `mkAppTy` n_app alphaTy + using_res_ty = m2_ty `mkAppTy` n_app tup_ty + using_poly_ty = mkInvForAllTy alphaTyVar $ + by_arrow $ + poly_arg_ty `mkVisFunTy` poly_res_ty + + -- 'stmts' returns a result of type (m1_ty tuple_ty), + -- typically something like [(Int,Bool,Int)] + -- We don't know what tuple_ty is yet, so we use a variable + ; let (bndr_names, n_bndr_names) = unzip bindersMap + ; (stmts', (bndr_ids, by', return_op')) <- + tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts + (mkCheckExpType using_arg_ty) $ \res_ty' -> do + { by' <- case by of + Nothing -> return Nothing + Just e -> do { e' <- tcLExpr e + (mkCheckExpType by_e_ty) + ; return (Just e') } + + -- Find the Ids (and hence types) of all old binders + ; bndr_ids <- tcLookupLocalIds bndr_names + + -- 'return' is only used for the binders, so we know its type. + -- return :: (a,b,c,..) -> m (a,b,c,..) + ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op + [synKnownType (mkBigCoreVarTupTy bndr_ids)] + res_ty' $ \ _ -> return () + + ; return (bndr_ids, by', return_op') } + + --------------- Typecheck the 'bind' function ------------- + -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + ; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op + [ synKnownType using_res_ty + , synKnownType (n_app tup_ty `mkVisFunTy` new_res_ty) ] + res_ty $ \ _ -> return () + + --------------- Typecheck the 'fmap' function ------------- + ; fmap_op' <- case form of + ThenForm -> return noExpr + _ -> fmap unLoc . tcCheckExpr (noLoc fmap_op) $ + mkInvForAllTy alphaTyVar $ + mkInvForAllTy betaTyVar $ + (alphaTy `mkVisFunTy` betaTy) + `mkVisFunTy` (n_app alphaTy) + `mkVisFunTy` (n_app betaTy) + + --------------- Typecheck the 'using' function ------------- + -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c)) + + ; using' <- tcCheckExpr using using_poly_ty + ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' + + --------------- Building the bindersMap ---------------- + ; let mk_n_bndr :: Name -> TcId -> TcId + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) + + -- Ensure that every old binder of type `b` is linked up with its + -- new binder which should have type `n b` + -- See Note [GroupStmt binder map] in GHC.Hs.Expr + n_bndr_ids = zipWithEqual "tcMcStmt" mk_n_bndr n_bndr_names bndr_ids + bindersMap' = bndr_ids `zip` n_bndr_ids + + -- Type check the thing in the environment with + -- these new binders and return the result + ; thing <- tcExtendIdEnv n_bndr_ids $ + thing_inside (mkCheckExpType new_res_ty) + + ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' + , trS_by = by', trS_using = final_using + , trS_ret = return_op', trS_bind = bind_op' + , trS_ext = n_app tup_ty + , trS_fmap = fmap_op', trS_form = form }, thing) } + +-- A parallel set of comprehensions +-- [ (g x, h x) | ... ; let g v = ... +-- | ... ; let h v = ... ] +-- +-- It's possible that g,h are overloaded, so we need to feed the LIE from the +-- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods). +-- Similarly if we had an existential pattern match: +-- +-- data T = forall a. Show a => C a +-- +-- [ (show x, show y) | ... ; C x <- ... +-- | ... ; C y <- ... ] +-- +-- Then we need the LIE from (show x, show y) to be simplified against +-- the bindings for x and y. +-- +-- It's difficult to do this in parallel, so we rely on the renamer to +-- ensure that g,h and x,y don't duplicate, and simply grow the environment. +-- So the binders of the first parallel group will be in scope in the second +-- group. But that's fine; there's no shadowing to worry about. +-- +-- Note: The `mzip` function will get typechecked via: +-- +-- ParStmt [st1::t1, st2::t2, st3::t3] +-- +-- mzip :: m st1 +-- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call +-- -> m (st1, (st2, st3)) +-- +tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside + = do { m_ty <- newFlexiTyVarTy typeToTypeKind + + ; let mzip_ty = mkInvForAllTys [alphaTyVar, betaTyVar] $ + (m_ty `mkAppTy` alphaTy) + `mkVisFunTy` + (m_ty `mkAppTy` betaTy) + `mkVisFunTy` + (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) + ; mzip_op' <- unLoc `fmap` tcCheckExpr (noLoc mzip_op) mzip_ty + + -- type dummies since we don't know all binder types yet + ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind)) + [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ] + + -- Typecheck bind: + ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ] + tuple_ty = mk_tuple_ty tup_tys + + ; (((blocks', thing), inner_res_ty), bind_op') + <- tcSyntaxOp MCompOrigin bind_op + [ synKnownType (m_ty `mkAppTy` tuple_ty) + , SynFun (synKnownType tuple_ty) SynRho ] res_ty $ + \ [inner_res_ty] -> + do { stuff <- loop m_ty (mkCheckExpType inner_res_ty) + tup_tys bndr_stmts_s + ; return (stuff, inner_res_ty) } + + ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) } + + where + mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys + + -- loop :: Type -- m_ty + -- -> ExpRhoType -- inner_res_ty + -- -> [TcType] -- tup_tys + -- -> [ParStmtBlock Name] + -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing) + loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty + ; return ([], thing) } + -- matching in the branches + + loop m_ty inner_res_ty (tup_ty_in : tup_tys_in) + (ParStmtBlock x stmts names return_op : pairs) + = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in + ; (stmts', (ids, return_op', pairs', thing)) + <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $ + \m_tup_ty' -> + do { ids <- tcLookupLocalIds names + ; let tup_ty = mkBigCoreVarTupTy ids + ; (_, return_op') <- + tcSyntaxOp MCompOrigin return_op + [synKnownType tup_ty] m_tup_ty' $ + \ _ -> return () + ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs + ; return (ids, return_op', pairs', thing) } + ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) } + loop _ _ _ _ = panic "tcMcStmt.loop" + +tcMcStmt _ stmt _ _ + = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- Do-notation +-- (supports rebindable syntax) +--------------------------------------------------- + +tcDoStmt :: TcExprStmtChecker + +tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside + = do { body' <- tcLExprNC body res_ty + ; thing <- thing_inside (panic "tcDoStmt: thing_inside") + ; return (LastStmt x body' noret noSyntaxExpr, thing) } + +tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside + = do { -- Deal with rebindable syntax: + -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty + -- This level of generality is needed for using do-notation + -- in full generality; see #1537 + + ((rhs', pat', new_res_ty, thing), bind_op') + <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $ + \ [rhs_ty, pat_ty, new_res_ty] -> + do { rhs' <- tcLExprNC rhs (mkCheckExpType rhs_ty) + ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ + thing_inside (mkCheckExpType new_res_ty) + ; return (rhs', pat', new_res_ty, thing) } + + -- If (but only if) the pattern can fail, typecheck the 'fail' operator + ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail -> + tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty + ; let xbstc = XBindStmtTc + { xbstc_bindOp = bind_op' + , xbstc_boundResultType = new_res_ty + , xbstc_failOp = fail_op' + } + ; return (BindStmt xbstc pat' rhs', thing) } + +tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside + = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $ + thing_inside . mkCheckExpType + ; ((pairs', body_ty, thing), mb_join') <- case mb_join of + Nothing -> (, Nothing) <$> tc_app_stmts res_ty + Just join_op -> + second Just <$> + (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $ + \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty)) + + ; return (ApplicativeStmt body_ty pairs' mb_join', thing) } + +tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside + = do { -- Deal with rebindable syntax; + -- (>>) :: rhs_ty -> new_res_ty -> res_ty + ; ((rhs', rhs_ty, thing), then_op') + <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $ + \ [rhs_ty, new_res_ty] -> + do { rhs' <- tcLExprNC rhs (mkCheckExpType rhs_ty) + ; thing <- thing_inside (mkCheckExpType new_res_ty) + ; return (rhs', rhs_ty, thing) } + ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } + +tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names + , recS_rec_ids = rec_names, recS_ret_fn = ret_op + , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) + res_ty thing_inside + = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names + ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind + ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys + tup_ty = mkBigCoreTupTy tup_elt_tys + + ; tcExtendIdEnv tup_ids $ do + { ((stmts', (ret_op', tup_rets)), stmts_ty) + <- tcInfer $ \ exp_ty -> + tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty -> + do { tup_rets <- zipWithM tcCheckId tup_names + (map mkCheckExpType tup_elt_tys) + -- Unify the types of the "final" Ids (which may + -- be polymorphic) with those of "knot-tied" Ids + ; (_, ret_op') + <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty] + inner_res_ty $ \_ -> return () + ; return (ret_op', tup_rets) } + + ; ((_, mfix_op'), mfix_res_ty) + <- tcInfer $ \ exp_ty -> + tcSyntaxOp DoOrigin mfix_op + [synKnownType (mkVisFunTy tup_ty stmts_ty)] exp_ty $ + \ _ -> return () + + ; ((thing, new_res_ty), bind_op') + <- tcSyntaxOp DoOrigin bind_op + [ synKnownType mfix_res_ty + , synKnownType tup_ty `SynFun` SynRho ] + res_ty $ + \ [new_res_ty] -> + do { thing <- thing_inside (mkCheckExpType new_res_ty) + ; return (thing, new_res_ty) } + + ; let rec_ids = takeList rec_names tup_ids + ; later_ids <- tcLookupLocalIds later_names + ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids), + ppr later_ids <+> ppr (map idType later_ids)] + ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids + , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' + , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' + , recS_ext = RecStmtTc + { recS_bind_ty = new_res_ty + , recS_later_rets = [] + , recS_rec_rets = tup_rets + , recS_ret_ty = stmts_ty} }, thing) + }} + +tcDoStmt _ stmt _ _ + = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt) + + + +--------------------------------------------------- +-- MonadFail Proposal warnings +--------------------------------------------------- + +-- The idea behind issuing MonadFail warnings is that we add them whenever a +-- failable pattern is encountered. However, instead of throwing a type error +-- when the constraint cannot be satisfied, we only issue a warning in +-- GHC.Tc.Errors.hs. + +tcMonadFailOp :: CtOrigin + -> LPat GhcTcId + -> SyntaxExpr GhcRn -- The fail op + -> TcType -- Type of the whole do-expression + -> TcRn (FailOperator GhcTcId) -- Typechecked fail op +-- Get a 'fail' operator expression, to use if the pattern match fails. +-- This won't be used in cases where we've already determined the pattern +-- match can't fail (so the fail op is Nothing), however, it seems that the +-- isIrrefutableHsPat test is still required here for some reason I haven't +-- yet determined. +tcMonadFailOp orig pat fail_op res_ty + | isIrrefutableHsPat pat + = return Nothing + | otherwise + = Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] + (mkCheckExpType res_ty) $ \_ -> return ()) + +{- +Note [Treat rebindable syntax first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking + do { bar; ... } :: IO () +we want to typecheck 'bar' in the knowledge that it should be an IO thing, +pushing info from the context into the RHS. To do this, we check the +rebindable syntax first, and push that information into (tcLExprNC rhs). +Otherwise the error shows up when checking the rebindable syntax, and +the expected/inferred stuff is back to front (see #3613). + +Note [typechecking ApplicativeStmt] + +join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en) + +fresh type variables: + pat_ty_1..pat_ty_n + exp_ty_1..exp_ty_n + t_1..t_(n-1) + +body :: body_ty +(\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty +pat_i :: pat_ty_i +e_i :: exp_ty_i +<$> :: (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 +-} + +tcApplicativeStmts + :: HsStmtContext GhcRn + -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)] + -> ExpRhoType -- rhs_ty + -> (TcRhoType -> TcM t) -- thing_inside + -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t) + +tcApplicativeStmts ctxt pairs rhs_ty thing_inside + = do { body_ty <- newFlexiTyVarTy liftedTypeKind + ; let arity = length pairs + ; ts <- replicateM (arity-1) $ newInferExpType + ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind + ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind + ; let fun_ty = mkVisFunTys pat_tys body_ty + + -- NB. do the <$>,<*> operators first, we don't want type errors here + -- i.e. goOps before goArgs + -- See Note [Treat rebindable syntax first] + ; let (ops, args) = unzip pairs + ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys) + + -- Typecheck each ApplicativeArg separately + -- See Note [ApplicativeDo and constraints] + ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys) + + -- Bring into scope all the things bound by the args, + -- and typecheck the thing_inside + -- See Note [ApplicativeDo and constraints] + ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $ + thing_inside body_ty + + ; return (zip ops' args', body_ty, res) } + where + goOps _ [] = return [] + goOps t_left ((op,t_i,exp_ty) : ops) + = do { (_, op') + <- tcSyntaxOp DoOrigin op + [synKnownType t_left, synKnownType exp_ty] t_i $ + \ _ -> return () + ; t_i <- readExpType t_i + ; ops' <- goOps t_i ops + ; return (op' : ops') } + + goArg :: Type -> (ApplicativeArg GhcRn, Type, Type) + -> TcM (ApplicativeArg GhcTcId) + + goArg body_ty (ApplicativeArgOne + { xarg_app_arg_one = fail_op + , app_arg_pattern = pat + , arg_expr = rhs + , .. + }, pat_ty, exp_ty) + = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ + addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs)) $ + do { rhs' <- tcLExprNC rhs (mkCheckExpType exp_ty) + ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ + return () + ; fail_op' <- fmap join . forM fail_op $ \fail -> + tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty + + ; return (ApplicativeArgOne + { xarg_app_arg_one = fail_op' + , app_arg_pattern = pat' + , arg_expr = rhs' + , .. } + ) } + + goArg _body_ty (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty) + = do { (stmts', (ret',pat')) <- + tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $ + \res_ty -> do + { ret' <- tcExpr ret res_ty + ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ + return () + ; return (ret', pat') + } + ; return (ApplicativeArgMany x stmts' ret' pat') } + + get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id] + get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat + get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat + +{- Note [ApplicativeDo and constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An applicative-do is supposed to take place in parallel, so +constraints bound in one arm can't possibly be available in another +(#13242). Our current rule is this (more details and discussion +on the ticket). Consider + + ...stmts... + ApplicativeStmts [arg1, arg2, ... argN] + ...more stmts... + +where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts. +Now, we say that: + +* Constraints required by the argi can be solved from + constraint bound by ...stmts... + +* Constraints and existentials bound by the argi are not available + to solve constraints required either by argj (where i /= j), + or by ...more stmts.... + +* Within the stmts of each 'argi' individually, however, constraints bound + by earlier stmts can be used to solve later ones. + +To achieve this, we just typecheck each 'argi' separately, bring all +the variables they bind into scope, and typecheck the thing_inside. + +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ + +@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same +number of args are used in each equation. +-} + +checkArgs :: Name -> MatchGroup GhcRn body -> TcM () +checkArgs _ (MG { mg_alts = L _ [] }) + = return () +checkArgs fun (MG { mg_alts = L _ (match1:matches) }) + | null bad_matches + = return () + | otherwise + = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+> + text "have different numbers of arguments" + , nest 2 (ppr (getLoc match1)) + , nest 2 (ppr (getLoc (head bad_matches)))]) + where + n_args1 = args_in_match match1 + bad_matches = [m | m <- matches, args_in_match m /= n_args1] + + args_in_match :: LMatch GhcRn body -> Int + args_in_match (L _ (Match { m_pats = pats })) = length pats diff --git a/compiler/GHC/Tc/Gen/Match.hs-boot b/compiler/GHC/Tc/Gen/Match.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Match.hs-boot @@ -0,0 +1,17 @@ +module GHC.Tc.Gen.Match where +import GHC.Hs ( GRHSs, MatchGroup, LHsExpr ) +import GHC.Tc.Types.Evidence ( HsWrapper ) +import GHC.Types.Name ( Name ) +import GHC.Tc.Utils.TcType( ExpSigmaType, TcRhoType ) +import GHC.Tc.Types ( TcM ) +import GHC.Types.SrcLoc ( Located ) +import GHC.Hs.Extension ( GhcRn, GhcTcId ) + +tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) + -> TcRhoType + -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId)) + +tcMatchesFun :: Located Name + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> ExpSigmaType + -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)) diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -0,0 +1,1300 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, RankNTypes, TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Typechecking patterns +module GHC.Tc.Gen.Pat + ( tcLetPat + , newLetBndr + , LetBndrSpec(..) + , tcCheckPat, tcCheckPat_O, tcInferPat + , tcPats + , addDataConStupidTheta + , badFieldCon + , polyPatSig + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma ) + +import GHC.Hs +import GHC.Tc.Utils.Zonk +import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Instantiate +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Validity( arityErr ) +import GHC.Core.TyCo.Ppr ( pprTyVars ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Unify +import GHC.Tc.Gen.HsType +import GHC.Builtin.Types +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Core.ConLike +import GHC.Builtin.Names +import GHC.Types.Basic hiding (SuccessFlag(..)) +import GHC.Driver.Session +import GHC.Types.SrcLoc +import GHC.Types.Var.Set +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import qualified GHC.LanguageExtensions as LangExt +import Control.Arrow ( second ) +import Control.Monad ( when ) +import GHC.Data.List.SetOps ( getNth ) + +{- +************************************************************************ +* * + External interface +* * +************************************************************************ +-} + +tcLetPat :: (Name -> Maybe TcId) + -> LetBndrSpec + -> LPat GhcRn -> ExpSigmaType + -> TcM a + -> TcM (LPat GhcTcId, a) +tcLetPat sig_fn no_gen pat pat_ty thing_inside + = do { bind_lvl <- getTcLevel + ; let ctxt = LetPat { pc_lvl = bind_lvl + , pc_sig_fn = sig_fn + , pc_new = no_gen } + penv = PE { pe_lazy = True + , pe_ctxt = ctxt + , pe_orig = PatOrigin } + + ; tc_lpat pat pat_ty penv thing_inside } + +----------------- +tcPats :: HsMatchContext GhcRn + -> [LPat GhcRn] -- Patterns, + -> [ExpSigmaType] -- and their types + -> TcM a -- and the checker for the body + -> TcM ([LPat GhcTcId], a) + +-- This is the externally-callable wrapper function +-- Typecheck the patterns, extend the environment to bind the variables, +-- do the thing inside, use any existentially-bound dictionaries to +-- discharge parts of the returning LIE, and deal with pattern type +-- signatures + +-- 1. Initialise the PatState +-- 2. Check the patterns +-- 3. Check the body +-- 4. Check that no existentials escape + +tcPats ctxt pats pat_tys thing_inside + = tc_lpats penv pats pat_tys thing_inside + where + penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } + +tcInferPat :: HsMatchContext GhcRn -> LPat GhcRn + -> TcM a + -> TcM ((LPat GhcTcId, a), TcSigmaType) +tcInferPat ctxt pat thing_inside + = tcInfer $ \ exp_ty -> + tc_lpat pat exp_ty penv thing_inside + where + penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } + +tcCheckPat :: HsMatchContext GhcRn + -> LPat GhcRn -> TcSigmaType + -> TcM a -- Checker for body + -> TcM (LPat GhcTcId, a) +tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin + +-- | A variant of 'tcPat' that takes a custom origin +tcCheckPat_O :: HsMatchContext GhcRn + -> CtOrigin -- ^ origin to use if the type needs inst'ing + -> LPat GhcRn -> TcSigmaType + -> TcM a -- Checker for body + -> TcM (LPat GhcTcId, a) +tcCheckPat_O ctxt orig pat pat_ty thing_inside + = tc_lpat pat (mkCheckExpType pat_ty) penv thing_inside + where + penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig } + + +{- +************************************************************************ +* * + PatEnv, PatCtxt, LetBndrSpec +* * +************************************************************************ +-} + +data PatEnv + = PE { pe_lazy :: Bool -- True <=> lazy context, so no existentials allowed + , pe_ctxt :: PatCtxt -- Context in which the whole pattern appears + , pe_orig :: CtOrigin -- origin to use if the pat_ty needs inst'ing + } + +data PatCtxt + = LamPat -- Used for lambdas, case etc + (HsMatchContext GhcRn) + + | LetPat -- Used only for let(rec) pattern bindings + -- See Note [Typing patterns in pattern bindings] + { pc_lvl :: TcLevel + -- Level of the binding group + + , pc_sig_fn :: Name -> Maybe TcId + -- Tells the expected type + -- for binders with a signature + + , pc_new :: LetBndrSpec + -- How to make a new binder + } -- for binders without signatures + +data LetBndrSpec + = LetLclBndr -- We are going to generalise, and wrap in an AbsBinds + -- so clone a fresh binder for the local monomorphic Id + + | LetGblBndr TcPragEnv -- Generalisation plan is NoGen, so there isn't going + -- to be an AbsBinds; So we must bind the global version + -- of the binder right away. + -- And here is the inline-pragma information + +instance Outputable LetBndrSpec where + ppr LetLclBndr = text "LetLclBndr" + ppr (LetGblBndr {}) = text "LetGblBndr" + +makeLazy :: PatEnv -> PatEnv +makeLazy penv = penv { pe_lazy = True } + +inPatBind :: PatEnv -> Bool +inPatBind (PE { pe_ctxt = LetPat {} }) = True +inPatBind (PE { pe_ctxt = LamPat {} }) = False + +{- ********************************************************************* +* * + Binders +* * +********************************************************************* -} + +tcPatBndr :: PatEnv -> Name -> ExpSigmaType -> TcM (HsWrapper, TcId) +-- (coi, xp) = tcPatBndr penv x pat_ty +-- Then coi : pat_ty ~ typeof(xp) +-- +tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl + , pc_sig_fn = sig_fn + , pc_new = no_gen } }) + bndr_name exp_pat_ty + -- For the LetPat cases, see + -- Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind + + | Just bndr_id <- sig_fn bndr_name -- There is a signature + = do { wrap <- tc_sub_type penv exp_pat_ty (idType bndr_id) + -- See Note [Subsumption check at pattern variables] + ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty) + ; return (wrap, bndr_id) } + + | otherwise -- No signature + = do { (co, bndr_ty) <- case exp_pat_ty of + Check pat_ty -> promoteTcType bind_lvl pat_ty + Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res ) + -- If we were under a constructor that bumped + -- the level, we'd be in checking mode + do { bndr_ty <- inferResultToType infer_res + ; return (mkTcNomReflCo bndr_ty, bndr_ty) } + ; bndr_id <- newLetBndr no_gen bndr_name bndr_ty + ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl + , ppr exp_pat_ty, ppr bndr_ty, ppr co + , ppr bndr_id ]) + ; return (mkWpCastN co, bndr_id) } + +tcPatBndr _ bndr_name pat_ty + = do { pat_ty <- expTypeToType pat_ty + ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty) + ; return (idHsWrapper, mkLocalIdOrCoVar bndr_name pat_ty) } + -- We should not have "OrCoVar" here, this is a bug (#17545) + -- Whether or not there is a sig is irrelevant, + -- as this is local + +newLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId +-- Make up a suitable Id for the pattern-binder. +-- See Note [Typechecking pattern bindings], item (4) in GHC.Tc.Gen.Bind +-- +-- In the polymorphic case when we are going to generalise +-- (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version" +-- of the Id; the original name will be bound to the polymorphic version +-- by the AbsBinds +-- In the monomorphic case when we are not going to generalise +-- (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds, +-- and we use the original name directly +newLetBndr LetLclBndr name ty + = do { mono_name <- cloneLocalName name + ; return (mkLocalId mono_name ty) } +newLetBndr (LetGblBndr prags) name ty + = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name) + +tc_sub_type :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper +-- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt +-- Used during typechecking patterns +tc_sub_type penv t1 t2 = tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2 + +{- Note [Subsumption check at pattern variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come across a variable with a type signature, we need to do a +subsumption, not equality, check against the context type. e.g. + + data T = MkT (forall a. a->a) + f :: forall b. [b]->[b] + MkT f = blah + +Since 'blah' returns a value of type T, its payload is a polymorphic +function of type (forall a. a->a). And that's enough to bind the +less-polymorphic function 'f', but we need some impedance matching +to witness the instantiation. + + +************************************************************************ +* * + The main worker functions +* * +************************************************************************ + +Note [Nesting] +~~~~~~~~~~~~~~ +tcPat takes a "thing inside" over which the pattern scopes. This is partly +so that tcPat can extend the environment for the thing_inside, but also +so that constraints arising in the thing_inside can be discharged by the +pattern. + +This does not work so well for the ErrCtxt carried by the monad: we don't +want the error-context for the pattern to scope over the RHS. +Hence the getErrCtxt/setErrCtxt stuff in tcMultiple +-} + +-------------------- +type Checker inp out = forall r. + inp + -> PatEnv + -> TcM r + -> TcM (out, r) + +tcMultiple :: Checker inp out -> Checker [inp] [out] +tcMultiple tc_pat args penv thing_inside + = do { err_ctxt <- getErrCtxt + ; let loop _ [] + = do { res <- thing_inside + ; return ([], res) } + + loop penv (arg:args) + = do { (p', (ps', res)) + <- tc_pat arg penv $ + setErrCtxt err_ctxt $ + loop penv args + -- setErrCtxt: restore context before doing the next pattern + -- See note [Nesting] above + + ; return (p':ps', res) } + + ; loop penv args } + +-------------------- +tc_lpat :: LPat GhcRn + -> ExpSigmaType + -> PatEnv + -> TcM a + -> TcM (LPat GhcTcId, a) +tc_lpat (L span pat) pat_ty penv thing_inside + = setSrcSpan span $ + do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) + thing_inside + ; return (L span pat', res) } + +tc_lpats :: PatEnv + -> [LPat GhcRn] -> [ExpSigmaType] + -> TcM a + -> TcM ([LPat GhcTcId], a) +tc_lpats penv pats tys thing_inside + = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys ) + tcMultiple (\(p,t) -> tc_lpat p t) + (zipEqual "tc_lpats" pats tys) + penv thing_inside + +-------------------- +tc_pat :: PatEnv + -> Pat GhcRn + -> ExpSigmaType -- Fully refined result type + -> TcM a -- Thing inside + -> TcM (Pat GhcTcId, -- Translated pattern + a) -- Result of thing inside + +tc_pat penv (VarPat x (L l name)) pat_ty thing_inside + = do { (wrap, id) <- tcPatBndr penv name pat_ty + ; res <- tcExtendIdEnv1 name id thing_inside + ; pat_ty <- readExpType pat_ty + ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } + +tc_pat penv (ParPat x pat) pat_ty thing_inside + = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside + ; return (ParPat x pat', res) } + +tc_pat penv (BangPat x pat) pat_ty thing_inside + = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside + ; return (BangPat x pat', res) } + +tc_pat penv (LazyPat x pat) pat_ty thing_inside + = do { (pat', (res, pat_ct)) + <- tc_lpat pat pat_ty (makeLazy penv) $ + captureConstraints thing_inside + -- Ignore refined penv', revert to penv + + ; emitConstraints pat_ct + -- captureConstraints/extendConstraints: + -- see Note [Hopping the LIE in lazy patterns] + + -- Check that the expected pattern type is itself lifted + ; pat_ty <- readExpType pat_ty + ; _ <- unifyType Nothing (tcTypeKind pat_ty) liftedTypeKind + + ; return (LazyPat x pat', res) } + +tc_pat _ (WildPat _) pat_ty thing_inside + = do { res <- thing_inside + ; pat_ty <- expTypeToType pat_ty + ; return (WildPat pat_ty, res) } + +tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside + = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) + ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ + tc_lpat pat (mkCheckExpType $ idType bndr_id) + penv thing_inside + -- NB: if we do inference on: + -- \ (y@(x::forall a. a->a)) = e + -- we'll fail. The as-pattern infers a monotype for 'y', which then + -- fails to unify with the polymorphic type for 'x'. This could + -- perhaps be fixed, but only with a bit more work. + -- + -- If you fix it, don't forget the bindInstsOfPatIds! + ; pat_ty <- readExpType pat_ty + ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, + res) } + +tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside + = do { + -- We use tcInferRho here. + -- If we have a view function with types like: + -- blah -> forall b. burble + -- then simple-subsumption means that 'forall b' won't be instantiated + -- so we can typecheck the inner pattern with that type + -- An exotic example: + -- pair :: forall a. a -> forall b. b -> (a,b) + -- f (pair True -> x) = ...here (x :: forall b. b -> (Bool,b)) + -- + -- TEMPORARY: pending simple subsumption, use tcInferSigma + -- When removing this, remove it from Expr.hs-boot too + ; (expr',expr_ty) <- tcInferSigma expr + + -- Expression must be a function + ; let expr_orig = lexprCtOrigin expr + herald = text "A view pattern expression expects" + ; (expr_wrap1, [inf_arg_ty], inf_res_ty) + <- matchActualFunTys herald expr_orig (Just (unLoc expr)) 1 expr_ty + -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_ty) + + -- Check that overall pattern is more polymorphic than arg type + ; expr_wrap2 <- tc_sub_type penv overall_pat_ty inf_arg_ty + -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty + + -- Pattern must have inf_res_ty + ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside + + ; overall_pat_ty <- readExpType overall_pat_ty + ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper + overall_pat_ty inf_res_ty doc + -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->" + -- (overall_pat_ty -> inf_res_ty) + expr_wrap = expr_wrap2' <.> expr_wrap1 + doc = text "When checking the view pattern function:" <+> (ppr expr) + ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)} + +-- Type signatures in patterns +-- See Note [Pattern coercions] below +tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside + = do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) + sig_ty pat_ty + -- Using tcExtendNameTyVarEnv is appropriate here + -- because we're not really bringing fresh tyvars into scope. + -- We're *naming* existing tyvars. Note that it is OK for a tyvar + -- from an outer scope to mention one of these tyvars in its kind. + ; (pat', res) <- tcExtendNameTyVarEnv wcs $ + tcExtendNameTyVarEnv tv_binds $ + tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside + ; pat_ty <- readExpType pat_ty + ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) } + +------------------------ +-- Lists, tuples, arrays +tc_pat penv (ListPat Nothing pats) pat_ty thing_inside + = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty + ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) + pats penv thing_inside + ; pat_ty <- readExpType pat_ty + ; return (mkHsWrapPat coi + (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res) +} + +tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside + = do { tau_pat_ty <- expTypeToType pat_ty + ; ((pats', res, elt_ty), e') + <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] + SynList $ + \ [elt_ty] -> + do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) + pats penv thing_inside + ; return (pats', res, elt_ty) } + ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res) +} + +tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside + = do { let arity = length pats + tc = tupleTyCon boxity arity + -- NB: tupleTyCon does not flatten 1-tuples + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make + ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) + penv pat_ty + -- Unboxed tuples have RuntimeRep vars, which we discard: + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys + Boxed -> arg_tys + ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys) + thing_inside + + ; dflags <- getDynFlags + + -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) + -- so that we can experiment with lazy tuple-matching. + -- This is a pretty odd place to make the switch, but + -- it was easy to do. + ; let + unmangled_result = TuplePat con_arg_tys pats' boxity + -- pat_ty /= pat_ty iff coi /= IdCo + possibly_mangled_result + | gopt Opt_IrrefutableTuples dflags && + isBoxed boxity = LazyPat noExtField (noLoc unmangled_result) + | otherwise = unmangled_result + + ; pat_ty <- readExpType pat_ty + ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced + return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) + } + +tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside + = do { let tc = sumTyCon arity + ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) + penv pat_ty + ; -- Drop levity vars, we don't care about them here + let con_arg_tys = drop arity arg_tys + ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1))) + penv thing_inside + ; pat_ty <- readExpType pat_ty + ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty + , res) + } + +------------------------ +-- Data constructors +tc_pat penv (ConPat NoExtField con arg_pats) pat_ty thing_inside + = tcConPat penv con pat_ty arg_pats thing_inside + +------------------------ +-- Literal patterns +tc_pat penv (LitPat x simple_lit) pat_ty thing_inside + = do { let lit_ty = hsLitType simple_lit + ; wrap <- tc_sub_type penv pat_ty lit_ty + ; res <- thing_inside + ; pat_ty <- readExpType pat_ty + ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty + , res) } + +------------------------ +-- Overloaded patterns: n, and n+k + +-- In the case of a negative literal (the more complicated case), +-- we get +-- +-- case v of (-5) -> blah +-- +-- becoming +-- +-- if v == (negate (fromInteger 5)) then blah else ... +-- +-- There are two bits of rebindable syntax: +-- (==) :: pat_ty -> neg_lit_ty -> Bool +-- negate :: lit_ty -> neg_lit_ty +-- where lit_ty is the type of the overloaded literal 5. +-- +-- When there is no negation, neg_lit_ty and lit_ty are the same +tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside + = do { let orig = LiteralOrigin over_lit + ; ((lit', mb_neg'), eq') + <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] + (mkCheckExpType boolTy) $ + \ [neg_lit_ty] -> + let new_over_lit lit_ty = newOverloadedLit over_lit + (mkCheckExpType lit_ty) + in case mb_neg of + Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty + Just neg -> -- Negative literal + -- The 'negate' is re-mappable syntax + second Just <$> + (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $ + \ [lit_ty] -> new_over_lit lit_ty) + + ; res <- thing_inside + ; pat_ty <- readExpType pat_ty + ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } + +{- +Note [NPlusK patterns] +~~~~~~~~~~~~~~~~~~~~~~ +From + + case v of x + 5 -> blah + +we get + + if v >= 5 then (\x -> blah) (v - 5) else ... + +There are two bits of rebindable syntax: + (>=) :: pat_ty -> lit1_ty -> Bool + (-) :: pat_ty -> lit2_ty -> var_ty + +lit1_ty and lit2_ty could conceivably be different. +var_ty is the type inferred for x, the variable in the pattern. + +If the pushed-down pattern type isn't a tau-type, the two pat_ty's above +could conceivably be different specializations. But this is very much +like the situation in Note [Case branches must be taus] in GHC.Tc.Gen.Match. +So we tauify the pat_ty before proceeding. + +Note that we need to type-check the literal twice, because it is used +twice, and may be used at different types. The second HsOverLit stored in the +AST is used for the subtraction operation. +-} + +-- See Note [NPlusK patterns] +tc_pat penv (NPlusKPat _ (L nm_loc name) + (L loc lit) _ ge minus) pat_ty + thing_inside + = do { pat_ty <- expTypeToType pat_ty + ; let orig = LiteralOrigin lit + ; (lit1', ge') + <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho] + (mkCheckExpType boolTy) $ + \ [lit1_ty] -> + newOverloadedLit lit (mkCheckExpType lit1_ty) + ; ((lit2', minus_wrap, bndr_id), minus') + <- tcSyntaxOpGen orig minus [synKnownType pat_ty, SynRho] SynAny $ + \ [lit2_ty, var_ty] -> + do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) + ; (wrap, bndr_id) <- setSrcSpan nm_loc $ + tcPatBndr penv name (mkCheckExpType var_ty) + -- co :: var_ty ~ idType bndr_id + + -- minus_wrap is applicable to minus' + ; return (lit2', wrap, bndr_id) } + + -- The Report says that n+k patterns must be in Integral + -- but it's silly to insist on this in the RebindableSyntax case + ; unlessM (xoptM LangExt.RebindableSyntax) $ + do { icls <- tcLookupClass integralClassName + ; instStupidTheta orig [mkClassPred icls [pat_ty]] } + + ; res <- tcExtendIdEnv1 name bndr_id thing_inside + + ; let minus'' = case minus' of + NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus') + -- this should be statically avoidable + -- Case (3) from Note [NoSyntaxExpr] in Hs.Expr + SyntaxExprTc { syn_expr = minus'_expr + , syn_arg_wraps = minus'_arg_wraps + , syn_res_wrap = minus'_res_wrap } + -> SyntaxExprTc { syn_expr = minus'_expr + , syn_arg_wraps = minus'_arg_wraps + , syn_res_wrap = minus_wrap <.> minus'_res_wrap } + -- Oy. This should really be a record update, but + -- we get warnings if we try. #17783 + pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' + ge' minus'' + ; return (pat', res) } + +-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSplicePat'. +-- Here we get rid of it and add the finalizers to the global environment. +-- +-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. +tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat))) + pat_ty thing_inside + = do addModFinalizersWithLclEnv mod_finalizers + tc_pat penv pat pat_ty thing_inside + +tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut + + +{- +Note [Hopping the LIE in lazy patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a lazy pattern, we must *not* discharge constraints from the RHS +from dictionaries bound in the pattern. E.g. + f ~(C x) = 3 +We can't discharge the Num constraint from dictionaries bound by +the pattern C! + +So we have to make the constraints from thing_inside "hop around" +the pattern. Hence the captureConstraints and emitConstraints. + +The same thing ensures that equality constraints in a lazy match +are not made available in the RHS of the match. For example + data T a where { T1 :: Int -> T Int; ... } + f :: T a -> Int -> a + f ~(T1 i) y = y +It's obviously not sound to refine a to Int in the right +hand side, because the argument might not match T1 at all! + +Finally, a lazy pattern should not bind any existential type variables +because they won't be in scope when we do the desugaring + + +************************************************************************ +* * + Pattern signatures (pat :: type) +* * +************************************************************************ +-} + +tcPatSig :: Bool -- True <=> pattern binding + -> LHsSigWcType GhcRn + -> ExpSigmaType + -> TcM (TcType, -- The type to use for "inside" the signature + [(Name,TcTyVar)], -- The new bit of type environment, binding + -- the scoped type variables + [(Name,TcTyVar)], -- The wildcards + HsWrapper) -- Coercion due to unification with actual ty + -- Of shape: res_ty ~ sig_ty +tcPatSig in_pat_bind sig res_ty + = do { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig + -- sig_tvs are the type variables free in 'sig', + -- and not already in scope. These are the ones + -- that should be brought into scope + + ; if null sig_tvs then do { + -- Just do the subsumption check and return + wrap <- addErrCtxtM (mk_msg sig_ty) $ + tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty + ; return (sig_ty, [], sig_wcs, wrap) + } else do + -- Type signature binds at least one scoped type variable + + -- A pattern binding cannot bind scoped type variables + -- It is more convenient to make the test here + -- than in the renamer + { when in_pat_bind (addErr (patBindSigErr sig_tvs)) + + -- Now do a subsumption check of the pattern signature against res_ty + ; wrap <- addErrCtxtM (mk_msg sig_ty) $ + tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty + + -- Phew! + ; return (sig_ty, sig_tvs, sig_wcs, wrap) + } } + where + mk_msg sig_ty tidy_env + = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty + ; res_ty <- readExpType res_ty -- should be filled in by now + ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty + ; let msg = vcat [ hang (text "When checking that the pattern signature:") + 4 (ppr sig_ty) + , nest 2 (hang (text "fits the type of its context:") + 2 (ppr res_ty)) ] + ; return (tidy_env, msg) } + +patBindSigErr :: [(Name,TcTyVar)] -> SDoc +patBindSigErr sig_tvs + = hang (text "You cannot bind scoped type variable" <> plural sig_tvs + <+> pprQuotedList (map fst sig_tvs)) + 2 (text "in a pattern binding signature") + + +{- ********************************************************************* +* * + Most of the work for constructors is here + (the rest is in the ConPatIn case of tc_pat) +* * +************************************************************************ + +[Pattern matching indexed data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following declarations: + + data family Map k :: * -> * + data instance Map (a, b) v = MapPair (Map a (Pair b v)) + +and a case expression + + case x :: Map (Int, c) w of MapPair m -> ... + +As explained by [Wrappers for data instance tycons] in GHC.Types.Id.Make, the +worker/wrapper types for MapPair are + + $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v + $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v + +So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is +:R123Map, which means the straight use of boxySplitTyConApp would give a type +error. Hence, the smart wrapper function boxySplitTyConAppWithFamily calls +boxySplitTyConApp with the family tycon Map instead, which gives us the family +type list {(Int, c), w}. To get the correct split for :R123Map, we need to +unify the family type list {(Int, c), w} with the instance types {(a, b), v} +(provided by tyConFamInst_maybe together with the family tycon). This +unification yields the substitution [a -> Int, b -> c, v -> w], which gives us +the split arguments for the representation tycon :R123Map as {Int, c, w} + +In other words, boxySplitTyConAppWithFamily implicitly takes the coercion + + Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} + +moving between representation and family type into account. To produce type +correct Core, this coercion needs to be used to case the type of the scrutinee +from the family to the representation type. This is achieved by +unwrapFamInstScrutinee using a CoPat around the result pattern. + +Now it might appear seem as if we could have used the previous GADT type +refinement infrastructure of refineAlt and friends instead of the explicit +unification and CoPat generation. However, that would be wrong. Why? The +whole point of GADT refinement is that the refinement is local to the case +alternative. In contrast, the substitution generated by the unification of +the family type list and instance types needs to be propagated to the outside. +Imagine that in the above example, the type of the scrutinee would have been +(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the +substitution [x -> (a, b), v -> w]. In contrast to GADT matching, the +instantiation of x with (a, b) must be global; ie, it must be valid in *all* +alternatives of the case expression, whereas in the GADT case it might vary +between alternatives. + +RIP GADT refinement: refinements have been replaced by the use of explicit +equality constraints that are used in conjunction with implication constraints +to express the local scope of GADT refinements. +-} + +-- Running example: +-- MkT :: forall a b c. (a~[b]) => b -> c -> T a +-- with scrutinee of type (T ty) + +tcConPat :: PatEnv -> Located Name + -> ExpSigmaType -- Type of the pattern + -> HsConPatDetails GhcRn -> TcM a + -> TcM (Pat GhcTcId, a) +tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside + = do { con_like <- tcLookupConLike con_name + ; case con_like of + RealDataCon data_con -> tcDataConPat penv con_lname data_con + pat_ty arg_pats thing_inside + PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn + pat_ty arg_pats thing_inside + } + +tcDataConPat :: PatEnv -> Located Name -> DataCon + -> ExpSigmaType -- Type of the pattern + -> HsConPatDetails GhcRn -> TcM a + -> TcM (Pat GhcTcId, a) +tcDataConPat penv (L con_span con_name) data_con pat_ty + arg_pats thing_inside + = do { let tycon = dataConTyCon data_con + -- For data families this is the representation tycon + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) + = dataConFullSig data_con + header = L con_span (RealDataCon data_con) + + -- Instantiate the constructor type variables [a->ty] + -- This may involve doing a family-instance coercion, + -- and building a wrapper + ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty + ; pat_ty <- readExpType pat_ty + + -- Add the stupid theta + ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys + + ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys + ; checkExistentials ex_tvs all_arg_tys penv + + ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys + -- NB: Do not use zipTvSubst! See #14154 + -- We want to create a well-kinded substitution, so + -- that the instantiated type is well-kinded + + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs + -- Get location from monad, not from ex_tvs + + ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys + -- pat_ty' is type of the actual constructor application + -- pat_ty' /= pat_ty iff coi /= IdCo + + arg_tys' = substTys tenv arg_tys + + ; traceTc "tcConPat" (vcat [ ppr con_name + , pprTyVars univ_tvs + , pprTyVars ex_tvs + , ppr eq_spec + , ppr theta + , pprTyVars ex_tvs' + , ppr ctxt_res_tys + , ppr arg_tys' + , ppr arg_pats ]) + ; if null ex_tvs && null eq_spec && null theta + then do { -- The common case; no class bindings etc + -- (see Note [Arrows and patterns]) + (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys' + arg_pats penv thing_inside + ; let res_pat = ConPat { pat_con = header + , pat_args = arg_pats' + , pat_con_ext = ConPatTc + { cpt_tvs = [], cpt_dicts = [] + , cpt_binds = emptyTcEvBinds + , cpt_arg_tys = ctxt_res_tys + , cpt_wrap = idHsWrapper + } + } + + ; return (mkHsWrapPat wrap res_pat pat_ty, res) } + + else do -- The general case, with existential, + -- and local equality constraints + { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) + -- order is *important* as we generate the list of + -- dictionary binders from theta' + no_equalities = null eq_spec && not (any isEqPred theta) + skol_info = PatSkol (RealDataCon data_con) mc + mc = case pe_ctxt penv of + LamPat mc -> mc + LetPat {} -> PatBindRhs + + ; gadts_on <- xoptM LangExt.GADTs + ; families_on <- xoptM LangExt.TypeFamilies + ; checkTc (no_equalities || gadts_on || families_on) + (text "A pattern match on a GADT requires the" <+> + text "GADTs or TypeFamilies language extension") + -- #2905 decided that a *pattern-match* of a GADT + -- should require the GADT language flag. + -- Re TypeFamilies see also #7156 + + ; given <- newEvVars theta' + ; (ev_binds, (arg_pats', res)) + <- checkConstraints skol_info ex_tvs' given $ + tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside + + ; let res_pat = ConPat + { pat_con = header + , pat_args = arg_pats' + , pat_con_ext = ConPatTc + { cpt_tvs = ex_tvs' + , cpt_dicts = given + , cpt_binds = ev_binds + , cpt_arg_tys = ctxt_res_tys + , cpt_wrap = idHsWrapper + } + } + ; return (mkHsWrapPat wrap res_pat pat_ty, res) + } } + +tcPatSynPat :: PatEnv -> Located Name -> PatSyn + -> ExpSigmaType -- Type of the pattern + -> HsConPatDetails GhcRn -> TcM a + -> TcM (Pat GhcTcId, a) +tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside + = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn + + ; (subst, univ_tvs') <- newMetaTyVars univ_tvs + + ; let all_arg_tys = ty : prov_theta ++ arg_tys + ; checkExistentials ex_tvs all_arg_tys penv + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs + ; let ty' = substTy tenv ty + arg_tys' = substTys tenv arg_tys + prov_theta' = substTheta tenv prov_theta + req_theta' = substTheta tenv req_theta + + ; wrap <- tc_sub_type penv pat_ty ty' + ; traceTc "tcPatSynPat" (ppr pat_syn $$ + ppr pat_ty $$ + ppr ty' $$ + ppr ex_tvs' $$ + ppr prov_theta' $$ + ppr req_theta' $$ + ppr arg_tys') + + ; prov_dicts' <- newEvVars prov_theta' + + ; let skol_info = case pe_ctxt penv of + LamPat mc -> PatSkol (PatSynCon pat_syn) mc + LetPat {} -> UnkSkol -- Doesn't matter + + ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta' + ; traceTc "instCall" (ppr req_wrap) + + ; traceTc "checkConstraints {" Outputable.empty + ; (ev_binds, (arg_pats', res)) + <- checkConstraints skol_info ex_tvs' prov_dicts' $ + tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside + + ; traceTc "checkConstraints }" (ppr ev_binds) + ; let res_pat = ConPat { pat_con = L con_span $ PatSynCon pat_syn + , pat_args = arg_pats' + , pat_con_ext = ConPatTc + { cpt_tvs = ex_tvs' + , cpt_dicts = prov_dicts' + , cpt_binds = ev_binds + , cpt_arg_tys = mkTyVarTys univ_tvs' + , cpt_wrap = req_wrap + } + } + ; pat_ty <- readExpType pat_ty + ; return (mkHsWrapPat wrap res_pat pat_ty, res) } + +---------------------------- +-- | Convenient wrapper for calling a matchExpectedXXX function +matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a)) + -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a) +-- See Note [Matching polytyped patterns] +-- Returns a wrapper : pat_ty ~R inner_ty +matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty + = do { pat_ty <- expTypeToType pat_ty + ; (wrap, pat_rho) <- topInstantiate orig pat_ty + ; (co, res) <- inner_match pat_rho + ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap) + ; return (mkWpCastN (mkTcSymCo co) <.> wrap, res) } + +---------------------------- +matchExpectedConTy :: PatEnv + -> TyCon -- The TyCon that this data + -- constructor actually returns + -- In the case of a data family this is + -- the /representation/ TyCon + -> ExpSigmaType -- The type of the pattern; in the case + -- of a data family this would mention + -- the /family/ TyCon + -> TcM (HsWrapper, [TcSigmaType]) +-- See Note [Matching constructor patterns] +-- Returns a wrapper : pat_ty "->" T ty1 ... tyn +matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty + | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc + -- Comments refer to Note [Matching constructor patterns] + -- co_tc :: forall a. T [a] ~ T7 a + = do { pat_ty <- expTypeToType exp_pat_ty + ; (wrap, pat_rho) <- topInstantiate orig pat_ty + + ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc) + -- tys = [ty1,ty2] + + ; traceTc "matchExpectedConTy" (vcat [ppr data_tc, + ppr (tyConTyVars data_tc), + ppr fam_tc, ppr fam_args, + ppr exp_pat_ty, + ppr pat_ty, + ppr pat_rho, ppr wrap]) + ; co1 <- unifyType Nothing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho + -- co1 : T (ty1,ty2) ~N pat_rho + -- could use tcSubType here... but it's the wrong way round + -- for actual vs. expected in error messages. + + ; let tys' = mkTyVarTys tvs' + co2 = mkTcUnbranchedAxInstCo co_tc tys' [] + -- co2 : T (ty1,ty2) ~R T7 ty1 ty2 + + full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2 + -- full_co :: pat_rho ~R T7 ty1 ty2 + + ; return ( mkWpCastR full_co <.> wrap, tys') } + + | otherwise + = do { pat_ty <- expTypeToType exp_pat_ty + ; (wrap, pat_rho) <- topInstantiate orig pat_ty + ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho + ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) } + +{- +Note [Matching constructor patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose (coi, tys) = matchExpectedConType data_tc pat_ty + + * In the simple case, pat_ty = tc tys + + * If pat_ty is a polytype, we want to instantiate it + This is like part of a subsumption check. Eg + f :: (forall a. [a]) -> blah + f [] = blah + + * In a type family case, suppose we have + data family T a + data instance T (p,q) = A p | B q + Then we'll have internally generated + data T7 p q = A p | B q + axiom coT7 p q :: T (p,q) ~ T7 p q + + So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that + coi = coi2 . coi1 : T7 t ~ pat_ty + coi1 : T (ty1,ty2) ~ pat_ty + coi2 : T7 ty1 ty2 ~ T (ty1,ty2) + + For families we do all this matching here, not in the unifier, + because we never want a whisper of the data_tycon to appear in + error messages; it's a purely internal thing +-} + +tcConArgs :: ConLike -> [TcSigmaType] + -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) + +tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside + = do { checkTc (con_arity == no_of_args) -- Check correct arity + (arityErr (text "constructor") con_like con_arity no_of_args) + ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys + ; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys + penv thing_inside + ; return (PrefixCon arg_pats', res) } + where + con_arity = conLikeArity con_like + no_of_args = length arg_pats + +tcConArgs con_like arg_tys (InfixCon p1 p2) penv thing_inside + = do { checkTc (con_arity == 2) -- Check correct arity + (arityErr (text "constructor") con_like con_arity 2) + ; let [arg_ty1,arg_ty2] = arg_tys -- This can't fail after the arity check + ; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)] + penv thing_inside + ; return (InfixCon p1' p2', res) } + where + con_arity = conLikeArity con_like + +tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside + = do { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside + ; return (RecCon (HsRecFields rpats' dd), res) } + where + tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) + (LHsRecField GhcTcId (LPat GhcTcId)) + tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) + penv thing_inside + = do { sel' <- tcLookupId sel + ; pat_ty <- setSrcSpan loc $ find_field_ty sel + (occNameFS $ rdrNameOcc rdr) + ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside + ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' + pun), res) } + + + find_field_ty :: Name -> FieldLabelString -> TcM TcType + find_field_ty sel lbl + = case [ty | (fl, ty) <- field_tys, flSelector fl == sel] of + + -- No matching field; chances are this field label comes from some + -- other record type (or maybe none). If this happens, just fail, + -- otherwise we get crashes later (#8570), and similar: + -- f (R { foo = (a,b) }) = a+b + -- If foo isn't one of R's fields, we don't want to crash when + -- typechecking the "a+b". + [] -> failWith (badFieldCon con_like lbl) + + -- The normal case, when the field comes from the right constructor + (pat_ty : extras) -> do + traceTc "find_field" (ppr pat_ty <+> ppr extras) + ASSERT( null extras ) (return pat_ty) + + field_tys :: [(FieldLabel, TcType)] + field_tys = zip (conLikeFieldLabels con_like) arg_tys + -- Don't use zipEqual! If the constructor isn't really a record, then + -- dataConFieldLabels will be empty (and each field in the pattern + -- will generate an error below). + +tcConArg :: Checker (LPat GhcRn, TcSigmaType) (LPat GhcTc) +tcConArg (arg_pat, arg_ty) penv thing_inside + = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside + +addDataConStupidTheta :: DataCon -> [TcType] -> TcM () +-- Instantiate the "stupid theta" of the data con, and throw +-- the constraints into the constraint set +addDataConStupidTheta data_con inst_tys + | null stupid_theta = return () + | otherwise = instStupidTheta origin inst_theta + where + origin = OccurrenceOf (dataConName data_con) + -- The origin should always report "occurrence of C" + -- even when C occurs in a pattern + stupid_theta = dataConStupidTheta data_con + univ_tvs = dataConUnivTyVars data_con + tenv = zipTvSubst univ_tvs (takeList univ_tvs inst_tys) + -- NB: inst_tys can be longer than the univ tyvars + -- because the constructor might have existentials + inst_theta = substTheta tenv stupid_theta + +{- +Note [Arrows and patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +(Oct 07) Arrow notation has the odd property that it involves +"holes in the scope". For example: + expr :: Arrow a => a () Int + expr = proc (y,z) -> do + x <- term -< y + expr' -< x + +Here the 'proc (y,z)' binding scopes over the arrow tails but not the +arrow body (e.g 'term'). As things stand (bogusly) all the +constraints from the proc body are gathered together, so constraints +from 'term' will be seen by the tcPat for (y,z). But we must *not* +bind constraints from 'term' here, because the desugarer will not make +these bindings scope over 'term'. + +The Right Thing is not to confuse these constraints together. But for +now the Easy Thing is to ensure that we do not have existential or +GADT constraints in a 'proc', and to short-cut the constraint +simplification for such vanilla patterns so that it binds no +constraints. Hence the 'fast path' in tcConPat; but it's also a good +plan for ordinary vanilla patterns to bypass the constraint +simplification step. + +************************************************************************ +* * + Note [Pattern coercions] +* * +************************************************************************ + +In principle, these program would be reasonable: + + f :: (forall a. a->a) -> Int + f (x :: Int->Int) = x 3 + + g :: (forall a. [a]) -> Bool + g [] = True + +In both cases, the function type signature restricts what arguments can be passed +in a call (to polymorphic ones). The pattern type signature then instantiates this +type. For example, in the first case, (forall a. a->a) <= Int -> Int, and we +generate the translated term + f = \x' :: (forall a. a->a). let x = x' Int in x 3 + +From a type-system point of view, this is perfectly fine, but it's *very* seldom useful. +And it requires a significant amount of code to implement, because we need to decorate +the translated pattern with coercion functions (generated from the subsumption check +by tcSub). + +So for now I'm just insisting on type *equality* in patterns. No subsumption. + +Old notes about desugaring, at a time when pattern coercions were handled: + +A SigPat is a type coercion and must be handled one at a time. We can't +combine them unless the type of the pattern inside is identical, and we don't +bother to check for that. For example: + + data T = T1 Int | T2 Bool + f :: (forall a. a -> a) -> T -> t + f (g::Int->Int) (T1 i) = T1 (g i) + f (g::Bool->Bool) (T2 b) = T2 (g b) + +We desugar this as follows: + + f = \ g::(forall a. a->a) t::T -> + let gi = g Int + in case t of { T1 i -> T1 (gi i) + other -> + let gb = g Bool + in case t of { T2 b -> T2 (gb b) + other -> fail }} + +Note that we do not treat the first column of patterns as a +column of variables, because the coerced variables (gi, gb) +would be of different types. So we get rather grotty code. +But I don't think this is a common case, and if it was we could +doubtless improve it. + +Meanwhile, the strategy is: + * treat each SigPat coercion (always non-identity coercions) + as a separate block + * deal with the stuff inside, and then wrap a binding round + the result to bind the new variable (gi, gb, etc) + + +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ + +Note [Existential check] +~~~~~~~~~~~~~~~~~~~~~~~~ +Lazy patterns can't bind existentials. They arise in two ways: + * Let bindings let { C a b = e } in b + * Twiddle patterns f ~(C a b) = e +The pe_lazy field of PatEnv says whether we are inside a lazy +pattern (perhaps deeply) + +See also Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind +-} + +maybeWrapPatCtxt :: Pat GhcRn -> (TcM a -> TcM b) -> TcM a -> TcM b +-- Not all patterns are worth pushing a context +maybeWrapPatCtxt pat tcm thing_inside + | not (worth_wrapping pat) = tcm thing_inside + | otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside + -- Remember to pop before doing thing_inside + where + worth_wrapping (VarPat {}) = False + worth_wrapping (ParPat {}) = False + worth_wrapping (AsPat {}) = False + worth_wrapping _ = True + msg = hang (text "In the pattern:") 2 (ppr pat) + +----------------------------------------------- +checkExistentials :: [TyVar] -- existentials + -> [Type] -- argument types + -> PatEnv -> TcM () + -- See Note [Existential check]] + -- See Note [Arrows and patterns] +checkExistentials ex_tvs tys _ + | all (not . (`elemVarSet` tyCoVarsOfTypes tys)) ex_tvs = return () +checkExistentials _ _ (PE { pe_ctxt = LetPat {}}) = return () +checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr }) = failWithTc existentialProcPat +checkExistentials _ _ (PE { pe_lazy = True }) = failWithTc existentialLazyPat +checkExistentials _ _ _ = return () + +existentialLazyPat :: SDoc +existentialLazyPat + = hang (text "An existential or GADT data constructor cannot be used") + 2 (text "inside a lazy (~) pattern") + +existentialProcPat :: SDoc +existentialProcPat + = text "Proc patterns cannot use existential or GADT data constructors" + +badFieldCon :: ConLike -> FieldLabelString -> SDoc +badFieldCon con field + = hsep [text "Constructor" <+> quotes (ppr con), + text "does not have field", quotes (ppr field)] + +polyPatSig :: TcType -> SDoc +polyPatSig sig_ty + = hang (text "Illegal polymorphic type signature in pattern:") + 2 (ppr sig_ty) diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -0,0 +1,495 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} + +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Typechecking transformation rules +module GHC.Tc.Gen.Rule ( tcRules ) where + +import GHC.Prelude + +import GHC.Hs +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Solver +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Expr +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Unify( buildImplicationFor ) +import GHC.Tc.Types.Evidence( mkTcCoVarCo ) +import GHC.Core.Type +import GHC.Core.TyCon( isTypeFamilyTyCon ) +import GHC.Types.Id +import GHC.Types.Var( EvVar ) +import GHC.Types.Var.Set +import GHC.Types.Basic ( RuleName ) +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Bag + +{- +Note [Typechecking rules] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We *infer* the typ of the LHS, and use that type to *check* the type of +the RHS. That means that higher-rank rules work reasonably well. Here's +an example (test simplCore/should_compile/rule2.hs) produced by Roman: + + foo :: (forall m. m a -> m b) -> m a -> m b + foo f = ... + + bar :: (forall m. m a -> m a) -> m a -> m a + bar f = ... + + {-# RULES "foo/bar" foo = bar #-} + +He wanted the rule to typecheck. + +Note [TcLevel in type checking rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Bringing type variables into scope naturally bumps the TcLevel. Thus, we type +check the term-level binders in a bumped level, and we must accordingly bump +the level whenever these binders are in scope. + +Note [Re-quantify type variables in rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example from #17710: + + foo :: forall k (a :: k) (b :: k). Proxy a -> Proxy b + foo x = Proxy + {-# RULES "foo" forall (x :: Proxy (a :: k)). foo x = Proxy #-} + +Written out in more detail, the "foo" rewrite rule looks like this: + + forall k (a :: k). forall (x :: Proxy (a :: k)). foo @k @a @b0 x = Proxy @k @b0 + +Where b0 is a unification variable. Where should b0 be quantified? We have to +quantify it after k, since (b0 :: k). But generalization usually puts inferred +type variables (such as b0) at the /front/ of the telescope! This creates a +conflict. + +One option is to simply throw an error, per the principles of +Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType. This is what would happen +if we were generalising over a normal type signature. On the other hand, the +types in a rewrite rule aren't quite "normal", since the notions of specified +and inferred type variables aren't applicable. + +A more permissive design (and the design that GHC uses) is to simply requantify +all of the type variables. That is, we would end up with this: + + forall k (a :: k) (b :: k). forall (x :: Proxy (a :: k)). foo @k @a @b x = Proxy @k @b + +It's a bit strange putting the generalized variable `b` after the user-written +variables `k` and `a`. But again, the notion of specificity is not relevant to +rewrite rules, since one cannot "visibly apply" a rewrite rule. This design not +only makes "foo" typecheck, but it also makes the implementation simpler. + +See also Note [Generalising in tcTyFamInstEqnGuts] in GHC.Tc.TyCl, which +explains a very similar design when generalising over a type family instance +equation. +-} + +tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTcId] +tcRules decls = mapM (wrapLocM tcRuleDecls) decls + +tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTcId) +tcRuleDecls (HsRules { rds_src = src + , rds_rules = decls }) + = do { tc_decls <- mapM (wrapLocM tcRule) decls + ; return $ HsRules { rds_ext = noExtField + , rds_src = src + , rds_rules = tc_decls } } + +tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId) +tcRule (HsRule { rd_ext = ext + , rd_name = rname@(L _ (_,name)) + , rd_act = act + , rd_tyvs = ty_bndrs + , rd_tmvs = tm_bndrs + , rd_lhs = lhs + , rd_rhs = rhs }) + = addErrCtxt (ruleCtxt name) $ + do { traceTc "---- Rule ------" (pprFullRuleName rname) + + -- Note [Typechecking rules] + ; (tc_lvl, stuff) <- pushTcLevelM $ + generateRuleConstraints ty_bndrs tm_bndrs lhs rhs + + ; let (id_bndrs, lhs', lhs_wanted + , rhs', rhs_wanted, rule_ty) = stuff + + ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname + , ppr lhs_wanted + , ppr rhs_wanted ]) + + ; (lhs_evs, residual_lhs_wanted) + <- simplifyRule name tc_lvl lhs_wanted rhs_wanted + + -- SimplfyRule Plan, step 4 + -- Now figure out what to quantify over + -- c.f. GHC.Tc.Solver.simplifyInfer + -- We quantify over any tyvars free in *either* the rule + -- *or* the bound variables. The latter is important. Consider + -- ss (x,(y,z)) = (x,z) + -- RULE: forall v. fst (ss v) = fst v + -- The type of the rhs of the rule is just a, but v::(a,(b,c)) + -- + -- 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) + + ; let tpl_ids = lhs_evs ++ id_bndrs + + -- See Note [Re-quantify type variables in rules] + ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids) + ; qtkvs <- quantifyTyVars forall_tkvs + ; traceTc "tcRule" (vcat [ pprFullRuleName rname + , ppr forall_tkvs + , ppr qtkvs + , ppr rule_ty + , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] + ]) + + -- SimplfyRule Plan, step 5 + -- Simplify the LHS and RHS constraints: + -- For the LHS constraints we must solve the remaining constraints + -- (a) so that we report insoluble ones + -- (b) so that we bind any soluble ones + ; let skol_info = RuleSkol name + ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs + lhs_evs residual_lhs_wanted + ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs + lhs_evs rhs_wanted + + ; emitImplications (lhs_implic `unionBags` rhs_implic) + ; return $ HsRule { rd_ext = ext + , rd_name = rname + , rd_act = act + , rd_tyvs = ty_bndrs -- preserved for ppr-ing + , rd_tmvs = map (noLoc . RuleBndr noExtField . noLoc) + (qtkvs ++ tpl_ids) + , rd_lhs = mkHsDictLet lhs_binds lhs' + , rd_rhs = mkHsDictLet rhs_binds rhs' } } + +generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] + -> LHsExpr GhcRn -> LHsExpr GhcRn + -> TcM ( [TcId] + , LHsExpr GhcTc, WantedConstraints + , LHsExpr GhcTc, WantedConstraints + , TcType ) +generateRuleConstraints ty_bndrs tm_bndrs lhs rhs + = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $ + tcRuleBndrs ty_bndrs tm_bndrs + -- bndr_wanted constraints can include wildcard hole + -- constraints, which we should not forget about. + -- It may mention the skolem type variables bound by + -- the RULE. c.f. #10072 + + ; tcExtendTyVarEnv tv_bndrs $ + tcExtendIdEnv id_bndrs $ + do { -- See Note [Solve order for RULES] + ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) + ; (rhs', rhs_wanted) <- captureConstraints $ + tcLExpr rhs (mkCheckExpType rule_ty) + ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted + ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } } + +-- See Note [TcLevel in type checking rules] +tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] + -> TcM ([TcTyVar], [Id]) +tcRuleBndrs (Just bndrs) xs + = do { (tys1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $ + tcRuleTmBndrs xs + ; return (tys1 ++ tys2, tms) } + +tcRuleBndrs Nothing xs + = tcRuleTmBndrs xs + +-- See Note [TcLevel in type checking rules] +tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id]) +tcRuleTmBndrs [] = return ([],[]) +tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs) + = do { ty <- newOpenFlexiTyVarTy + ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs + ; return (tyvars, mkLocalId name ty : tmvars) } +tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) +-- e.g x :: a->a +-- The tyvar 'a' is brought into scope first, just as if you'd written +-- a::*, x :: a->a +-- If there's an explicit forall, the renamer would have already reported an +-- error for each out-of-scope type variable used + = do { let ctxt = RuleSigCtxt name + ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty + ; let id = mkLocalId name id_ty + -- See Note [Pattern signature binders] in GHC.Tc.Gen.HsType + + -- The type variables scope over subsequent bindings; yuk + ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $ + tcRuleTmBndrs rule_bndrs + ; return (map snd tvs ++ tyvars, id : tmvars) } + +ruleCtxt :: FastString -> SDoc +ruleCtxt name = text "When checking the transformation rule" <+> + doubleQuotes (ftext name) + + +{- +********************************************************************************* +* * + Constraint simplification for rules +* * +*********************************************************************************** + +Note [The SimplifyRule Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Example. Consider the following left-hand side of a rule + f (x == y) (y > z) = ... +If we typecheck this expression we get constraints + d1 :: Ord a, d2 :: Eq a +We do NOT want to "simplify" to the LHS + forall x::a, y::a, z::a, d1::Ord a. + f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ... +Instead we want + forall x::a, y::a, z::a, d1::Ord a, d2::Eq a. + f ((==) d2 x y) ((>) d1 y z) = ... + +Here is another example: + fromIntegral :: (Integral a, Num b) => a -> b + {-# RULES "foo" fromIntegral = id :: Int -> Int #-} +In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But +we *dont* want to get + forall dIntegralInt. + fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int +because the scsel will mess up RULE matching. Instead we want + forall dIntegralInt, dNumInt. + fromIntegral Int Int dIntegralInt dNumInt = id Int + +Even if we have + g (x == y) (y == z) = .. +where the two dictionaries are *identical*, we do NOT WANT + forall x::a, y::a, z::a, d1::Eq a + f ((==) d1 x y) ((>) d1 y z) = ... +because that will only match if the dict args are (visibly) equal. +Instead we want to quantify over the dictionaries separately. + +In short, simplifyRuleLhs must *only* squash equalities, leaving +all dicts unchanged, with absolutely no sharing. + +Also note that we can't solve the LHS constraints in isolation: +Example foo :: Ord a => a -> a + foo_spec :: Int -> Int + {-# RULE "foo" foo = foo_spec #-} +Here, it's the RHS that fixes the type variable + +HOWEVER, under a nested implication things are different +Consider + f :: (forall a. Eq a => a->a) -> Bool -> ... + {-# RULES "foo" forall (v::forall b. Eq b => b->b). + f b True = ... + #-} +Here we *must* solve the wanted (Eq a) from the given (Eq a) +resulting from skolemising the argument type of g. So we +revert to SimplCheck when going under an implication. + + +--------- So the SimplifyRule Plan is this ----------------------- + +* Step 0: typecheck the LHS and RHS to get constraints from each + +* Step 1: Simplify the LHS and RHS constraints all together in one bag + We do this to discover all unification equalities + +* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take + advantage of those unifications + +* Setp 3: Partition the LHS constraints into the ones we will + quantify over, and the others. + See Note [RULE quantification over equalities] + +* Step 4: Decide on the type variables to quantify over + +* Step 5: Simplify the LHS and RHS constraints separately, using the + quantified constraints as givens + +Note [Solve order for RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In step 1 above, we need to be a bit careful about solve order. +Consider + f :: Int -> T Int + type instance T Int = Bool + + RULE f 3 = True + +From the RULE we get + lhs-constraints: T Int ~ alpha + rhs-constraints: Bool ~ alpha +where 'alpha' is the type that connects the two. If we glom them +all together, and solve the RHS constraint first, we might solve +with alpha := Bool. But then we'd end up with a RULE like + + RULE: f 3 |> (co :: T Int ~ Bool) = True + +which is terrible. We want + + RULE: f 3 = True |> (sym co :: Bool ~ T Int) + +So we are careful to solve the LHS constraints first, and *then* the +RHS constraints. Actually much of this is done by the on-the-fly +constraint solving, so the same order must be observed in +tcRule. + + +Note [RULE quantification over equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deciding which equalities to quantify over is tricky: + * We do not want to quantify over insoluble equalities (Int ~ Bool) + (a) because we prefer to report a LHS type error + (b) because if such things end up in 'givens' we get a bogus + "inaccessible code" error + + * But we do want to quantify over things like (a ~ F b), where + F is a type function. + +The difficulty is that it's hard to tell what is insoluble! +So we see whether the simplification step yielded any type errors, +and if so refrain from quantifying over *any* equalities. + +Note [Quantifying over coercion holes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Equality constraints from the LHS will emit coercion hole Wanteds. +These don't have a name, so we can't quantify over them directly. +Instead, because we really do want to quantify here, invent a new +EvVar for the coercion, fill the hole with the invented EvVar, and +then quantify over the EvVar. Not too tricky -- just some +impedance matching, really. + +Note [Simplify cloned constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At this stage, we're simplifying constraints only for insolubility +and for unification. Note that all the evidence is quickly discarded. +We use a clone of the real constraint. If we don't do this, +then RHS coercion-hole constraints get filled in, only to get filled +in *again* when solving the implications emitted from tcRule. That's +terrible, so we avoid the problem by cloning the constraints. + +-} + +simplifyRule :: RuleName + -> TcLevel -- Level at which to solve the constraints + -> WantedConstraints -- Constraints from LHS + -> WantedConstraints -- Constraints from RHS + -> TcM ( [EvVar] -- Quantify over these LHS vars + , WantedConstraints) -- Residual un-quantified LHS constraints +-- See Note [The SimplifyRule Plan] +-- NB: This consumes all simple constraints on the LHS, but not +-- any LHS implication constraints. +simplifyRule name tc_lvl lhs_wanted rhs_wanted + = do { + -- Note [The SimplifyRule Plan] step 1 + -- First solve the LHS and *then* solve the RHS + -- Crucially, this performs unifications + -- Why clone? See Note [Simplify cloned constraints] + ; lhs_clone <- cloneWC lhs_wanted + ; rhs_clone <- cloneWC rhs_wanted + ; setTcLevel tc_lvl $ + runTcSDeriveds $ + do { _ <- solveWanteds lhs_clone + ; _ <- solveWanteds rhs_clone + -- Why do them separately? + -- See Note [Solve order for RULES] + ; return () } + + -- Note [The SimplifyRule Plan] step 2 + ; lhs_wanted <- zonkWC lhs_wanted + ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted + + -- Note [The SimplifyRule Plan] step 3 + ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts) + + ; traceTc "simplifyRule" $ + vcat [ text "LHS of rule" <+> doubleQuotes (ftext name) + , text "lhs_wanted" <+> ppr lhs_wanted + , text "rhs_wanted" <+> ppr rhs_wanted + , text "quant_cts" <+> ppr quant_cts + , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted + ] + + ; return (quant_evs, residual_lhs_wanted) } + + where + mk_quant_ev :: Ct -> TcM EvVar + mk_quant_ev ct + | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct + = case dest of + EvVarDest ev_id -> return ev_id + HoleDest hole -> -- See Note [Quantifying over coercion holes] + do { ev_id <- newEvVar pred + ; fillCoercionHole hole (mkTcCoVarCo ev_id) + ; return ev_id } + mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct) + + +getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints) +-- Extract all the constraints we can quantify over, +-- also returning the depleted WantedConstraints +-- +-- NB: we must look inside implications, because with +-- -fdefer-type-errors we generate implications rather eagerly; +-- see GHC.Tc.Utils.Unify.implicationNeeded. Not doing so caused #14732. +-- +-- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged, +-- 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 +-- and instead solves from the top level. +-- +-- So we must partition the WantedConstraints ourselves +-- Not hard, but tiresome. + +getRuleQuantCts wc + = float_wc emptyVarSet wc + where + float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints) + float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics }) + = ( simple_yes `andCts` implic_yes + , WC { wc_simple = simple_no, wc_impl = implics_no }) + where + (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples + (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs) + emptyBag implics + + float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication) + float_implic skol_tvs yes1 imp + = (yes1 `andCts` yes2, imp { ic_wanted = no }) + where + (yes2, no) = float_wc new_skol_tvs (ic_wanted imp) + new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp + + rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool + rule_quant_ct skol_tvs ct + | EqPred _ t1 t2 <- classifyPredType (ctPred ct) + , not (ok_eq t1 t2) + = False -- Note [RULE quantification over equalities] + | isHoleCt ct + = False -- Don't quantify over type holes, obviously + | otherwise + = tyCoVarsOfCt ct `disjointVarSet` skol_tvs + + ok_eq t1 t2 + | t1 `tcEqType` t2 = False + | otherwise = is_fun_app t1 || is_fun_app t2 + + is_fun_app ty -- ty is of form (F tys) where F is a type function + = case tyConAppTyCon_maybe ty of + Just tc -> isTypeFamilyTyCon tc + Nothing -> False diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -0,0 +1,832 @@ +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-2002 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Gen.Sig( + TcSigInfo(..), + TcIdSigInfo(..), TcIdSigInst, + TcPatSynInfo(..), + TcSigFun, + + isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName, + completeSigPolyId_maybe, + + tcTySigs, tcUserTypeSig, completeSigFromId, + tcInstSig, + + TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv, + mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Tc.Gen.HsType +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Validity ( checkValidType ) +import GHC.Tc.Utils.Unify( tcSkolemise, unifyType ) +import GHC.Tc.Utils.Instantiate( topInstantiate ) +import GHC.Tc.Utils.Env( tcLookupId ) +import GHC.Tc.Types.Evidence( HsWrapper, (<.>) ) +import GHC.Core.Type ( mkTyVarBinders ) + +import GHC.Driver.Session +import GHC.Types.Var ( TyVar, tyVarKind ) +import GHC.Types.Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) +import GHC.Builtin.Names( mkUnboundName ) +import GHC.Types.Basic +import GHC.Unit.Module( getModule ) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Utils.Misc( singleton ) +import GHC.Data.Maybe( orElse ) +import Data.Maybe( mapMaybe ) +import Control.Monad( unless ) + + +{- ------------------------------------------------------------- + Note [Overview of type signatures] +---------------------------------------------------------------- +Type signatures, including partial signatures, are jolly tricky, +especially on value bindings. Here's an overview. + + f :: forall a. [a] -> [a] + g :: forall b. _ -> b + + f = ...g... + g = ...f... + +* HsSyn: a signature in a binding starts off as a TypeSig, in + type HsBinds.Sig + +* When starting a mutually recursive group, like f/g above, we + call tcTySig on each signature in the group. + +* tcTySig: Sig -> TcIdSigInfo + - For a /complete/ signature, like 'f' above, tcTySig kind-checks + the HsType, producing a Type, and wraps it in a CompleteSig, and + extend the type environment with this polymorphic 'f'. + + - For a /partial/signature, like 'g' above, tcTySig does nothing + Instead it just wraps the pieces in a PartialSig, to be handled + later. + +* tcInstSig: TcIdSigInfo -> TcIdSigInst + In tcMonoBinds, when looking at an individual binding, we use + tcInstSig to instantiate the signature forall's in the signature, + and attribute that instantiated (monomorphic) type to the + binder. You can see this in GHC.Tc.Gen.Bind.tcLhsId. + + The instantiation does the obvious thing for complete signatures, + but for /partial/ signatures it starts from the HsSyn, so it + has to kind-check it etc: tcHsPartialSigType. It's convenient + to do this at the same time as instantiation, because we can + make the wildcards into unification variables right away, raather + than somehow quantifying over them. And the "TcLevel" of those + unification variables is correct because we are in tcMonoBinds. + + +Note [Scoped tyvars] +~~~~~~~~~~~~~~~~~~~~ +The -XScopedTypeVariables flag brings lexically-scoped type variables +into scope for any explicitly forall-quantified type variables: + f :: forall a. a -> a + f x = e +Then 'a' is in scope inside 'e'. + +However, we do *not* support this + - For pattern bindings e.g + f :: forall a. a->a + (f,g) = e + +Note [Binding scoped type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type variables *brought into lexical scope* by a type signature +may be a subset of the *quantified type variables* of the signatures, +for two reasons: + +* With kind polymorphism a signature like + f :: forall f a. f a -> f a + may actually give rise to + f :: forall k. forall (f::k -> *) (a:k). f a -> f a + So the sig_tvs will be [k,f,a], but only f,a are scoped. + NB: the scoped ones are not necessarily the *initial* ones! + +* Even aside from kind polymorphism, there may be more instantiated + type variables than lexically-scoped ones. For example: + type T a = forall b. b -> (a,b) + f :: forall c. T c + Here, the signature for f will have one scoped type variable, c, + but two instantiated type variables, c' and b'. + +However, all of this only applies to the renamer. The typechecker +just puts all of them into the type environment; any lexical-scope +errors were dealt with by the renamer. + +-} + + +{- ********************************************************************* +* * + Utility functions for TcSigInfo +* * +********************************************************************* -} + +tcIdSigName :: TcIdSigInfo -> Name +tcIdSigName (CompleteSig { sig_bndr = id }) = idName id +tcIdSigName (PartialSig { psig_name = n }) = n + +tcSigInfoName :: TcSigInfo -> Name +tcSigInfoName (TcIdSig idsi) = tcIdSigName idsi +tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi + +completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId +completeSigPolyId_maybe sig + | TcIdSig sig_info <- sig + , CompleteSig { sig_bndr = id } <- sig_info = Just id + | otherwise = Nothing + + +{- ********************************************************************* +* * + Typechecking user signatures +* * +********************************************************************* -} + +tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun) +tcTySigs hs_sigs + = checkNoErrs $ + do { -- Fail if any of the signatures is duff + -- Hence mapAndReportM + -- See Note [Fail eagerly on bad signatures] + ty_sigs_s <- mapAndReportM tcTySig hs_sigs + + ; let ty_sigs = concat ty_sigs_s + poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs + -- The returned [TcId] are the ones for which we have + -- a complete type signature. + -- See Note [Complete and partial type signatures] + env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs] + + ; return (poly_ids, lookupNameEnv env) } + +tcTySig :: LSig GhcRn -> TcM [TcSigInfo] +tcTySig (L _ (IdSig _ id)) + = do { let ctxt = FunSigCtxt (idName id) False + -- False: do not report redundant constraints + -- The user has no control over the signature! + sig = completeSigFromId ctxt id + ; return [TcIdSig sig] } + +tcTySig (L loc (TypeSig _ names sig_ty)) + = setSrcSpan loc $ + do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name) + | L _ name <- names ] + ; return (map TcIdSig sigs) } + +tcTySig (L loc (PatSynSig _ names sig_ty)) + = setSrcSpan loc $ + do { tpsigs <- sequence [ tcPatSynSig name sig_ty + | L _ name <- names ] + ; return (map TcPatSynSig tpsigs) } + +tcTySig _ = return [] + + +tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name + -> TcM TcIdSigInfo +-- A function or expression type signature +-- Returns a fully quantified type signature; even the wildcards +-- are quantified with ordinary skolems that should be instantiated +-- +-- The SrcSpan is what to declare as the binding site of the +-- any skolems in the signature. For function signatures we +-- use the whole `f :: ty' signature; for expression signatures +-- just the type part. +-- +-- Just n => Function type signature name :: type +-- Nothing => Expression type signature :: type +tcUserTypeSig loc hs_sig_ty mb_name + | isCompleteHsSig hs_sig_ty + = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty + ; traceTc "tcuser" (ppr sigma_ty) + ; return $ + CompleteSig { sig_bndr = mkLocalId name sigma_ty + , sig_ctxt = ctxt_T + , sig_loc = loc } } + -- Location of the in f :: + + -- Partial sig with wildcards + | otherwise + = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty + , sig_ctxt = ctxt_F, sig_loc = loc }) + where + name = case mb_name of + Just n -> n + Nothing -> mkUnboundName (mkVarOcc "") + ctxt_F = case mb_name of + Just n -> FunSigCtxt n False + Nothing -> ExprSigCtxt + ctxt_T = case mb_name of + Just n -> FunSigCtxt n True + Nothing -> ExprSigCtxt + + + +completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo +-- Used for instance methods and record selectors +completeSigFromId ctxt id + = CompleteSig { sig_bndr = id + , sig_ctxt = ctxt + , sig_loc = getSrcSpan id } + +isCompleteHsSig :: LHsSigWcType GhcRn -> Bool +-- ^ If there are no wildcards, return a LHsSigType +isCompleteHsSig (HsWC { hswc_ext = wcs + , hswc_body = HsIB { hsib_body = hs_ty } }) + = null wcs && no_anon_wc hs_ty + +no_anon_wc :: LHsType GhcRn -> Bool +no_anon_wc lty = go lty + where + go (L _ ty) = case ty of + HsWildCardTy _ -> False + HsAppTy _ ty1 ty2 -> go ty1 && go ty2 + HsAppKindTy _ ty ki -> go ty && go ki + HsFunTy _ ty1 ty2 -> go ty1 && go ty2 + HsListTy _ ty -> go ty + HsTupleTy _ _ tys -> gos tys + HsSumTy _ tys -> gos tys + HsOpTy _ ty1 _ ty2 -> go ty1 && go ty2 + HsParTy _ ty -> go ty + HsIParamTy _ _ ty -> go ty + HsKindSig _ ty kind -> go ty && go kind + HsDocTy _ ty _ -> go ty + HsBangTy _ _ ty -> go ty + HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds + HsExplicitListTy _ _ tys -> gos tys + HsExplicitTupleTy _ tys -> gos tys + HsForAllTy { hst_bndrs = bndrs + , hst_body = ty } -> no_anon_wc_bndrs bndrs + && go ty + HsQualTy { hst_ctxt = L _ ctxt + , hst_body = ty } -> gos ctxt && go ty + HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty + HsSpliceTy{} -> True + HsTyLit{} -> True + HsTyVar{} -> True + HsStarTy{} -> True + XHsType (NHsCoreTy{}) -> True -- Core type, which does not have any wildcard + + gos = all go + +no_anon_wc_bndrs :: [LHsTyVarBndr GhcRn] -> Bool +no_anon_wc_bndrs ltvs = all (go . unLoc) ltvs + where + go (UserTyVar _ _) = True + go (KindedTyVar _ _ ki) = no_anon_wc ki + +{- Note [Fail eagerly on bad signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a type signature is wrong, fail immediately: + + * the type sigs may bind type variables, so proceeding without them + can lead to a cascade of errors + + * the type signature might be ambiguous, in which case checking + the code against the signature will give a very similar error + to the ambiguity error. + +ToDo: this means we fall over if any top-level type signature in the +module is wrong, because we typecheck all the signatures together +(see GHC.Tc.Gen.Bind.tcValBinds). Moreover, because of top-level +captureTopConstraints, only insoluble constraints will be reported. +We typecheck all signatures at the same time because a signature +like f,g :: blah might have f and g from different SCCs. + +So it's a bit awkward to get better error recovery, and no one +has complained! +-} + +{- ********************************************************************* +* * + Type checking a pattern synonym signature +* * +************************************************************************ + +Note [Pattern synonym signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Pattern synonym signatures are surprisingly tricky (see #11224 for example). +In general they look like this: + + pattern P :: forall univ_tvs. req_theta + => forall ex_tvs. prov_theta + => arg1 -> .. -> argn -> res_ty + +For parsing and renaming we treat the signature as an ordinary LHsSigType. + +Once we get to type checking, we decompose it into its parts, in tcPatSynSig. + +* Note that 'forall univ_tvs' and 'req_theta =>' + and 'forall ex_tvs' and 'prov_theta =>' + are all optional. We gather the pieces at the top of tcPatSynSig + +* Initially the implicitly-bound tyvars (added by the renamer) include both + universal and existential vars. + +* After we kind-check the pieces and convert to Types, we do kind generalisation. + +Note [solveEqualities in tcPatSynSig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important that we solve /all/ the equalities in a pattern +synonym signature, because we are going to zonk the signature to +a Type (not a TcType), in GHC.Tc.TyCl.PatSyn.tc_patsyn_finish, and that +fails if there are un-filled-in coercion variables mentioned +in the type (#15694). + +The best thing is simply to use solveEqualities to solve all the +equalites, rather than leaving them in the ambient constraints +to be solved later. Pattern synonyms are top-level, so there's +no problem with completely solving them. + +(NB: this solveEqualities wraps newImplicitTKBndrs, which itself +does a solveLocalEqualities; so solveEqualities isn't going to +make any further progress; it'll just report any unsolved ones, +and fail, as it should.) +-} + +tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo +-- See Note [Pattern synonym signatures] +-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType +tcPatSynSig name sig_ty + | HsIB { hsib_ext = implicit_hs_tvs + , hsib_body = hs_ty } <- sig_ty + , (univ_hs_tvs, hs_req, hs_ty1) <- splitLHsSigmaTyInvis hs_ty + , (ex_hs_tvs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 + = do { traceTc "tcPatSynSig 1" (ppr sig_ty) + ; (implicit_tvs, (univ_tvs, (ex_tvs, (req, prov, body_ty)))) + <- pushTcLevelM_ $ + solveEqualities $ -- See Note [solveEqualities in tcPatSynSig] + bindImplicitTKBndrs_Skol implicit_hs_tvs $ + bindExplicitTKBndrs_Skol univ_hs_tvs $ + bindExplicitTKBndrs_Skol ex_hs_tvs $ + do { req <- tcHsContext hs_req + ; prov <- tcHsContext hs_prov + ; body_ty <- tcHsOpenType hs_body_ty + -- A (literal) pattern can be unlifted; + -- e.g. pattern Zero <- 0# (#12094) + ; return (req, prov, body_ty) } + + ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvs + req ex_tvs prov body_ty + + -- Kind generalisation + ; kvs <- kindGeneralizeAll ungen_patsyn_ty + ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty) + + -- These are /signatures/ so we zonk to squeeze out any kind + -- unification variables. Do this after kindGeneralize which may + -- default kind variables to *. + ; implicit_tvs <- zonkAndScopedSort implicit_tvs + ; univ_tvs <- mapM zonkTyCoVarKind univ_tvs + ; ex_tvs <- mapM zonkTyCoVarKind ex_tvs + ; req <- zonkTcTypes req + ; prov <- zonkTcTypes prov + ; body_ty <- zonkTcType body_ty + + -- Skolems have TcLevels too, though they're used only for debugging. + -- If you don't do this, the debugging checks fail in GHC.Tc.TyCl.PatSyn. + -- Test case: patsyn/should_compile/T13441 +{- + ; tclvl <- getTcLevel + ; let env0 = mkEmptyTCvSubst $ mkInScopeSet $ mkVarSet kvs + (env1, implicit_tvs') = promoteSkolemsX tclvl env0 implicit_tvs + (env2, univ_tvs') = promoteSkolemsX tclvl env1 univ_tvs + (env3, ex_tvs') = promoteSkolemsX tclvl env2 ex_tvs + req' = substTys env3 req + prov' = substTys env3 prov + body_ty' = substTy env3 body_ty +-} + ; let implicit_tvs' = implicit_tvs + univ_tvs' = univ_tvs + ex_tvs' = ex_tvs + req' = req + prov' = prov + body_ty' = body_ty + + -- Now do validity checking + ; checkValidType ctxt $ + build_patsyn_type kvs implicit_tvs' univ_tvs' req' ex_tvs' prov' body_ty' + + -- arguments become the types of binders. We thus cannot allow + -- levity polymorphism here + ; let (arg_tys, _) = tcSplitFunTys body_ty' + ; mapM_ (checkForLevPoly empty) arg_tys + + ; traceTc "tcTySig }" $ + vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs' + , text "kvs" <+> ppr_tvs kvs + , text "univ_tvs" <+> ppr_tvs univ_tvs' + , text "req" <+> ppr req' + , text "ex_tvs" <+> ppr_tvs ex_tvs' + , text "prov" <+> ppr prov' + , text "body_ty" <+> ppr body_ty' ] + ; return (TPSI { patsig_name = name + , patsig_implicit_bndrs = mkTyVarBinders Inferred kvs ++ + mkTyVarBinders Specified implicit_tvs' + , patsig_univ_bndrs = univ_tvs' + , patsig_req = req' + , patsig_ex_bndrs = ex_tvs' + , patsig_prov = prov' + , patsig_body_ty = body_ty' }) } + where + ctxt = PatSynCtxt name + + build_patsyn_type kvs imp univ req ex prov body + = mkInvForAllTys kvs $ + mkSpecForAllTys (imp ++ univ) $ + mkPhiTy req $ + mkSpecForAllTys ex $ + mkPhiTy prov $ + body + +ppr_tvs :: [TyVar] -> SDoc +ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv) + | tv <- tvs]) + + +{- ********************************************************************* +* * + Instantiating user signatures +* * +********************************************************************* -} + + +tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst +-- Instantiate a type signature; only used with plan InferGen +tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }) + = setSrcSpan loc $ -- Set the binding site of the tyvars + do { (tv_prs, theta, tau) <- tcInstType newMetaTyVarTyVars poly_id + -- See Note [Pattern bindings and complete signatures] + + ; return (TISI { sig_inst_sig = sig + , sig_inst_skols = tv_prs + , sig_inst_wcs = [] + , sig_inst_wcx = Nothing + , sig_inst_theta = theta + , sig_inst_tau = tau }) } + +tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty + , sig_ctxt = ctxt + , sig_loc = loc }) + = setSrcSpan loc $ -- Set the binding site of the tyvars + do { traceTc "Staring partial sig {" (ppr hs_sig) + ; (wcs, wcx, tv_prs, theta, tau) <- tcHsPartialSigType ctxt hs_ty + -- See Note [Checking partial type signatures] in GHC.Tc.Gen.HsType + ; let inst_sig = TISI { sig_inst_sig = hs_sig + , sig_inst_skols = tv_prs + , sig_inst_wcs = wcs + , sig_inst_wcx = wcx + , sig_inst_theta = theta + , sig_inst_tau = tau } + ; traceTc "End partial sig }" (ppr inst_sig) + ; return inst_sig } + + +{- Note [Pattern bindings and complete signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = MkT a a + f :: forall a. a->a + g :: forall b. b->b + MkT f g = MkT (\x->x) (\y->y) +Here we'll infer a type from the pattern of 'T a', but if we feed in +the signature types for f and g, we'll end up unifying 'a' and 'b' + +So we instantiate f and g's signature with TyVarTv skolems +(newMetaTyVarTyVars) that can unify with each other. If too much +unification takes place, we'll find out when we do the final +impedance-matching check in GHC.Tc.Gen.Bind.mkExport + +See Note [Signature skolems] in GHC.Tc.Utils.TcType + +None of this applies to a function binding with a complete +signature, which doesn't use tcInstSig. See GHC.Tc.Gen.Bind.tcPolyCheck. +-} + +{- ********************************************************************* +* * + Pragmas and PragEnv +* * +********************************************************************* -} + +type TcPragEnv = NameEnv [LSig GhcRn] + +emptyPragEnv :: TcPragEnv +emptyPragEnv = emptyNameEnv + +lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn] +lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` [] + +extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv +extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig + +--------------- +mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv +mkPragEnv sigs binds + = foldl' extendPragEnv emptyNameEnv prs + where + prs = mapMaybe get_sig sigs + + get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn) + get_sig (L l (SpecSig x lnm@(L _ nm) ty inl)) + = Just (nm, L l $ SpecSig x lnm ty (add_arity nm inl)) + get_sig (L l (InlineSig x lnm@(L _ nm) inl)) + = Just (nm, L l $ InlineSig x lnm (add_arity nm inl)) + get_sig (L l (SCCFunSig x st lnm@(L _ nm) str)) + = Just (nm, L l $ SCCFunSig x st lnm str) + get_sig _ = Nothing + + add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function + | Inline <- inl_inline inl_prag + -- add arity only for real INLINE pragmas, not INLINABLE + = case lookupNameEnv ar_env n of + Just ar -> inl_prag { inl_sat = Just ar } + Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n ) + -- There really should be a binding for every INLINE pragma + inl_prag + | otherwise + = inl_prag + + -- ar_env maps a local to the arity of its definition + ar_env :: NameEnv Arity + ar_env = foldr lhsBindArity emptyNameEnv binds + +lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity +lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env + = extendNameEnv env (unLoc id) (matchGroupArity ms) +lhsBindArity _ env = env -- PatBind/VarBind + + +----------------- +addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId +addInlinePrags poly_id prags_for_me + | inl@(L _ prag) : inls <- inl_prags + = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) + ; unless (null inls) (warn_multiple_inlines inl inls) + ; return (poly_id `setInlinePragma` prag) } + | otherwise + = return poly_id + where + inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me] + + warn_multiple_inlines _ [] = return () + + warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls) + | inlinePragmaActivation prag1 == inlinePragmaActivation prag2 + , noUserInlineSpec (inlinePragmaSpec prag1) + = -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop + -- and inl2 is a user NOINLINE pragma; we don't want to complain + warn_multiple_inlines inl2 inls + | otherwise + = setSrcSpan loc $ + addWarnTc NoReason + (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) + 2 (vcat (text "Ignoring all but the first" + : map pp_inl (inl1:inl2:inls)))) + + pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) + + +{- ********************************************************************* +* * + SPECIALISE pragmas +* * +************************************************************************ + +Note [Handling SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea is this: + + foo :: Num a => a -> b -> a + {-# SPECIALISE foo :: Int -> b -> Int #-} + +We check that + (forall a b. Num a => a -> b -> a) + is more polymorphic than + forall b. Int -> b -> Int +(for which we could use tcSubType, but see below), generating a HsWrapper +to connect the two, something like + wrap = /\b. Int b dNumInt +This wrapper is put in the TcSpecPrag, in the ABExport record of +the AbsBinds. + + + f :: (Eq a, Ix b) => a -> b -> Bool + {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-} + f = + +From this the typechecker generates + + AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds + + SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX + -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ]) + +From these we generate: + + Rule: forall p, q, (dp:Ix p), (dq:Ix q). + f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq + + Spec bind: f_spec = wrap_fn + +Note that + + * The LHS of the rule may mention dictionary *expressions* (eg + $dfIxPair dp dq), and that is essential because the dp, dq are + needed on the RHS. + + * The RHS of f_spec, has a *copy* of 'binds', so that it + can fully specialise it. + + + +From the TcSpecPrag, in GHC.HsToCore.Binds we generate a binding for f_spec and a RULE: + + f_spec :: Int -> b -> Int + f_spec = wrap + + RULE: forall b (d:Num b). f b d = f_spec b + +The RULE is generated by taking apart the HsWrapper, which is a little +delicate, but works. + +Some wrinkles + +1. We don't use full-on tcSubType, because that does co and contra + variance and that in turn will generate too complex a LHS for the + RULE. So we use a single invocation of skolemise / + topInstantiate in tcSpecWrapper. (Actually I think that even + the "deeply" stuff may be too much, because it introduces lambdas, + though I think it can be made to work without too much trouble.) + +2. We need to take care with type families (#5821). Consider + type instance F Int = Bool + f :: Num a => a -> F a + {-# SPECIALISE foo :: Int -> Bool #-} + + We *could* try to generate an f_spec with precisely the declared type: + f_spec :: Int -> Bool + f_spec = Int dNumInt |> co + + RULE: forall d. f Int d = f_spec |> sym co + + but the 'co' and 'sym co' are (a) playing no useful role, and (b) are + hard to generate. At all costs we must avoid this: + RULE: forall d. f Int d |> co = f_spec + because the LHS will never match (indeed it's rejected in + decomposeRuleLhs). + + So we simply do this: + - Generate a constraint to check that the specialised type (after + skolemiseation) is equal to the instantiated function type. + - But *discard* the evidence (coercion) for that constraint, + so that we ultimately generate the simpler code + f_spec :: Int -> F Int + f_spec = Int dNumInt + + RULE: forall d. f Int d = f_spec + You can see this discarding happening in + +3. Note that the HsWrapper can transform *any* function with the right + type prefix + forall ab. (Eq a, Ix b) => XXX + regardless of XXX. It's sort of polymorphic in XXX. This is + useful: we use the same wrapper to transform each of the class ops, as + well as the dict. That's what goes on in GHC.Tc.TyCl.Instance.mk_meth_spec_prags +-} + +tcSpecPrags :: Id -> [LSig GhcRn] + -> TcM [LTcSpecPrag] +-- Add INLINE and SPECIALSE pragmas +-- INLINE prags are added to the (polymorphic) Id directly +-- SPECIALISE prags are passed to the desugarer via TcSpecPrags +-- Pre-condition: the poly_id is zonked +-- Reason: required by tcSubExp +tcSpecPrags poly_id prag_sigs + = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs) + ; unless (null bad_sigs) warn_discarded_sigs + ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs + ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } + where + spec_sigs = filter isSpecLSig prag_sigs + bad_sigs = filter is_bad_sig prag_sigs + is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) + + warn_discarded_sigs + = addWarnTc NoReason + (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) + 2 (vcat (map (ppr . getLoc) bad_sigs))) + +-------------- +tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag] +tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl) +-- See Note [Handling SPECIALISE pragmas] +-- +-- The Name fun_name in the SpecSig may not be the same as that of the poly_id +-- Example: SPECIALISE for a class method: the Name in the SpecSig is +-- for the selector Id, but the poly_id is something like $cop +-- However we want to use fun_name in the error message, since that is +-- what the user wrote (#8537) + = addErrCtxt (spec_ctxt prag) $ + do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) + (text "SPECIALISE pragma for non-overloaded function" + <+> quotes (ppr fun_name)) + -- Note [SPECIALISE pragmas] + ; spec_prags <- mapM tc_one hs_tys + ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags))) + ; return spec_prags } + where + name = idName poly_id + poly_ty = idType poly_id + spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) + + tc_one hs_ty + = do { spec_ty <- tcHsSigType (FunSigCtxt name False) hs_ty + ; wrap <- tcSpecWrapper (FunSigCtxt name True) poly_ty spec_ty + ; return (SpecPrag poly_id wrap inl) } + +tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag) + +-------------- +tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper +-- A simpler variant of tcSubType, used for SPECIALISE pragmas +-- See Note [Handling SPECIALISE pragmas], wrinkle 1 +tcSpecWrapper ctxt poly_ty spec_ty + = do { (sk_wrap, inst_wrap) + <- tcSkolemise ctxt spec_ty $ \ _ spec_tau -> + do { (inst_wrap, tau) <- topInstantiate orig poly_ty + ; _ <- unifyType Nothing spec_tau tau + -- Deliberately ignore the evidence + -- See Note [Handling SPECIALISE pragmas], + -- wrinkle (2) + ; return inst_wrap } + ; return (sk_wrap <.> inst_wrap) } + where + orig = SpecPragOrigin ctxt + +-------------- +tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag] +-- SPECIALISE pragmas for imported things +tcImpPrags prags + = do { this_mod <- getModule + ; dflags <- getDynFlags + ; if (not_specialising dflags) then + return [] + else do + { pss <- mapAndRecoverM (wrapLocM tcImpSpec) + [L loc (name,prag) + | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags + , not (nameIsLocalOrFrom this_mod name) ] + ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } } + where + -- Ignore SPECIALISE pragmas for imported things + -- when we aren't specialising, or when we aren't generating + -- code. The latter happens when Haddocking the base library; + -- we don't want complaints about lack of INLINABLE pragmas + not_specialising dflags + | not (gopt Opt_Specialise dflags) = True + | otherwise = case hscTarget dflags of + HscNothing -> True + HscInterpreted -> True + _other -> False + +tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] +tcImpSpec (name, prag) + = do { id <- tcLookupId name + ; unless (isAnyInlinePragma (idInlinePragma id)) + (addWarnTc NoReason (impSpecErr name)) + ; tcSpecPrag id prag } + +impSpecErr :: Name -> SDoc +impSpecErr name + = hang (text "You cannot SPECIALISE" <+> quotes (ppr name)) + 2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma" + , parens $ sep + [ text "or its defining module" <+> quotes (ppr mod) + , text "was compiled without -O"]]) + where + mod = nameModule name diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -0,0 +1,2383 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Template Haskell splices +module GHC.Tc.Gen.Splice( + tcSpliceExpr, tcTypedBracket, tcUntypedBracket, +-- runQuasiQuoteExpr, runQuasiQuotePat, +-- runQuasiQuoteDecl, runQuasiQuoteType, + runAnnotation, + + runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, + tcTopSpliceExpr, lookupThName_maybe, + defaultRunMeta, runMeta', runRemoteModFinalizers, + finishTH, runTopSplice + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Types.Annotations +import GHC.Driver.Finder +import GHC.Types.Name +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType + +import GHC.Utils.Outputable +import GHC.Tc.Gen.Expr +import GHC.Types.SrcLoc +import GHC.Builtin.Names.TH +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Origin +import GHC.Core.Coercion( etaExpandCoAxBranch ) +import GHC.SysTools.FileCleanup ( newTempName, TempFileLifetime(..) ) + +import Control.Monad + +import GHCi.Message +import GHCi.RemoteTypes +import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.Types +import GHC.Driver.Main + -- These imports are the reason that GHC.Tc.Gen.Splice + -- is very high up the module hierarchy +import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) +import GHC.Types.Name.Reader +import GHC.Driver.Types +import GHC.ThToHs +import GHC.Rename.Expr +import GHC.Rename.Env +import GHC.Rename.Utils ( HsDocContext(..) ) +import GHC.Rename.Fixity ( lookupFixityRn_help ) +import GHC.Rename.HsType +import GHC.Tc.Utils.Zonk +import GHC.Tc.Solver +import GHC.Core.Type as Type +import GHC.Types.Name.Set +import GHC.Tc.Utils.TcMType +import GHC.Tc.Gen.HsType +import GHC.IfaceToCore +import GHC.Core.TyCo.Rep as TyCoRep +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv as InstEnv +import GHC.Tc.Utils.Instantiate +import GHC.Types.Name.Env +import GHC.Builtin.Names +import GHC.Builtin.Types +import GHC.Types.Name.Occurrence as OccName +import GHC.Driver.Hooks +import GHC.Types.Var +import GHC.Unit.Module +import GHC.Iface.Load +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.PatSyn +import GHC.Core.ConLike +import GHC.Core.DataCon as DataCon +import GHC.Tc.Types.Evidence +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.HsToCore.Expr +import GHC.HsToCore.Monad +import GHC.Serialized +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Types.Unique +import GHC.Types.Var.Set +import Data.List ( find ) +import Data.Maybe +import GHC.Data.FastString +import GHC.Types.Basic as BasicTypes hiding( SuccessFlag(..) ) +import GHC.Data.Maybe( MaybeErr(..) ) +import GHC.Driver.Session +import GHC.Utils.Panic as Panic +import GHC.Utils.Lexeme +import qualified GHC.Data.EnumSet as EnumSet +import GHC.Driver.Plugins +import GHC.Data.Bag + +import qualified Language.Haskell.TH as TH +-- THSyntax gives access to internal functions and data types +import qualified Language.Haskell.TH.Syntax as TH + +#if defined(HAVE_INTERNAL_INTERPRETER) +-- Because GHC.Desugar might not be in the base library of the bootstrapping compiler +import GHC.Desugar ( AnnotationWrapper(..) ) +import Unsafe.Coerce ( unsafeCoerce ) +#endif + +import Control.Exception +import Data.Binary +import Data.Binary.Get +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import Data.Dynamic ( fromDynamic, toDyn ) +import qualified Data.Map as Map +import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) +import Data.Data (Data) +import Data.Proxy ( Proxy (..) ) + +{- +************************************************************************ +* * +\subsection{Main interface + stubs for the non-GHCI case +* * +************************************************************************ +-} + +tcTypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) +tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType + -> TcM (HsExpr GhcTcId) +tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) + -- None of these functions add constraints to the LIE + +-- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName) +-- runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName) +-- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName) +-- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] + +runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation +{- +************************************************************************ +* * +\subsection{Quoting an expression} +* * +************************************************************************ +-} + +-- See Note [How brackets and nested splices are handled] +-- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) +tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty + = addErrCtxt (quotationCtxtDoc brack) $ + do { cur_stage <- getStage + ; ps_ref <- newMutVar [] + ; lie_var <- getConstraintVar -- Any constraints arising from nested splices + -- should get thrown into the constraint set + -- from outside the bracket + + -- Make a new type variable for the type of the overall quote + ; m_var <- mkTyVarTy <$> mkMetaTyVar + -- Make sure the type variable satisfies Quote + ; ev_var <- emitQuoteWanted m_var + -- Bundle them together so they can be used in GHC.HsToCore.Quote for desugaring + -- brackets. + ; let wrapper = QuoteWrapper ev_var m_var + -- Typecheck expr to make sure it is valid, + -- Throw away the typechecked expression but return its type. + -- We'll typecheck it again when we splice it in somewhere + ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $ + tcInferRhoNC expr + -- NC for no context; tcBracket does that + ; let rep = getRuntimeRep expr_ty + ; meta_ty <- tcTExpTy m_var expr_ty + ; ps' <- readMutVar ps_ref + ; texpco <- tcLookupId unsafeTExpCoerceName + ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") + rn_expr + (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper) + (nlHsTyApp texpco [rep, expr_ty])) + (noLoc (HsTcBracketOut noExtField (Just wrapper) brack ps')))) + meta_ty res_ty } +tcTypedBracket _ other_brack _ + = pprPanic "tcTypedBracket" (ppr other_brack) + +-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId) +-- See Note [Typechecking Overloaded Quotes] +tcUntypedBracket rn_expr brack ps res_ty + = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) + + + -- Create the type m Exp for expression bracket, m Type for a type + -- bracket and so on. The brack_info is a Maybe because the + -- VarBracket ('a) isn't overloaded, but also shouldn't contain any + -- splices. + ; (brack_info, expected_type) <- brackTy brack + + -- Match the expected type with the type of all the internal + -- splices. They might have further constrained types and if they do + -- we want to reflect that in the overall type of the bracket. + ; ps' <- case quoteWrapperTyVarTy <$> brack_info of + Just m_var -> mapM (tcPendingSplice m_var) ps + Nothing -> ASSERT(null ps) return [] + + ; traceTc "tc_bracket done untyped" (ppr expected_type) + + -- Unify the overall type of the bracket with the expected result + -- type + ; tcWrapResultO BracketOrigin rn_expr + (HsTcBracketOut noExtField brack_info brack ps') + expected_type res_ty + + } + +-- | A type variable with kind * -> * named "m" +mkMetaTyVar :: TcM TyVar +mkMetaTyVar = + newNamedFlexiTyVar (fsLit "m") (mkVisFunTy liftedTypeKind liftedTypeKind) + + +-- | For a type 'm', emit the constraint 'Quote m'. +emitQuoteWanted :: Type -> TcM EvVar +emitQuoteWanted m_var = do + quote_con <- tcLookupTyCon quoteClassName + emitWantedEvVar BracketOrigin $ + mkTyConApp quote_con [m_var] + +--------------- +-- | Compute the expected type of a quotation, and also the QuoteWrapper in +-- the case where it is an overloaded quotation. All quotation forms are +-- overloaded aprt from Variable quotations ('foo) +brackTy :: HsBracket GhcRn -> TcM (Maybe QuoteWrapper, Type) +brackTy b = + let mkTy n = do + -- New polymorphic type variable for the bracket + m_var <- mkTyVarTy <$> mkMetaTyVar + -- Emit a Quote constraint for the bracket + ev_var <- emitQuoteWanted m_var + -- Construct the final expected type of the quote, for example + -- m Exp or m Type + final_ty <- mkAppTy m_var <$> tcMetaTy n + -- Return the evidence variable and metavariable to be used during + -- desugaring. + let wrapper = QuoteWrapper ev_var m_var + return (Just wrapper, final_ty) + in + case b of + (VarBr {}) -> (Nothing,) <$> tcMetaTy nameTyConName + -- Result type is Var (not Quote-monadic) + (ExpBr {}) -> mkTy expTyConName -- Result type is m Exp + (TypBr {}) -> mkTy typeTyConName -- Result type is m Type + (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec] + (PatBr {}) -> mkTy patTyConName -- Result type is m Pat + (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL" + (TExpBr {}) -> panic "tcUntypedBracket: Unexpected TExpBr" + +--------------- +-- | Typechecking a pending splice from a untyped bracket +tcPendingSplice :: TcType -- Metavariable for the expected overall type of the + -- quotation. + -> PendingRnSplice + -> TcM PendingTcSplice +tcPendingSplice m_var (PendingRnSplice flavour splice_name expr) + -- See Note [Typechecking Overloaded Quotes] + = do { meta_ty <- tcMetaTy meta_ty_name + -- Expected type of splice, e.g. m Exp + ; let expected_type = mkAppTy m_var meta_ty + ; expr' <- tcCheckExpr expr expected_type + ; return (PendingTcSplice splice_name expr') } + where + meta_ty_name = case flavour of + UntypedExpSplice -> expTyConName + UntypedPatSplice -> patTyConName + UntypedTypeSplice -> typeTyConName + UntypedDeclSplice -> decsTyConName + +--------------- +-- 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 (err_msg exp_ty) + ; texp <- tcLookupTyCon tExpTyConName + ; let rep = getRuntimeRep exp_ty + ; return (mkAppTy m_ty (mkTyConApp texp [rep, exp_ty])) } + where + err_msg ty + = vcat [ text "Illegal polytype:" <+> ppr ty + , text "The type of a Typed Template Haskell expression must" <+> + text "not have any quantification." ] + +quotationCtxtDoc :: HsBracket GhcRn -> SDoc +quotationCtxtDoc br_body + = hang (text "In the Template Haskell quotation") + 2 (ppr br_body) + + + -- The whole of the rest of the file is the else-branch (ie stage2 only) + +{- +Note [How top-level splices are handled] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Top-level splices (those not inside a [| .. |] quotation bracket) are handled +very straightforwardly: + + 1. tcTopSpliceExpr: typecheck the body e of the splice $(e) + + 2. runMetaT: desugar, compile, run it, and convert result back to + GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName, + HsExpr RdrName etc) + + 3. treat the result as if that's what you saw in the first place + e.g for HsType, rename and kind-check + for HsExpr, rename and type-check + + (The last step is different for decls, because they can *only* be + top-level: we return the result of step 2.) + +Note [How brackets and nested splices are handled] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Nested splices (those inside a [| .. |] quotation bracket), +are treated quite differently. + +Remember, there are two forms of bracket + typed [|| e ||] + and untyped [| e |] + +The life cycle of a typed bracket: + * Starts as HsBracket + + * When renaming: + * Set the ThStage to (Brack s RnPendingTyped) + * Rename the body + * Result is still a HsBracket + + * When typechecking: + * Set the ThStage to (Brack s (TcPending ps_var lie_var)) + * Typecheck the body, and throw away the elaborated result + * Nested splices (which must be typed) are typechecked, and + the results accumulated in ps_var; their constraints + accumulate in lie_var + * Result is a HsTcBracketOut rn_brack pending_splices + where rn_brack is the incoming renamed bracket + +The life cycle of a un-typed bracket: + * Starts as HsBracket + + * When renaming: + * Set the ThStage to (Brack s (RnPendingUntyped ps_var)) + * Rename the body + * Nested splices (which must be untyped) are renamed, and the + results accumulated in ps_var + * Result is still (HsRnBracketOut rn_body pending_splices) + + * When typechecking a HsRnBracketOut + * Typecheck the pending_splices individually + * Ignore the body of the bracket; just check that the context + expects a bracket of that type (e.g. a [p| pat |] bracket should + be in a context needing a (Q Pat) + * Result is a HsTcBracketOut rn_brack pending_splices + where rn_brack is the incoming renamed bracket + + +In both cases, desugaring happens like this: + * HsTcBracketOut is desugared by GHC.HsToCore.Quote.dsBracket. It + + a) Extends the ds_meta environment with the PendingSplices + attached to the bracket + + b) Converts the quoted (HsExpr Name) to a CoreExpr that, when + run, will produce a suitable TH expression/type/decl. This + is why we leave the *renamed* expression attached to the bracket: + the quoted expression should not be decorated with all the goop + added by the type checker + + * Each splice carries a unique Name, called a "splice point", thus + ${n}(e). The name is initialised to an (Unqual "splice") when the + splice is created; the renamer gives it a unique. + + * When GHC.HsToCore.Quote (used to desugar the body of the bracket) comes across + a splice, it looks up the splice's Name, n, in the ds_meta envt, + to find an (HsExpr Id) that should be substituted for the splice; + it just desugars it to get a CoreExpr (GHC.HsToCore.Quote.repSplice). + +Example: + Source: f = [| Just $(g 3) |] + The [| |] part is a HsBracket + + Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3} + The [| |] part is a HsBracketOut, containing *renamed* + (not typechecked) expression + The "s7" is the "splice point"; the (g Int 3) part + is a typechecked expression + + Desugared: f = do { s7 <- g Int 3 + ; return (ConE "Data.Maybe.Just" s7) } + + +Note [Template Haskell state diagram] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here are the ThStages, s, their corresponding level numbers +(the result of (thLevel s)), and their state transitions. +The top level of the program is stage Comp: + + Start here + | + V + ----------- $ ------------ $ + | Comp | ---------> | Splice | -----| + | 1 | | 0 | <----| + ----------- ------------ + ^ | ^ | + $ | | [||] $ | | [||] + | v | v + -------------- ---------------- + | Brack Comp | | Brack Splice | + | 2 | | 1 | + -------------- ---------------- + +* Normal top-level declarations start in state Comp + (which has level 1). + Annotations start in state Splice, since they are + treated very like a splice (only without a '$') + +* Code compiled in state Splice (and only such code) + will be *run at compile time*, with the result replacing + the splice + +* The original paper used level -1 instead of 0, etc. + +* The original paper did not allow a splice within a + splice, but there is no reason not to. This is the + $ transition in the top right. + +Note [Template Haskell levels] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Imported things are impLevel (= 0) + +* However things at level 0 are not *necessarily* imported. + eg $( \b -> ... ) here b is bound at level 0 + +* In GHCi, variables bound by a previous command are treated + as impLevel, because we have bytecode for them. + +* Variables are bound at the "current level" + +* The current level starts off at outerLevel (= 1) + +* The level is decremented by splicing $(..) + incremented by brackets [| |] + incremented by name-quoting 'f + +* When a variable is used, checkWellStaged compares + bind: binding level, and + use: current level at usage site + + Generally + bind > use Always error (bound later than used) + [| \x -> $(f x) |] + + bind = use Always OK (bound same stage as used) + [| \x -> $(f [| x |]) |] + + bind < use Inside brackets, it depends + Inside splice, OK + Inside neither, OK + + For (bind < use) inside brackets, there are three cases: + - Imported things OK f = [| map |] + - Top-level things OK g = [| f |] + - Non-top-level Only if there is a liftable instance + h = \(x:Int) -> [| x |] + + To track top-level-ness we use the ThBindEnv in TcLclEnv + + For example: + f = ... + g1 = $(map ...) is OK + g2 = $(f ...) is not OK; because we haven't compiled f yet + +Note [Typechecking Overloaded Quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The main function for typechecking untyped quotations is `tcUntypedBracket`. + +Consider an expression quote, `[| e |]`, its type is `forall m . Quote m => m Exp`. +When we typecheck it we therefore create a template of a metavariable `m` applied to `Exp` and +emit a constraint `Quote m`. All this is done in the `brackTy` function. +`brackTy` also selects the correct contents type for the quotation (Exp, Type, Decs etc). + +The meta variable and the constraint evidence variable are +returned together in a `QuoteWrapper` and then passed along to two further places +during compilation: + +1. Typechecking nested splices (immediately in tcPendingSplice) +2. Desugaring quotations (see GHC.HsToCore.Quote) + +`tcPendingSplice` takes the `m` type variable as an argument and checks +each nested splice against this variable `m`. During this +process the variable `m` can either be fixed to a specific value or further constrained by the +nested splices. + +Once we have checked all the nested splices, the quote type is checked against +the expected return type. + +The process is very simple and like typechecking a list where the quotation is +like the container and the splices are the elements of the list which must have +a specific type. + +After the typechecking process is completed, the evidence variable for `Quote m` +and the type `m` is stored in a `QuoteWrapper` which is passed through the pipeline +and used when desugaring quotations. + +Typechecking typed quotations is a similar idea but the `QuoteWrapper` is stored +in the `PendingStuff` as the nested splices are gathered up in a different way +to untyped splices. Untyped splices are found in the renamer but typed splices are +not typechecked and extracted until during typechecking. + +-} + +-- | We only want to produce warnings for TH-splices if the user requests so. +-- See Note [Warnings for TH splices]. +getThSpliceOrigin :: TcM Origin +getThSpliceOrigin = do + warn <- goptM Opt_EnableThSpliceWarnings + if warn then return FromSource else return Generated + +{- Note [Warnings for TH splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only produce warnings for TH splices when the user requests so +(-fenable-th-splice-warnings). There are multiple reasons: + + * It's not clear that the user that compiles a splice is the author of the code + that produces the warning. Think of the situation where she just splices in + code from a third-party library that produces incomplete pattern matches. + In this scenario, the user isn't even able to fix that warning. + * Gathering information for producing the warnings (pattern-match check + warnings in particular) is costly. There's no point in doing so if the user + is not interested in those warnings. + +That's why we store Origin flags in the Haskell AST. The functions from ThToHs +take such a flag and depending on whether TH splice warnings were enabled or +not, we pass FromSource (if the user requests warnings) or Generated +(otherwise). This is implemented in getThSpliceOrigin. + +For correct pattern-match warnings it's crucial that we annotate the Origin +consistently (#17270). In the future we could offer the Origin as part of the +TH AST. That would enable us to give quotes from the current module get +FromSource origin, and/or third library authors to tag certain parts of +generated code as FromSource to enable warnings. That effort is tracked in +#14838. +-} + +{- +************************************************************************ +* * +\subsection{Splicing an expression} +* * +************************************************************************ +-} + +tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty + = addErrCtxt (spliceCtxtDoc splice) $ + setSrcSpan (getLoc expr) $ do + { stage <- getStage + ; case stage of + Splice {} -> tcTopSplice expr res_ty + Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty + RunSplice _ -> + -- See Note [RunSplice ThLevel] in "GHC.Tc.Types". + pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++ + "running another splice") (ppr splice) + Comp -> tcTopSplice expr res_ty + } +tcSpliceExpr splice _ + = pprPanic "tcSpliceExpr" (ppr splice) + +{- Note [Collecting modFinalizers in typed splices] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local +environment (see Note [Delaying modFinalizers in untyped splices] in +GHC.Rename.Splice). Thus after executing the splice, we move the finalizers to the +finalizer list in the global environment and set them to use the current local +environment (with 'addModFinalizersWithLclEnv'). + +-} + +tcNestedSplice :: ThStage -> PendingStuff -> Name + -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) + -- See Note [How brackets and nested splices are handled] + -- A splice inside brackets +tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) splice_name expr res_ty + = do { res_ty <- expTypeToType res_ty + ; let rep = getRuntimeRep res_ty + ; meta_exp_ty <- tcTExpTy m_var res_ty + ; expr' <- setStage pop_stage $ + setConstraintVar lie_var $ + tcLExpr expr (mkCheckExpType meta_exp_ty) + ; untypeq <- tcLookupId unTypeQName + ; let expr'' = mkHsApp + (mkLHsWrap (applyQuoteWrapper q) + (nlHsTyApp untypeq [rep, res_ty])) expr' + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps) + + -- The returned expression is ignored; it's in the pending splices + ; return (panic "tcSpliceExpr") } + +tcNestedSplice _ _ splice_name _ _ + = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name) + +tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) +tcTopSplice expr res_ty + = do { -- Typecheck the expression, + -- making sure it has type Q (T res_ty) + res_ty <- expTypeToType res_ty + ; q_type <- tcMetaTy qTyConName + -- Top level splices must still be of type Q (TExp a) + ; meta_exp_ty <- tcTExpTy q_type res_ty + ; q_expr <- tcTopSpliceExpr Typed $ + tcLExpr expr (mkCheckExpType meta_exp_ty) + ; lcl_env <- getLclEnv + ; let delayed_splice + = DelayedSplice lcl_env expr res_ty q_expr + ; return (HsSpliceE noExtField (XSplice (HsSplicedT delayed_splice))) + + } + + +-- This is called in the zonker +-- See Note [Running typed splices in the zonker] +runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) +runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr) + = setLclEnv lcl_env $ do { + zonked_ty <- zonkTcType res_ty + ; zonked_q_expr <- zonkTopLExpr q_expr + -- See Note [Collecting modFinalizers in typed splices]. + ; modfinalizers_ref <- newTcRef [] + -- Run the expression + ; expr2 <- setStage (RunSplice modfinalizers_ref) $ + runMetaE zonked_q_expr + ; mod_finalizers <- readTcRef modfinalizers_ref + ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers + -- We use orig_expr here and not q_expr when tracing as a call to + -- unsafeTExpCoerce is added to the original expression by the + -- typechecker when typed quotes are type checked. + ; traceSplice (SpliceInfo { spliceDescription = "expression" + , spliceIsDecl = False + , spliceSource = Just orig_expr + , spliceGenerated = ppr expr2 }) + -- Rename and typecheck the spliced-in expression, + -- making sure it has type res_ty + -- These steps should never fail; this is a *typed* splice + ; (res, wcs) <- + captureConstraints $ + addErrCtxt (spliceResultDoc zonked_q_expr) $ do + { (exp3, _fvs) <- rnLExpr expr2 + ; tcLExpr exp3 (mkCheckExpType zonked_ty)} + ; ev <- simplifyTop wcs + ; return $ unLoc (mkHsDictLet (EvBinds ev) res) + } + + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +spliceCtxtDoc :: HsSplice GhcRn -> SDoc +spliceCtxtDoc splice + = hang (text "In the Template Haskell splice") + 2 (pprSplice splice) + +spliceResultDoc :: LHsExpr GhcTc -> SDoc +spliceResultDoc expr + = sep [ text "In the result of the splice:" + , nest 2 (char '$' <> ppr expr) + , text "To see what the splice expanded to, use -ddump-splices"] + +------------------- +tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) +-- Note [How top-level splices are handled] +-- Type check an expression that is the body of a top-level splice +-- (the caller will compile and run it) +-- Note that set the level to Splice, regardless of the original level, +-- before typechecking the expression. For example: +-- f x = $( ...$(g 3) ... ) +-- The recursive call to tcCheckExpr will simply expand the +-- inner escape before dealing with the outer one + +tcTopSpliceExpr isTypedSplice tc_action + = checkNoErrs $ -- checkNoErrs: must not try to run the thing + -- if the type checker fails! + unsetGOptM Opt_DeferTypeErrors $ + -- Don't defer type errors. Not only are we + -- going to run this code, but we do an unsafe + -- coerce, so we get a seg-fault if, say we + -- splice a type into a place where an expression + -- is expected (#7276) + setStage (Splice isTypedSplice) $ + do { -- Typecheck the expression + (expr', wanted) <- captureConstraints tc_action + ; const_binds <- simplifyTop wanted + + -- Zonk it and tie the knot of dictionary bindings + ; return $ mkHsDictLet (EvBinds const_binds) expr' } + +{- +************************************************************************ +* * + Annotations +* * +************************************************************************ +-} + +runAnnotation target expr = do + -- Find the classes we want instances for in order to call toAnnotationWrapper + loc <- getSrcSpanM + data_class <- tcLookupClass dataClassName + to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName + + -- Check the instances we require live in another module (we want to execute it..) + -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr + -- also resolves the LIE constraints to detect e.g. instance ambiguity + zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped ( + do { (expr', expr_ty) <- tcInferRhoNC expr + -- We manually wrap the typechecked expression in a call to toAnnotationWrapper + -- By instantiating the call >here< it gets registered in the + -- LIE consulted by tcTopSpliceExpr + -- and hence ensures the appropriate dictionary is bound by const_binds + ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] + ; let specialised_to_annotation_wrapper_expr + = L loc (mkHsWrap wrapper + (HsVar noExtField (L loc to_annotation_wrapper_id))) + ; return (L loc (HsApp noExtField + specialised_to_annotation_wrapper_expr expr')) + }) + + -- Run the appropriately wrapped expression to get the value of + -- the annotation and its dictionaries. The return value is of + -- type AnnotationWrapper by construction, so this conversion is + -- safe + serialized <- runMetaAW zonked_wrapped_expr' + return Annotation { + ann_target = target, + ann_value = serialized + } + +convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized) +convertAnnotationWrapper fhv = do + interp <- tcGetInterp + case interp of + ExternalInterp {} -> Right <$> runTH THAnnWrapper fhv +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> do + annotation_wrapper <- liftIO $ wormhole InternalInterp fhv + return $ Right $ + case unsafeCoerce annotation_wrapper of + AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> + -- Got the value and dictionaries: build the serialized value and + -- call it a day. We ensure that we seq the entire serialized value + -- in order that any errors in the user-written code for the + -- annotation are exposed at this point. This is also why we are + -- doing all this stuff inside the context of runMeta: it has the + -- facilities to deal with user error in a meta-level expression + seqSerialized serialized `seq` serialized + +-- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms +seqSerialized :: Serialized -> () +seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` () + +#endif + +{- +************************************************************************ +* * +\subsection{Running an expression} +* * +************************************************************************ +-} + +runQuasi :: TH.Q a -> TcM a +runQuasi act = TH.runQ act + +runRemoteModFinalizers :: ThModFinalizers -> TcM () +runRemoteModFinalizers (ThModFinalizers finRefs) = do + let withForeignRefs [] f = f [] + withForeignRefs (x : xs) f = withForeignRef x $ \r -> + withForeignRefs xs $ \rs -> f (r : rs) + interp <- tcGetInterp + case interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> do + qs <- liftIO (withForeignRefs finRefs $ mapM localRef) + runQuasi $ sequence_ qs +#endif + + ExternalInterp conf iserv -> withIServ_ conf iserv $ \i -> 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 -> + withForeignRefs finRefs $ \qrefs -> + writeIServ i (putMessage (RunModFinalizers st qrefs)) + () <- runRemoteTH i [] + readQResult i + +runQResult + :: (a -> String) + -> (Origin -> SrcSpan -> a -> b) + -> (ForeignHValue -> TcM a) + -> SrcSpan + -> ForeignHValue {- TH.Q a -} + -> TcM b +runQResult show_th f runQ expr_span hval + = do { th_result <- runQ hval + ; th_origin <- getThSpliceOrigin + ; traceTc "Got TH result:" (text (show_th th_result)) + ; return (f th_origin expr_span th_result) } + + +----------------- +runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn) + -> LHsExpr GhcTc + -> TcM hs_syn +runMeta unwrap e + = do { h <- getHooked runMetaHook defaultRunMeta + ; unwrap h e } + +defaultRunMeta :: MetaHook TcM +defaultRunMeta (MetaE r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp) +defaultRunMeta (MetaP r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat) +defaultRunMeta (MetaT r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType) +defaultRunMeta (MetaD r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec) +defaultRunMeta (MetaAW r) + = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper) + -- We turn off showing the code in meta-level exceptions because doing so exposes + -- the toAnnotationWrapper function that we slap around the user's code + +---------------- +runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper + -> TcM Serialized +runMetaAW = runMeta metaRequestAW + +runMetaE :: LHsExpr GhcTc -- Of type (Q Exp) + -> TcM (LHsExpr GhcPs) +runMetaE = runMeta metaRequestE + +runMetaP :: LHsExpr GhcTc -- Of type (Q Pat) + -> TcM (LPat GhcPs) +runMetaP = runMeta metaRequestP + +runMetaT :: LHsExpr GhcTc -- Of type (Q Type) + -> TcM (LHsType GhcPs) +runMetaT = runMeta metaRequestT + +runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] + -> TcM [LHsDecl GhcPs] +runMetaD = runMeta metaRequestD + +--------------- +runMeta' :: Bool -- Whether code should be printed in the exception message + -> (hs_syn -> SDoc) -- how to print the code + -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x + -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or + -- something like that + -> TcM hs_syn -- Of type t +runMeta' show_code ppr_hs run_and_convert expr + = do { traceTc "About to run" (ppr expr) + ; recordThSpliceUse -- seems to be the best place to do this, + -- we catch all kinds of splices and annotations. + + -- Check that we've had no errors of any sort so far. + -- For example, if we found an error in an earlier defn f, but + -- recovered giving it type f :: forall a.a, it'd be very dodgy + -- to carry ont. Mind you, the staging restrictions mean we won't + -- actually run f, but it still seems wrong. And, more concretely, + -- see #5358 for an example that fell over when trying to + -- reify a function with a "?" kind in it. (These don't occur + -- in type-correct programs. + ; failIfErrsM + + -- run plugins + ; hsc_env <- getTopEnv + ; expr' <- withPlugins (hsc_dflags hsc_env) spliceRunAction expr + + -- Desugar + ; ds_expr <- initDsTc (dsLExpr expr') + -- Compile and link it; might fail if linking fails + ; src_span <- getSrcSpanM + ; traceTc "About to run (desugared)" (ppr ds_expr) + ; either_hval <- tryM $ liftIO $ + GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr + ; case either_hval of { + Left exn -> fail_with_exn "compile and link" exn ; + Right hval -> do + + { -- Coerce it to Q t, and run it + + -- Running might fail if it throws an exception of any kind (hence tryAllM) + -- including, say, a pattern-match exception in the code we are running + -- + -- We also do the TH -> HS syntax conversion inside the same + -- exception-catching thing so that if there are any lurking + -- exceptions in the data structure returned by hval, we'll + -- encounter them inside the try + -- + -- See Note [Exceptions in TH] + let expr_span = getLoc expr + ; either_tval <- tryAllM $ + setSrcSpan expr_span $ -- Set the span so that qLocation can + -- see where this splice is + do { mb_result <- run_and_convert expr_span hval + ; case mb_result of + Left err -> failWithTc err + Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) + ; return $! result } } + + ; case either_tval of + Right v -> return v + Left se -> case fromException se of + Just IOEnvFailure -> failM -- Error already in Tc monad + _ -> fail_with_exn "run" se -- Exception + }}} + where + -- see Note [Concealed TH exceptions] + fail_with_exn :: Exception e => String -> e -> TcM a + fail_with_exn phase exn = do + exn_msg <- liftIO $ Panic.safeShowException exn + let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", + nest 2 (text exn_msg), + if show_code then text "Code:" <+> ppr expr else empty] + failWithTc msg + +{- +Note [Running typed splices in the zonker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +See #15471 for the full discussion. + +For many years typed splices were run immediately after they were type checked +however, this is too early as it means to zonk some type variables before +they can be unified with type variables in the surrounding context. + +For example, + +``` +module A where + +test_foo :: forall a . Q (TExp (a -> a)) +test_foo = [|| id ||] + +module B where + +import A + +qux = $$(test_foo) +``` + +We would expect `qux` to have inferred type `forall a . a -> a` but if +we run the splices too early the unified variables are zonked to `Any`. The +inferred type is the unusable `Any -> Any`. + +To run the splice, we must compile `test_foo` all the way to byte code. +But at the moment when the type checker is looking at the splice, test_foo +has type `Q (TExp (alpha -> alpha))` and we +certainly can't compile code involving unification variables! + +We could default `alpha` to `Any` but then we infer `qux :: Any -> Any` +which definitely is not what we want. Moreover, if we had + qux = [$$(test_foo), (\x -> x +1::Int)] +then `alpha` would have to be `Int`. + +Conclusion: we must defer taking decisions about `alpha` until the +typechecker is done; and *then* we can run the splice. It's fine to do it +later, because we know it'll produce type-correct code. + +Deferring running the splice until later, in the zonker, means that the +unification variables propagate upwards from the splice into the surrounding +context and are unified correctly. + +This is implemented by storing the arguments we need for running the splice +in a `DelayedSplice`. In the zonker, the arguments are passed to +`GHC.Tc.Gen.Splice.runTopSplice` and the expression inserted into the AST as normal. + + + +Note [Exceptions in TH] +~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have something like this + $( f 4 ) +where + f :: Int -> Q [Dec] + f n | n>3 = fail "Too many declarations" + | otherwise = ... + +The 'fail' is a user-generated failure, and should be displayed as a +perfectly ordinary compiler error message, not a panic or anything +like that. Here's how it's processed: + + * 'fail' is the monad fail. The monad instance for Q in TH.Syntax + effectively transforms (fail s) to + qReport True s >> fail + where 'qReport' comes from the Quasi class and fail from its monad + superclass. + + * The TcM monad is an instance of Quasi (see GHC.Tc.Gen.Splice), and it implements + (qReport True s) by using addErr to add an error message to the bag of errors. + The 'fail' in TcM raises an IOEnvFailure exception + + * 'qReport' forces the message to ensure any exception hidden in unevaluated + thunk doesn't get into the bag of errors. Otherwise the following splice + will trigger panic (#8987): + $(fail undefined) + See also Note [Concealed TH exceptions] + + * So, when running a splice, we catch all exceptions; then for + - an IOEnvFailure exception, we assume the error is already + in the error-bag (above) + - other errors, we add an error to the bag + and then fail + +Note [Concealed TH exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When displaying the error message contained in an exception originated from TH +code, we need to make sure that the error message itself does not contain an +exception. For example, when executing the following splice: + + $( error ("foo " ++ error "bar") ) + +the message for the outer exception is a thunk which will throw the inner +exception when evaluated. + +For this reason, we display the message of a TH exception using the +'safeShowException' function, which recursively catches any exception thrown +when showing an error message. + + +To call runQ in the Tc monad, we need to make TcM an instance of Quasi: +-} + +instance TH.Quasi TcM where + qNewName s = do { u <- newUnique + ; let i = toInteger (getKey u) + ; return (TH.mkNameU s i) } + + -- 'msg' is forced to ensure exceptions don't escape, + -- see Note [Exceptions in TH] + qReport True msg = seqList msg $ addErr (text msg) + qReport False msg = seqList msg $ addWarn NoReason (text msg) + + qLocation = do { m <- getModule + ; l <- getSrcSpanM + ; r <- case l of + UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" + (ppr l) + RealSrcSpan s _ -> return s + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = unitString (moduleUnit m) + , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) + , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } + + qLookupName = lookupName + qReify = reify + qReifyFixity nm = lookupThName nm >>= reifyFixity + qReifyType = reifyTypeOfThing + qReifyInstances = reifyInstances + qReifyRoles = reifyRoles + qReifyAnnotations = reifyAnnotations + qReifyModule = reifyModule + qReifyConStrictness nm = do { nm' <- lookupThName nm + ; dc <- tcLookupDataCon nm' + ; let bangs = dataConImplBangs dc + ; return (map reifyDecidedStrictness bangs) } + + -- For qRecover, discard error messages if + -- the recovery action is chosen. Otherwise + -- we'll only fail higher up. + qRecover recover main = tryTcDiscardingErrs recover main + + qAddDependentFile fp = do + ref <- fmap tcg_dependent_files getGblEnv + dep_files <- readTcRef ref + writeTcRef ref (fp:dep_files) + + qAddTempFile suffix = do + dflags <- getDynFlags + liftIO $ newTempName dflags TFL_GhcSession suffix + + qAddTopDecls thds = do + l <- getSrcSpanM + th_origin <- getThSpliceOrigin + let either_hval = convertToHsDecls th_origin l thds + ds <- case either_hval of + Left exn -> failWithTc $ + hang (text "Error in a declaration passed to addTopDecls:") + 2 exn + Right ds -> return ds + mapM_ (checkTopDecl . unLoc) ds + th_topdecls_var <- fmap tcg_th_topdecls getGblEnv + updTcRef th_topdecls_var (\topds -> ds ++ topds) + where + checkTopDecl :: HsDecl GhcPs -> TcM () + checkTopDecl (ValD _ binds) + = mapM_ bindName (collectHsBindBinders binds) + checkTopDecl (SigD _ _) + = return () + checkTopDecl (AnnD _ _) + = return () + checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) + = bindName name + checkTopDecl _ + = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" + + bindName :: RdrName -> TcM () + bindName (Exact n) + = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv + ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) + } + + bindName name = + addErr $ + hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU.")) + 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") + + qAddForeignFilePath lang fp = do + var <- fmap tcg_th_foreign_files getGblEnv + updTcRef var ((lang, fp) :) + + qAddModFinalizer fin = do + r <- liftIO $ mkRemoteRef fin + fref <- liftIO $ mkForeignRef r (freeRemoteRef r) + addModFinalizerRef fref + + qAddCorePlugin plugin = do + hsc_env <- getTopEnv + r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin) + let err = hang + (text "addCorePlugin: invalid plugin module " + <+> text (show plugin) + ) + 2 + (text "Plugins in the current package can't be specified.") + case r of + Found {} -> addErr err + FoundMultiple {} -> addErr err + _ -> return () + th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv + updTcRef th_coreplugins_var (plugin:) + + qGetQ :: forall a. Typeable a => TcM (Maybe a) + qGetQ = do + th_state_var <- fmap tcg_th_state getGblEnv + th_state <- readTcRef th_state_var + -- See #10596 for why we use a scoped type variable here. + return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) + + qPutQ x = do + th_state_var <- fmap tcg_th_state getGblEnv + updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) + + qIsExtEnabled = xoptM + + qExtsEnabled = + EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv + +-- | Adds a mod finalizer reference to the local environment. +addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM () +addModFinalizerRef finRef = do + th_stage <- getStage + case th_stage of + RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :) + -- This case happens only if a splice is executed and the caller does + -- not set the 'ThStage' to 'RunSplice' to collect finalizers. + -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. + _ -> + pprPanic "addModFinalizer was called when no finalizers were collected" + (ppr th_stage) + +-- | Releases the external interpreter state. +finishTH :: TcM () +finishTH = do + hsc_env <- getTopEnv + case hsc_interp hsc_env of + Nothing -> pure () +#if defined(HAVE_INTERNAL_INTERPRETER) + Just InternalInterp -> pure () +#endif + Just (ExternalInterp {}) -> do + tcg <- getGblEnv + writeTcRef (tcg_th_remote_state tcg) Nothing + + +runTHExp :: ForeignHValue -> TcM TH.Exp +runTHExp = runTH THExp + +runTHPat :: ForeignHValue -> TcM TH.Pat +runTHPat = runTH THPat + +runTHType :: ForeignHValue -> TcM TH.Type +runTHType = runTH THType + +runTHDec :: ForeignHValue -> TcM [TH.Dec] +runTHDec = runTH THDec + +runTH :: Binary a => THResultType -> ForeignHValue -> TcM a +runTH ty fhv = do + interp <- tcGetInterp + case interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> do + -- Run it in the local TcM + hv <- liftIO $ wormhole InternalInterp fhv + r <- runQuasi (unsafeCoerce hv :: TH.Q a) + return r +#endif + + ExternalInterp conf iserv -> + -- 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) + + +-- | communicate with a remotely-running TH computation until it finishes. +-- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. +runRemoteTH + :: IServInstance + -> [Messages] -- saved from nested calls to qRecover + -> TcM () +runRemoteTH iserv recovers = do + THMsg msg <- liftIO $ readIServ iserv getTHMessage + 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) + EndRecover caught_error -> do + let (prev_msgs@(prev_warns,prev_errs), rest) = case recovers of + [] -> panic "EndRecover" + a : b -> (a,b) + v <- getErrsVar + (warn_msgs,_) <- readTcRef v + -- keep the warnings only if there were no errors + writeTcRef v $ if caught_error + then prev_msgs + else (prev_warns `unionBags` warn_msgs, prev_errs) + runRemoteTH iserv rest + _other -> do + r <- handleTHMessage msg + liftIO $ writeIServ iserv (put r) + runRemoteTH iserv recovers + +-- | Read a value of type QResult from the iserv +readQResult :: Binary a => IServInstance -> TcM a +readQResult i = do + qr <- liftIO $ readIServ i get + case qr of + QDone a -> return a + QException str -> liftIO $ throwIO (ErrorCall str) + QFail str -> fail str + +{- Note [TH recover with -fexternal-interpreter] + +Recover is slightly tricky to implement. + +The meaning of "recover a b" is + - Do a + - If it finished with no errors, then keep the warnings it generated + - If it failed, discard any messages it generated, and do b + +Note that "failed" here can mean either + (1) threw an exception (failTc) + (2) generated an error message (addErrTcM) + +The messages are managed by GHC in the TcM monad, whereas the +exception-handling is done in the ghc-iserv process, so we have to +coordinate between the two. + +On the server: + - emit a StartRecover message + - run "a; FailIfErrs" inside a try + - emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed + - if "a; FailIfErrs" failed, run "b" + +Back in GHC, when we receive: + + FailIfErrrs + failTc if there are any error messages (= failIfErrsM) + StartRecover + save the current messages and start with an empty set. + EndRecover caught_error + Restore the previous messages, + and merge in the new messages if caught_error is false. +-} + +-- | Retrieve (or create, if it hasn't been created already), the +-- remote TH state. The TH state is a remote reference to an IORef +-- QState living on the server, and we have to pass this to each RunTH +-- call we make. +-- +-- 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 + hsc_env <- getTopEnv + fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH + writeTcRef (tcg_th_remote_state tcg) (Just fhv) + return fhv + +wrapTHResult :: TcM a -> TcM (THResult a) +wrapTHResult tcm = do + e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic + case e of + Left e -> return (THException (show e)) + Right a -> return (THComplete a) + +handleTHMessage :: THMessage a -> TcM a +handleTHMessage msg = case msg of + NewName a -> wrapTHResult $ TH.qNewName a + Report b str -> wrapTHResult $ TH.qReport b str + LookupName b str -> wrapTHResult $ TH.qLookupName b str + Reify n -> wrapTHResult $ TH.qReify n + ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n + ReifyType n -> wrapTHResult $ TH.qReifyType n + ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts + ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n + ReifyAnnotations lookup tyrep -> + wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) + ReifyModule m -> wrapTHResult $ TH.qReifyModule m + ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm + AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f + AddTempFile s -> wrapTHResult $ TH.qAddTempFile s + AddModFinalizer r -> do + hsc_env <- getTopEnv + wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef + AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str + AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs + AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str + IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext + ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled + FailIfErrs -> wrapTHResult failIfErrsM + _ -> panic ("handleTHMessage: unexpected message " ++ show msg) + +getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]] +getAnnotationsByTypeRep th_name tyrep + = do { name <- lookupThAnnLookup th_name + ; topEnv <- getTopEnv + ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing + ; tcg <- getGblEnv + ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep + ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep + ; return (selectedEpsHptAnns ++ selectedTcgAnns) } + +{- +************************************************************************ +* * + Instance Testing +* * +************************************************************************ +-} + +reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] +reifyInstances th_nm th_tys + = addErrCtxt (text "In the argument of reifyInstances:" + <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ + do { loc <- getSrcSpanM + ; th_origin <- getThSpliceOrigin + ; rdr_ty <- cvt th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys) + -- #9262 says to bring vars into scope, like in HsForAllTy case + -- of rnHsTyKi + ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty + -- Rename to HsType Name + ; ((tv_names, rn_ty), _fvs) + <- checkNoErrs $ -- If there are out-of-scope Names here, then we + -- must error before proceeding to typecheck the + -- renamed type, as that will result in GHC + -- internal errors (#13837). + bindLRdrNames tv_rdrs $ \ tv_names -> + do { (rn_ty, fvs) <- rnLHsType doc rdr_ty + ; return ((tv_names, rn_ty), fvs) } + ; (_tvs, ty) + <- pushTcLevelM_ $ + solveEqualities $ -- Avoid error cascade if there are unsolved + bindImplicitTKBndrs_Skol tv_names $ + fst <$> tcLHsType rn_ty + ; ty <- zonkTcTypeToType ty + -- Substitute out the meta type variables + -- In particular, the type might have kind + -- variables inside it (#7477) + + ; traceTc "reifyInstances" (ppr ty $$ ppr (tcTypeKind ty)) + ; case splitTyConApp_maybe ty of -- This expands any type synonyms + Just (tc, tys) -- See #7910 + | Just cls <- tyConClass_maybe tc + -> do { inst_envs <- tcGetInstEnvs + ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys + ; traceTc "reifyInstances1" (ppr matches) + ; reifyClassInstances cls (map fst matches ++ unifies) } + | isOpenFamilyTyCon tc + -> do { inst_envs <- tcGetFamInstEnvs + ; let matches = lookupFamInstEnv inst_envs tc tys + ; traceTc "reifyInstances2" (ppr matches) + ; reifyFamilyInstances tc (map fim_instance matches) } + _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty)) + 2 (text "is not a class constraint or type family application")) } + 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 msg + Right ty -> return ty + +{- +************************************************************************ +* * + Reification +* * +************************************************************************ +-} + +lookupName :: Bool -- True <=> type namespace + -- False <=> value namespace + -> String -> TcM (Maybe TH.Name) +lookupName is_type_name s + = do { lcl_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv lcl_env rdr_name of + Just n -> return (Just (reifyName n)) + Nothing -> do { mb_nm <- lookupGlobalOccRn_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' + + occ_fs :: FastString + occ_fs = mkFastString (TH.nameBase th_name) + + occ :: OccName + occ | is_type_name + = if isLexVarSym occ_fs || isLexCon occ_fs + then mkTcOccFS occ_fs + else mkTyVarOccFS occ_fs + | otherwise + = if isLexCon occ_fs then mkDataOccFS occ_fs + else mkVarOccFS occ_fs + + rdr_name = case TH.nameModule th_name of + Nothing -> mkRdrUnqual occ + Just mod -> mkRdrQual (mkModuleName mod) occ + +getThing :: TH.Name -> TcM TcTyThing +getThing th_name + = do { name <- lookupThName th_name + ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name) + ; tcLookupTh name } + -- 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 _ = panic "reify/ppr_ns" + +reify :: TH.Name -> TcM TH.Info +reify th_name + = do { traceTc "reify 1" (text (TH.showName th_name)) + ; thing <- getThing th_name + ; traceTc "reify 2" (ppr thing) + ; reifyThing thing } + +lookupThName :: TH.Name -> TcM Name +lookupThName th_name = do + mb_name <- lookupThName_maybe th_name + case mb_name of + Nothing -> failWithTc (notInScope th_name) + Just name -> return name + +lookupThName_maybe :: TH.Name -> TcM (Maybe Name) +lookupThName_maybe th_name + = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) + -- 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) } + where + lookup rdr_name + = do { -- Repeat much of lookupOccRn, because we want + -- to report errors in a TH-relevant way + ; rdr_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv rdr_env rdr_name of + Just name -> return (Just name) + Nothing -> lookupGlobalOccRn_maybe rdr_name } + +tcLookupTh :: Name -> TcM TcTyThing +-- This is a specialised version of GHC.Tc.Utils.Env.tcLookup; specialised mainly in that +-- it gives a reify-related error message on failure, whereas in the normal +-- tcLookup, failure is a bug. +tcLookupTh name + = do { (gbl_env, lcl_env) <- getEnvs + ; case lookupNameEnv (tcl_env lcl_env) name of { + Just thing -> return thing; + Nothing -> + + case lookupNameEnv (tcg_type_env gbl_env) name of { + Just thing -> return (AGlobal thing); + Nothing -> + + -- EZY: I don't think this choice matters, no TH in signatures! + if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name + then -- It's defined in this module + failWithTc (notInEnv name) + + else + do { mb_thing <- tcLookupImported_maybe name + ; case mb_thing of + Succeeded thing -> return (AGlobal thing) + Failed msg -> failWithTc msg + }}}} + +notInScope :: TH.Name -> SDoc +notInScope th_name = quotes (text (TH.pprint th_name)) <+> + text "is not in scope at a reify" + -- Ugh! Rather an indirect way to display the name + +notInEnv :: Name -> SDoc +notInEnv name = quotes (ppr name) <+> + text "is not in the type environment at a reify" + +------------------------------ +reifyRoles :: TH.Name -> TcM [TH.Role] +reifyRoles th_name + = do { thing <- getThing th_name + ; case thing of + AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) + _ -> failWithTc (text "No roles associated with" <+> (ppr thing)) + } + where + reify_role Nominal = TH.NominalR + reify_role Representational = TH.RepresentationalR + reify_role Phantom = TH.PhantomR + +------------------------------ +reifyThing :: TcTyThing -> TcM TH.Info +-- The only reason this is monadic is for error reporting, +-- which in turn is mainly for the case when TH can't express +-- some random GHC extension + +reifyThing (AGlobal (AnId id)) + = 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) + } + +reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc +reifyThing (AGlobal (AConLike (RealDataCon dc))) + = do { let name = dataConName dc + ; ty <- reifyType (idType (dataConWrapId dc)) + ; return (TH.DataConI (reifyName name) ty + (reifyName (dataConOrigTyCon dc))) + } + +reifyThing (AGlobal (AConLike (PatSynCon ps))) + = do { let name = reifyName ps + ; ty <- reifyPatSynType (patSynSig ps) + ; return (TH.PatSynI name ty) } + +reifyThing (ATcId {tct_id = id}) + = do { ty1 <- 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 + ; ty2 <- reifyType ty1 + ; return (TH.TyVarI (reifyName tv) ty2) } + +reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing) + +------------------------------------------- +reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn +reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs + , cab_lhs = lhs + , cab_rhs = rhs }) + -- remove kind patterns (#8884) + = do { tvs' <- reifyTyVarsToMaybe tvs + ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs + ; lhs' <- reifyTypes lhs_types_only + ; annot_th_lhs <- zipWith3M annotThType (tyConArgsPolyKinded fam_tc) + lhs_types_only lhs' + ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs + ; rhs' <- reifyType rhs + ; return (TH.TySynEqn tvs' lhs_type rhs') } + +reifyTyCon :: TyCon -> TcM TH.Info +reifyTyCon tc + | Just cls <- tyConClass_maybe tc + = reifyClass cls + + | isFunTyCon tc + = return (TH.PrimTyConI (reifyName tc) 2 False) + + | isPrimTyCon tc + = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc)) + (isUnliftedTyCon tc)) + + | isTypeFamilyTyCon tc + = do { let tvs = tyConTyVars tc + res_kind = tyConResKind tc + resVar = famTcResVar tc + + ; kind' <- reifyKind res_kind + ; let (resultSig, injectivity) = + case resVar of + Nothing -> (TH.KindSig kind', Nothing) + Just name -> + let thName = reifyName name + injAnnot = tyConInjectivityInfo tc + sig = TH.TyVarSig (TH.KindedTV thName kind') + inj = case injAnnot of + NotInjective -> Nothing + Injective ms -> + Just (TH.InjectivityAnn thName injRHS) + where + injRHS = map (reifyName . tyVarName) + (filterByList ms tvs) + in (sig, inj) + ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; let tfHead = + TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity + ; if isOpenTypeFamilyTyCon tc + then do { fam_envs <- tcGetFamInstEnvs + ; instances <- reifyFamilyInstances tc + (familyInstances fam_envs tc) + ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) } + else do { eqns <- + case isClosedSynFamilyTyConWithAxiom_maybe tc of + Just ax -> mapM (reifyAxBranch tc) $ + fromBranches $ coAxiomBranches ax + Nothing -> return [] + ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns) + []) } } + + | isDataFamilyTyCon tc + = do { let res_kind = tyConResKind tc + + ; kind' <- fmap Just (reifyKind res_kind) + + ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; fam_envs <- tcGetFamInstEnvs + ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc) + ; return (TH.FamilyI + (TH.DataFamilyD (reifyName tc) tvs' kind') instances) } + + | Just (_, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym + = do { rhs' <- reifyType rhs + ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; return (TH.TyConI + (TH.TySynD (reifyName tc) tvs' rhs')) + } + + | otherwise + = do { cxt <- reifyCxt (tyConStupidTheta tc) + ; let tvs = tyConTyVars tc + dataCons = tyConDataCons tc + isGadt = isGadtSyntaxTyCon tc + ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons + ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc) + ; let name = reifyName tc + deriv = [] -- Don't know about deriving + decl | isNewTyCon tc = + TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv + | otherwise = + TH.DataD cxt name r_tvs Nothing cons deriv + ; return (TH.TyConI decl) } + +reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con +reifyDataCon isGadtDataCon tys dc + = do { let -- used for H98 data constructors + (ex_tvs, theta, arg_tys) + = dataConInstSig dc tys + -- used for GADTs data constructors + g_user_tvs' = dataConUserTyVars dc + (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty') + = dataConFullSig dc + (srcUnpks, srcStricts) + = mapAndUnzip reifySourceBang (dataConSrcBangs dc) + dcdBangs = zipWith TH.Bang srcUnpks srcStricts + fields = dataConFieldLabels dc + name = reifyName dc + -- Universal tvs present in eq_spec need to be filtered out, as + -- they will not appear anywhere in the type. + eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec) + + ; (univ_subst, _) + -- See Note [Freshen reified GADT constructors' universal tyvars] + <- freshenTyVarBndrs $ + filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs + ; let (tvb_subst, g_user_tvs) = substTyVarBndrs univ_subst g_user_tvs' + g_theta = substTys tvb_subst g_theta' + g_arg_tys = substTys tvb_subst g_arg_tys' + g_res_ty = substTy tvb_subst g_res_ty' + + ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys) + + ; main_con <- + if | not (null fields) && not isGadtDataCon -> + return $ TH.RecC name (zip3 (map reifyFieldLabel fields) + dcdBangs r_arg_tys) + | not (null fields) -> do + { res_ty <- reifyType g_res_ty + ; return $ TH.RecGadtC [name] + (zip3 (map (reifyName . flSelector) fields) + dcdBangs r_arg_tys) res_ty } + -- We need to check not isGadtDataCon here because GADT + -- constructors can be declared infix. + -- See Note [Infix GADT constructors] in GHC.Tc.TyCl. + | dataConIsInfix dc && not isGadtDataCon -> + ASSERT( r_arg_tys `lengthIs` 2 ) do + { let [r_a1, r_a2] = r_arg_tys + [s1, s2] = dcdBangs + ; 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 } + | otherwise -> + return $ TH.NormalC name (dcdBangs `zip` r_arg_tys) + + ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta) + | otherwise = ASSERT( all isTyVar ex_tvs ) + -- no covars for haskell syntax + (ex_tvs, theta) + ret_con | null ex_tvs' && null theta' = return main_con + | otherwise = do + { cxt <- reifyCxt theta' + ; ex_tvs'' <- reifyTyVars ex_tvs' + ; return (TH.ForallC ex_tvs'' cxt main_con) } + ; ASSERT( r_arg_tys `equalLength` dcdBangs ) + ret_con } + +{- +Note [Freshen reified GADT constructors' universal tyvars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose one were to reify this GADT: + + data a :~: b where + Refl :: forall a b. (a ~ b) => a :~: b + +We ought to be careful here about the uniques we give to the occurrences of `a` +and `b` in this definition. That is because in the original DataCon, all uses +of `a` and `b` have the same unique, since `a` and `b` are both universally +quantified type variables--that is, they are used in both the (:~:) tycon as +well as in the constructor type signature. But when we turn the DataCon +definition into the reified one, the `a` and `b` in the constructor type +signature becomes differently scoped than the `a` and `b` in `data a :~: b`. + +While it wouldn't technically be *wrong* per se to re-use the same uniques for +`a` and `b` across these two different scopes, it's somewhat annoying for end +users of Template Haskell, since they wouldn't be able to rely on the +assumption that all TH names have globally distinct uniques (#13885). For this +reason, we freshen the universally quantified tyvars that go into the reified +GADT constructor type signature to give them distinct uniques from their +counterparts in the tycon. +-} + +------------------------------ +reifyClass :: Class -> TcM TH.Info +reifyClass cls + = do { cxt <- reifyCxt theta + ; inst_envs <- tcGetInstEnvs + ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) + ; assocTys <- concatMapM reifyAT ats + ; ops <- concatMapM reify_op op_stuff + ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls)) + ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops) + ; return (TH.ClassI dec insts) } + where + (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls + fds' = map reifyFunDep fds + reify_op (op, def_meth) + = do { let (_, _, ty) = tcSplitMethodTy (idType op) + -- Use tcSplitMethodTy to get rid of the extraneous class + -- variables and predicates at the beginning of op's type + -- (see #15551). + ; ty' <- reifyType ty + ; let nm' = reifyName op + ; case def_meth of + Just (_, GenericDM gdm_ty) -> + do { gdm_ty' <- reifyType gdm_ty + ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] } + _ -> return [TH.SigD nm' ty'] } + + reifyAT :: ClassATItem -> TcM [TH.Dec] + reifyAT (ATI tycon def) = do + tycon' <- reifyTyCon tycon + case tycon' of + TH.FamilyI dec _ -> do + let (tyName, tyArgs) = tfNames dec + (dec :) <$> maybe (return []) + (fmap (:[]) . reifyDefImpl tyName tyArgs . fst) + def + _ -> pprPanic "reifyAT" (text (show tycon')) + + reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec + reifyDefImpl n args ty = + TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args)) + <$> reifyType ty + + tfNames :: TH.Dec -> (TH.Name, [TH.Name]) + tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _)) + = (n, map bndrName args) + tfNames d = pprPanic "tfNames" (text (show d)) + + bndrName :: TH.TyVarBndr -> TH.Name + bndrName (TH.PlainTV n) = n + bndrName (TH.KindedTV n _) = n + +------------------------------ +-- | Annotate (with TH.SigT) a type if the first parameter is True +-- and if the type contains a free variable. +-- This is used to annotate type patterns for poly-kinded tyvars in +-- reifying class and type instances. +-- See @Note [Reified instances and explicit kind signatures]@. +annotThType :: Bool -- True <=> annotate + -> TyCoRep.Type -> TH.Type -> TcM TH.Type + -- tiny optimization: if the type is annotated, don't annotate again. +annotThType _ _ th_ty@(TH.SigT {}) = return th_ty +annotThType True ty th_ty + | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty + = do { let ki = tcTypeKind ty + ; th_ki <- reifyKind ki + ; return (TH.SigT th_ty th_ki) } +annotThType _ _ th_ty = return th_ty + +-- | For every argument type that a type constructor accepts, +-- report whether or not the argument is poly-kinded. This is used to +-- eventually feed into 'annotThType'. +-- See @Note [Reified instances and explicit kind signatures]@. +tyConArgsPolyKinded :: TyCon -> [Bool] +tyConArgsPolyKinded tc = + map (is_poly_ty . tyVarKind) tc_vis_tvs + -- See "Wrinkle: Oversaturated data family instances" in + -- @Note [Reified instances and explicit kind signatures]@ + ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs -- (1) in Wrinkle + ++ repeat True -- (2) in Wrinkle + where + is_poly_ty :: Type -> Bool + is_poly_ty ty = not $ + isEmptyVarSet $ + filterVarSet isTyVar $ + tyCoVarsOfType ty + + tc_vis_tvs :: [TyVar] + tc_vis_tvs = tyConVisibleTyVars tc + + tc_res_kind_vis_bndrs :: [TyCoBinder] + tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc + +{- +Note [Reified instances and explicit kind signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Reified class instances and type family instances often include extra kind +information to disambiguate instances. Here is one such example that +illustrates this (#8953): + + type family Poly (a :: k) :: Type + type instance Poly (x :: Bool) = Int + type instance Poly (x :: Maybe k) = Double + +If you're not careful, reifying these instances might yield this: + + type instance Poly x = Int + type instance Poly x = Double + +To avoid this, we go through some care to annotate things with extra kind +information. Some functions which accomplish this feat include: + +* annotThType: This annotates a type with a kind signature if the type contains + a free variable. +* tyConArgsPolyKinded: This checks every argument that a type constructor can + accept and reports if the type of the argument is poly-kinded. This + information is ultimately fed into annotThType. + +----- +-- Wrinkle: Oversaturated data family instances +----- + +What constitutes an argument to a type constructor in the definition of +tyConArgsPolyKinded? For most type constructors, it's simply the visible +type variable binders (i.e., tyConVisibleTyVars). There is one corner case +we must keep in mind, however: data family instances can appear oversaturated +(#17296). For instance: + + data family Foo :: Type -> Type + data instance Foo x + + data family Bar :: k + data family Bar x + +For these sorts of data family instances, tyConVisibleTyVars isn't enough, +as they won't give you the kinds of the oversaturated arguments. We must +also consult: + +1. The kinds of the arguments in the result kind (i.e., the tyConResKind). + This will tell us, e.g., the kind of `x` in `Foo x` above. +2. If we go beyond the number of arguments in the result kind (like the + `x` in `Bar x`), then we conservatively assume that the argument's + kind is poly-kinded. + +----- +-- Wrinkle: data family instances with return kinds +----- + +Another squirrelly corner case is this: + + data family Foo (a :: k) + data instance Foo :: Bool -> Type + data instance Foo :: Char -> Type + +If you're not careful, reifying these instances might yield this: + + data instance Foo + data instance Foo + +We can fix this ambiguity by reifying the instances' explicit return kinds. We +should only do this if necessary (see +Note [When does a tycon application need an explicit kind signature?] in GHC.Core.Type), +but more importantly, we *only* do this if either of the following are true: + +1. The data family instance has no constructors. +2. The data family instance is declared with GADT syntax. + +If neither of these are true, then reifying the return kind would yield +something like this: + + data instance (Bar a :: Type) = MkBar a + +Which is not valid syntax. +-} + +------------------------------ +reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec] +reifyClassInstances cls insts + = mapM (reifyClassInstance (tyConArgsPolyKinded (classTyCon cls))) insts + +reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded + -- includes only *visible* tvs + -> ClsInst -> TcM TH.Dec +reifyClassInstance is_poly_tvs i + = do { cxt <- reifyCxt theta + ; let vis_types = filterOutInvisibleTypes cls_tc types + ; thtypes <- reifyTypes vis_types + ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes + ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes + ; return $ (TH.InstanceD over cxt head_ty []) } + where + (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun) + cls_tc = classTyCon cls + dfun = instanceDFunId i + over = case overlapMode (is_flag i) of + NoOverlap _ -> Nothing + Overlappable _ -> Just TH.Overlappable + Overlapping _ -> Just TH.Overlapping + Overlaps _ -> Just TH.Overlaps + Incoherent _ -> Just TH.Incoherent + +------------------------------ +reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] +reifyFamilyInstances fam_tc fam_insts + = mapM (reifyFamilyInstance (tyConArgsPolyKinded fam_tc)) fam_insts + +reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded + -- includes only *visible* tvs + -> FamInst -> TcM TH.Dec +reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor + , fi_axiom = ax + , fi_fam = fam }) + | let fam_tc = coAxiomTyCon ax + branch = coAxiomSingleBranch ax + , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch + = case flavor of + SynFamilyInst -> + -- remove kind patterns (#8884) + do { th_tvs <- reifyTyVarsToMaybe tvs + ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs + ; th_lhs <- reifyTypes lhs_types_only + ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only + th_lhs + ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs + ; th_rhs <- reifyType rhs + ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) } + + DataFamilyInst rep_tc -> + do { let -- eta-expand lhs types, because sometimes data/newtype + -- instances are eta-reduced; See #9692 + -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch + fam' = reifyName fam + dataCons = tyConDataCons rep_tc + isGadt = isGadtSyntaxTyCon rep_tc + ; th_tvs <- reifyTyVarsToMaybe ee_tvs + ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons + ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs + ; th_tys <- reifyTypes types_only + ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys + ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys + ; mb_sig <- + -- See "Wrinkle: data family instances with return kinds" in + -- Note [Reified instances and explicit kind signatures] + if (null cons || isGadtSyntaxTyCon rep_tc) + && tyConAppNeedsKindSig False fam_tc (length ee_lhs) + then do { let full_kind = tcTypeKind (mkTyConApp fam_tc ee_lhs) + ; th_full_kind <- reifyKind full_kind + ; pure $ Just th_full_kind } + else pure Nothing + ; return $ + if isNewTyCon rep_tc + then TH.NewtypeInstD [] th_tvs lhs_type mb_sig (head cons) [] + else TH.DataInstD [] th_tvs lhs_type mb_sig cons [] + } + +------------------------------ +reifyType :: TyCoRep.Type -> TcM TH.Type +-- Monadic only because of failure +reifyType ty | tcIsLiftedTypeKind ty = return TH.StarT + -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it + -- with Constraint (#14869). +reifyType ty@(ForAllTy (Bndr _ argf) _) + = reify_for_all argf ty +reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } +reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) +reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here +reifyType ty@(AppTy {}) = do + let (ty_head, ty_args) = splitAppTys ty + ty_head' <- reifyType ty_head + ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args) + pure $ mkThAppTs ty_head' ty_args' + where + -- Make sure to filter out any invisible arguments. For instance, if you + -- reify the following: + -- + -- newtype T (f :: forall a. a -> Type) = MkT (f Bool) + -- + -- Then you should receive back `f Bool`, not `f Type Bool`, since the + -- `Type` argument is invisible (#15792). + filter_out_invisible_args :: Type -> [Type] -> [Type] + filter_out_invisible_args ty_head ty_args = + filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) + ty_args +reifyType ty@(FunTy { ft_af = af, ft_arg = t1, ft_res = t2 }) + | InvisArg <- af = reify_for_all Inferred ty -- Types like ((?x::Int) => Char -> Char) + | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } +reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH +reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty) + +reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type +-- Arg of reify_for_all is always ForAllTy or a predicate FunTy +reify_for_all argf ty = do + tvs' <- reifyTyVars tvs + case argToForallVisFlag argf of + ForallVis -> do phi' <- reifyType phi + pure $ TH.ForallVisT tvs' phi' + ForallInvis -> do let (cxt, tau) = tcSplitPhiTy phi + cxt' <- reifyCxt cxt + tau' <- reifyType tau + pure $ TH.ForallT tvs' cxt' tau' + where + (tvs, phi) = tcSplitForAllTysSameVis argf ty + +reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit +reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) +reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s)) + +reifyTypes :: [Type] -> TcM [TH.Type] +reifyTypes = mapM reifyType + +reifyPatSynType + :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type +-- reifies a pattern synonym's type and returns its *complete* type +-- signature; see NOTE [Pattern synonym signatures and Template +-- Haskell] +reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy) + = do { univTyVars' <- reifyTyVars univTyVars + ; req' <- reifyCxt req + ; exTyVars' <- reifyTyVars exTyVars + ; prov' <- reifyCxt prov + ; tau' <- reifyType (mkVisFunTys argTys resTy) + ; return $ TH.ForallT univTyVars' req' + $ TH.ForallT exTyVars' prov' tau' } + +reifyKind :: Kind -> TcM TH.Kind +reifyKind = reifyType + +reifyCxt :: [PredType] -> TcM [TH.Pred] +reifyCxt = mapM reifyType + +reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep +reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) + +reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr] +reifyTyVars tvs = mapM reify_tv tvs + where + -- even if the kind is *, we need to include a kind annotation, + -- in case a poly-kind would be inferred without the annotation. + -- See #8953 or test th/T8953 + reify_tv tv = TH.KindedTV name <$> reifyKind kind + where + kind = tyVarKind tv + name = reifyName tv + +reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr]) +reifyTyVarsToMaybe [] = pure Nothing +reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys + +reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type +reify_tc_app tc tys + = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys) + ; maybe_sig_t (mkThAppTs r_tc tys') } + where + arity = tyConArity tc + + r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2) + | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2) + | isPromotedTupleTyCon tc = TH.PromotedTupleT (arity `div` 2) + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + | isTupleTyCon tc = if isPromotedDataCon tc + then TH.PromotedTupleT arity + else TH.TupleT arity + | tc `hasKey` constraintKindTyConKey + = TH.ConstraintT + | tc `hasKey` funTyConKey = TH.ArrowT + | tc `hasKey` listTyConKey = TH.ListT + | tc `hasKey` nilDataConKey = TH.PromotedNilT + | tc `hasKey` consDataConKey = TH.PromotedConsT + | tc `hasKey` heqTyConKey = TH.EqualityT + | tc `hasKey` eqPrimTyConKey = TH.EqualityT + | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon) + | isPromotedDataCon tc = TH.PromotedT (reifyName tc) + | otherwise = TH.ConT (reifyName tc) + + -- See Note [When does a tycon application need an explicit kind + -- signature?] in GHC.Core.TyCo.Rep + maybe_sig_t th_type + | tyConAppNeedsKindSig + False -- We don't reify types using visible kind applications, so + -- don't count specified binders as contributing towards + -- injective positions in the kind of the tycon. + tc (length tys) + = do { let full_kind = tcTypeKind (mkTyConApp tc tys) + ; th_full_kind <- reifyKind full_kind + ; return (TH.SigT th_type th_full_kind) } + | otherwise + = return th_type + +------------------------------ +reifyName :: NamedThing n => n -> TH.Name +reifyName thing + | isExternalName name + = mk_varg pkg_str mod_str occ_str + | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name)) + -- Many of the things we reify have local bindings, and + -- NameL's aren't supposed to appear in binding positions, so + -- we use NameU. When/if we start to reify nested things, that + -- have free variables, we may need to generate NameL's for them. + where + name = getName thing + mod = ASSERT( isExternalName name ) nameModule name + pkg_str = unitString (moduleUnit mod) + mod_str = moduleNameString (moduleName mod) + occ_str = occNameString occ + occ = nameOccName name + mk_varg | OccName.isDataOcc occ = TH.mkNameG_d + | OccName.isVarOcc occ = TH.mkNameG_v + | OccName.isTcOcc occ = TH.mkNameG_tc + | 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 (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) + +------------------------------ +reifyFixity :: Name -> TcM (Maybe TH.Fixity) +reifyFixity name + = do { (found, fix) <- lookupFixityRn_help name + ; return (if found then Just (conv_fix fix) else Nothing) } + where + conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d) + conv_dir BasicTypes.InfixR = TH.InfixR + conv_dir BasicTypes.InfixL = TH.InfixL + conv_dir BasicTypes.InfixN = TH.InfixN + +reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness +reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness +reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack +reifyUnpackedness SrcUnpack = TH.SourceUnpack + +reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness +reifyStrictness NoSrcStrict = TH.NoSourceStrictness +reifyStrictness SrcStrict = TH.SourceStrict +reifyStrictness SrcLazy = TH.SourceLazy + +reifySourceBang :: DataCon.HsSrcBang + -> (TH.SourceUnpackedness, TH.SourceStrictness) +reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s) + +reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness +reifyDecidedStrictness HsLazy = TH.DecidedLazy +reifyDecidedStrictness HsStrict = TH.DecidedStrict +reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack + +reifyTypeOfThing :: TH.Name -> TcM TH.Type +reifyTypeOfThing th_name = do + thing <- getThing th_name + case thing of + AGlobal (AnId id) -> reifyType (idType id) + AGlobal (ATyCon tc) -> reifyKind (tyConKind tc) + AGlobal (AConLike (RealDataCon dc)) -> + reifyType (idType (dataConWrapId dc)) + AGlobal (AConLike (PatSynCon ps)) -> + reifyPatSynType (patSynSig ps) + ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType + ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType + -- Impossible cases, supposedly: + AGlobal (ACoAxiom _) -> panic "reifyTypeOfThing: ACoAxiom" + ATcTyCon _ -> panic "reifyTypeOfThing: ATcTyCon" + APromotionErr _ -> panic "reifyTypeOfThing: APromotionErr" + +------------------------------ +lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget +lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm) +lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn)) + = return $ ModuleTarget $ + mkModule (stringToUnit $ TH.pkgString pn) (mkModuleName $ TH.modString mn) + +reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a] +reifyAnnotations th_name + = do { name <- lookupThAnnLookup th_name + ; topEnv <- getTopEnv + ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing + ; tcg <- getGblEnv + ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name + ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name + ; return (selectedEpsHptAnns ++ selectedTcgAnns) } + +------------------------------ +modToTHMod :: Module -> TH.Module +modToTHMod m = TH.Module (TH.PkgName $ unitString $ moduleUnit m) + (TH.ModName $ moduleNameString $ moduleName m) + +reifyModule :: TH.Module -> TcM TH.ModuleInfo +reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do + this_mod <- getModule + let reifMod = mkModule (stringToUnit pkgString) (mkModuleName mString) + if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod + where + reifyThisModule = do + usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports + return $ TH.ModuleInfo usages + + reifyFromIface reifMod = do + iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod + let usages = [modToTHMod m | usage <- mi_usages iface, + Just m <- [usageToModule (moduleUnit reifMod) usage] ] + return $ TH.ModuleInfo usages + + usageToModule :: Unit -> Usage -> Maybe Module + usageToModule _ (UsageFile {}) = Nothing + usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn + usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m + usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m + +------------------------------ +mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type +mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys + +noTH :: PtrString -> SDoc -> TcM a +noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+> + text "in Template Haskell:", + nest 2 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 + hsc_env <- getTopEnv + case hsc_interp hsc_env of + Nothing -> liftIO $ throwIO (InstallationError "Template haskell requires a target code interpreter") + Just i -> pure i diff --git a/compiler/GHC/Tc/Gen/Splice.hs-boot b/compiler/GHC/Tc/Gen/Splice.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Splice.hs-boot @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Gen.Splice where + +import GHC.Prelude +import GHC.Types.Name +import GHC.Hs.Expr ( PendingRnSplice, DelayedSplice ) +import GHC.Tc.Types( TcM , SpliceType ) +import GHC.Tc.Utils.TcType ( ExpRhoType ) +import GHC.Types.Annotations ( Annotation, CoreAnnTarget ) +import GHC.Hs.Extension ( GhcTcId, GhcRn, GhcPs, GhcTc ) + +import GHC.Hs ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, + LHsDecl, ThModFinalizers ) +import qualified Language.Haskell.TH as TH + +tcSpliceExpr :: HsSplice GhcRn + -> ExpRhoType + -> TcM (HsExpr GhcTcId) + +tcUntypedBracket :: HsExpr GhcRn + -> HsBracket GhcRn + -> [PendingRnSplice] + -> ExpRhoType + -> TcM (HsExpr GhcTcId) +tcTypedBracket :: HsExpr GhcRn + -> HsBracket GhcRn + -> ExpRhoType + -> TcM (HsExpr GhcTcId) + +runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) + +runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation + +tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId) + +runMetaE :: LHsExpr GhcTcId -> TcM (LHsExpr GhcPs) +runMetaP :: LHsExpr GhcTcId -> TcM (LPat GhcPs) +runMetaT :: LHsExpr GhcTcId -> TcM (LHsType GhcPs) +runMetaD :: LHsExpr GhcTcId -> TcM [LHsDecl GhcPs] + +lookupThName_maybe :: TH.Name -> TcM (Maybe Name) +runQuasi :: TH.Q a -> TcM a +runRemoteModFinalizers :: ThModFinalizers -> TcM () +finishTH :: TcM () diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -0,0 +1,714 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Tc.Instance.Class ( + matchGlobalInst, + ClsInstResult(..), + InstanceWhat(..), safeOverlap, instanceReturnsDictCon, + AssocInstInfo(..), isNotAssociated + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Tc.Instance.Typeable +import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.Evidence +import GHC.Core.Predicate +import GHC.Rename.Env( addUsedGRE ) +import GHC.Types.Name.Reader( lookupGRE_FieldLabel ) +import GHC.Core.InstEnv +import GHC.Tc.Utils.Instantiate( instDFunType ) +import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst ) + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim( eqPrimTyCon, eqReprPrimTyCon ) +import GHC.Builtin.Names + +import GHC.Types.Id +import GHC.Core.Type +import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr ) + +import GHC.Types.Name ( Name, pprDefinedAt ) +import GHC.Types.Var.Env ( VarEnv ) +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Utils.Misc( splitAtList, fstOf3 ) +import Data.Maybe + +{- ******************************************************************* +* * + A helper for associated types within + class instance declarations +* * +**********************************************************************-} + +-- | Extra information about the parent instance declaration, needed +-- when type-checking associated types. The 'Class' is the enclosing +-- class, the [TyVar] are the /scoped/ type variable of the instance decl. +-- The @VarEnv Type@ maps class variables to their instance types. +data AssocInstInfo + = NotAssociated + | InClsInst { ai_class :: Class + , ai_tyvars :: [TyVar] -- ^ The /scoped/ tyvars of the instance + -- Why scoped? See bind_me in + -- GHC.Tc.Validity.checkConsistentFamInst + , ai_inst_env :: VarEnv Type -- ^ Maps /class/ tyvars to their instance types + -- See Note [Matching in the consistent-instantiation check] + } + +isNotAssociated :: AssocInstInfo -> Bool +isNotAssociated NotAssociated = True +isNotAssociated (InClsInst {}) = False + + +{- ******************************************************************* +* * + Class lookup +* * +**********************************************************************-} + +-- | 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 } + + | NotSure -- Multiple matches and/or one or more unifiers + +data InstanceWhat + = BuiltinInstance + | BuiltinEqInstance -- A built-in "equality instance"; see the + -- GHC.Tc.Solver.Monad Note [Solved dictionaries] + | LocalInstance + | TopLevInstance { iw_dfun_id :: DFunId + , iw_safe_over :: SafeOverlapping } + +instance Outputable ClsInstResult where + ppr NoInstance = text "NoInstance" + ppr NotSure = text "NotSure" + ppr (OneInst { cir_new_theta = ev + , cir_what = what }) + = text "OneInst" <+> vcat [ppr ev, ppr what] + +instance Outputable InstanceWhat where + ppr BuiltinInstance = text "a built-in 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 + +instanceReturnsDictCon :: InstanceWhat -> Bool +-- See Note [Solved dictionaries] in GHC.Tc.Solver.Monad +instanceReturnsDictCon (TopLevInstance {}) = True +instanceReturnsDictCon BuiltinInstance = True +instanceReturnsDictCon BuiltinEqInstance = False +instanceReturnsDictCon LocalInstance = False + +matchGlobalInst :: DynFlags + -> Bool -- True <=> caller is the short-cut solver + -- See Note [Shortcut solving: overlap] + -> Class -> [Type] -> TcM ClsInstResult +matchGlobalInst dflags short_cut clas tys + | cls_name == knownNatClassName + = matchKnownNat dflags short_cut clas tys + | cls_name == knownSymbolClassName + = matchKnownSymbol dflags short_cut clas tys + | isCTupleClass clas = matchCTuple clas tys + | cls_name == typeableClassName = matchTypeable clas 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 + where + cls_name = className clas + + +{- ******************************************************************** +* * + Looking in the instance environment +* * +***********************************************************************-} + + +matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult +matchInstEnv dflags short_cut_solver clas tys + = do { instEnvs <- tcGetInstEnvs + ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy] + (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys + safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps) + ; traceTc "matchInstEnv" $ + vcat [ text "goal:" <+> ppr clas <+> ppr tys + , text "matches:" <+> ppr matches + , text "unify:" <+> ppr unify ] + ; case (matches, unify, safeHaskFail) of + + -- Nothing matches + ([], [], _) + -> do { traceTc "matchClass not matching" (ppr pred) + ; return NoInstance } + + -- A single match (& no safe haskell failure) + ([(ispec, inst_tys)], [], False) + | short_cut_solver -- Called from the short-cut solver + , isOverlappable ispec + -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT + -- then don't let the short-cut solver choose it, because a + -- later instance might overlap it. #14434 is an example + -- See Note [Shortcut solving: overlap] + -> do { traceTc "matchClass: ignoring overlappable" (ppr pred) + ; return NotSure } + + | otherwise + -> do { let dfun_id = instanceDFunId ispec + ; traceTc "matchClass success" $ + vcat [text "dict" <+> ppr pred, + text "witness" <+> ppr dfun_id + <+> ppr (idType dfun_id) ] + -- Record that this dfun is needed + ; match_one (null unsafeOverlaps) 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 + _ -> do { traceTc "matchClass multiple matches, deferring choice" $ + vcat [text "dict" <+> ppr pred, + text "matches" <+> ppr matches] + ; return NotSure } } + 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 + = 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 } } } + + +{- Note [Shortcut solving: overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + instance {-# OVERLAPPABLE #-} C a where ... +and we are typechecking + f :: C a => a -> a + f = e -- Gives rise to [W] C a + +We don't want to solve the wanted constraint with the overlappable +instance; rather we want to use the supplied (C a)! That was the whole +point of it being overlappable! #14434 wwas an example. + +Alas even if the instance has no overlap flag, thus + instance C a where ... +there is nothing to stop it being overlapped. GHC provides no way to +declare an instance as "final" so it can't be overlapped. But really +only final instances are OK for short-cut solving. Sigh. #15135 +was a puzzling example. +-} + + +{- ******************************************************************** +* * + Class lookup for CTuples +* * +***********************************************************************-} + +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 }) + -- The dfun *is* the data constructor! + where + data_con = tyConSingleDataCon (classTyCon clas) + tuple_ev = evDFunApp (dataConWrapId data_con) tys + +{- ******************************************************************** +* * + Class lookup for Literals +* * +***********************************************************************-} + +{- +Note [KnownNat & KnownSymbol and EvLit] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A part of the type-level literals implementation are the classes +"KnownNat" and "KnownSymbol", which provide a "smart" constructor for +defining singleton values. Here is the key stuff from GHC.TypeLits + + class KnownNat (n :: Nat) where + natSing :: SNat n + + newtype SNat (n :: Nat) = SNat Integer + +Conceptually, this class has infinitely many instances: + + instance KnownNat 0 where natSing = SNat 0 + instance KnownNat 1 where natSing = SNat 1 + 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)`. + +We make the following assumptions about dictionaries in GHC: + 1. The "dictionary" for classes with a single method---like `KnownNat`---is + a newtype for the type of the method, so using a evidence amounts + to a coercion, and + 2. Newtypes use the same representation as their definition types. + +So, the evidence for `KnownNat` is just a value of the representation type, +wrapped in two newtype constructors: one to make it into a `SNat` value, +and another to make it into a `KnownNat` dictionary. + +Also note that `natSing` and `SNat` are never actually exposed from the +library---they are just an implementation detail. Instead, users see +a more convenient function, defined in terms of `natSing`: + + natVal :: KnownNat n => proxy n -> Integer + +The reason we don't use this directly in the class is that it is simpler +and more efficient to pass around an integer rather than an entire function, +especially when the `KnowNat` evidence is packaged up in an existential. + +The story for kind `Symbol` is analogous: + * class KnownSymbol + * newtype SSymbol + * Evidence: a Core literal (e.g. mkNaturalExpr) + + +Note [Fabricating Evidence for Literals in Backpack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Let `T` be a type of kind `Nat`. When solving for a purported instance +of `KnownNat T`, ghc tries to resolve the type `T` to an integer `n`, +in which case the evidence `EvLit (EvNum n)` is generated on the +fly. It might appear that this is sufficient as users cannot define +their own instances of `KnownNat`. However, for backpack module this +would not work (see issue #15379). Consider the signature `Abstract` + +> signature Abstract where +> data T :: Nat +> instance KnownNat T + +and a module `Util` that depends on it: + +> module Util where +> import Abstract +> printT :: IO () +> printT = do print $ natVal (Proxy :: Proxy T) + +Clearly, we need to "use" the dictionary associated with `KnownNat T` +in the module `Util`, but it is too early for the compiler to produce +a real dictionary as we still have not fixed what `T` is. Only when we +mixin a concrete module + +> module Concrete where +> type T = 42 + +do we really get hold of the underlying integer. So the strategy that +we follow is the following + +1. If T is indeed available as a type alias for an integer constant, + generate the dictionary on the fly, failing which + +2. Look up the type class environment for the evidence. + +Finally actual code gets generate for Util only when a module like +Concrete gets "mixed-in" in place of the signature Abstract. As a +result all things, including the typeclass instances, in Concrete gets +reexported. So `KnownNat` gets resolved the normal way post-Backpack. + +A similar generation works for `KnownSymbol` as well + +-} + +matchKnownNat :: DynFlags + -> Bool -- True <=> caller is the short-cut solver + -- See Note [Shortcut solving: overlap] + -> Class -> [Type] -> TcM ClsInstResult +matchKnownNat _ _ clas [ty] -- clas = KnownNat + | Just n <- isNumLitTy ty = do + et <- mkNaturalExpr n + makeLitDict clas ty et +matchKnownNat df sc clas tys = matchInstEnv df sc clas tys + -- See Note [Fabricating Evidence for Literals in Backpack] for why + -- this lookup into the instance environment is required. + +matchKnownSymbol :: DynFlags + -> Bool -- True <=> caller is the short-cut solver + -- See Note [Shortcut solving: overlap] + -> Class -> [Type] -> TcM ClsInstResult +matchKnownSymbol _ _ clas [ty] -- clas = KnownSymbol + | Just s <- isStrLitTy ty = do + et <- mkStringExprFS s + makeLitDict clas ty et +matchKnownSymbol df sc clas tys = matchInstEnv df sc clas tys + -- See Note [Fabricating Evidence for Literals in Backpack] for why + -- this lookup into the instance environment is required. + +makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult +-- makeLitDict adds a coercion that will convert the literal into a dictionary +-- of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit] +-- in GHC.Tc.Types.Evidence. The coercion happens in 2 steps: +-- +-- Integer -> SNat n -- representation of literal to singleton +-- SNat n -> KnownNat n -- singleton to dictionary +-- +-- The process is mirrored for Symbols: +-- String -> SSymbol n +-- SSymbol n -> KnownSymbol n +makeLitDict clas ty et + | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty] + -- co_dict :: KnownNat n ~ SNat n + , [ meth ] <- classMethods clas + , Just tcRep <- tyConAppTyCon_maybe -- SNat + $ funResultTy -- SNat n + $ dropForAlls -- KnownNat n => SNat n + $ idType meth -- forall n. KnownNat n => SNat n + , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] + -- SNat n ~ Integer + , let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep)) + = return $ OneInst { cir_new_theta = [] + , cir_mk_ev = \_ -> ev_tm + , cir_what = BuiltinInstance } + + | otherwise + = pprPanic "makeLitDict" $ + text "Unexpected evidence for" <+> ppr (className clas) + $$ vcat (map (ppr . idType) (classMethods clas)) + +{- ******************************************************************** +* * + Class lookup for Typeable +* * +***********************************************************************-} + +-- | Assumes that we've checked that this is the 'Typeable' class, +-- and it was applied to the correct argument. +matchTypeable :: Class -> [Type] -> TcM ClsInstResult +matchTypeable clas [k,t] -- clas = Typeable + -- For the first two cases, See Note [No Typeable for polytypes or qualified types] + | isForAllTy k = return NoInstance -- Polytype + | isJust (tcSplitPredFunTy_maybe t) = return NoInstance -- Qualified type + + -- Now cases that do work + | k `eqType` typeNatKind = doTyLit knownNatClassName t + | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t + | tcIsConstraintKind t = doTyConApp clas t constraintKindTyCon [] + | Just (arg,ret) <- splitFunTy_maybe t = doFunTy clas t arg ret + | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] + , onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks + | Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt + +matchTypeable _ _ = return NoInstance + +-- | Representation for a type @ty@ of the form @arg -> ret@. +doFunTy :: Class -> Type -> Type -> Type -> TcM ClsInstResult +doFunTy clas ty arg_ty ret_ty + = return $ OneInst { cir_new_theta = preds + , cir_mk_ev = mk_ev + , cir_what = BuiltinInstance } + where + preds = map (mk_typeable_pred clas) [arg_ty, ret_ty] + mk_ev [arg_ev, ret_ev] = evTypeable ty $ + EvTypeableTrFun (EvExpr arg_ev) (EvExpr ret_ev) + mk_ev _ = panic "GHC.Tc.Solver.Interact.doFunTy" + + +-- | Representation for type constructor applied to some kinds. +-- 'onlyNamedBndrsApplied' has ensured that this application results in a type +-- of monomorphic kind (e.g. all kind variables have been instantiated). +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 = BuiltinInstance } + | otherwise + = return NoInstance + where + mk_ev kinds = evTypeable ty $ EvTypeableTyCon tc (map EvExpr kinds) + +-- | Representation for TyCon applications of a concrete kind. We just use the +-- kind itself, but first we must make sure that we've instantiated all kind- +-- polymorphism, but no more. +onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool +onlyNamedBndrsApplied tc ks + = all isNamedTyConBinder used_bndrs && + not (any isNamedTyConBinder leftover_bndrs) + where + bndrs = tyConBinders tc + (used_bndrs, leftover_bndrs) = splitAtList ks bndrs + +doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult +-- Representation for an application of a type to a type-or-kind. +-- This may happen when the type expression starts with a type variable. +-- Example (ignoring kind parameter): +-- Typeable (f Int Char) --> +-- (Typeable (f Int), Typeable Char) --> +-- (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps) +-- Typeable f +doTyApp clas ty f tk + | isForAllTy (tcTypeKind 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 } + where + mk_ev [t1,t2] = evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2) + mk_ev _ = panic "doTyApp" + + +-- Emit a `Typeable` constraint for the given type. +mk_typeable_pred :: Class -> Type -> PredType +mk_typeable_pred clas ty = mkClassPred clas [ tcTypeKind ty, ty ] + + -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal + -- we generate a sub-goal for the appropriate class. + -- See Note [Typeable for Nat and Symbol] +doTyLit :: Name -> Type -> TcM ClsInstResult +doTyLit kc t = do { kc_clas <- tcLookupClass kc + ; 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 }) } + +{- Note [Typeable (T a b c)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For type applications we always decompose using binary application, +via doTyApp, until we get to a *kind* instantiation. Example + Proxy :: forall k. k -> * + +To solve Typeable (Proxy (* -> *) Maybe) we + - First decompose with doTyApp, + to get (Typeable (Proxy (* -> *))) and Typeable Maybe + - Then solve (Typeable (Proxy (* -> *))) with doTyConApp + +If we attempt to short-cut by solving it all at once, via +doTyConApp + +(this note is sadly truncated FIXME) + + +Note [No Typeable for polytypes or qualified types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not support impredicative typeable, such as + Typeable (forall a. a->a) + Typeable (Eq a => a -> a) + Typeable (() => Int) + Typeable (((),()) => Int) + +See #9858. For forall's the case is clear: we simply don't have +a TypeRep for them. For qualified but not polymorphic types, like +(Eq a => a -> a), things are murkier. But: + + * We don't need a TypeRep for these things. TypeReps are for + monotypes only. + + * Perhaps we could treat `=>` as another type constructor for `Typeable` + purposes, and thus support things like `Eq Int => Int`, however, + at the current state of affairs this would be an odd exception as + no other class works with impredicative types. + For now we leave it off, until we have a better story for impredicativity. + + +Note [Typeable for Nat and Symbol] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have special Typeable instances for Nat and Symbol. Roughly we +have this instance, implemented here by doTyLit: + instance KnownNat n => Typeable (n :: Nat) where + typeRep = typeNatTypeRep @n +where + Data.Typeable.Internals.typeNatTypeRep :: KnownNat a => TypeRep a + +Ultimately typeNatTypeRep uses 'natSing' from KnownNat to get a +runtime value 'n'; it turns it into a string with 'show' and uses +that to whiz up a TypeRep TyCon for 'n', with mkTypeLitTyCon. +See #10348. + +Because of this rule it's inadvisable (see #15322) to have a constraint + f :: (Typeable (n :: Nat)) => blah +in a function signature; it gives rise to overlap problems just as +if you'd written + f :: Eq [a] => blah +-} + +{- ******************************************************************** +* * + Class lookup for lifted equality +* * +***********************************************************************-} + +-- 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 }) + +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) + +-- 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) + + +{- ******************************************************************** +* * + Class lookup for overloaded record fields +* * +***********************************************************************-} + +{- +Note [HasField instances] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + data T y = MkT { foo :: [y] } + +and `foo` is in scope. Then GHC will automatically solve a constraint like + + HasField "foo" (T Int) b + +by emitting a new wanted + + T alpha -> [alpha] ~# T Int -> b + +and building a HasField dictionary out of the selector function `foo`, +appropriately cast. + +The HasField class is defined (in GHC.Records) thus: + + class HasField (x :: k) r a | x r -> a where + getField :: r -> a + +Since this is a one-method class, it is represented as a newtype. +Hence we can solve `HasField "foo" (T Int) b` by taking an expression +of type `T Int -> b` and casting it using the newtype coercion. +Note that + + foo :: forall y . T y -> [y] + +so the expression we construct is + + foo @alpha |> co + +where + + co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b + +is built from + + co1 :: (T alpha -> [alpha]) ~# (T Int -> b) + +which is the new wanted, and + + co2 :: (T Int -> b) ~# HasField "foo" (T Int) b + +which can be derived from the newtype coercion. + +If `foo` is not in scope, or has a higher-rank or existentially +quantified type, then the constraint is not solved automatically, but +may be solved by a user-supplied HasField instance. Similarly, if we +encounter a HasField constraint where the field is not a literal +string, or does not belong to the type, then we fall back on the +normal constraint solver behaviour. +-} + +-- See Note [HasField instances] +matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult +matchHasField dflags short_cut clas tys + = do { fam_inst_envs <- tcGetFamInstEnvs + ; rdr_env <- getGlobalRdrEnv + ; case tys of + -- We are matching HasField {k} x r a... + [_k_ty, x_ty, r_ty, a_ty] + -- x should be a literal string + | Just x <- isStrLitTy x_ty + -- r should be an applied type constructor + , Just (tc, args) <- tcSplitTyConApp_maybe r_ty + -- use representation tycon (if data family); it has the fields + , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args) + -- x should be a field of r + , Just fl <- lookupTyConFieldLabel x r_tc + -- the field selector should be in scope + , Just gre <- lookupGRE_FieldLabel rdr_env fl + + -> do { sel_id <- tcLookupId (flSelector fl) + ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id + + -- The first new wanted constraint equates the actual + -- type of the selector with the type (r -> a) within + -- the HasField x r a dictionary. The preds will + -- typically be empty, but if the datatype has a + -- "stupid theta" then we have to include it here. + ; let theta = mkPrimEqPred sel_ty (mkVisFunTy r_ty a_ty) : preds + + -- Use the equality proof to cast the selector Id to + -- type (r -> a), then use the newtype coercion to cast + -- it to a HasField dictionary. + mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co + where + co = mkTcSubCo (evTermCoercion (EvExpr ev1)) + `mkTcTransCo` mkTcSymCo co2 + mk_ev [] = panic "matchHasField.mk_ev" + + Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas) + tys + + tvs = mkTyVarTys (map snd tv_prs) + + -- The selector must not be "naughty" (i.e. the field + -- cannot have an existentially quantified type), and + -- it must not be higher-rank. + ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty + then do { addUsedGRE True gre + ; return OneInst { cir_new_theta = theta + , cir_mk_ev = mk_ev + , 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 new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -0,0 +1,1056 @@ +{-# LANGUAGE CPP, GADTs, ViewPatterns #-} + +-- | The @FamInst@ type: family instance heads +module GHC.Tc.Instance.Family ( + FamInstEnvs, tcGetFamInstEnvs, + checkFamInstConsistency, tcExtendLocalFamInstEnv, + tcLookupDataFamInst, tcLookupDataFamInst_maybe, + tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe, + newFamInst, + + -- * Injectivity + reportInjectivityErrors, reportConflictingInjectivityErrs + ) where + +import GHC.Prelude + +import GHC.Driver.Types +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv( roughMatchTcs ) +import GHC.Core.Coercion +import GHC.Core.Lint +import GHC.Tc.Types.Evidence +import GHC.Iface.Load +import GHC.Tc.Utils.Monad +import GHC.Types.SrcLoc as SrcLoc +import GHC.Core.TyCon +import GHC.Tc.Utils.TcType +import GHC.Core.Coercion.Axiom +import GHC.Driver.Session +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.Name.Reader +import GHC.Core.DataCon ( dataConName ) +import GHC.Data.Maybe +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen ) +import GHC.Tc.Utils.TcMType +import GHC.Types.Name +import GHC.Utils.Panic +import GHC.Types.Var.Set +import GHC.Utils.FV +import GHC.Data.Bag( Bag, unionBags, unitBag ) +import Control.Monad +import Data.List ( sortBy ) +import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Function ( on ) + +import qualified GHC.LanguageExtensions as LangExt + +#include "HsVersions.h" + +{- Note [The type family instance consistency story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To preserve type safety we must ensure that for any given module, all +the type family instances used either in that module or in any module +it directly or indirectly imports are consistent. For example, consider + + module F where + type family F a + + module A where + import F( F ) + type instance F Int = Bool + f :: F Int -> Bool + f x = x + + module B where + import F( F ) + type instance F Int = Char + g :: Char -> F Int + g x = x + + module Bad where + import A( f ) + import B( g ) + bad :: Char -> Int + bad c = f (g c) + +Even though module Bad never mentions the type family F at all, by +combining the functions f and g that were type checked in contradictory +type family instance environments, the function bad is able to coerce +from one type to another. So when we type check Bad we must verify that +the type family instances defined in module A are consistent with those +defined in module B. + +How do we ensure that we maintain the necessary consistency? + +* Call a module which defines at least one type family instance a + "family instance module". This flag `mi_finsts` is recorded in the + interface file. + +* For every module we calculate the set of all of its direct and + indirect dependencies that are family instance modules. This list + `dep_finsts` is also recorded in the interface file so we can compute + this list for a module from the lists for its direct dependencies. + +* When type checking a module M we check consistency of all the type + family instances that are either provided by its `dep_finsts` or + defined in the module M itself. This is a pairwise check, i.e., for + every pair of instances we must check that they are consistent. + + - For family instances coming from `dep_finsts`, this is checked in + checkFamInstConsistency, called from tcRnImports. See Note + [Checking family instance consistency] for details on this check + (and in particular how we avoid having to do all these checks for + every module we compile). + + - That leaves checking the family instances defined in M itself + against instances defined in either M or its `dep_finsts`. This is + checked in `tcExtendLocalFamInstEnv'. + +There are four subtle points in this scheme which have not been +addressed yet. + +* We have checked consistency of the family instances *defined* by M + or its imports, but this is not by definition the same thing as the + family instances *used* by M or its imports. Specifically, we need to + ensure when we use a type family instance while compiling M that this + instance was really defined from either M or one of its imports, + rather than being an instance that we happened to know about from + reading an interface file in the course of compiling an unrelated + module. Otherwise, we'll end up with no record of the fact that M + depends on this family instance and type safety will be compromised. + See #13102. + +* It can also happen that M uses a function defined in another module + which is not transitively imported by M. Examples include the + desugaring of various overloaded constructs, and references inserted + by Template Haskell splices. If that function's definition makes use + of type family instances which are not checked against those visible + from M, type safety can again be compromised. See #13251. + +* When a module C imports a boot module B.hs-boot, we check that C's + type family instances are compatible with those visible from + B.hs-boot. However, C will eventually be linked against a different + module B.hs, which might define additional type family instances which + are inconsistent with C's. This can also lead to loss of type safety. + See #9562. + +* The call to checkFamConsistency for imported functions occurs very + early (in tcRnImports) and that causes problems if the imported + instances use type declared in the module being compiled. + See Note [Loading your own hi-boot file] in GHC.Iface.Load. +-} + +{- +************************************************************************ +* * + 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 }) + = ASSERT2( tyCoVarsOfTypes lhs `subVarSet` tcv_set, text "lhs" <+> pp_ax ) + ASSERT2( lhs_kind `eqType` rhs_kind, text "kind" <+> pp_ax $$ ppr lhs_kind $$ ppr rhs_kind ) + -- We used to have an assertion that the tyvars of the RHS were bound + -- by tcv_set, but in error situations like F Int = a that isn't + -- true; a later check in checkValidFamInst rejects it + do { (subst, tvs') <- freshenTyVarBndrs tvs + ; (subst, cvs') <- freshenCoVarBndrsX subst cvs + ; dflags <- getDynFlags + ; let lhs' = substTys subst lhs + rhs' = substTy subst rhs + tcvs' = tvs' ++ cvs' + ; ifErrsM (return ()) $ -- Don't lint when there are errors, because + -- errors might mean TcTyCons. + -- See Note [Recover from validity error] in GHC.Tc.TyCl + when (gopt Opt_DoCoreLinting dflags) $ + -- Check that the types involved in this instance are well formed. + -- Do /not/ expand type synonyms, for the reasons discussed in + -- Note [Linting type synonym applications]. + case lintTypes dflags tcvs' (rhs':lhs') of + Nothing -> pure () + Just fail_msg -> pprPanic "Core Lint error in newFamInst" $ + vcat [ fail_msg + , ppr fam_tc + , ppr subst + , ppr tvs' + , ppr cvs' + , ppr lhs' + , ppr 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 + lhs_kind = tcTypeKind (mkTyConApp fam_tc lhs) + rhs_kind = tcTypeKind rhs + tcv_set = mkVarSet (tvs ++ cvs) + pp_ax = pprCoAxiom axiom + CoAxBranch { cab_tvs = tvs + , cab_cvs = cvs + , cab_lhs = lhs + , cab_rhs = rhs } = coAxiomSingleBranch axiom + + +{- +************************************************************************ +* * + Optimised overlap checking for family instances +* * +************************************************************************ + +Note [Checking family instance consistency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For any two family instance modules that we import directly or indirectly, we +check whether the instances in the two modules are consistent, *unless* we can +be certain that the instances of the two modules have already been checked for +consistency during the compilation of modules that we import. + +Why do we need to check? Consider + module X1 where module X2 where + data T1 data T2 + type instance F T1 b = Int type instance F a T2 = Char + f1 :: F T1 a -> Int f2 :: Char -> F a T2 + f1 x = x f2 x = x + +Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char. +Notice that neither instance is an orphan. + +How do we know which pairs of modules have already been checked? For each +module M we directly import, we look up the family instance modules that M +imports (directly or indirectly), say F1, ..., FN. For any two modules +among M, F1, ..., FN, we know that the family instances defined in those +two modules are consistent--because we checked that when we compiled M. + +For every other pair of family instance modules we import (directly or +indirectly), we check that they are consistent now. (So that we can be +certain that the modules in our `GHC.Driver.Types.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] +we need to ensure that every pair of transitive imports that define type family +instances is consistent. + +Let's define df(A) = transitive imports of A that define type family instances ++ A, if A defines type family instances + +Then for every direct import A, df(A) is already consistent. + +Let's name the current module M. + +We want to make sure that df(M) is consistent. +df(M) = df(D_1) U df(D_2) U ... U df(D_i) where D_1 .. D_i are direct imports. + +We perform the check iteratively, maintaining a set of consistent modules 'C' +and trying to add df(D_i) to it. + +The key part is how to ensure that the union C U df(D_i) is consistent. + +Let's consider two modules: A and B from C U df(D_i). +There are nine possible ways to choose A and B from C U df(D_i): + + | A in C only | A in C and B in df(D_i) | A in df(D_i) only +-------------------------------------------------------------------------------- +B in C only | Already checked | Already checked | Needs to be checked + | when checking C | when checking C | +-------------------------------------------------------------------------------- +B in C and | Already checked | Already checked | Already checked when +B in df(D_i) | when checking C | when checking C | checking df(D_i) +-------------------------------------------------------------------------------- +B in df(D_i) | Needs to be | Already checked | Already checked when +only | checked | when checking df(D_i) | checking df(D_i) + +That means to ensure that C U df(D_i) is consistent we need to check every +module from C - df(D_i) against every module from df(D_i) - C and +every module from df(D_i) - C against every module from C - df(D_i). +But since the checks are symmetric it suffices to pick A from C - df(D_i) +and B from df(D_i) - C. + +In other words these are the modules we need to check: + [ (m1, m2) | m1 <- C, m1 not in df(D_i) + , m2 <- df(D_i), m2 not in C ] + +One final thing to note here is that if there's lot of overlap between +subsequent df(D_i)'s then we expect those set differences to be small. +That situation should be pretty common in practice, there's usually +a set of utility modules that every module imports directly or indirectly. + +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]. +checkFamInstConsistency :: [Module] -> TcM () +checkFamInstConsistency directlyImpMods + = do { (eps, hpt) <- getEpsAndHpt + ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) + ; let { -- Fetch the iface of a given module. Must succeed as + -- all directly imported modules must already have been loaded. + modIface mod = + case lookupIfaceByModule hpt (eps_PIT eps) mod of + Nothing -> panicDoc "FamInst.checkFamInstConsistency" + (ppr mod $$ pprHPT hpt) + Just iface -> iface + + -- Which family instance modules were checked for consistency + -- when we compiled `mod`? + -- Itself (if a family instance module) and its dep_finsts. + -- This is df(D_i) from + -- Note [Checking family instance optimization] + ; modConsistent :: Module -> [Module] + ; modConsistent mod = + if mi_finsts (mi_final_exts (modIface mod)) then mod:deps else deps + where + deps = dep_finsts . mi_deps . modIface $ mod + + ; hmiModule = mi_module . hm_iface + ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv + . md_fam_insts . hm_details + ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) + | hmi <- eltsHpt hpt] + + } + + ; checkMany hpt_fam_insts modConsistent directlyImpMods + } + where + -- See Note [Checking family instance optimization] + checkMany + :: ModuleEnv FamInstEnv -- home package family instances + -> (Module -> [Module]) -- given A, modules checked when A was checked + -> [Module] -- modules to process + -> TcM () + checkMany hpt_fam_insts modConsistent mods = go [] emptyModuleSet mods + where + go :: [Module] -- list of consistent modules + -> ModuleSet -- set of consistent modules, same elements as the + -- list above + -> [Module] -- modules to process + -> TcM () + go _ _ [] = return () + go consistent consistent_set (mod:mods) = do + sequence_ + [ check hpt_fam_insts m1 m2 + | m1 <- to_check_from_mod + -- loop over toCheckFromMod first, it's usually smaller, + -- it may even be empty + , m2 <- to_check_from_consistent + ] + go consistent' consistent_set' mods + where + mod_deps_consistent = modConsistent mod + mod_deps_consistent_set = mkModuleSet mod_deps_consistent + consistent' = to_check_from_mod ++ consistent + consistent_set' = + extendModuleSetList consistent_set to_check_from_mod + to_check_from_consistent = + filterOut (`elemModuleSet` mod_deps_consistent_set) consistent + to_check_from_mod = + filterOut (`elemModuleSet` consistent_set) mod_deps_consistent + -- Why don't we just minusModuleSet here? + -- We could, but doing so means one of two things: + -- + -- 1. When looping over the cartesian product we convert + -- a set into a non-deterministicly ordered list. Which + -- happens to be fine for interface file determinism + -- in this case, today, because the order only + -- determines the order of deferred checks. But such + -- invariants are hard to keep. + -- + -- 2. When looping over the cartesian product we convert + -- a set into a deterministically ordered list - this + -- adds some additional cost of sorting for every + -- direct import. + -- + -- That also explains why we need to keep both 'consistent' + -- and 'consistentSet'. + -- + -- See also Note [ModuleEnv performance and determinism]. + check hpt_fam_insts m1 m2 + = do { env1' <- getFamInsts hpt_fam_insts m1 + ; env2' <- getFamInsts hpt_fam_insts m2 + -- We're checking each element of env1 against env2. + -- The cost of that is dominated by the size of env1, because + -- for each instance in env1 we look it up in the type family + -- environment env2, and lookup is cheap. + -- The code below ensures that env1 is the smaller environment. + ; let sizeE1 = famInstEnvSize env1' + 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 + } + +getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv +getFamInsts hpt_fam_insts mod + | Just env <- lookupModuleEnv hpt_fam_insts mod = return env + | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod) + ; eps <- getEps + ; return (expectJust "checkFamInstConsistency" $ + lookupModuleEnv (eps_mod_fam_inst_env eps) mod) } + where + doc = ppr mod <+> text "is a family-instance module" + +{- +************************************************************************ +* * + Lookup +* * +************************************************************************ + +-} + +-- | If @co :: T ts ~ rep_ty@ then: +-- +-- > instNewTyCon_maybe T ts = Just (rep_ty, co) +-- +-- Checks for a newtype, and for being saturated +-- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion +tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion) +tcInstNewTyCon_maybe = instNewTyCon_maybe + +-- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if +-- there is no data family to unwrap. +-- Returns a Representational coercion +tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType] + -> (TyCon, [TcType], Coercion) +tcLookupDataFamInst fam_inst_envs tc tc_args + | Just (rep_tc, rep_args, co) + <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args + = (rep_tc, rep_args, co) + | otherwise + = (tc, tc_args, mkRepReflCo (mkTyConApp tc tc_args)) + +tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType] + -> Maybe (TyCon, [TcType], Coercion) +-- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a) +-- and returns a coercion between the two: co :: F [a] ~R FList a. +tcLookupDataFamInst_maybe fam_inst_envs tc tc_args + | isDataFamilyTyCon tc + , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args + , FamInstMatch { fim_instance = rep_fam@(FamInst { fi_axiom = ax + , fi_cvs = cvs }) + , fim_tys = rep_args + , fim_cos = rep_cos } <- match + , let rep_tc = dataFamInstRepTyCon rep_fam + co = mkUnbranchedAxInstCo Representational ax rep_args + (mkCoVarCos cvs) + = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in GHC.Core.FamInstEnv + Just (rep_tc, rep_args, co) + + | otherwise + = Nothing + +-- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes, +-- potentially looking through newtype /instances/. +-- +-- It is only used by the type inference engine (specifically, when +-- solving representational equality), and hence it is careful to unwrap +-- only if the relevant data constructor is in scope. That's why +-- it get a GlobalRdrEnv argument. +-- +-- It is careful not to unwrap data/newtype instances if it can't +-- continue unwrapping. Such care is necessary for proper error +-- messages. +-- +-- It does not look through type families. +-- It does not normalise arguments to a tycon. +-- +-- If the result is Just (rep_ty, (co, gres), rep_ty), then +-- co : ty ~R rep_ty +-- gres are the GREs for the data constructors that +-- had to be in scope +tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs + -> GlobalRdrEnv + -> Type + -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type) +tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty +-- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe + = topNormaliseTypeX stepper plus ty + where + plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion) + -> (Bag GlobalRdrElt, TcCoercion) + plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2 + , co1 `mkTransCo` co2 ) + + stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion) + stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance + + -- For newtype instances we take a double step or nothing, so that + -- we don't return the representation type of the newtype instance, + -- which would lead to terrible error messages + unwrap_newtype_instance rec_nts tc tys + | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys + = mapStepResult (\(gres, co1) -> (gres, co `mkTransCo` co1)) $ + unwrap_newtype rec_nts tc' tys' + | otherwise = NS_Done + + unwrap_newtype rec_nts tc tys + | Just con <- newTyConDataCon_maybe tc + , Just gre <- lookupGRE_Name rdr_env (dataConName con) + -- This is where we check that the + -- data constructor is in scope + = mapStepResult (\co -> (unitBag gre, co)) $ + unwrapNewTypeStepper rec_nts tc tys + + | otherwise + = NS_Done + +{- +************************************************************************ +* * + Extending the family instance environment +* * +************************************************************************ +-} + +-- Add new locally-defined family instances, checking consistency with +-- previous locally-defined family instances as well as all instances +-- available from imported modules. This requires loading all of our +-- imports that define family instances (if we haven't loaded them already). +tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a + +-- If we weren't actually given any instances to add, then we don't want +-- to go to the bother of loading family instance module dependencies. +tcExtendLocalFamInstEnv [] thing_inside = thing_inside + +-- Otherwise proceed... +tcExtendLocalFamInstEnv fam_insts thing_inside + = do { -- Load family-instance modules "below" this module, so that + -- allLocalFamInst can check for consistency with them + -- See Note [The type family instance consistency story] + loadDependentFamInstModules fam_insts + + -- Now add the instances one by one + ; env <- getGblEnv + ; (inst_env', fam_insts') <- foldlM addLocalFamInst + (tcg_fam_inst_env env, tcg_fam_insts env) + fam_insts + + ; let env' = env { tcg_fam_insts = fam_insts' + , tcg_fam_inst_env = inst_env' } + ; setGblEnv env' thing_inside + } + +loadDependentFamInstModules :: [FamInst] -> TcM () +-- Load family-instance modules "below" this module, so that +-- allLocalFamInst can check for consistency with them +-- See Note [The type family instance consistency story] +loadDependentFamInstModules fam_insts + = do { env <- getGblEnv + ; let this_mod = tcg_mod env + imports = tcg_imports env + + want_module mod -- See Note [Home package family instances] + | mod == this_mod = False + | home_fams_only = moduleUnit mod == moduleUnit this_mod + | otherwise = True + home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts + + ; loadModuleInterfaces (text "Loading family-instance modules") $ + filter want_module (imp_finsts imports) } + +{- Note [Home package family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Optimization: If we're only defining type family instances +for type families *defined in the home package*, then we +only have to load interface files that belong to the home +package. The reason is that there's no recursion between +packages, so modules in other packages can't possibly define +instances for our type families. + +(Within the home package, we could import a module M that +imports us via an hs-boot file, and thereby defines an +instance of a type family defined in this module. So we can't +apply the same logic to avoid reading any interface files at +all, when we define an instances for type family defined in +the current module. +-} + +-- Check that the proposed new instance is OK, +-- and then add it to the home inst env +-- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match] +-- in GHC.Core.FamInstEnv +addLocalFamInst :: (FamInstEnv,[FamInst]) + -> FamInst + -> TcM (FamInstEnv, [FamInst]) +addLocalFamInst (home_fie, my_fis) fam_inst + -- home_fie includes home package and this module + -- my_fies is just the ones from this module + = do { traceTc "addLocalFamInst" (ppr fam_inst) + + -- Unlike the case of class instances, don't override existing + -- instances in GHCi; it's unsound. See #7102. + + ; mod <- getModule + ; traceTc "alfi" (ppr mod) + + -- Fetch imported instances, so that we report + -- overlaps correctly. + -- Really we ought to only check consistency with + -- those instances which are transitively imported + -- by the current module, rather than every instance + -- we've ever seen. Fixing this is part of #13102. + ; eps <- getEps + ; let inst_envs = (eps_fam_inst_env eps, home_fie) + home_fie' = extendFamInstEnv home_fie fam_inst + + -- Check for conflicting instance decls and injectivity violations + ; ((), no_errs) <- askNoErrs $ + do { checkForConflicts inst_envs fam_inst + ; checkForInjectivityConflicts inst_envs fam_inst + ; checkInjectiveEquation fam_inst + } + + ; if no_errs then + return (home_fie', fam_inst : my_fis) + else + return (home_fie, my_fis) } + +{- +************************************************************************ +* * + Checking an instance against conflicts with an instance env +* * +************************************************************************ + +Check whether a single family instance conflicts with those in two instance +environments (one for the EPS and one for the HPT). +-} + +-- | Checks to make sure no two family instances overlap. +checkForConflicts :: FamInstEnvs -> FamInst -> TcM () +checkForConflicts inst_envs fam_inst + = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst + ; traceTc "checkForConflicts" $ + vcat [ ppr (map fim_instance conflicts) + , ppr fam_inst + -- , ppr inst_envs + ] + ; reportConflictInstErr fam_inst conflicts } + +checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM () + -- see Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv, check 1B1. +checkForInjectivityConflicts instEnvs famInst + | isTypeFamilyTyCon tycon -- as opposed to data family tycon + , Injective inj <- tyConInjectivityInfo tycon + = let conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst in + reportConflictingInjectivityErrs tycon conflicts (coAxiomSingleBranch (fi_axiom famInst)) + + | otherwise + = return () + + where tycon = famInstTyCon famInst + +-- | Check whether a new open type family equation can be added without +-- violating injectivity annotation supplied by the user. Returns True when +-- this is possible and False if adding this equation would violate injectivity +-- annotation. This looks only at the one equation; it does not look for +-- interaction between equations. Use checkForInjectivityConflicts for that. +-- Does checks (2)-(4) of Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv. +checkInjectiveEquation :: FamInst -> TcM () +checkInjectiveEquation famInst + | isTypeFamilyTyCon tycon + -- type family is injective in at least one argument + , Injective inj <- tyConInjectivityInfo tycon = do + { dflags <- getDynFlags + ; let axiom = coAxiomSingleBranch fi_ax + -- see Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv + ; reportInjectivityErrors dflags fi_ax axiom inj + } + + -- if there was no injectivity annotation or tycon does not represent a + -- type family we report no conflicts + | otherwise + = return () + + where tycon = famInstTyCon famInst + fi_ax = fi_axiom famInst + +-- | Report a list of injectivity errors together with their source locations. +-- Looks only at one equation; does not look for conflicts *among* equations. +reportInjectivityErrors + :: DynFlags + -> CoAxiom br -- ^ Type family for which we generate errors + -> CoAxBranch -- ^ Currently checked equation (represented by axiom) + -> [Bool] -- ^ Injectivity annotation + -> TcM () +reportInjectivityErrors dflags fi_ax axiom inj + = ASSERT2( any id inj, text "No injective type variables" ) + do let lhs = coAxBranchLHS axiom + rhs = coAxBranchRHS axiom + fam_tc = coAxiomTyCon fi_ax + (unused_inj_tvs, unused_vis, undec_inst_flag) + = unusedInjTvsInRHS dflags fam_tc lhs rhs + inj_tvs_unused = not $ isEmptyVarSet unused_inj_tvs + tf_headed = isTFHeaded rhs + bare_variables = bareTvInRHSViolated lhs rhs + wrong_bare_rhs = not $ null bare_variables + + when inj_tvs_unused $ reportUnusedInjectiveVarsErr fam_tc unused_inj_tvs + unused_vis undec_inst_flag axiom + when tf_headed $ reportTfHeadedErr fam_tc axiom + when wrong_bare_rhs $ reportBareVariableInRHSErr fam_tc bare_variables axiom + +-- | Is type headed by a type family application? +isTFHeaded :: Type -> Bool +-- See Note [Verifying injectivity annotation], case 3. +isTFHeaded ty | Just ty' <- coreView ty + = isTFHeaded ty' +isTFHeaded ty | (TyConApp tc args) <- ty + , isTypeFamilyTyCon tc + = args `lengthIs` tyConArity tc +isTFHeaded _ = False + + +-- | If a RHS is a bare type variable return a set of LHS patterns that are not +-- bare type variables. +bareTvInRHSViolated :: [Type] -> Type -> [Type] +-- See Note [Verifying injectivity annotation], case 2. +bareTvInRHSViolated pats rhs | isTyVarTy rhs + = filter (not . isTyVarTy) pats +bareTvInRHSViolated _ _ = [] + +------------------------------------------------------------------ +-- Checking for the coverage condition for injective type families +------------------------------------------------------------------ + +{- +Note [Coverage condition for injective type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Injective Type Families paper describes how we can tell whether +or not a type family equation upholds the injectivity condition. +Briefly, consider the following: + + type family F a b = r | r -> a -- NB: b is not injective + + type instance F ty1 ty2 = ty3 + +We need to make sure that all variables mentioned in ty1 are mentioned in ty3 +-- that's how we know that knowing ty3 determines ty1. But they can't be +mentioned just anywhere in ty3: they must be in *injective* positions in ty3. +For example: + + type instance F a Int = Maybe (G a) + +This is no good, if G is not injective. However, if G is indeed injective, +then this would appear to meet our needs. There is a trap here, though: while +knowing G a does indeed determine a, trying to compute a from G a might not +terminate. This is precisely the same problem that we have with functional +dependencies and their liberal coverage condition. Here is the test case: + + type family G a = r | r -> a + type instance G [a] = [G a] + [W] G alpha ~ [alpha] + +We see that the equation given applies, because G alpha equals a list. So we +learn that alpha must be [beta] for some beta. We then have + + [W] G [beta] ~ [[beta]] + +This can reduce to + + [W] [G beta] ~ [[beta]] + +which then decomposes to + + [W] G beta ~ [beta] + +right where we started. The equation G [a] = [G a] thus is dangerous: while +it does not violate the injectivity assumption, it might throw us into a loop, +with a particularly dastardly Wanted. + +We thus do what functional dependencies do: require -XUndecidableInstances to +accept this. + +Checking the coverage condition is not terribly hard, but we also want to produce +a nice error message. A nice error message has at least two properties: + +1. If any of the variables involved are invisible or are used in an invisible context, +we want to print invisible arguments (as -fprint-explicit-kinds does). + +2. If we fail to accept the equation because we're worried about non-termination, +we want to suggest UndecidableInstances. + +To gather the right information, we can talk about the *usage* of a variable. Every +variable is used either visibly or invisibly, and it is either not used at all, +in a context where acceptance requires UndecidableInstances, or in a context that +does not require UndecidableInstances. If a variable is used both visibly and +invisibly, then we want to remember the fact that it was used invisibly: printing +out invisibles will be helpful for the user to understand what is going on. +If a variable is used where we need -XUndecidableInstances and where we don't, +we can similarly just remember the latter. + +We thus define Visibility and NeedsUndecInstFlag below. These enumerations are +*ordered*, and we used their Ord instances. We then define VarUsage, which is just a pair +of a Visibility and a NeedsUndecInstFlag. (The visibility is irrelevant when a +variable is NotPresent, but this extra slack in the representation causes no +harm.) We finally define VarUsages as a mapping from variables to VarUsage. +Its Monoid instance combines two maps, using the Semigroup instance of VarUsage +to combine elements that are represented in both maps. In this way, we can +compositionally analyze types (and portions thereof). + +To do the injectivity check: + +1. We build VarUsages that represent the LHS (rather, the portion of the LHS +that is flagged as injective); each usage on the LHS is NotPresent, because we +have not yet looked at the RHS. + +2. We also build a VarUsage for the RHS, done by injTyVarUsages. + +3. We then combine these maps. Now, every variable in the injective components of the LHS +will be mapped to its correct usage (either NotPresent or perhaps needing +-XUndecidableInstances in order to be seen as injective). + +4. We look up each var used in an injective argument on the LHS in +the map, making a list of tvs that should be determined by the RHS +but aren't. + +5. We then return the set of bad variables, whether any of the bad +ones were used invisibly, and whether any bad ones need -XUndecidableInstances. +If -XUndecidableInstances is enabled, than a var that needs the flag +won't be bad, so it won't appear in this list. + +6. We use all this information to produce a nice error message, (a) switching +on -fprint-explicit-kinds if appropriate and (b) telling the user about +-XUndecidableInstances if appropriate. + +-} + +-- | Return the set of type variables that a type family equation is +-- expected to be injective in but is not. Suppose we have @type family +-- F a b = r | r -> a@. Then any variables that appear free in the first +-- argument to F in an equation must be fixed by that equation's RHS. +-- This function returns all such variables that are not indeed fixed. +-- It also returns whether any of these variables appear invisibly +-- and whether -XUndecidableInstances would help. +-- See Note [Coverage condition for injective type families]. +unusedInjTvsInRHS :: DynFlags + -> TyCon -- type family + -> [Type] -- LHS arguments + -> Type -- the RHS + -> ( TyVarSet + , Bool -- True <=> one or more variable is used invisibly + , Bool ) -- True <=> suggest -XUndecidableInstances +-- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv. +-- This function implements check (4) described there, further +-- described in Note [Coverage condition for injective type families]. +-- In theory (and modulo the -XUndecidableInstances wrinkle), +-- instead of implementing this whole check in this way, we could +-- attempt to unify equation with itself. We would reject exactly the same +-- equations but this method gives us more precise error messages by returning +-- precise names of variables that are not mentioned in the RHS. +unusedInjTvsInRHS dflags tycon@(tyConInjectivityInfo -> Injective inj_list) lhs rhs = + -- Note [Coverage condition for injective type families], step 5 + (bad_vars, any_invisible, suggest_undec) + where + undec_inst = xopt LangExt.UndecidableInstances dflags + + inj_lhs = filterByList inj_list lhs + lhs_vars = tyCoVarsOfTypes inj_lhs + + rhs_inj_vars = fvVarSet $ injectiveVarsOfType undec_inst rhs + + bad_vars = lhs_vars `minusVarSet` rhs_inj_vars + + any_bad = not $ isEmptyVarSet bad_vars + + invis_vars = fvVarSet $ invisibleVarsOfTypes [mkTyConApp tycon lhs, rhs] + + any_invisible = any_bad && (bad_vars `intersectsVarSet` invis_vars) + suggest_undec = any_bad && + not undec_inst && + (lhs_vars `subVarSet` fvVarSet (injectiveVarsOfType True rhs)) + +-- When the type family is not injective in any arguments +unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, False, False) + +--------------------------------------- +-- Producing injectivity error messages +--------------------------------------- + +-- | Report error message for a pair of equations violating an injectivity +-- annotation. No error message if there are no branches. +reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM () +reportConflictingInjectivityErrs _ [] _ = return () +reportConflictingInjectivityErrs fam_tc (confEqn1:_) tyfamEqn + = addErrs [buildInjectivityError fam_tc herald (confEqn1 :| [tyfamEqn])] + where + herald = text "Type family equation right-hand sides overlap; this violates" $$ + text "the family's injectivity annotation:" + +-- | Injectivity error herald common to all injectivity errors. +injectivityErrorHerald :: SDoc +injectivityErrorHerald = + text "Type family equation violates the family's injectivity annotation." + + +-- | Report error message for equation with injective type variables unused in +-- the RHS. Note [Coverage condition for injective type families], step 6 +reportUnusedInjectiveVarsErr :: TyCon + -> TyVarSet + -> Bool -- True <=> print invisible arguments + -> Bool -- True <=> suggest -XUndecidableInstances + -> CoAxBranch + -> TcM () +reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn + = let (loc, doc) = buildInjectivityError fam_tc + (injectivityErrorHerald $$ + herald $$ + text "In the type family equation:") + (tyfamEqn :| []) + in addErrAt loc (pprWithExplicitKindsWhen has_kinds doc) + where + herald = sep [ what <+> text "variable" <> + pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort) + , text "cannot be inferred from the right-hand side." ] + $$ extra + + what | has_kinds = text "Type/kind" + | otherwise = text "Type" + + extra | undec_inst = text "Using UndecidableInstances might help" + | otherwise = empty + +-- | Report error message for equation that has a type family call at the top +-- level of RHS +reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM () +reportTfHeadedErr fam_tc branch + = addErrs [buildInjectivityError fam_tc + (injectivityErrorHerald $$ + text "RHS of injective type family equation cannot" <+> + text "be a type family:") + (branch :| [])] + +-- | Report error message for equation that has a bare type variable in the RHS +-- but LHS pattern is not a bare type variable. +reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM () +reportBareVariableInRHSErr fam_tc tys branch + = addErrs [buildInjectivityError fam_tc + (injectivityErrorHerald $$ + text "RHS of injective type family equation is a bare" <+> + text "type variable" $$ + text "but these LHS type and kind patterns are not bare" <+> + text "variables:" <+> pprQuotedList tys) + (branch :| [])] + +buildInjectivityError :: TyCon -> SDoc -> NonEmpty CoAxBranch -> (SrcSpan, SDoc) +buildInjectivityError fam_tc herald (eqn1 :| rest_eqns) + = ( coAxBranchSpan eqn1 + , hang herald + 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) ) + +reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () +reportConflictInstErr _ [] + = return () -- No conflicts +reportConflictInstErr fam_inst (match1 : _) + | FamInstMatch { fim_instance = conf_inst } <- match1 + , let sorted = sortBy (SrcLoc.leftmost_smallest `on` getSpan) [fam_inst, conf_inst] + fi1 = head sorted + span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) + = setSrcSpan span $ addErr $ + hang (text "Conflicting family instance declarations:") + 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax) + | fi <- sorted + , let ax = famInstAxiom fi ]) + where + getSpan = getSrcSpan . famInstAxiom + -- The sortBy just arranges that instances are displayed in order + -- of source location, which reduced wobbling in error messages, + -- and is better for users + +tcGetFamInstEnvs :: TcM FamInstEnvs +-- Gets both the external-package inst-env +-- and the home-pkg inst env (includes module being compiled) +tcGetFamInstEnvs + = do { eps <- getEps; env <- getGblEnv + ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) } diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -0,0 +1,682 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 2000 + + +-} + +{-# LANGUAGE CPP #-} + +-- | Functional dependencies +-- +-- It's better to read it as: "if we know these, then we're going to know these" +module GHC.Tc.Instance.FunDeps + ( FunDepEqn(..) + , pprEquation + , improveFromInstEnv + , improveFromAnother + , checkInstCoverage + , checkFunDeps + , pprFundeps + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Name +import GHC.Types.Var +import GHC.Core.Class +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Tc.Utils.TcType( transSuperClasses ) +import GHC.Core.Coercion.Axiom( TypeEqn ) +import GHC.Core.Unify +import GHC.Core.InstEnv +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr( pprWithExplicitKindsWhen ) +import GHC.Utils.FV +import GHC.Utils.Outputable +import GHC.Utils.Error( Validity(..), allValid ) +import GHC.Types.SrcLoc +import GHC.Utils.Misc + +import GHC.Data.Pair ( Pair(..) ) +import Data.List ( nubBy ) +import Data.Maybe +import Data.Foldable ( fold ) + +{- +************************************************************************ +* * +\subsection{Generate equations from functional dependencies} +* * +************************************************************************ + + +Each functional dependency with one variable in the RHS is responsible +for generating a single equality. For instance: + class C a b | a -> b +The constraints ([Wanted] C Int Bool) and [Wanted] C Int alpha +will generate the following FunDepEqn + FDEqn { fd_qtvs = [] + , fd_eqs = [Pair Bool alpha] + , fd_pred1 = C Int Bool + , fd_pred2 = C Int alpha + , fd_loc = ... } +However notice that a functional dependency may have more than one variable +in the RHS which will create more than one pair of types in fd_eqs. Example: + class C a b c | a -> b c + [Wanted] C Int alpha alpha + [Wanted] C Int Bool beta +Will generate: + FDEqn { fd_qtvs = [] + , fd_eqs = [Pair Bool alpha, Pair alpha beta] + , fd_pred1 = C Int Bool + , fd_pred2 = C Int alpha + , fd_loc = ... } + +INVARIANT: Corresponding types aren't already equal +That is, there exists at least one non-identity equality in FDEqs. + +Assume: + class C a b c | a -> b c + instance C Int x x +And: [Wanted] C Int Bool alpha +We will /match/ the LHS of fundep equations, producing a matching substitution +and create equations for the RHS sides. In our last example we'd have generated: + ({x}, [fd1,fd2]) +where + fd1 = FDEq 1 Bool x + fd2 = FDEq 2 alpha x +To ``execute'' the equation, make fresh type variable for each tyvar in the set, +instantiate the two types with these fresh variables, and then unify or generate +a new constraint. In the above example we would generate a new unification +variable 'beta' for x and produce the following constraints: + [Wanted] (Bool ~ beta) + [Wanted] (alpha ~ beta) + +Notice the subtle difference between the above class declaration and: + class C a b c | a -> b, a -> c +where we would generate: + ({x},[fd1]),({x},[fd2]) +This means that the template variable would be instantiated to different +unification variables when producing the FD constraints. + +Finally, the position parameters will help us rewrite the wanted constraint ``on the spot'' +-} + +data FunDepEqn loc + = FDEqn { fd_qtvs :: [TyVar] -- Instantiate these type and kind vars + -- to fresh unification vars, + -- Non-empty only for FunDepEqns arising from instance decls + + , fd_eqs :: [TypeEqn] -- Make these pairs of types equal + , fd_pred1 :: PredType -- The FunDepEqn arose from + , fd_pred2 :: PredType -- combining these two constraints + , fd_loc :: loc } + +{- +Given a bunch of predicates that must hold, such as + + C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5 + +improve figures out what extra equations must hold. +For example, if we have + + class C a b | a->b where ... + +then improve will return + + [(t1,t2), (t4,t5)] + +NOTA BENE: + + * improve does not iterate. It's possible that when we make + t1=t2, for example, that will in turn trigger a new equation. + This would happen if we also had + C t1 t7, C t2 t8 + If t1=t2, we also get t7=t8. + + improve does *not* do this extra step. It relies on the caller + doing so. + + * The equations unify types that are not already equal. So there + is no effect iff the result of improve is empty +-} + +instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type +-- (instFD fd tvs tys) returns fd instantiated with (tvs -> tys) +instFD (ls,rs) tvs tys + = (map lookup ls, map lookup rs) + where + env = zipVarEnv tvs tys + lookup tv = lookupVarEnv_NF env tv + +zipAndComputeFDEqs :: (Type -> Type -> Bool) -- Discard this FDEq if true + -> [Type] -> [Type] + -> [TypeEqn] +-- Create a list of (Type,Type) pairs from two lists of types, +-- making sure that the types are not already equal +zipAndComputeFDEqs discard (ty1:tys1) (ty2:tys2) + | discard ty1 ty2 = zipAndComputeFDEqs discard tys1 tys2 + | otherwise = Pair ty1 ty2 : zipAndComputeFDEqs discard tys1 tys2 +zipAndComputeFDEqs _ _ _ = [] + +-- Improve a class constraint from another class constraint +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +improveFromAnother :: loc + -> PredType -- Template item (usually given, or inert) + -> PredType -- Workitem [that can be improved] + -> [FunDepEqn loc] +-- Post: FDEqs always oriented from the other to the workitem +-- Equations have empty quantified variables +improveFromAnother loc pred1 pred2 + | Just (cls1, tys1) <- getClassPredTys_maybe pred1 + , Just (cls2, tys2) <- getClassPredTys_maybe pred2 + , cls1 == cls2 + = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2, fd_loc = loc } + | let (cls_tvs, cls_fds) = classTvsFds cls1 + , fd <- cls_fds + , let (ltys1, rs1) = instFD fd cls_tvs tys1 + (ltys2, rs2) = instFD fd cls_tvs tys2 + , eqTypes ltys1 ltys2 -- The LHSs match + , let eqs = zipAndComputeFDEqs eqType rs1 rs2 + , not (null eqs) ] + +improveFromAnother _ _ _ = [] + + +-- Improve a class constraint from instance declarations +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +instance Outputable (FunDepEqn a) where + ppr = pprEquation + +pprEquation :: FunDepEqn a -> SDoc +pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) + = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs), + nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2 + | Pair t1 t2 <- pairs])] + +improveFromInstEnv :: InstEnvs + -> (PredType -> SrcSpan -> loc) + -> PredType + -> [FunDepEqn loc] -- Needs to be a FunDepEqn because + -- of quantified variables +-- Post: Equations oriented from the template (matching instance) to the workitem! +improveFromInstEnv inst_env mk_loc pred + | Just (cls, tys) <- ASSERT2( isClassPred pred, ppr pred ) + getClassPredTys_maybe pred + , let (cls_tvs, cls_fds) = classTvsFds cls + instances = classInstances inst_env cls + rough_tcs = roughMatchTcs tys + = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs + , fd_pred1 = p_inst, fd_pred2 = pred + , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) } + | fd <- cls_fds -- Iterate through the fundeps first, + -- because there often are none! + , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs + -- Trim the rough_tcs based on the head of the fundep. + -- Remember that instanceCantMatch treats both arguments + -- symmetrically, so it's ok to trim the rough_tcs, + -- rather than trimming each inst_tcs in turn + , ispec <- instances + , (meta_tvs, eqs) <- improveClsFD cls_tvs fd ispec + tys trimmed_tcs -- NB: orientation + , let p_inst = mkClassPred cls (is_tys ispec) + ] +improveFromInstEnv _ _ _ = [] + + +improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class + -> ClsInst -- An instance template + -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate + -> [([TyCoVar], [TypeEqn])] -- Empty or singleton + +improveClsFD clas_tvs fd + (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst }) + tys_actual rough_tcs_actual + +-- Compare instance {a,b} C sx sp sy sq +-- with wanted [W] C tx tp ty tq +-- for fundep (x,y -> p,q) from class (C x p y q) +-- If (sx,sy) unifies with (tx,ty), take the subst S + +-- 'qtvs' are the quantified type variables, the ones which can be instantiated +-- to make the types match. For example, given +-- class C a b | a->b where ... +-- instance C (Maybe x) (Tree x) where .. +-- +-- and a wanted constraint of form (C (Maybe t1) t2), +-- then we will call checkClsFD with +-- +-- is_qtvs = {x}, is_tys = [Maybe x, Tree x] +-- tys_actual = [Maybe t1, t2] +-- +-- We can instantiate x to t1, and then we want to force +-- (Tree x) [t1/x] ~ t2 + + | instanceCantMatch rough_tcs_inst rough_tcs_actual + = [] -- Filter out ones that can't possibly match, + + | otherwise + = ASSERT2( equalLength tys_inst tys_actual && + equalLength tys_inst clas_tvs + , ppr tys_inst <+> ppr tys_actual ) + + case tcMatchTyKis ltys1 ltys2 of + Nothing -> [] + Just subst | isJust (tcMatchTyKisX subst rtys1 rtys2) + -- Don't include any equations that already hold. + -- Reason: then we know if any actual improvement has happened, + -- in which case we need to iterate the solver + -- In making this check we must taking account of the fact that any + -- qtvs that aren't already instantiated can be instantiated to anything + -- at all + -- NB: We can't do this 'is-useful-equation' check element-wise + -- because of: + -- class C a b c | a -> b c + -- instance C Int x x + -- [Wanted] C Int alpha Int + -- We would get that x -> alpha (isJust) and x -> Int (isJust) + -- so we would produce no FDs, which is clearly wrong. + -> [] + + | null fdeqs + -> [] + + | otherwise + -> -- pprTrace "iproveClsFD" (vcat + -- [ text "is_tvs =" <+> ppr qtvs + -- , text "tys_inst =" <+> ppr tys_inst + -- , text "tys_actual =" <+> ppr tys_actual + -- , text "ltys1 =" <+> ppr ltys1 + -- , text "ltys2 =" <+> ppr ltys2 + -- , text "subst =" <+> ppr subst ]) $ + [(meta_tvs, fdeqs)] + -- We could avoid this substTy stuff by producing the eqn + -- (qtvs, ls1++rs1, ls2++rs2) + -- which will re-do the ls1/ls2 unification when the equation is + -- executed. What we're doing instead is recording the partial + -- work of the ls1/ls2 unification leaving a smaller unification problem + where + rtys1' = map (substTyUnchecked subst) rtys1 + + fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2 + -- Don't discard anything! + -- We could discard equal types but it's an overkill to call + -- eqType again, since we know for sure that /at least one/ + -- equation in there is useful) + + meta_tvs = [ setVarType tv (substTyUnchecked subst (varType tv)) + | tv <- qtvs, tv `notElemTCvSubst` subst ] + -- meta_tvs are the quantified type variables + -- that have not been substituted out + -- + -- Eg. class C a b | a -> b + -- instance C Int [y] + -- Given constraint C Int z + -- we generate the equation + -- ({y}, [y], z) + -- + -- But note (a) we get them from the dfun_id, so they are *in order* + -- because the kind variables may be mentioned in the + -- type variables' kinds + -- (b) we must apply 'subst' to the kinds, in case we have + -- matched out a kind variable, but not a type variable + -- whose kind mentions that kind variable! + -- #6015, #6068 + where + (ltys1, rtys1) = instFD fd clas_tvs tys_inst + (ltys2, rtys2) = instFD fd clas_tvs tys_actual + +{- +%************************************************************************ +%* * + The Coverage condition for instance declarations +* * +************************************************************************ + +Note [Coverage condition] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Example + class C a b | a -> b + instance theta => C t1 t2 + +For the coverage condition, we check + (normal) fv(t2) `subset` fv(t1) + (liberal) fv(t2) `subset` oclose(fv(t1), theta) + +The liberal version ensures the self-consistency of the instance, but +it does not guarantee termination. Example: + + class Mul a b c | a b -> c where + (.*.) :: a -> b -> c + + instance Mul Int Int Int where (.*.) = (*) + instance Mul Int Float Float where x .*. y = fromIntegral x * y + instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v + +In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]). +But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) ) + +But it is a mistake to accept the instance because then this defn: + f = \ b x y -> if b then x .*. [y] else y +makes instance inference go into a loop, because it requires the constraint + Mul a [b] b +-} + +checkInstCoverage :: Bool -- Be liberal + -> Class -> [PredType] -> [Type] + -> Validity +-- "be_liberal" flag says whether to use "liberal" coverage of +-- See Note [Coverage Condition] below +-- +-- Return values +-- Nothing => no problems +-- Just msg => coverage problem described by msg + +checkInstCoverage be_liberal clas theta inst_taus + = allValid (map fundep_ok fds) + where + (tyvars, fds) = classTvsFds clas + fundep_ok fd + | and (isEmptyVarSet <$> undetermined_tvs) = IsValid + | otherwise = NotValid msg + where + (ls,rs) = instFD fd tyvars inst_taus + ls_tvs = tyCoVarsOfTypes ls + rs_tvs = splitVisVarsOfTypes rs + + undetermined_tvs | be_liberal = liberal_undet_tvs + | otherwise = conserv_undet_tvs + + closed_ls_tvs = oclose theta ls_tvs + liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs + conserv_undet_tvs = (`minusVarSet` ls_tvs) <$> rs_tvs + + undet_set = fold undetermined_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 "oclose" <+> ppr (oclose 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a fundep (a::k) -> b +Then if 'a' is instantiated to (x y), where x:k2->*, y:k2, +then fixing x really fixes k2 as well, and so k2 should be added to +the lhs tyvars in the fundep check. + +Example (#8391), using liberal coverage + data Foo a = ... -- Foo :: forall k. k -> * + class Bar a b | a -> b + instance Bar a (Foo a) + + In the instance decl, (a:k) does fix (Foo k a), but only if we notice + that (a:k) fixes k. #10109 is another example. + +Here is a more subtle example, from HList-0.4.0.0 (#10564) + + class HasFieldM (l :: k) r (v :: Maybe *) + | l r -> v where ... + class HasFieldM1 (b :: Maybe [*]) (l :: k) r v + | b l r -> v where ... + class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) + | e1 l -> r + + data Label :: k -> * + type family LabelsOf (a :: [*]) :: * + + instance (HMemberM (Label {k} (l::k)) (LabelsOf xs) b, + HasFieldM1 b l (r xs) v) + => HasFieldM l (r xs) v where + +Is the instance OK? Does {l,r,xs} determine v? Well: + + * From the instance constraint HMemberM (Label k l) (LabelsOf xs) b, + plus the fundep "| el l -> r" in class HMameberM, + we get {l,k,xs} -> b + + * Note the 'k'!! We must call closeOverKinds on the seed set + ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b + fundep won't fire. This was the reason for #10564. + + * So starting from seeds {l,r,xs,k} we do oclose to get + first {l,r,xs,k,b}, via the HMemberM constraint, and then + {l,r,xs,k,b,v}, via the HasFieldM1 constraint. + + * And that fixes v. + +However, we must closeOverKinds whenever augmenting the seed set +in oclose! Consider #10109: + + data Succ a -- Succ :: forall k. k -> * + class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab + instance (Add a b ab) => Add (Succ {k1} (a :: k1)) + b + (Succ {k3} (ab :: k3}) + +We start with seed set {a:k1,b:k2} and closeOverKinds to {a,k1,b,k2}. +Now use the fundep to extend to {a,k1,b,k2,ab}. But we need to +closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all +the variables free in (Succ {k3} ab). + +Bottom line: + * closeOverKinds on initial seeds (done automatically + by tyCoVarsOfTypes in checkInstCoverage) + * and closeOverKinds whenever extending those seeds (in oclose) + +Note [The liberal coverage condition] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(oclose preds tvs) closes the set of type variables tvs, +wrt functional dependencies in preds. The result is a superset +of the argument set. For example, if we have + class C a b | a->b where ... +then + oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z} +because if we know x and y then that fixes z. + +We also use equality predicates in the predicates; if we have an +assumption `t1 ~ t2`, then we use the fact that if we know `t1` we +also know `t2` and the other way. + eg oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x} + +oclose is used (only) when checking the coverage condition for +an instance declaration + +Note [Equality superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + class (a ~ [b]) => C a b + +Remember from Note [The equality types story] in GHC.Builtin.Types.Prim, that + * (a ~~ b) is a superclass of (a ~ b) + * (a ~# b) is a superclass of (a ~~ b) + +So when oclose expands superclasses we'll get a (a ~# [b]) superclass. +But that's an EqPred not a ClassPred, and we jolly well do want to +account for the mutual functional dependencies implied by (t1 ~# t2). +Hence the EqPred handling in oclose. See #10778. + +Note [Care with type functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#12803) + class C x y | x -> y + type family F a b + type family G c d = r | r -> d + +Now consider + oclose (C (F a b) (G c d)) {a,b} + +Knowing {a,b} fixes (F a b) regardless of the injectivity of F. +But knowing (G c d) fixes only {d}, because G is only injective +in its second parameter. + +Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds. +-} + +oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet +-- See Note [The liberal coverage condition] +oclose preds fixed_tvs + | null tv_fds = fixed_tvs -- Fast escape hatch for common case. + | otherwise = fixVarSet extend fixed_tvs + where + extend fixed_tvs = foldl' add fixed_tvs tv_fds + where + add fixed_tvs (ls,rs) + | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs + | otherwise = fixed_tvs + -- closeOverKinds: see Note [Closing over kinds in coverage] + + tv_fds :: [(TyCoVarSet,TyCoVarSet)] + tv_fds = [ (tyCoVarsOfTypes ls, fvVarSet $ injectiveVarsOfTypes True rs) + -- See Note [Care with type functions] + | pred <- preds + , pred' <- pred : transSuperClasses pred + -- Look for fundeps in superclasses too + , (ls, rs) <- determined pred' ] + + determined :: PredType -> [([Type],[Type])] + determined pred + = case classifyPredType pred of + EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])] + -- See Note [Equality superclasses] + ClassPred cls tys -> [ instFD fd cls_tvs tys + | let (cls_tvs, cls_fds) = classTvsFds cls + , fd <- cls_fds ] + _ -> [] + + +{- ********************************************************************* +* * + Check that a new instance decl is OK wrt fundeps +* * +************************************************************************ + +Here is the bad case: + class C a b | a->b where ... + instance C Int Bool where ... + instance C Int Char where ... + +The point is that a->b, so Int in the first parameter must uniquely +determine the second. In general, given the same class decl, and given + + instance C s1 s2 where ... + instance C t1 t2 where ... + +Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2). + +Matters are a little more complicated if there are free variables in +the s2/t2. + + class D a b c | a -> b + instance D a b => D [(a,a)] [b] Int + instance D a b => D [a] [b] Bool + +The instance decls don't overlap, because the third parameter keeps +them separate. But we want to make sure that given any constraint + D s1 s2 s3 +if s1 matches + +Note [Bogus consistency check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In checkFunDeps we check that a new ClsInst is consistent with all the +ClsInsts in the environment. + +The bogus aspect is discussed in #10675. Currently it if the two +types are *contradicatory*, using (isNothing . tcUnifyTys). But all +the papers say we should check if the two types are *equal* thus + not (substTys subst rtys1 `eqTypes` substTys subst rtys2) +For now I'm leaving the bogus form because that's the way it has +been for years. +-} + +checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst] +-- The Consistency Check. +-- Check whether adding DFunId would break functional-dependency constraints +-- Used only for instance decls defined in the module being compiled +-- Returns a list of the ClsInst in InstEnvs that are inconsistent +-- with the proposed new ClsInst +checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls + , is_tys = tys1, is_tcs = rough_tcs1 }) + | null fds + = [] + | otherwise + = nubBy eq_inst $ + [ ispec | ispec <- cls_insts + , fd <- fds + , is_inconsistent fd ispec ] + where + cls_insts = classInstances inst_envs cls + (cls_tvs, fds) = classTvsFds cls + qtv_set1 = mkVarSet qtvs1 + + is_inconsistent fd (ClsInst { is_tvs = qtvs2, is_tys = tys2, is_tcs = rough_tcs2 }) + | instanceCantMatch trimmed_tcs rough_tcs2 + = False + | otherwise + = case tcUnifyTyKis bind_fn ltys1 ltys2 of + Nothing -> False + Just subst + -> isNothing $ -- Bogus legacy test (#10675) + -- See Note [Bogus consistency check] + tcUnifyTyKis bind_fn (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2) + + where + trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs1 + (ltys1, rtys1) = instFD fd cls_tvs tys1 + (ltys2, rtys2) = instFD fd cls_tvs tys2 + qtv_set2 = mkVarSet qtvs2 + bind_fn tv | tv `elemVarSet` qtv_set1 = BindMe + | tv `elemVarSet` qtv_set2 = BindMe + | otherwise = Skolem + + eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2 + -- A single instance may appear twice in the un-nubbed conflict list + -- because it may conflict with more than one fundep. E.g. + -- class C a b c | a -> b, a -> c + -- instance C Int Bool Bool + -- instance C Int Char Char + -- The second instance conflicts with the first by *both* fundeps + +trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name] +-- Computing rough_tcs for a particular fundep +-- class C a b c | a -> b where ... +-- For each instance .... => C ta tb tc +-- we want to match only on the type ta; so our +-- rough-match thing must similarly be filtered. +-- Hence, we Nothing-ise the tb and tc types right here +-- +-- Result list is same length as input list, just with more Nothings +trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs + = zipWith select clas_tvs mb_tcs + where + select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc + | otherwise = Nothing diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -0,0 +1,760 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Platform + +import GHC.Types.Basic ( Boxity(..), neverInlinePragma, SourceText(..) ) +import GHC.Iface.Env( newGlobalBinder ) +import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Evidence ( mkWpTyApps ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Driver.Types ( lookupId ) +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim ( primTyCons ) +import GHC.Builtin.Types + ( tupleTyCon, sumTyCon, runtimeRepTyCon + , vecCountTyCon, vecElemTyCon + , nilDataCon, consDataCon ) +import GHC.Types.Name +import GHC.Types.Id +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Unit.Module +import GHC.Hs +import GHC.Driver.Session +import GHC.Data.Bag +import GHC.Types.Var ( VarBndr(..) ) +import GHC.Core.Map +import GHC.Settings.Constants +import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) +import GHC.Utils.Outputable +import GHC.Data.FastString ( FastString, mkFastString, fsLit ) + +import Control.Monad.Trans.State +import Control.Monad.Trans.Class (lift) +import Data.Maybe ( isJust ) +import Data.Word( Word64 ) + +{- Note [Grand plan for Typeable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The overall plan is this: + +1. Generate a binding for each module p:M + (done in GHC.Tc.Instance.Typeable by mkModIdBindings) + M.$trModule :: GHC.Unit.Module + M.$trModule = Module "p" "M" + ("tr" is short for "type representation"; see GHC.Types) + + We might want to add the filename too. + This can be used for the lightweight stack-tracing stuff too + + Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv + +2. Generate a binding for every data type declaration T in module M, + M.$tcT :: GHC.Types.TyCon + M.$tcT = TyCon ...fingerprint info... + $trModule + "T" + 0# + kind_rep + + Here 0# is the number of arguments expected by the tycon to fully determine + its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a + recipe for computing the kind of an instantiation of the tycon (see + Note [Representing TyCon kinds: KindRep] later in this file for details). + + We define (in GHC.Core.TyCon) + + type TyConRepName = Name + + to use for these M.$tcT "tycon rep names". Note that these must be + treated as "never exported" names by Backpack (see + Note [Handling never-exported TyThings under Backpack]). Consequently + they get slightly special treatment in GHC.Iface.Rename.rnIfaceDecl. + +3. Record the TyConRepName in T's TyCon, including for promoted + data and type constructors, and kinds like * and #. + + The TyConRepName is not an "implicit Id". It's more like a record + selector: the TyCon knows its name but you have to go to the + 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). + +There are many wrinkles: + +* The timing of when we produce this bindings is rather important: they must be + defined after the rest of the module has been typechecked since we need to be + able to lookup Module and TyCon in the type environment and we may be + currently compiling GHC.Types (where they are defined). + +* GHC.Prim doesn't have any associated object code, so we need to put the + representations for types defined in this module elsewhere. We chose this + place to be GHC.Types. GHC.Tc.Instance.Typeable.mkPrimTypeableBinds is responsible for + injecting the bindings for the GHC.Prim representions when compiling + GHC.Types. + +* TyCon.tyConRepModOcc is responsible for determining where to find + the representation binding for a given type. This is where we handle + the special case for GHC.Prim. + +* To save space and reduce dependencies, we need use quite low-level + representations for TyCon and Module. See GHC.Types + Note [Runtime representation of modules and tycons] + +* The KindReps can unfortunately get quite large. Moreover, the simplifier will + float out various pieces of them, resulting in numerous top-level bindings. + Consequently we mark the KindRep bindings as noinline, ensuring that the + float-outs don't make it into the interface file. This is important since + there is generally little benefit to inlining KindReps and they would + otherwise strongly affect compiler performance. + +* In general there are lots of things of kind *, * -> *, and * -> * -> *. To + reduce the number of bindings we need to produce, we generate their KindReps + once in GHC.Types. These are referred to as "built-in" KindReps below. + +* Even though KindReps aren't inlined, this scheme still has more of an effect on + compilation time than I'd like. This is especially true in the case of + families of type constructors (e.g. tuples and unboxed sums). The problem is + particularly bad in the case of sums, since each arity-N tycon brings with it + N promoted datacons, each with a KindRep whose size also scales with N. + Consequently we currently simply don't allow sums to be Typeable. + + In general we might consider moving some or all of this generation logic back + to the solver since the performance hit we take in doing this at + type-definition time is non-trivial and Typeable isn't very widely used. This + is discussed in #13261. + +-} + +-- | Generate the Typeable bindings for a module. This is the only +-- entry-point of this module and is invoked by the typechecker driver in +-- 'tcRnSrcDecls'. +-- +-- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable. +mkTypeableBinds :: TcM TcGblEnv +mkTypeableBinds + = do { dflags <- getDynFlags + ; if gopt Opt_NoTypeableBinds dflags then getGblEnv else do + { -- Create a binding for $trModule. + -- Do this before processing any data type declarations, + -- which need tcg_tr_module to be initialised + ; tcg_env <- mkModIdBindings + -- Now we can generate the TyCon representations... + -- First we handle the primitive TyCons if we are compiling GHC.Types + ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos + + -- Then we produce bindings for the user-defined types in this module. + ; setGblEnv tcg_env $ + do { mod <- getModule + ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env) + mod_id = case tcg_tr_module tcg_env of -- Should be set by now + Just mod_id -> mod_id + Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons) + ; traceTc "mkTypeableBinds" (ppr tycons) + ; this_mod_todos <- todoForTyCons mod mod_id tycons + ; mkTypeRepTodoBinds (this_mod_todos : prim_todos) + } } } + where + needs_typeable_binds tc + | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon] + = False + | otherwise = + isAlgTyCon tc + || isDataFamilyTyCon tc + || isClassTyCon tc + + +{- ********************************************************************* +* * + Building top-level binding for $trModule +* * +********************************************************************* -} + +mkModIdBindings :: TcM TcGblEnv +mkModIdBindings + = do { mod <- getModule + ; loc <- getSrcSpanM + ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc + ; trModuleTyCon <- tcLookupTyCon trModuleTyConName + ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon []) + ; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod + + ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv + ; return (tcg_env { tcg_tr_module = Just mod_id } + `addTypecheckedBinds` [unitBag mod_bind]) } + +mkModIdRHS :: Module -> TcM (LHsExpr GhcTc) +mkModIdRHS mod + = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName + ; trNameLit <- mkTrNameLit + ; return $ nlHsDataCon trModuleDataCon + `nlHsApp` trNameLit (unitFS (moduleUnit mod)) + `nlHsApp` trNameLit (moduleNameFS (moduleName mod)) + } + +{- ********************************************************************* +* * + Building type-representation bindings +* * +********************************************************************* -} + +-- | Information we need about a 'TyCon' to generate its representation. We +-- carry the 'Id' in order to share it between the generation of the @TyCon@ and +-- @KindRep@ bindings. +data TypeableTyCon + = TypeableTyCon + { tycon :: !TyCon + , tycon_rep_id :: !Id + } + +-- | A group of 'TyCon's in need of type-rep bindings. +data TypeRepTodo + = TypeRepTodo + { mod_rep_expr :: LHsExpr GhcTc -- ^ Module's typerep binding + , pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint + , mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint + , todo_tycons :: [TypeableTyCon] + -- ^ The 'TyCon's in need of bindings kinds + } + | ExportedKindRepsTodo [(Kind, Id)] + -- ^ Build exported 'KindRep' bindings for the given set of kinds. + +todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo +todoForTyCons mod mod_id tycons = do + trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName + let mk_rep_id :: TyConRepName -> Id + mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy + + let typeable_tycons :: [TypeableTyCon] + typeable_tycons = + [ TypeableTyCon { tycon = tc'' + , tycon_rep_id = mk_rep_id rep_name + } + | tc <- tycons + , tc' <- tc : tyConATs tc + -- We need type representations for any associated types + , let promoted = map promoteDataCon (tyConDataCons tc') + , tc'' <- tc' : promoted + -- Don't make bindings for data-family instance tycons. + -- Do, however, make them for their promoted datacon (see #13915). + , not $ isFamInstTyCon tc'' + , Just rep_name <- pure $ tyConRepName_maybe tc'' + , tyConIsTypeable tc'' + ] + return TypeRepTodo { mod_rep_expr = nlHsVar mod_id + , pkg_fingerprint = pkg_fpr + , mod_fingerprint = mod_fpr + , todo_tycons = typeable_tycons + } + where + mod_fpr = fingerprintString $ moduleNameString $ moduleName mod + pkg_fpr = fingerprintString $ unitString $ moduleUnit mod + +todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo +todoForExportedKindReps kinds = do + trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName + let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy) + return $ ExportedKindRepsTodo $ map mkId kinds + +-- | Generate TyCon bindings for a set of type constructors +mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv +mkTypeRepTodoBinds [] = getGblEnv +mkTypeRepTodoBinds todos + = do { stuff <- collect_stuff + + -- First extend the type environment with all of the bindings + -- which we are going to produce since we may need to refer to them + -- while generating kind representations (namely, when we want to + -- represent a TyConApp in a kind, we must be able to look up the + -- TyCon associated with the applied type constructor). + ; let produced_bndrs :: [Id] + produced_bndrs = [ tycon_rep_id + | todo@(TypeRepTodo{}) <- todos + , TypeableTyCon {..} <- todo_tycons todo + ] ++ + [ rep_id + | ExportedKindRepsTodo kinds <- todos + , (_, rep_id) <- kinds + ] + ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv + + ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc] + mk_binds todo@(TypeRepTodo {}) = + mapM (mkTyConRepBinds stuff todo) (todo_tycons todo) + mk_binds (ExportedKindRepsTodo kinds) = + mkExportedKindReps stuff kinds >> return [] + + ; (gbl_env, binds) <- setGblEnv gbl_env + $ runKindRepM (mapM mk_binds todos) + ; return $ gbl_env `addTypecheckedBinds` concat binds } + +-- | Generate bindings for the type representation of a wired-in 'TyCon's +-- defined by the virtual "GHC.Prim" module. This is where we inject the +-- representation bindings for these primitive types into "GHC.Types" +-- +-- See Note [Grand plan for Typeable] in this module. +mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo]) +mkPrimTypeableTodos + = do { mod <- getModule + ; if mod == gHC_TYPES + then do { -- Build Module binding for GHC.Prim + trModuleTyCon <- tcLookupTyCon trModuleTyConName + ; let ghc_prim_module_id = + mkExportedVanillaId trGhcPrimModuleName + (mkTyConTy trModuleTyCon) + + ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id + <$> mkModIdRHS gHC_PRIM + + -- Extend our environment with above + ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id] + getGblEnv + ; let gbl_env' = gbl_env `addTypecheckedBinds` + [unitBag ghc_prim_module_bind] + + -- Build TypeRepTodos for built-in KindReps + ; todo1 <- todoForExportedKindReps builtInKindReps + -- Build TypeRepTodos for types in GHC.Prim + ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id + ghcPrimTypeableTyCons + ; return ( gbl_env' , [todo1, todo2]) + } + else do gbl_env <- getGblEnv + return (gbl_env, []) + } + +-- | This is the list of primitive 'TyCon's for which we must generate bindings +-- in "GHC.Types". This should include all types defined in "GHC.Prim". +-- +-- The majority of the types we need here are contained in 'primTyCons'. +-- However, not all of them: in particular unboxed tuples are absent since we +-- don't want to include them in the original name cache. See +-- Note [Built-in syntax and the OrigNameCache] in GHC.Iface.Env for more. +ghcPrimTypeableTyCons :: [TyCon] +ghcPrimTypeableTyCons = concat + [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ] + , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE] + , map sumTyCon [2..mAX_SUM_SIZE] + , primTyCons + ] + +data TypeableStuff + = Stuff { platform :: Platform -- ^ Target platform + , trTyConDataCon :: DataCon -- ^ of @TyCon@ + , trNameLit :: FastString -> LHsExpr GhcTc + -- ^ To construct @TrName@s + -- The various TyCon and DataCons of KindRep + , kindRepTyCon :: TyCon + , kindRepTyConAppDataCon :: DataCon + , kindRepVarDataCon :: DataCon + , kindRepAppDataCon :: DataCon + , kindRepFunDataCon :: DataCon + , kindRepTYPEDataCon :: DataCon + , kindRepTypeLitSDataCon :: DataCon + , typeLitSymbolDataCon :: DataCon + , typeLitNatDataCon :: DataCon + } + +-- | Collect various tidbits which we'll need to generate TyCon representations. +collect_stuff :: TcM TypeableStuff +collect_stuff = do + platform <- targetPlatform <$> getDynFlags + trTyConDataCon <- tcLookupDataCon trTyConDataConName + kindRepTyCon <- tcLookupTyCon kindRepTyConName + kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName + kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName + kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName + kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName + kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName + kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName + typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName + typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName + trNameLit <- mkTrNameLit + return Stuff {..} + +-- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we +-- can save the work of repeating lookups when constructing many TyCon +-- representations. +mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc) +mkTrNameLit = do + trNameSDataCon <- tcLookupDataCon trNameSDataConName + let trNameLit :: FastString -> LHsExpr GhcTc + trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon + `nlHsApp` nlHsLit (mkHsStringPrimLit fs) + return trNameLit + +-- | Make Typeable bindings for the given 'TyCon'. +mkTyConRepBinds :: TypeableStuff -> TypeRepTodo + -> TypeableTyCon -> KindRepM (LHsBinds GhcTc) +mkTyConRepBinds stuff todo (TypeableTyCon {..}) + = do -- Make a KindRep + let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon) + liftTc $ traceTc "mkTyConKindRepBinds" + (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind) + let ctx = mkDeBruijnContext (map binderVar bndrs) + kind_rep <- getKindRep stuff ctx kind + + -- Make the TyCon binding + let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep + tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs + return $ unitBag tycon_rep_bind + +-- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type +-- families and polytypes. +tyConIsTypeable :: TyCon -> Bool +tyConIsTypeable tc = + isJust (tyConRepName_maybe tc) + && kindIsTypeable (dropForAlls $ tyConKind tc) + +-- | Is a particular 'Kind' representable by @Typeable@? Here we look for +-- polytypes and types containing casts (which may be, for instance, a type +-- family). +kindIsTypeable :: Kind -> Bool +-- We handle types of the form (TYPE LiftedRep) specifically to avoid +-- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr) +-- to be typeable without inspecting rr, but this exhibits bad behavior +-- when rr is a type family. +kindIsTypeable ty + | Just ty' <- coreView ty = kindIsTypeable ty' +kindIsTypeable ty + | isLiftedTypeKind ty = True +kindIsTypeable (TyVarTy _) = True +kindIsTypeable (AppTy a b) = kindIsTypeable a && kindIsTypeable b +kindIsTypeable (FunTy _ a b) = kindIsTypeable a && kindIsTypeable b +kindIsTypeable (TyConApp tc args) = tyConIsTypeable tc + && all kindIsTypeable args +kindIsTypeable (ForAllTy{}) = False +kindIsTypeable (LitTy _) = True +kindIsTypeable (CastTy{}) = False + -- See Note [Typeable instances for casted types] +kindIsTypeable (CoercionTy{}) = False + +-- | Maps kinds to 'KindRep' bindings. This binding may either be defined in +-- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing') +-- or a binding which we generated in the current module (in which case it will +-- be 'Just' the RHS of the binding). +type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc)) + +-- | A monad within which we will generate 'KindRep's. Here we keep an +-- environment containing 'KindRep's which we've already generated so we can +-- re-use them opportunistically. +newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a } + deriving (Functor, Applicative, Monad) + +liftTc :: TcRn a -> KindRepM a +liftTc = KindRepM . lift + +-- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they +-- can be reused across modules. +builtInKindReps :: [(Kind, Name)] +builtInKindReps = + [ (star, starKindRepName) + , (mkVisFunTy star star, starArrStarKindRepName) + , (mkVisFunTys [star, star] star, starArrStarArrStarKindRepName) + ] + where + star = liftedTypeKind + +initialKindRepEnv :: TcRn KindRepEnv +initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps + where + add_kind_rep acc (k,n) = do + id <- tcLookupId n + return $! extendTypeMap acc k (id, Nothing) + +-- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's. +mkExportedKindReps :: TypeableStuff + -> [(Kind, Id)] -- ^ the kinds to generate bindings for + -> KindRepM () +mkExportedKindReps stuff = mapM_ kindrep_binding + where + empty_scope = mkDeBruijnContext [] + + kindrep_binding :: (Kind, Id) -> KindRepM () + kindrep_binding (kind, rep_bndr) = do + -- We build the binding manually here instead of using mkKindRepRhs + -- since the latter would find the built-in 'KindRep's in the + -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv'). + rhs <- mkKindRepRhs stuff empty_scope kind + addKindRepBind empty_scope kind rep_bndr rhs + +addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM () +addKindRepBind in_scope k bndr rhs = + KindRepM $ modify' $ + \env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs) + +-- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking +-- environment. +runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a) +runKindRepM (KindRepM action) = do + kindRepEnv <- initialKindRepEnv + (res, reps_env) <- runStateT action kindRepEnv + let rep_binds = foldTypeMap to_bind_pair [] reps_env + to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest + to_bind_pair (_, Nothing) rest = rest + tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv + let binds = map (uncurry mkVarBind) rep_binds + tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds] + return (tcg_env', res) + +-- | Produce or find a 'KindRep' for the given kind. +getKindRep :: TypeableStuff -> CmEnv -- ^ in-scope kind variables + -> Kind -- ^ the kind we want a 'KindRep' for + -> KindRepM (LHsExpr GhcTc) +getKindRep stuff@(Stuff {..}) in_scope = go + where + go :: Kind -> KindRepM (LHsExpr GhcTc) + go = KindRepM . StateT . go' + + go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv) + go' k env + -- Look through type synonyms + | Just k' <- tcView k = go' k' env + + -- We've already generated the needed KindRep + | Just (id, _) <- lookupTypeMapWithScope env in_scope k + = return (nlHsVar id, env) + + -- We need to construct a new KindRep binding + | otherwise + = do -- Place a NOINLINE pragma on KindReps since they tend to be quite + -- large and bloat interface files. + rep_bndr <- (`setInlinePragma` neverInlinePragma) + <$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon) + + -- do we need to tie a knot here? + flip runStateT env $ unKindRepM $ do + rhs <- mkKindRepRhs stuff in_scope k + addKindRepBind in_scope k rep_bndr rhs + return $ nlHsVar rep_bndr + +-- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and +-- in-scope kind variable set. +mkKindRepRhs :: TypeableStuff + -> CmEnv -- ^ in-scope kind variables + -> Kind -- ^ the kind we want a 'KindRep' for + -> KindRepM (LHsExpr GhcTc) -- ^ RHS expression +mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep + where + new_kind_rep k + -- We handle (TYPE LiftedRep) etc separately to make it + -- clear to consumers (e.g. serializers) that there is + -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep) + | not (tcIsConstraintKind k) + -- Typeable respects the Constraint/Type distinction + -- so do not follow the special case here + , Just arg <- kindRep_maybe k + , Just (tc, []) <- splitTyConApp_maybe arg + , Just dc <- isPromotedDataCon_maybe tc + = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc + + new_kind_rep (TyVarTy v) + | Just idx <- lookupCME in_scope v + = return $ nlHsDataCon kindRepVarDataCon + `nlHsApp` nlHsIntLit (fromIntegral idx) + | otherwise + = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v) + + new_kind_rep (AppTy t1 t2) + = do rep1 <- getKindRep stuff in_scope t1 + rep2 <- getKindRep stuff in_scope t2 + return $ nlHsDataCon kindRepAppDataCon + `nlHsApp` rep1 `nlHsApp` rep2 + + new_kind_rep k@(TyConApp tc tys) + | Just rep_name <- tyConRepName_maybe tc + = do rep_id <- liftTc $ lookupId rep_name + tys' <- mapM (getKindRep stuff in_scope) tys + return $ nlHsDataCon kindRepTyConAppDataCon + `nlHsApp` nlHsVar rep_id + `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys' + | otherwise + = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k) + + new_kind_rep (ForAllTy (Bndr var _) ty) + = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty) + + new_kind_rep (FunTy _ t1 t2) + = do rep1 <- getKindRep stuff in_scope t1 + rep2 <- getKindRep stuff in_scope t2 + return $ nlHsDataCon kindRepFunDataCon + `nlHsApp` rep1 `nlHsApp` rep2 + + new_kind_rep (LitTy (NumTyLit n)) + = return $ nlHsDataCon kindRepTypeLitSDataCon + `nlHsApp` nlHsDataCon typeLitNatDataCon + `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n) + + new_kind_rep (LitTy (StrTyLit s)) + = return $ nlHsDataCon kindRepTypeLitSDataCon + `nlHsApp` nlHsDataCon typeLitSymbolDataCon + `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s) + + -- See Note [Typeable instances for casted types] + new_kind_rep (CastTy ty co) + = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co) + + new_kind_rep (CoercionTy co) + = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co) + +-- | Produce the right-hand-side of a @TyCon@ representation. +mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo + -> TyCon -- ^ the 'TyCon' we are producing a binding for + -> LHsExpr GhcTc -- ^ its 'KindRep' + -> LHsExpr GhcTc +mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep + = nlHsDataCon trTyConDataCon + `nlHsApp` nlHsLit (word64 platform high) + `nlHsApp` nlHsLit (word64 platform low) + `nlHsApp` mod_rep_expr todo + `nlHsApp` trNameLit (mkFastString tycon_str) + `nlHsApp` nlHsLit (int n_kind_vars) + `nlHsApp` kind_rep + where + n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon) + tycon_str = add_tick (occNameString (getOccName tycon)) + add_tick s | isPromotedDataCon tycon = '\'' : s + | otherwise = s + + -- This must match the computation done in + -- Data.Typeable.Internal.mkTyConFingerprint. + Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo + , mod_fingerprint todo + , fingerprintString tycon_str + ] + + int :: Int -> HsLit GhcTc + int n = HsIntPrim (SourceText $ show n) (toInteger n) + +word64 :: Platform -> Word64 -> HsLit GhcTc +word64 platform n = case platformWordSize platform of + PW4 -> HsWord64Prim NoSourceText (toInteger n) + PW8 -> HsWordPrim NoSourceText (toInteger n) + +{- +Note [Representing TyCon kinds: KindRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One of the operations supported by Typeable is typeRepKind, + + typeRepKind :: TypeRep (a :: k) -> TypeRep k + +Implementing this is a bit tricky for poly-kinded types like + + data Proxy (a :: k) :: Type + -- Proxy :: forall k. k -> Type + +The TypeRep encoding of `Proxy Type Int` looks like this: + + $tcProxy :: GHC.Types.TyCon + $trInt :: TypeRep Int + TrType :: TypeRep Type + + $trProxyType :: TypeRep (Proxy Type :: Type -> Type) + $trProxyType = TrTyCon $tcProxy + [TrType] -- kind variable instantiation + (tyConKind $tcProxy [TrType]) -- The TypeRep of + -- Type -> Type + + $trProxy :: TypeRep (Proxy Type Int) + $trProxy = TrApp $trProxyType $trInt TrType + + $tkProxy :: GHC.Types.KindRep + $tkProxy = KindRepFun (KindRepVar 0) + (KindRepTyConApp (KindRepTYPE LiftedRep) []) + +Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent +polymorphic types. So instead + + * $trProxyType uses 'TrTyCon' to apply Proxy to (the representations) + of all its kind arguments. We can't represent a tycon that is + applied to only some of its kind arguments. + + * In $tcProxy, the GHC.Types.TyCon structure for Proxy, we store a + GHC.Types.KindRep, which represents the polymorphic kind of Proxy + Proxy :: forall k. k->Type + + * A KindRep is just a recipe that we can instantiate with the + argument kinds, using Data.Typeable.Internal.tyConKind and + store in the relevant 'TypeRep' constructor. + + Data.Typeable.Internal.typeRepKind looks up the stored kinds. + + * In a KindRep, the kind variables are represented by 0-indexed + de Bruijn numbers: + + type KindBndr = Int -- de Bruijn index + + data KindRep = KindRepTyConApp TyCon [KindRep] + | KindRepVar !KindBndr + | KindRepApp KindRep KindRep + | KindRepFun KindRep KindRep + ... + +Note [Typeable instances for casted types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At present, GHC does not manufacture TypeReps for types containing casts +(#16835). In theory, GHC could do so today, but it might be dangerous tomorrow. + +In today's GHC, we normalize all types before computing their TypeRep. +For example: + + type family F a + type instance F Int = Type + + data D = forall (a :: F Int). MkD a + + tr :: TypeRep (MkD Bool) + tr = typeRep + +When computing the TypeRep for `MkD Bool` (or rather, +`MkD (Bool |> Sym (FInt[0]))`), we simply discard the cast to obtain the +TypeRep for `MkD Bool`. + +Why does this work? If we have a type definition with casts, then the +only coercions that those casts can mention are either Refl, type family +axioms, built-in axioms, and coercions built from those roots. Therefore, +type family (and built-in) axioms will apply precisely when type normalization +succeeds (i.e, the type family applications are reducible). Therefore, it +is safe to ignore the cast entirely when constructing the TypeRep. + +This approach would be fragile in a future where GHC permits other forms of +coercions to appear in casts (e.g., coercion quantification as described +in #15710). If GHC permits local assumptions to appear in casts that cannot be +reduced with conventional normalization, then discarding casts would become +unsafe. It would be unfortunate for the Typeable solver to become a roadblock +obstructing such a future, so we deliberately do not implement the ability +for TypeReps to represent types with casts at the moment. + +If we do wish to allow this in the future, it will likely require modeling +casts and coercions in TypeReps themselves. +-} + +mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc +mkList ty = foldr consApp (nilExpr ty) + where + cons = consExpr ty + consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc + consApp x xs = cons `nlHsApp` x `nlHsApp` xs + + nilExpr :: Type -> LHsExpr GhcTc + nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon) + + consExpr :: Type -> LHsExpr GhcTc + consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon) diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Module.hs @@ -0,0 +1,3095 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking a whole module +-- +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker +module GHC.Tc.Module ( + tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType, + tcRnImportDecls, + tcRnLookupRdrName, + getModuleInterface, + tcRnDeclsi, + isGHCiMonad, + runTcInteractive, -- Used by GHC API clients (#8878) + tcRnLookupName, + tcRnGetInfo, + tcRnModule, tcRnModuleTcRnM, + tcTopSrcDecls, + rnTopSrcDecls, + checkBootDecl, checkHiBootIface', + findExtraSigImports, + implicitRequirements, + checkUnit, + mergeSignatures, + tcRnMergeSignatures, + instantiateSignature, + tcRnInstantiateSignature, + loadUnqualIfaces, + -- More private... + badReexportedBootThing, + checkBootDeclM, + missingBootThing, + getRenamedStuff, RenamedStuff + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) +import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) +import GHC.Iface.Env ( externaliseName ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Validity( checkValidType ) +import GHC.Tc.Gen.Match +import GHC.Tc.Utils.Unify( checkConstraints ) +import GHC.Rename.HsType +import GHC.Rename.Expr +import GHC.Rename.Utils ( HsDocContext(..) ) +import GHC.Rename.Fixity ( lookupFixityRn ) +import GHC.Builtin.Types ( unitTy, mkListTy ) +import GHC.Driver.Plugins +import GHC.Driver.Session +import GHC.Hs +import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) +import GHC.Iface.Type ( ShowForAllFlag(..) ) +import GHC.Core.PatSyn( pprPatSynType ) +import GHC.Builtin.Names +import GHC.Builtin.Utils +import GHC.Types.Name.Reader +import GHC.Tc.Utils.Zonk +import GHC.Tc.Gen.Expr +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 qualified GHC.Data.BooleanFormula as BF +import GHC.Core.Ppr.TyThing ( pprTyThingInContext ) +import GHC.Core.FVs ( orphNamesOfFamInst ) +import GHC.Tc.Instance.Family +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv + ( FamInst, pprFamInst, famInstsRepTyCons + , famInstEnvElts, extendFamInstEnvList, normaliseType ) +import GHC.Tc.Gen.Annotation +import GHC.Tc.Gen.Bind +import GHC.Iface.Make ( coAxiomToIfaceDecl ) +import GHC.Parser.Header ( mkPrelImports ) +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.IfaceToCore +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.Iface.Load +import GHC.Rename.Names +import GHC.Rename.Env +import GHC.Rename.Module +import GHC.Utils.Error +import GHC.Types.Id as Id +import GHC.Types.Id.Info( IdDetails(..) ) +import GHC.Types.Var.Env +import GHC.Unit.Module +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.Core.TyCon +import GHC.Types.SrcLoc +import GHC.Driver.Types +import GHC.Data.List.SetOps +import GHC.Utils.Outputable as Outputable +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.Class +import GHC.Types.Basic hiding( SuccessFlag(..) ) +import GHC.Core.Coercion.Axiom +import GHC.Types.Annotations +import Data.List ( find, sortBy, sort ) +import Data.Ord +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Data.Bag +import GHC.Tc.Utils.Instantiate (tcGetInsts) +import qualified GHC.LanguageExtensions as LangExt +import Data.Data ( Data ) +import GHC.Hs.Dump +import qualified Data.Set as S + +import Control.DeepSeq +import Control.Monad + +import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) ) + + +#include "HsVersions.h" + +{- +************************************************************************ +* * + Typecheck and rename a module +* * +************************************************************************ +-} + +-- | Top level entry point for typechecker and renamer +tcRnModule :: HscEnv + -> ModSummary + -> Bool -- True <=> save renamed syntax + -> HsParsedModule + -> IO (Messages, Maybe TcGblEnv) + +tcRnModule hsc_env mod_sum save_rn_syntax + parsedModule@HsParsedModule {hpm_module= L loc this_module} + | RealSrcSpan real_loc _ <- loc + = withTiming dflags + (text "Renamer/typechecker"<+>brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ + withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $ + + tcRnModuleTcRnM hsc_env mod_sum parsedModule pair + + | otherwise + = return ((emptyBag, unitBag err_msg), Nothing) + + where + hsc_src = ms_hsc_src mod_sum + dflags = hsc_dflags hsc_env + err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $ + text "Module does not have a RealSrcSpan:" <+> ppr this_mod + + this_pkg = thisPackage (hsc_dflags hsc_env) + + pair :: (Module, SrcSpan) + pair@(this_mod,_) + | Just (L mod_loc mod) <- hsmodName this_module + = (mkModule this_pkg mod, mod_loc) + + | otherwise -- 'module M where' is omitted + = (mAIN, 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 maybe_mod export_ies + import_decls local_decls mod_deprec + maybe_doc_hdr)), + 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 } + + ; whenWOptM Opt_WarnImplicitPrelude $ + when (notNull prel_imports) $ + addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) + + ; -- TODO This is a little skeevy; maybe handle a bit more directly + let { simplifyImport (L _ idecl) = + ( fmap sl_fs (ideclPkgQual idecl) , 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 (Nothing, L _ mod_name) = noLoc + $ (simpleImportDecl mod_name) + { ideclHiding = Just (False, noLoc [])} + ; mkImport _ = panic "mkImport" } + ; let { all_imports = prel_imports ++ import_decls + ++ map mkImport (raw_sig_imports ++ raw_req_imports) } + ; -- OK now finally rename the imports + tcg_env <- {-# SCC "tcRnImports" #-} + tcRnImports hsc_env all_imports + + ; -- 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 + let { tcg_env1 = case mod_deprec of + Just (L _ txt) -> + tcg_env {tcg_warns = WarnAll txt} + Nothing -> tcg_env + } + ; setGblEnv tcg_env1 + $ do { -- Rename and type check the declarations + traceRn "rn1a" empty + ; tcg_env <- if isHsBootOrSig hsc_src + then tcRnHsBootDecls hsc_src local_decls + else {-# SCC "tcRnSrcDecls" #-} + tcRnSrcDecls explicit_mod_hdr local_decls export_ies + ; setGblEnv tcg_env + $ do { -- Process the export list + traceRn "rn4a: before exports" empty + ; tcg_env <- tcRnExports explicit_mod_hdr export_ies + tcg_env + ; traceRn "rn4b: after exports" empty + ; -- 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. + + -- Don't need to rename the Haddock documentation, + -- it's not parsed by GHC anymore. + tcg_env <- return (tcg_env + { tcg_doc_hdr = maybe_doc_hdr }) + ; -- 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 + ; -- add extra source files to tcg_dependent_files + addDependentFiles src_files + ; tcg_env <- runTypecheckerPlugin mod_sum hsc_env 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] -> TcM TcGblEnv +tcRnImports hsc_env import_decls + = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; + + ; this_mod <- getModule + ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) + ; dep_mods = imp_dep_mods imports + + -- 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. + ; want_instances :: ModuleName -> Bool + ; want_instances mod = mod `elemUFM` dep_mods + && mod /= moduleName this_mod + ; (home_insts, home_fam_insts) = hptInstances hsc_env + want_instances + } ; + + -- Record boot-file info in the EPS, so that it's + -- visible to loadHiBootInterface in tcRnSrcDecls, + -- and any other incrementally-performed imports + ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; + + -- 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 = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) + home_fam_insts, + tcg_hpc = hpc_info + }) $ do { + + ; traceRn "rn1" (ppr (imp_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 + -> [LHsDecl GhcPs] -- Declarations + -> Maybe (Located [LIE GhcPs]) + -> TcM TcGblEnv +tcRnSrcDecls explicit_mod_hdr decls export_ies + = do { -- Do all the declarations + ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls + + -- Check for the 'main' declaration + -- Must do this inside the captureTopConstraints + -- NB: always set envs *before* captureTopConstraints + ; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $ + captureTopConstraints $ + checkMain explicit_mod_hdr export_ies + + ; setEnvs (tcg_env, tcl_env) $ do { + + -- Simplify constraints + -- + -- We do this after checkMain, so that we use the type info + -- that checkMain adds + -- + -- We do it with both global and local env in scope: + -- * the global env exposes the instances to simplifyTop + -- * the local env exposes the local Ids to simplifyTop, + -- so that we get better error messages (monomorphism restriction) + ; new_ev_binds <- {-# SCC "simplifyTop" #-} + simplifyTop (lie `andWC` lie_main) + + -- Emit Typeable bindings + ; tcg_env <- mkTypeableBinds + + + ; traceTc "Tc9" empty + + ; failIfErrsM -- Don't zonk if there have been errors + -- It's a waste of time; and we may get debug warnings + -- about strangely-typed TyCons! + ; traceTc "Tc10" empty + + -- Zonk the final code. This must be done last. + -- Even simplifyTop may do some unification. + -- This pass also warns about missing type signatures + ; (bind_env, ev_binds', binds', fords', imp_specs', rules') + <- zonkTcGblEnv new_ev_binds tcg_env + + -- Finalizers must run after constraints are simplified, or some 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. + ; (tcg_env_mf, _) <- setGblEnv (clearTcGblEnv tcg_env) + run_th_modfinalizers + ; finishTH + ; traceTc "Tc11" empty + + ; -- zonk the new bindings arising from running the finalisers. + -- This won't give rise to any more finalisers as you can't nest + -- finalisers inside finalisers. + ; (bind_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf) + <- zonkTcGblEnv emptyBag tcg_env_mf + + + ; let { final_type_env = plusTypeEnv (tcg_type_env tcg_env) + (plusTypeEnv bind_env_mf bind_env) + ; tcg_env' = tcg_env_mf + { 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 new_ev_binds tcg_env = + let TcGblEnv { tcg_binds = binds, + tcg_ev_binds = cur_ev_binds, + tcg_imp_specs = imp_specs, + tcg_rules = rules, + tcg_fords = fords } = tcg_env + + all_ev_binds = cur_ev_binds `unionBags` new_ev_binds + + in {-# SCC "zonkTopDecls" #-} + zonkTopDecls all_ev_binds binds rules imp_specs fords + + +-- | Remove accumulated bindings, rules and so on from TcGblEnv +clearTcGblEnv :: TcGblEnv -> TcGblEnv +clearTcGblEnv tcg_env + = tcg_env { tcg_binds = emptyBag, + tcg_ev_binds = emptyBag , + tcg_imp_specs = [], + tcg_rules = [], + tcg_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) = + setLclEnv 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 [] + + setEnvs (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 _) _, _) -> + setSrcSpan loc + $ addErr (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 + ; setEnvs (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 + ; (tcg_env, tcl_env, lie2) <- + setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ + addTopEvBinds ev_binds1 $ + tc_rn_src_decls (spliced_decls ++ rest_ds) + + ; return (tcg_env, tcl_env, lie2) + } + } + } + +{- +************************************************************************ +* * + 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) + <- 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 -> Located decl -> TcM () +badBootDecl hsc_src what (L loc _) + = addErrAt loc (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 () + | isWiredInName name = return () -- No checking for wired-in names. In particular, + -- 'error' is handled by a rather gross hack + -- (see comments in GHC.Err.hs-boot) + + -- Check that the actual module exports the same thing + | not (null missing_names) + = addErrAt (nameSrcSpan (head missing_names)) + (missingBootThing True (head missing_names) "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 (eqMaybeBy 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) + (_, rho_ty1) = splitForAllTys (idType id1) + op_ty1 = funResultTy rho_ty1 + (_, rho_ty2) = splitForAllTys (idType id2) + op_ty2 = funResultTy rho_ty2 + + 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 t2)) (Just (_, VanillaDM)) + = eqTypeX env t1 t2 + -- 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) = + eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && + eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) + in + checkRoles roles1 roles2 `andThenCheck` + -- Checks kind of class + check (eqListBy eqFD clas_fds1 clas_fds2) + (text "The functional dependencies do not match") `andThenCheck` + checkUnless (isAbstractTyCon tc1) $ + check (eqListBy (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 (eqListBy (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 (mkNthCo). 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 paramaters), + -- + -- 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 (eqListBy 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 (dataConUserType c1) (dataConUserType 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 + = eqListBy (eqTypeX env) lhs1 lhs2 && + eqTypeX env rhs1 rhs2 + + | otherwise = False + +emptyRnEnv2 :: RnEnv2 +emptyRnEnv2 = mkRnEnv2 emptyInScopeSet + +---------------- +missingBootThing :: Bool -> Name -> String -> SDoc +missingBootThing is_boot name what + = 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 -> SDoc +badReexportedBootThing is_boot name name' + = 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 -> SDoc +bootMisMatch is_boot extra_info real_thing boot_thing + = 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 -> SDoc +instMisMatch dfun + = 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, XValBindsLR (NValBinds deriv_binds deriv_sigs)) + <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; + + 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; + setEnvs 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) ; + setEnvs 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` gre_name gre) + emptyFVs fo_gres + + ; sig_names = mkNameSet (collectHsValBinders 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 + 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 . occEnvElts . tcg_rdr_env) getGblEnv + + ; let clashes :: GlobalRdrElt -> Bool + clashes x = isLocalDef && nameClashes && isNotInProperModule + where + isLocalDef = gre_lcl x == True + -- Names are identical ... + nameClashes = nameOccName (gre_name 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 = gre_name 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 = addWarnAt (Reason warnFlag) (nameSrcSpan (gre_name x)) (hsep + [ text "Local definition of" + , (quotes . ppr . nameOccName . gre_name) 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 + + -- 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 (Bool, [Name]) + importListOf = fmap toImportList . ideclHiding + where + toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc)) + + isExplicit :: ImportDecl GhcRn -> Bool + isExplicit x = case importListOf x of + Nothing -> False + Just (False, explicit) + -> nameOccName name `elem` map nameOccName explicit + Just (True, 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 (Just name:_) = + addWarnAt (Reason warnFlag) instLoc $ + 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 (null 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 + 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) + <- 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, val_binds) + }}} + +{- ********************************************************************* +* * + Checking for 'main' +* * +************************************************************************ +-} + +checkMain :: Bool -- False => no 'module M(..) where' header at all + -> Maybe (Located [LIE GhcPs]) -- Export specs of Main module + -> TcM TcGblEnv +-- If we are in module Main, check that 'main' is defined and exported. +checkMain explicit_mod_hdr export_ies + = do { dflags <- getDynFlags + ; tcg_env <- getGblEnv + ; check_main dflags tcg_env explicit_mod_hdr export_ies } + +check_main :: DynFlags -> TcGblEnv -> Bool -> Maybe (Located [LIE GhcPs]) + -> TcM TcGblEnv +check_main dflags tcg_env explicit_mod_hdr export_ies + | mod /= main_mod + = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >> + return tcg_env + + | otherwise + -- Compare the list of main functions in scope with those + -- specified in the export list. + = do mains_all <- lookupInfoOccRn main_fn + -- get all 'main' functions in scope + -- They may also be imported from other modules! + case exportedMains of -- check the main(s) specified in the export list + [ ] -> do + -- The module has no main functions in the export spec, so we must give + -- some kind of error message. The tricky part is giving an error message + -- that accurately characterizes what the problem is. + -- See Note [Main module without a main function in the export spec] + traceTc "checkMain no main module exported" ppr_mod_mainfn + complain_no_main + -- In order to reduce the number of potential error messages, we check + -- to see if there are any main functions defined (but not exported)... + case getSomeMain mains_all of + Nothing -> return tcg_env + -- ...if there are no such main functions, there is nothing we can do... + Just some_main -> use_as_main some_main + -- ...if there is such a main function, then communicate this to the + -- typechecker. This can prevent a spurious "Ambiguous type variable" + -- error message in certain cases, as described in + -- Note [Main module without a main function in the export spec]. + _ -> do -- The module has one or more main functions in the export spec + let mains = filterInsMains exportedMains mains_all + case mains of + [] -> do -- + traceTc "checkMain fail" ppr_mod_mainfn + complain_no_main + return tcg_env + [main_name] -> use_as_main main_name + _ -> do -- multiple main functions are exported + addAmbiguousNameErr main_fn -- issue error msg + return tcg_env + where + mod = tcg_mod tcg_env + main_mod = mainModIs dflags + main_mod_nm = moduleName main_mod + main_fn = getMainFun dflags + occ_main_fn = occName main_fn + interactive = ghcLink dflags == LinkInMemory + exportedMains = selExportMains export_ies + ppr_mod_mainfn = ppr main_mod <+> ppr main_fn + + -- There is a single exported 'main' function. + use_as_main :: Name -> TcM TcGblEnv + use_as_main main_name = do + { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn) + ; let loc = srcLocSpan (getSrcLoc main_name) + ; ioTyCon <- tcLookupTyCon ioTyConName + ; res_ty <- newFlexiTyVarTy liftedTypeKind + ; let io_ty = mkTyConApp ioTyCon [res_ty] + skol_info = SigSkol (FunSigCtxt main_name False) io_ty [] + ; (ev_binds, main_expr) + <- checkConstraints skol_info [] [] $ + addErrCtxt mainCtxt $ + tcLExpr (L loc (HsVar noExtField (L loc main_name))) + (mkCheckExpType 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 + (mkTyConApp ioTyCon [res_ty]) + ; co = mkWpTyApps [res_ty] + -- The ev_binds of the `main` function may contain deferred + -- type error 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 + })} + + complain_no_main = unless (interactive && not explicit_mod_hdr) + (addErrTc noMainMsg) -- #12906 + -- 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. + + mainCtxt = text "When checking the type of the" <+> pp_main_fn + noMainMsg = text "The" <+> pp_main_fn + <+> text "is not" <+> text defOrExp <+> text "module" + <+> quotes (ppr main_mod) + defOrExp = if null exportedMains then "exported by" else "defined in" + + pp_main_fn = ppMainFn main_fn + + -- Select the main functions from the export list. + -- Only the module name is needed, the function name is fixed. + selExportMains :: Maybe (Located [LIE GhcPs]) -> [ModuleName] -- #16453 + selExportMains Nothing = [main_mod_nm] + -- no main specified, but there is a header. + selExportMains (Just exps) = fmap fst $ + filter (\(_,n) -> n == occ_main_fn ) texp + where + ies = fmap unLoc $ unLoc exps + texp = mapMaybe transExportIE ies + + -- Filter all main functions in scope that match the export specs + filterInsMains :: [ModuleName] -> [Name] -> [Name] -- #16453 + filterInsMains export_mains inscope_mains = + [mod | mod <- inscope_mains, + (moduleName . nameModule) mod `elem` export_mains] + + -- Transform an export_ie to a (ModuleName, OccName) pair. + -- 'IEVar' constructors contain exported values (functions), eg '(Main.main)' + -- 'IEModuleContents' constructors contain fully exported modules, eg '(Main)' + -- All other 'IE...' constructors are not used and transformed to Nothing. + transExportIE :: IE GhcPs -> Maybe (ModuleName, OccName) -- #16453 + transExportIE (IEVar _ var) = isQual_maybe $ + upqual $ ieWrappedName $ unLoc var + where + -- A module name is always needed, so qualify 'UnQual' rdr names. + upqual (Unqual occ) = Qual main_mod_nm occ + upqual rdr = rdr + transExportIE (IEModuleContents _ mod) = Just (unLoc mod, occ_main_fn) + transExportIE _ = Nothing + + -- Get a main function that is in scope. + -- See Note [Main module without a main function in the export spec] + getSomeMain :: [Name] -> Maybe Name -- #16453 + getSomeMain all_mains = case all_mains of + [] -> Nothing -- No main function in scope + [m] -> Just m -- Just one main function in scope + _ -> case mbMainOfMain of + Nothing -> listToMaybe all_mains -- Take the first main function in scope or Nothing + _ -> mbMainOfMain -- Take the Main module's main function or Nothing + where + mbMainOfMain = find (\n -> (moduleName . nameModule) n == main_mod_nm ) + all_mains -- the main function of the Main module + +-- | 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 +getMainFun :: DynFlags -> RdrName +getMainFun dflags = case mainFunIs dflags of + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) + Nothing -> main_RDR_Unqual + +ppMainFn :: RdrName -> SDoc +ppMainFn main_fn + | rdrNameOcc main_fn == mainOcc + = text "IO action" <+> quotes (ppr main_fn) + | otherwise + = text "main IO action" <+> quotes (ppr main_fn) + +mainOcc :: OccName +mainOcc = mkVarOccFS (fsLit "main") + +{- +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! + + +Note [Main module without a main function in the export spec] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Giving accurate error messages for a Main module that does not export a main +function is surprisingly tricky. To see why, consider a module in a file +`Foo.hs` that has no `main` function in the explicit export specs of the module +header: + + module Main () where + foo = return () + +This does not export a main function and therefore should be rejected, per +chapter 5 of the Haskell Report 2010: + + A Haskell program is a collection of modules, one of which, by convention, + must be called Main and must export the value main. The value of the + program is the value of the identifier main in module Main, which must be + a computation of type IO τ for some type τ. + +In fact, when you compile the program above using `ghc Foo.hs`, you will +actually get *two* errors: + + - The IO action ‘main’ is not defined in module ‘Main’ + + - Ambiguous type variable ‘m0’ arising from a use of ‘return’ + prevents the constraint ‘(Monad m0)’ from being solved. + +The first error is self-explanatory, while the second error message occurs +due to the monomorphism restriction. + +Now consider what would happen if the program above were compiled with +`ghc -main-is foo Foo`. The has the effect of `foo` being designated as the +main function. The program will still be rejected since it does not export +`foo` (and therefore does not export its main function), but there is one +important difference: `foo` will be checked against the type `IO τ`. As a +result, we would *not* expect the monomorphism restriction error message +to occur, since the typechecker should have no trouble figuring out the type +of `foo`. In other words, we should only throw the former error message, +not the latter. + +The implementation uses the function `getSomeMain` to find a potential main +function that is defined but not exported. If one is found, it is passed to +`use_as_main` to inform the typechecker that the main function should be of +type `IO τ`. See also the `T414` and `T17171a` test cases for similar examples +of programs whose error messages are influenced by the situation described in +this Note. + + +********************************************************* +* * + GHCi stuff +* * +********************************************************* +-} + +runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, 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 $ withHoleFitPlugins hsc_env $ + do { traceTc "setInteractiveContext" $ + vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) + , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts) + , text "ic_rn_gbl_env (LocalDef)" <+> + vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt) + , let local_gres = filter isLocalGRE gres + , not (null local_gres) ]) ] + + ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface + : dep_orphs (mi_deps iface)) + (loadSrcInterface (text "runTcInteractive") m + False mb_pkg) + + ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> + case i of -- force above: see #15111 + IIModule n -> getOrphans n Nothing + IIDecl i -> + let mb_pkg = sl_fs <$> ideclPkgQual i in + getOrphans (unLoc (ideclName i)) mb_pkg + + ; let imports = emptyImportAvails { + imp_orphs = orphs + } + + ; (gbl_env, lcl_env) <- getEnvs + ; let gbl_env' = gbl_env { + tcg_rdr_env = ic_rn_gbl_env icxt + , tcg_type_env = type_env + , tcg_inst_env = extendInstEnvList + (extendInstEnvList (tcg_inst_env gbl_env) ic_insts) + 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 + + ; setEnvs (gbl_env', lcl_env') thing_inside } + where + (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) + + 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 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, 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 levity 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 (isUnliftedType . 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.Types + +{- --------------------------------------------- + At one stage I removed any shadowed bindings from the type_env; + they are inaccessible but might, I suppose, cause a space leak if we leave them there. + However, with Template Haskell they aren't necessarily inaccessible. Consider this + GHCi session + Prelude> let f n = n * 2 :: Int + Prelude> fName <- runQ [| f |] + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + 14 + Prelude> let f n = n * 3 :: Int + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + In the last line we use 'fName', which resolves to the *first* 'f' + in scope. If we delete it from the type env, GHCi crashes because + it doesn't expect that. + + Hence this code is commented out + +-------------------------------------------------- -} + + 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 (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 :: [Plan] -> TcM PlanResult +runPlans [] = panic "runPlans" +runPlans [p] = p +runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p + +-- | 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.Types 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) + -- Don't try to typecheck if the renamer fails! + ; ghciStep <- getGhciStepIO + ; uniq <- newUnique + ; interPrintName <- getInteractivePrintName + ; let fresh_it = itName uniq loc + matches = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr + (noLoc 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 noExtField $ noLoc $ HsValBinds noExtField + $ 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 + + ; 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 GhciStmtCtxt rnLExpr [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 gi_stmt -- One binder + = [mk_print_result_plan gi_stmt v] + | otherwise = [] + + -- The plans are: + -- [stmt; print v] if one binder and not v::() + -- [stmt] otherwise + ; plan <- runPlans (print_result_plan ++ [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 GhciStmtCtxt tcDoStmt stmts + (mkCheckExpType io_ret_ty) + names = collectLStmtsBinders 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 + + -- rec_expr is the expression + -- returnIO @ [()] [unsafeCoerce# () x, .., unsafeCorece# () 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]) $ + noLoc $ ExplicitList unitTy Nothing $ + 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 ++ [noLoc (mkLastStmt ret_expr)] + + ; return (ids, mkHsDictLet (EvBinds const_binds) $ + noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc 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 ghciTy) (nlHsTyVar a_tv) + ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) + + step_ty = noLoc $ HsForAllTy + { hst_fvf = ForallInvis + , hst_bndrs = [noLoc $ UserTyVar noExtField (noLoc a_tv)] + , hst_xforall = noExtField + , hst_body = nlHsFunTy ghciM ioM } + + stepTy :: LHsSigWcType GhcRn + stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty) + + return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) + +isGHCiMonad :: HscEnv -> String -> IO (Messages, 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 = gre_name n + ghciClass <- tcLookupClass ghciIoClassName + userTyCon <- tcLookupTyCon name + let userTy = mkTyConApp userTyCon [] + _ <- tcLookupInstance ghciClass [userTy] + return name + + Just _ -> failWithTc $ text "Ambiguous type!" + Nothing -> failWithTc $ text ("Can't find type:" ++ ty) + +-- | How should we infer a type? See Note [TcRnExprMode] +data TcRnExprMode = TM_Inst -- ^ Instantiate the type fully (:type) + | TM_NoInst -- ^ Do not instantiate the type (:type +v) + | TM_Default -- ^ Default the type eagerly (:type +d) + +-- | tcRnExpr just finds the type of an expression +tcRnExpr :: HscEnv + -> TcRnExprMode + -> LHsExpr GhcPs + -> IO (Messages, Maybe Type) +tcRnExpr hsc_env mode rdr_expr + = runTcInteractive hsc_env $ + do { + + (rn_expr, _fvs) <- rnLExpr rdr_expr ; + failIfErrsM ; + + -- Now typecheck the expression, and generalise its type + -- it might have a rank-2 type (e.g. :t runST) + uniq <- newUnique ; + let { fresh_it = itName uniq (getLoc rdr_expr) } ; + ((tclvl, (_tc_expr, res_ty)), lie) + <- captureTopConstraints $ + pushTcLevelM $ + tc_infer rn_expr ; + + -- Generalise + (qtvs, dicts, _, residual, _) + <- 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 = mkInvForAllTys qtvs $ + mkPhiTy (map idType dicts) res_ty } ; + ty <- zonkTcType all_expr_ty ; + + -- We normalise type families, so that the type of an expression is the + -- same as of a bound expression (GHC.Tc.Gen.Bind.mkInferredPolyId). See Trac + -- #10321 for further discussion. + fam_envs <- tcGetFamInstEnvs ; + -- normaliseType returns a coercion which we discard, so the Role is + -- irrelevant + return (snd (normaliseType fam_envs Nominal ty)) + } + where + tc_infer expr | inst = tcInferRho expr + | otherwise = tcInferSigma expr + -- tcInferSigma: see Note [Implementing :type] + + -- See Note [TcRnExprMode] + (inst, infer_mode, perhaps_disable_default_warnings) = case mode of + TM_Inst -> (True, NoRestrictions, id) + TM_NoInst -> (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. +-} + +-------------------------- +tcRnImportDecls :: HscEnv + -> [LImportDecl GhcPs] + -> IO (Messages, 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 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, 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_type }, _fvs) + <- rnHsWcType GHCiCtx (mkHsWildCardBndrs 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_type]) + ; (ty, kind) <- pushTcLevelM_ $ + -- must push level to satisfy level precondition of + -- kindGeneralize, below + solveEqualities $ + tcNamedWildCardBinders wcs $ \ wcs' -> + do { emitNamedWildCardHoleConstraints wcs' + ; tcLHsTypeUnsaturated rn_type } + + -- Do kind generalisation; see Note [Kind-generalise in tcRnType] + ; kvs <- kindGeneralizeAll kind + ; e <- mkEmptyZonkEnv flexi + + ; ty <- zonkTcTypeToTypeX e ty + + -- Do validity checking on type + ; checkValidType (GhciCtxt True) ty + + ; ty' <- if normalise + then do { fam_envs <- tcGetFamInstEnvs + ; let (_, ty') + = normaliseType fam_envs Nominal ty + ; return ty' } + else return ty ; + + ; return (ty', mkInvForAllTys kvs (tcTypeKind 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 3 different possibilities, described below. Each +considers this example, with -fprint-explicit-foralls enabled: + + foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String + :type{,-spec,-def} foo @Int + +:type / TM_Inst + + In this mode, we report the type that would be inferred if a variable + were assigned to expression e, without applying the monomorphism restriction. + This means we deeply instantiate the type and then regeneralize, as discussed + in #11376. + + > :type foo @Int + forall {b} {f :: * -> *}. (Foldable f, Num b) => Int -> f b -> String + + 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. + +:type +v / TM_NoInst + + This mode is for the benefit of users using TypeApplications. It does no + instantiation whatsoever, sometimes meaning that class constraints are not + solved. + + > :type +v 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, any type variable that can be defaulted is defaulted. Because + GHCi uses -XExtendedDefaultRules, this means that Foldable and Traversable are + defaulted. + + > :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 [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, Maybe TcGblEnv) +tcRnDeclsi hsc_env local_decls + = runTcInteractive hsc_env $ + tcRnSrcDecls False local_decls Nothing + +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, Maybe ModIface) +getModuleInterface hsc_env mod + = runTcInteractive hsc_env $ + loadModuleInterface (text "getModuleInterface") mod + +tcRnLookupRdrName :: HscEnv -> Located RdrName + -> IO (Messages, Maybe [Name]) +-- ^ Find all the Names that this RdrName could mean, in GHCi +tcRnLookupRdrName hsc_env (L loc rdr_name) + = runTcInteractive hsc_env $ + setSrcSpan 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 (text "Not in scope:" <+> quotes (ppr rdr_name))) + ; return names } + +tcRnLookupName :: HscEnv -> Name -> IO (Messages, 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 + , 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 $ do + mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) + where + this_pkg = thisPackage (hsc_dflags hsc_env) + + unqual_mods = [ nameModule name + | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt) + , let name = gre_name gre + , nameIsFromExternalPackage this_pkg 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 { dflags <- getDynFlags ; + + -- Dump short output if -ddump-types or -ddump-tc + when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + (dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types) + "" FormatText 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 (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:" <+> + pprUFM (imp_dep_mods imports) (ppr . sort) + , text "Dependent packages:" <+> + ppr (S.toList $ imp_dep_pkgs imports)] + where -- 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 + RecSelId {} -> True + ClassOpId {} -> True + FCallId {} -> True + _ -> False + -- Data cons (workers and wrappers), pattern synonyms, + -- etc are suppressed (unless -dppr-debug), + -- because they appear elsewhere + + ppr_sig id = hang (pprPrefixOcc id <+> dcolon) 2 (ppr (tidyTopType (idType id))) + +ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc +ppr_tycons debug fam_insts type_env + = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons + , ppr_things "COERCION AXIOMS" ppr_ax + (typeEnvCoAxioms type_env) ] + where + fi_tycons = famInstsRepTyCons fam_insts + + tycons = sortBy (comparing getOccName) $ + [tycon | tycon <- typeEnvTyCons type_env + , want_tycon tycon] + -- Sort by OccName to reduce unnecessary changes + want_tycon tycon | debug = True + | otherwise = isExternalName (tyConName tycon) && + not (tycon `elem` fi_tycons) + ppr_tc tc + = vcat [ hang (ppr (tyConFlavour tc) <+> pprPrefixOcc (tyConName tc) + <> braces (ppr (tyConArity tc)) <+> dcolon) + 2 (ppr (tidyTopType (tyConKind tc))) + , nest 2 $ + ppWhen show_roles $ + text "roles" <+> (sep (map ppr roles)) ] + where + show_roles = debug || not (all (== boring_role) roles) + roles = tyConRoles tc + boring_role | isClassTyCon tc = Nominal + | otherwise = Representational + -- Matches the choice in GHC.Iface.Syntax, calls to pprRoles + + ppr_ax ax = ppr (coAxiomToIfaceDecl ax) + -- We go via IfaceDecl rather than using pprCoAxiom + -- This way we get the full axiom (both LHS and RHS) with + -- wildcard binders tidied to _1, _2, etc. + +ppr_datacons :: Bool -> TypeEnv -> SDoc +ppr_datacons debug type_env + = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs + -- The filter gets rid of class data constructors + where + ppr_dc dc = ppr dc <+> dcolon <+> ppr (dataConUserType dc) + all_dcs = typeEnvDataCons type_env + wanted_dcs | debug = all_dcs + | otherwise = filterOut is_cls_dc all_dcs + is_cls_dc dc = isClassTyCon (dataConTyCon dc) + +ppr_patsyns :: TypeEnv -> SDoc +ppr_patsyns type_env + = ppr_things "PATTERN SYNONYMS" ppr_ps + (typeEnvPatSyns type_env) + where + ppr_ps ps = pprPrefixOcc ps <+> dcolon <+> pprPatSynType ps + +ppr_insts :: [ClsInst] -> SDoc +ppr_insts ispecs + = ppr_things "CLASS INSTANCES" pprInstance ispecs + +ppr_fam_insts :: [FamInst] -> SDoc +ppr_fam_insts fam_insts + = ppr_things "FAMILY INSTANCES" pprFamInst fam_insts + +ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc +ppr_things herald ppr_one things + | null things = empty + | otherwise = text herald $$ nest 2 (vcat (map ppr_one things)) + +hasTopUserName :: NamedThing x => x -> Bool +-- A top-level thing whose name is not "derived" +-- Thus excluding things like $tcX, from Typeable boilerplate +-- and C:Coll from class-dictionary data constructors +hasTopUserName x + = isExternalName name && not (isDerivedOccName (nameOccName name)) + where + name = getName x + +{- +******************************************************************************** + +Type Checker Plugins + +******************************************************************************** +-} + +withTcPlugins :: HscEnv -> TcM a -> TcM a +withTcPlugins hsc_env m = + do let plugins = getTcPlugins (hsc_dflags hsc_env) + case plugins of + [] -> m -- Common fast case + _ -> do ev_binds_var <- newTcEvBinds + (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins + -- This ensures that tcPluginStop is called even if a type + -- error occurs during compilation (Fix of #10078) + eitherRes <- tryM $ do + updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m + mapM_ (flip runTcPluginM ev_binds_var) stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + startPlugin ev_binds_var (TcPlugin start solve stop) = + do s <- runTcPluginM start ev_binds_var + return (solve s, stop s) + +getTcPlugins :: DynFlags -> [GHC.Tc.Utils.Monad.TcPlugin] +getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args) + + +withHoleFitPlugins :: HscEnv -> TcM a -> TcM a +withHoleFitPlugins hsc_env m = + case (getHfPlugins (hsc_dflags hsc_env)) of + [] -> m -- Common fast case + plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins + -- This ensures that hfPluginStop is called even if a type + -- error occurs during compilation. + eitherRes <- tryM $ do + updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m + sequence_ stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + startPlugin (HoleFitPluginR init plugin stop) = + do ref <- init + return (plugin ref, stop ref) + +getHfPlugins :: DynFlags -> [HoleFitPluginR] +getHfPlugins dflags = + catMaybes $ mapPlugins dflags (\p args -> holeFitPlugin p args) + + +runRenamerPlugin :: TcGblEnv + -> HsGroup GhcRn + -> TcM (TcGblEnv, HsGroup GhcRn) +runRenamerPlugin gbl_env hs_group = do + dflags <- getDynFlags + withPlugins dflags + (\p opts (e, g) -> ( mark_plugin_unsafe dflags >> renamedResultAction p opts e g)) + (gbl_env, hs_group) + + +-- XXX: should this really be a Maybe X? Check under which circumstances this +-- can become a Nothing and decide whether this should instead throw an +-- exception/signal an error. +type RenamedStuff = + (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], + Maybe LHsDocString)) + +-- | Extract the renamed information from TcGblEnv. +getRenamedStuff :: TcGblEnv -> RenamedStuff +getRenamedStuff tc_result + = fmap (\decls -> ( decls, tcg_rn_imports tc_result + , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) ) + (tcg_rn_decls tc_result) + +runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv +runTypecheckerPlugin sum hsc_env gbl_env = do + let dflags = hsc_dflags hsc_env + withPlugins dflags + (\p opts env -> mark_plugin_unsafe dflags + >> typeCheckResultAction p opts sum env) + gbl_env + +mark_plugin_unsafe :: DynFlags -> TcM () +mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $ + recordUnsafeInfer pluginUnsafe + where + unsafeText = "Use of plugins makes the module unsafe" + pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan + (Outputable.text unsafeText) ) diff --git a/compiler/GHC/Tc/Module.hs-boot b/compiler/GHC/Tc/Module.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Module.hs-boot @@ -0,0 +1,12 @@ +module GHC.Tc.Module where + +import GHC.Prelude +import GHC.Core.Type(TyThing) +import GHC.Tc.Types (TcM) +import GHC.Utils.Outputable (SDoc) +import GHC.Types.Name (Name) + +checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) + -> TyThing -> TyThing -> TcM () +missingBootThing :: Bool -> Name -> String -> SDoc +badReexportedBootThing :: Bool -> Name -> Name -> SDoc diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Plugin.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE CPP #-} +-- | This module provides an interface for typechecker plugins to +-- access select functions of the 'TcM', principally those to do with +-- reading parts of the state. +module GHC.Tc.Plugin ( + -- * Basic TcPluginM functionality + TcPluginM, + tcPluginIO, + tcPluginTrace, + unsafeTcPluginTcM, + + -- * Finding Modules and Names + FindResult(..), + findImportedModule, + lookupOrig, + + -- * Looking up Names in the typechecking environment + tcLookupGlobal, + tcLookupTyCon, + tcLookupDataCon, + tcLookupClass, + tcLookup, + tcLookupId, + + -- * Getting the TcM state + getTopEnv, + getEnvs, + getInstEnvs, + getFamInstEnvs, + matchFam, + + -- * Type variables + newUnique, + newFlexiTyVar, + isTouchableTcPluginM, + + -- * Zonking + zonkTcType, + zonkCt, + + -- * Creating constraints + newWanted, + newDerived, + newGiven, + newCoercionHole, + + -- * Manipulating evidence bindings + newEvVar, + setEvBind, + getEvBindsTcPluginM + ) where + +import GHC.Prelude + +import qualified GHC.Tc.Utils.Monad as TcM +import qualified GHC.Tc.Solver.Monad as TcS +import qualified GHC.Tc.Utils.Env as TcM +import qualified GHC.Tc.Utils.TcMType as TcM +import qualified GHC.Tc.Instance.Family as TcM +import qualified GHC.Iface.Env as IfaceEnv +import qualified GHC.Driver.Finder as Finder + +import GHC.Core.FamInstEnv ( FamInstEnv ) +import GHC.Tc.Utils.Monad ( TcGblEnv, TcLclEnv, TcPluginM + , unsafeTcPluginTcM, getEvBindsTcPluginM + , liftIO, traceTc ) +import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..), ctLocOrigin ) +import GHC.Tc.Utils.TcMType ( TcTyVar, TcType ) +import GHC.Tc.Utils.Env ( TcTyThing ) +import GHC.Tc.Types.Evidence ( TcCoercion, CoercionHole, EvTerm(..) + , EvExpr, EvBind, mkGivenEvBind ) +import GHC.Types.Var ( EvVar ) + +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.Class +import GHC.Driver.Types +import GHC.Utils.Outputable +import GHC.Core.Type +import GHC.Core.Coercion ( BlockSubstFlag(..) ) +import GHC.Types.Id +import GHC.Core.InstEnv +import GHC.Data.FastString +import GHC.Types.Unique + + +-- | Perform some IO, typically to interact with an external tool. +tcPluginIO :: IO a -> TcPluginM a +tcPluginIO a = unsafeTcPluginTcM (liftIO a) + +-- | Output useful for debugging the compiler. +tcPluginTrace :: String -> SDoc -> TcPluginM () +tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) + + +findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult +findImportedModule mod_name mb_pkg = do + hsc_env <- getTopEnv + tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg + +lookupOrig :: Module -> OccName -> TcPluginM Name +lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod + + +tcLookupGlobal :: Name -> TcPluginM TyThing +tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal + +tcLookupTyCon :: Name -> TcPluginM TyCon +tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon + +tcLookupDataCon :: Name -> TcPluginM DataCon +tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon + +tcLookupClass :: Name -> TcPluginM Class +tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass + +tcLookup :: Name -> TcPluginM TcTyThing +tcLookup = unsafeTcPluginTcM . TcM.tcLookup + +tcLookupId :: Name -> TcPluginM Id +tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId + + +getTopEnv :: TcPluginM HscEnv +getTopEnv = unsafeTcPluginTcM TcM.getTopEnv + +getEnvs :: TcPluginM (TcGblEnv, TcLclEnv) +getEnvs = unsafeTcPluginTcM TcM.getEnvs + +getInstEnvs :: TcPluginM InstEnvs +getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs + +getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv) +getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs + +matchFam :: TyCon -> [Type] + -> TcPluginM (Maybe (TcCoercion, TcType)) +matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args + +newUnique :: TcPluginM Unique +newUnique = unsafeTcPluginTcM TcM.newUnique + +newFlexiTyVar :: Kind -> TcPluginM TcTyVar +newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar + +isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool +isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM + +-- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType. +zonkTcType :: TcType -> TcPluginM TcType +zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType + +zonkCt :: Ct -> TcPluginM Ct +zonkCt = unsafeTcPluginTcM . TcM.zonkCt + + +-- | Create a new wanted constraint. +newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence +newWanted loc pty + = unsafeTcPluginTcM (TcM.newWanted (ctLocOrigin loc) Nothing pty) + +-- | Create a new derived constraint. +newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence +newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc } + +-- | Create a new given constraint, with the supplied evidence. This +-- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it +-- will panic. +newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence +newGiven loc pty evtm = do + new_ev <- newEvVar pty + setEvBind $ mkGivenEvBind new_ev (EvExpr evtm) + return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc } + +-- | Create a fresh evidence variable. +newEvVar :: PredType -> TcPluginM EvVar +newEvVar = unsafeTcPluginTcM . TcM.newEvVar + +-- | Create a fresh coercion hole. +newCoercionHole :: PredType -> TcPluginM CoercionHole +newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole YesBlockSubst + +-- | Bind an evidence variable. This must not be invoked from +-- 'tcPluginInit' or 'tcPluginStop', or it will panic. +setEvBind :: EvBind -> TcPluginM () +setEvBind ev_bind = do + tc_evbinds <- getEvBindsTcPluginM + unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Solver.hs @@ -0,0 +1,2727 @@ +{-# LANGUAGE CPP #-} + +module GHC.Tc.Solver( + simplifyInfer, InferMode(..), + growThetaTyVars, + simplifyAmbiguityCheck, + simplifyDefault, + simplifyTop, simplifyTopImplic, + simplifyInteractive, + solveEqualities, solveLocalEqualities, solveLocalEqualitiesX, + simplifyWantedsTcM, + tcCheckSatisfiability, + tcNormalise, + + captureTopConstraints, + + simpl_top, + + promoteTyVar, + promoteTyVarSet, + + -- For Rules we need these + solveWanteds, solveWantedsAndDrop, + approximateWC, runTcSDeriveds + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Core.Class ( Class, classKey, classTyCon ) +import GHC.Driver.Session +import GHC.Types.Id ( idType, mkLocalId ) +import GHC.Tc.Utils.Instantiate +import GHC.Data.List.SetOps +import GHC.Types.Name +import GHC.Utils.Outputable +import GHC.Builtin.Utils +import GHC.Builtin.Names +import GHC.Tc.Errors +import GHC.Tc.Types.Evidence +import GHC.Tc.Solver.Interact +import GHC.Tc.Solver.Canonical ( makeSuperClasses, solveCallStack ) +import GHC.Tc.Utils.TcMType as TcM +import GHC.Tc.Utils.Monad as TcM +import GHC.Tc.Solver.Monad as TcS +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Builtin.Types ( liftedRepTy ) +import GHC.Core.Unify ( tcMatchTyKi ) +import GHC.Utils.Misc +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Unique.Set +import GHC.Types.Basic ( IntWithInf, intGtLimit ) +import GHC.Utils.Error ( emptyMessages ) +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 ( 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 solveLocalEqualities (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 + ; MASSERT2( 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 <- simpl_top 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 $ WC { wc_simple = unsafe_ol + , wc_impl = emptyBag } + + ; whyUnsafe <- fst <$> TcM.readTcRef errs_var + ; TcM.writeTcRef errs_var saved_msg + ; recordUnsafeInfer whyUnsafe + } + ; traceTc "reportUnsolved (unsafe overlapping) }" empty + + ; return (evBindMapBinds binds1 `unionBags` binds2) } + + +-- | Type-check a thing that emits only equality constraints, solving any +-- constraints we can and re-emitting constraints that we can't. The thing_inside +-- should generally bump the TcLevel to make sure that this run of the solver +-- doesn't affect anything lying around. +solveLocalEqualities :: String -> TcM a -> TcM a +solveLocalEqualities callsite thing_inside + = do { (wanted, res) <- solveLocalEqualitiesX callsite thing_inside + ; emitConstraints wanted + + -- See Note [Fail fast if there are insoluble kind equalities] + ; when (insolubleWC wanted) $ + failM + + ; return res } + +{- Note [Fail fast if there are insoluble kind equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rather like in simplifyInfer, fail fast if there is an insoluble +constraint. Otherwise we'll just succeed in kind-checking a nonsense +type, with a cascade of follow-up errors. + +For example polykinds/T12593, T15577, and many others. + +Take care to ensure that you emit the insoluble constraints before +failing, because they are what will ultimately lead to the error +messsage! +-} + +solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a) +solveLocalEqualitiesX callsite thing_inside + = do { traceTc "solveLocalEqualitiesX {" (vcat [ text "Called from" <+> text callsite ]) + + ; (result, wanted) <- captureConstraints thing_inside + + ; traceTc "solveLocalEqualities: running solver" (ppr wanted) + ; residual_wanted <- runTcSEqualities (solveWanteds wanted) + + ; traceTc "solveLocalEqualitiesX end }" $ + text "residual_wanted =" <+> ppr residual_wanted + + ; return (residual_wanted, result) } + +-- | Type-check a thing that emits only equality constraints, then +-- solve those constraints. Fails outright if there is trouble. +-- Use this if you're not going to get another crack at solving +-- (because, e.g., you're checking a datatype declaration) +solveEqualities :: TcM a -> TcM a +solveEqualities thing_inside + = checkNoErrs $ -- See Note [Fail fast on kind errors] + do { lvl <- TcM.getTcLevel + ; traceTc "solveEqualities {" (text "level =" <+> ppr lvl) + + ; (result, wanted) <- captureConstraints thing_inside + + ; traceTc "solveEqualities: running solver" $ text "wanted = " <+> ppr wanted + ; final_wc <- runTcSEqualities $ simpl_top wanted + -- NB: Use simpl_top here so that we potentially default RuntimeRep + -- vars to LiftedRep. This is needed to avoid #14991. + + ; traceTc "End solveEqualities }" empty + ; reportAllUnsolved final_wc + ; return result } + +-- | Simplify top-level constraints, but without reporting any unsolved +-- constraints nor unsafe overlapping. +simpl_top :: WantedConstraints -> TcS WantedConstraints + -- See Note [Top-level Defaulting Plan] +simpl_top wanteds + = do { wc_first_go <- nestTcS (solveWantedsAndDrop 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 { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc) + ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs + -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked + -- filter isMetaTyVar: we might have runtime-skolems in GHCi, + -- and we definitely don't want to try to assign to those! + -- The isTyVar is needed to weed out coercion variables + + ; defaulted <- mapM defaultTyVarTcS meta_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] + = return 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 (solveWantedsAndDrop 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 [Fail fast on kind errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +solveEqualities is used to solve kind equalities when kind-checking +user-written types. If solving fails we should fail outright, rather +than just accumulate an error message, 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, so we + don't build evidence bindings (by usine reportAllUnsolved). That + means that we'll be left with with a type that has coercion holes + in it, something like + |> co-hole + where co-hole is not filled in. Eeek! That un-filled-in + hole actually causes GHC to crash with "fvProv falls into a hole" + See #11563, #11520, #11516, #11399 + +So it's important to use 'checkNoErrs' here! + +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 [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 inferrence 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 simpl_top, 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 an + IORef called `tcg_safeInfer`. + + 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling + `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inferrence + failed. + +Note [No defaulting in the ambiguity check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When simplifying constraints for the ambiguity check, we use +solveWantedsAndDrop, not simpl_top, 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. + +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. +-} + +------------------ +simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () +simplifyAmbiguityCheck ty wanteds + = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds) + ; (final_wc, _) <- runTcS $ solveWantedsAndDrop 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 () -- Succeeds if the constraint is soluble +simplifyDefault theta + = do { traceTc "simplifyDefault" empty + ; wanteds <- newWanteds DefaultOrigin theta + ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds)) + ; reportAllUnsolved unsolved + ; return () } + +------------------ +tcCheckSatisfiability :: Bag EvVar -> TcM Bool +-- Return True if satisfiable, False if definitely contradictory +tcCheckSatisfiability given_ids + = do { lcl_env <- TcM.getLclEnv + ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env + ; (res, _ev_binds) <- runTcS $ + do { traceTcS "checkSatisfiability {" (ppr given_ids) + ; let given_cts = mkGivens given_loc (bagToList given_ids) + -- See Note [Superclasses and satisfiability] + ; solveSimpleGivens given_cts + ; insols <- getInertInsols + ; insols <- try_harder insols + ; traceTcS "checkSatisfiability }" (ppr insols) + ; return (isEmptyBag insols) } + ; return res } + 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 } + +-- | Normalise a type as much as possible using the given constraints. +-- See @Note [tcNormalise]@. +tcNormalise :: Bag EvVar -> Type -> TcM Type +tcNormalise given_ids ty + = do { lcl_env <- TcM.getLclEnv + ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env + ; wanted_ct <- mk_wanted_ct + ; (res, _ev_binds) <- runTcS $ + do { traceTcS "tcNormalise {" (ppr given_ids) + ; let given_cts = mkGivens given_loc (bagToList given_ids) + ; solveSimpleGivens given_cts + ; wcs <- solveSimpleWanteds (unitBag wanted_ct) + -- It's an invariant that this wc_simple will always be + -- a singleton Ct, since that's what we fed in as input. + ; let ty' = case bagToList (wc_simple wcs) of + (ct:_) -> ctEvPred (ctEvidence ct) + cts -> pprPanic "tcNormalise" (ppr cts) + ; traceTcS "tcNormalise }" (ppr ty') + ; pure ty' } + ; return res } + where + mk_wanted_ct :: TcM Ct + mk_wanted_ct = do + let occ = mkVarOcc "$tcNorm" + name <- newSysName occ + let ev = mkLocalId name ty + newHoleCt ExprHole ev ty + +{- Note [Superclasses and satisfiability] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 stratightforard 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 local constraints, 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 Check. + +To accomplish its stated goal, tcNormalise first feeds the local constraints +into solveSimpleGivens, then stuffs the argument type in a CHoleCan, and feeds +that singleton Ct into solveSimpleWanteds, which reduces the type in the +CHoleCan as much as possible with respect to the local given constraints. When +solveSimpleWanteds is finished, we dig out the type from the CHoleCan and +return that. + +*********************************************************************************** +* * +* 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. + +-} + +-- | 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 TcType.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 + WantedConstraints, -- Redidual as-yet-unsolved constraints + 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 + , (_,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) + ; qtkvs <- quantifyTyVars dep_vars + ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) + ; return (qtkvs, [], emptyTcEvBinds, emptyWC, 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. + + ; tc_env <- TcM.getEnv + ; ev_binds_var <- TcM.newTcEvBinds + ; psig_theta_vars <- mapM TcM.newEvVar psig_theta + ; wanted_transformed_incl_derivs + <- setTcLevel rhs_tclvl $ + runTcSWithEvBinds ev_binds_var $ + do { let loc = mkGivenLoc rhs_tclvl UnkSkol $ + env_lcl tc_env + psig_givens = mkGivens loc psig_theta_vars + ; _ <- solveSimpleGivens psig_givens + -- See Note [Add signature contexts as givens] + ; solveWanteds wanteds } + + -- 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_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs + ; let definite_error = insolubleWC wanted_transformed_incl_derivs + -- See Note [Quantification with errors] + -- NB: must include derived errors in this test, + -- hence "incl_derivs" + wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs + 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 + ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl + name_taus partial_sigs + quant_pred_candidates + ; bound_theta_vars <- mapM TcM.newEvVar bound_theta + + -- We must produce bindings for the psig_theta_vars, because we may have + -- used them in evidence bindings constructed by solveWanteds earlier + -- Easiest way to do this is to emit them as new Wanteds (#14643) + ; ct_loc <- getCtLocM AnnOrigin Nothing + ; let psig_wanted = [ CtWanted { ctev_pred = idType psig_theta_var + , ctev_dest = EvVarDest psig_theta_var + , ctev_nosh = WDeriv + , ctev_loc = ct_loc } + | psig_theta_var <- psig_theta_vars ] + + -- Now construct the residual constraint + ; residual_wanted <- mkResidualConstraints rhs_tclvl ev_binds_var + name_taus co_vars qtvs bound_theta_vars + (wanted_transformed `andWC` mkSimpleWC psig_wanted) + + -- 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 =" <+> ppr bound_theta + , text "qtvs =" <+> ppr qtvs + , text "definite_error =" <+> ppr definite_error ] + + ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var + , residual_wanted, definite_error ) } + -- NB: bound_theta_vars must be fully zonked + where + partial_sigs = filter isPartialSig sigs + +-------------------- +mkResidualConstraints :: TcLevel -> EvBindsVar + -> [(Name, TcTauType)] + -> VarSet -> [TcTyVar] -> [EvVar] + -> WantedConstraints -> TcM WantedConstraints +-- Emit the remaining constraints from the RHS. +-- See Note [Emitting the residual implication in simplifyInfer] +mkResidualConstraints rhs_tclvl ev_binds_var + name_taus co_vars qtvs full_theta_vars wanteds + | isEmptyWC wanteds + = return wanteds + + | otherwise + = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds) + ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple + is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars + + ; _ <- 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_telescope = Nothing + , ic_given = full_theta_vars + , ic_wanted = inner_wanted + , ic_binds = ev_binds_var + , ic_no_eqs = False + , ic_info = skol_info } + + ; return (WC { 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 ] + -- 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 ] + +{- 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 givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#11016): + f2 :: (?x :: Int) => _ + f2 = ?x +or this + f3 :: a ~ Bool => (a, _) + f3 = (True, False) +or theis + f4 :: (Ord a, _) => a -> Bool + f4 x = x==x + +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 we want the (a ~ Bool) available to solve the wanted (a ~ Bool) + in the RHS + * For f4 we want to use the (Ord a) in the signature to solve the Eq a + constraint. + +Solution: in simplifyInfer, just before simplifying the constraints +gathered from the RHS, add Given constraints for the context of any +type signatures. + +************************************************************************ +* * + Quantification +* * +************************************************************************ + +Note [Deciding quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the monomorphism restriction does not apply, then we quantify as follows: + +* Step 1. Take the global tyvars, and "grow" them using the equality + constraints + 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 + + 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. 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. + +* Step 3: decide which variables to quantify over, as follows: + + - Take the free vars of the tau-type (zonked_tau_tvs) and "grow" + them using all the constraints. These are tau_tvs_plus + + - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being + careful to close over kinds, and to skolemise the quantified tyvars. + (This actually unifies each quantifies meta-tyvar with a fresh skolem.) + + 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. + +-} + +decideQuantification + :: 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) + , VarSet) +-- See Note [Deciding quantification] +decideQuantification 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 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 quantifiable_candidates + = pickQuantifiablePreds (mkVarSet qtvs) candidates + -- NB: do /not/ run pickQuantifiablePreds over psig_theta, + -- because we always want to quantify over psig_theta, and not + -- drop any of them; e.g. CallStack constraints. c.f #14658 + + theta = mkMinimalBySCs id $ -- See Note [Minimize by Superclasses] + (psig_theta ++ quantifiable_candidates) + + ; 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) } + +------------------ +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 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 <- mapM zonkTcTyVarToTyVar $ + 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) + 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 + -- candidates 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 + + eq_constraints = filter isEqPrimPred candidates + mono_tvs2 = growThetaTyVars eq_constraints mono_tvs1 + + constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $ + (growThetaTyVars eq_constraints + (tyCoVarsOfTypes no_quant) + `minusVarSet` mono_tvs2) + `delVarSetList` psig_qtvs + -- 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) + -- + -- (`delVarSetList` psig_qtvs): if the user has explicitly + -- asked for quantification, then that request "wins" + -- over the MR. Note: do /not/ delete psig_qtvs from + -- mono_tvs1, because mono_tvs1 cannot under any circumstances + -- be quantified (#14479); see + -- Note [Quantification and partial signatures], Wrinkle 3, 4 + + mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs + + -- Warn about the monomorphism restriction + ; warn_mono <- woptM Opt_WarnMonomorphism + ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $ + warnTc (Reason Opt_WarnMonomorphism) + (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) + mr_msg + + ; traceTc "decideMonoTyVars" $ vcat + [ text "mono_tvs0 =" <+> ppr mono_tvs0 + , text "no_quant =" <+> ppr no_quant + , text "maybe_quant =" <+> ppr maybe_quant + , text "eq_constraints =" <+> ppr eq_constraints + , 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 + + pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus + mr_msg = + hang (sep [ text "The Monomorphism Restriction applies to the binding" + <> plural name_taus + , text "for" <+> pp_bndrs ]) + 2 (hsep [ text "Consider giving" + , text (if isSingleton name_taus then "it" else "them") + , text "a type signature"]) + +------------------- +defaultTyVarsAndSimplify :: TcLevel + -> TyCoVarSet + -> [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 mono_tvs candidates + = do { -- Promote any tyvars that we cannot generalise + -- See Note [Promote momomorphic tyvars] + ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs) + ; (prom, _) <- 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 + ; default_kvs <- mapM (default_one poly_kinds True) + (dVarSetElems cand_kvs) + ; default_tvs <- mapM (default_one poly_kinds False) + (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) + ; let some_default = or default_kvs || or default_tvs + + ; case () of + _ | some_default -> simplify_cand candidates + | prom -> mapM TcM.zonkTcType candidates + | otherwise -> return candidates + } + where + default_one poly_kinds is_kind_var tv + | not (isMetaTyVar tv) + = return False + | tv `elemVarSet` mono_tvs + = return False + | otherwise + = defaultTyVar (not poly_kinds && is_kind_var) tv + + 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 + :: [(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 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 + , (_,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' + 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 "candidates =" <+> ppr candidates + , 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 dvs_plus } + +------------------ +growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet +-- See Note [Growing the tau-tvs using constraints] +growThetaTyVars theta tcvs + | null theta = tcvs + | otherwise = transCloVarSet mk_next seed_tcvs + where + seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips + (ips, non_ips) = partition isIPPred theta + -- See Note [Inheriting implicit parameters] in GHC.Tc.Utils.TcType + + 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 momomorphic 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: promoteTyVar 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, be 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 (HoleCan (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 [Growing the tau-tvs using constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(growThetaTyVars insts tvs) is the result of extending the set + of tyvars, tvs, using all conceivable links from pred + +E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e} +Then growThetaTyVars preds tvs = {a,b,c} + +Notice that + growThetaTyVars is conservative if v might be fixed by vs + => v `elem` grow(vs,C) + +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. + +NB that we must include *derived* errors in the check for insolubles. +Example: + (a::*) ~ Int# +We get an insoluble derived error *~#, and we don't want to discard +it before doing the isInsolubleWC test! (#8262) + +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 +-- Discards all Derived stuff in result +-- Postcondition: fully zonked and unflattened constraints +simplifyWantedsTcM wanted + = do { traceTc "simplifyWantedsTcM {" (ppr wanted) + ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted)) + ; result <- TcM.zonkWC result + ; traceTc "simplifyWantedsTcM }" (ppr result) + ; return result } + +solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints +-- Since solveWanteds returns the residual WantedConstraints, +-- it should always be called within a runTcS or something similar, +-- Result is not zonked +solveWantedsAndDrop wanted + = do { wc <- solveWanteds wanted + ; return (dropDerivedWC wc) } + +solveWanteds :: WantedConstraints -> TcS WantedConstraints +-- so that the inert set doesn't mindlessly propagate. +-- NB: wc_simples may be wanted /or/ derived now +solveWanteds wc@(WC { wc_simple = simples, wc_impl = implics }) + = do { cur_lvl <- TcS.getTcLevel + ; traceTcS "solveWanteds {" $ + vcat [ text "Level =" <+> ppr cur_lvl + , ppr wc ] + + ; wc1 <- solveSimpleWanteds simples + -- Any insoluble constraints are in 'simples' and so get rewritten + -- See Note [Rewrite insolubles] in GHC.Tc.Solver.Monad + + ; (floated_eqs, implics2) <- solveNestedImplications $ + implics `unionBags` wc_impl wc1 + + ; dflags <- getDynFlags + ; final_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs + (wc1 { wc_impl = implics2 }) + + ; 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 } + +simpl_loop :: Int -> IntWithInf -> Cts + -> WantedConstraints -> TcS WantedConstraints +simpl_loop n limit floated_eqs 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 (hang (text "solveWanteds: too many iterations" + <+> parens (text "limit =" <+> ppr limit)) + 2 (vcat [ text "Unsolved:" <+> ppr wc + , ppUnless (isEmptyBag floated_eqs) $ + text "Floated equalities:" <+> ppr floated_eqs + , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" + ])) + ; return wc } + + | not (isEmptyBag floated_eqs) + = simplify_again n limit True (wc { wc_simple = floated_eqs `unionBags` simples }) + -- Put floated_eqs first so they get solved first + -- NB: the floated_eqs may include /derived/ equalities + -- arising from fundeps inside an implication + + | 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_again n limit (null pending_given) + wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } } + + | otherwise + = return wc + +simplify_again :: Int -> IntWithInf -> Bool + -> WantedConstraints -> TcS WantedConstraints +-- We have definitely decided to have another go at solving +-- the wanted constraints (we have tried at least once already +simplify_again n limit no_new_given_scs + wc@(WC { wc_simple = simples, wc_impl = implics }) + = do { csTraceTcS $ + text "simpl_loop iteration=" <> int n + <+> (parens $ hsep [ text "no new given superclasses =" <+> ppr no_new_given_scs <> comma + , int (lengthBag simples) <+> text "simples to solve" ]) + ; traceTcS "simpl_loop: wc =" (ppr wc) + + ; (unifs1, wc1) <- reportUnifications $ + solveSimpleWanteds $ + simples + + -- See Note [Cutting off simpl_loop] + -- We have already tried to solve the nested implications once + -- Try again only if we have unified some meta-variables + -- (which is a bit like adding more givens), or we have some + -- new Given superclasses + ; let new_implics = wc_impl wc1 + ; if unifs1 == 0 && + no_new_given_scs && + isEmptyBag new_implics + + then -- Do not even try to solve the implications + simpl_loop (n+1) limit emptyBag (wc1 { wc_impl = implics }) + + else -- Try to solve the implications + do { (floated_eqs2, implics2) <- solveNestedImplications $ + implics `unionBags` new_implics + ; simpl_loop (n+1) limit floated_eqs2 (wc1 { wc_impl = implics2 }) + } } + +solveNestedImplications :: Bag Implication + -> TcS (Cts, 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, emptyBag) + | otherwise + = do { traceTcS "solveNestedImplications starting {" empty + ; (floated_eqs_s, unsolved_implics) <- mapAndUnzipBagM solveImplication implics + ; let floated_eqs = concatBag floated_eqs_s + + -- ... 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 "all floated_eqs =" <+> ppr floated_eqs + , text "unsolved_implics =" <+> ppr unsolved_implics ] + + ; return (floated_eqs, catBagMaybes unsolved_implics) } + +solveImplication :: Implication -- Wanted + -> TcS (Cts, -- All wanted or derived floated equalities: var = type + 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_skols = skols + , ic_given = given_ids + , ic_wanted = wanteds + , ic_info = info + , ic_status = status }) + | isSolvedStatus status + = return (emptyCts, 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 + ; (no_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 + -- solveWanteds, *not* solveWantedsAndDrop, because + -- we want to retain derived equalities so we can float + -- them out in floatEqualities + + ; (no_eqs, given_insols) <- getNoGivenEqs tclvl skols + -- Call getNoGivenEqs /after/ solveWanteds, because + -- solveWanteds can augment the givens, via expandSuperClasses, + -- to reveal given superclass equalities + + ; return (no_eqs, given_insols, residual_wanted) } + + ; (floated_eqs, residual_wanted) + <- floatEqualities skols given_ids ev_binds_var + no_given_eqs 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_no_eqs = no_given_eqs + , ic_wanted = final_wanted }) + + ; evbinds <- TcS.getTcEvBindsMap ev_binds_var + ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var + ; traceTcS "solveImplication end }" $ vcat + [ text "no_given_eqs =" <+> ppr no_given_eqs + , text "floated_eqs =" <+> ppr floated_eqs + , text "res_implic =" <+> ppr res_implic + , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) + , text "implication tvcs =" <+> ppr tcvs ] + + ; return (floated_eqs, res_implic) } + + where + -- TcLevels must be strictly increasing (see (ImplicInv) in + -- Note [TcLevel and untouchable type variables] 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 + ; MASSERT2( 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: +-- * Set the ic_status field +-- * Trim the ic_wanted field to remove Derived constraints +-- 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 }) + | ASSERT2( 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 dead_givens | warnRedundantGivens info + = filterOut (`elemVarSet` need_inner) givens + | otherwise = [] -- None to report + + discard_entire_implication -- Can we discard the entire implication? + = null dead_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 = dead_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 + + pruned_simples = dropDerivedSimples simples + pruned_implics = filterBag keep_me implics + pruned_wc = WC { wc_simple = pruned_simples + , wc_impl = pruned_implics } + + 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 + +checkBadTelescope :: Implication -> TcS Bool +-- True <=> the skolems form a bad telescope +-- See Note [Checking telescopes] in GHC.Tc.Types.Constraint +checkBadTelescope (Implic { ic_telescope = m_telescope + , ic_skols = skols }) + | isJust m_telescope + = 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 :: SkolemInfo -> Bool +warnRedundantGivens (SigSkol ctxt _ _) + = case ctxt of + FunSigCtxt _ warn_redundant -> warn_redundant + ExprSigCtxt -> True + _ -> 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 = foldEvBindMap add_wanted seeds1 ev_binds + seeds3 = seeds2 `unionVarSet` tcvs + need_inner = findNeededEvVars ev_binds seeds3 + live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds + need_outer = foldEvBindMap del_ev_bndr need_inner live_ev_binds + `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 + + del_ev_bndr :: EvBind -> VarSet -> VarSet + del_ev_bndr (EvBind { eb_lhs = v }) needs = delVarSet needs v + + add_wanted :: EvBind -> VarSet -> VarSet + add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs + | is_given = needs -- Add the rhs vars of the Wanted bindings only + | otherwise = evVarsOfTerm rhs `unionVarSet` needs + + +{- 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_looop), 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 [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: + +----- 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 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 + b) 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 + +* To find (a), when we have two Given constraints, + we must be careful to drop the one that is a naked variable (if poss). + So if we have + f :: (Eq a, Ord a) => blah + then we may find [G] sc_sel (d1::Ord a) :: Eq a + [G] d2 :: Eq a + We want to discard d2 in favour of the superclass selection from + the Ord dictionary. This is done by GHC.Tc.Solver.Interact.solveOneFromTheOther + See Note [Replacement vs keeping]. + +* To find (b) we need to know which evidence bindings are 'wanted'; + hence the eb_is_given field on an EvBind. + +----- How tracking works + +* 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. + +* 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, + c) it is in the ics_need of a nested implication. + +* 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. + +----- 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 (see #9939) + f2 :: (Eq a, Ord a) => a -> a -> Bool + -- Ord a redundant, but Eq a is reported + f2 x y = (x == y) + +We report (Eq a) as redundant, whereas actually (Ord a) is. But it's +really not easy to detect that! + + +Note [Cutting off simpl_loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very important not to iterate in simpl_loop unless there is a chance +of progress. #8474 is a classic 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 [D] alpha ~ Int, + but alpha is untouchable until we get out to the outermost one + + * We float [D] alpha~Int out (it is in floated_eqs), but since alpha + is untouchable, the solveInteract in simpl_loop makes no progress + + * So there is no point in attempting to re-solve + ?yn:betan => [W] ?x:Int + via solveNestedImplications, because we'll just get the + same [D] again + + * If we *do* re-solve, we'll get an infinite loop. It is cut off by + the fixed bound of 10, but solving the next takes 10*10*...*10 (ie + exponentially many) iterations! + +Conclusion: we should call solveNestedImplications only if we did +some unification in solveSimpleWanteds; because that's the only way +we'll get more Givens (a unification is like adding a Given) to +allow the implication to make progress. +-} + +promoteTyVar :: TcTyVar -> TcM (Bool, TcTyVar) +-- When we float a constraint out of an implication we must restore +-- invariant (WantedInv) in Note [TcLevel and untouchable type variables] 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] +promoteTyVar tv + = do { tclvl <- TcM.getTcLevel + ; if (isFloatedTouchableMetaTyVar tclvl tv) + then do { cloned_tv <- TcM.cloneMetaTyVar tv + ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl + ; TcM.writeMetaTyVar tv (mkTyVarTy rhs_tv) + ; return (True, rhs_tv) } + else return (False, tv) } + +-- Returns whether or not *any* tyvar is defaulted +promoteTyVarSet :: TcTyVarSet -> TcM (Bool, TcTyVarSet) +promoteTyVarSet tvs + = do { (bools, tyvars) <- mapAndUnzipM promoteTyVar (nonDetEltsUniqSet tvs) + -- non-determinism is OK because order of promotion doesn't matter + + ; return (or bools, mkVarSet tyvars) } + +promoteTyVarTcS :: TcTyVar -> TcS () +-- When we float a constraint out of an implication we must restore +-- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in GHC.Tc.Utils.TcType +-- See Note [Promoting unification variables] +-- We don't just call promoteTyVar because we want to use unifyTyVar, +-- not writeMetaTyVar +promoteTyVarTcS tv + = do { tclvl <- TcS.getTcLevel + ; when (isFloatedTouchableMetaTyVar tclvl tv) $ + do { cloned_tv <- TcS.cloneMetaTyVar tv + ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl + ; unifyTyVar tv (mkTyVarTy rhs_tv) } } + +-- | Like 'defaultTyVar', but in the TcS monad. +defaultTyVarTcS :: TcTyVar -> TcS Bool +defaultTyVarTcS the_tv + | isRuntimeRepVar the_tv + , not (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 + = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) + ; unifyTyVar the_tv liftedRepTy + ; return True } + | otherwise + = return False -- the common case + +approximateWC :: Bool -> WantedConstraints -> Cts +-- Postcondition: Wanted or Derived Cts +-- See Note [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` + do_bag (float_implic trapping_tvs) implics + where + + float_implic :: TcTyCoVarSet -> Implication -> Cts + float_implic trapping_tvs imp + | float_past_equalities || ic_no_eqs imp + = 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 + + do_bag :: (a -> Bag c) -> Bag a -> Bag c + do_bag f = foldr (unionBags.f) emptyBag + + is_floatable skol_tvs ct + | isGivenCt ct = False + | isHoleCt 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 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 tcTypeKind (*) 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 derived 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 and untouchable type variables] 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 and untouchable type variables] in +TcType. for the leftover implication. + +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) + + + +********************************************************************************* +* * +* Floating equalities * +* * +********************************************************************************* + +Note [Float Equalities out of Implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For ordinary pattern matches (including existentials) we float +equalities out of implications, for instance: + data T where + MkT :: Eq a => a -> T + f x y = case x of MkT _ -> (y::Int) +We get the implication constraint (x::T) (y::alpha): + forall a. [untouchable=alpha] Eq a => alpha ~ Int +We want to float out the equality into a scope where alpha is no +longer untouchable, to solve the implication! + +But we cannot float equalities out of implications whose givens may +yield or contain equalities: + + data T a where + T1 :: T Int + T2 :: T Bool + T3 :: T a + + h :: T a -> a -> Int + + f x y = case x of + T1 -> y::Int + T2 -> y::Bool + T3 -> h x y + +We generate constraint, for (x::T alpha) and (y :: beta): + [untouchables = beta] (alpha ~ Int => beta ~ Int) -- From 1st branch + [untouchables = beta] (alpha ~ Bool => beta ~ Bool) -- From 2nd branch + (alpha ~ beta) -- From 3rd branch + +If we float the equality (beta ~ Int) outside of the first implication and +the equality (beta ~ Bool) out of the second we get an insoluble constraint. +But if we just leave them inside the implications, we unify alpha := beta and +solve everything. + +Principle: + We do not want to float equalities out which may + need the given *evidence* to become soluble. + +Consequence: classes with functional dependencies don't matter (since there is +no evidence for a fundep equality), but equality superclasses do matter (since +they carry evidence). +-} + +floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> Bool + -> WantedConstraints + -> TcS (Cts, WantedConstraints) +-- Main idea: see Note [Float Equalities out of Implications] +-- +-- Precondition: the wc_simple of the incoming WantedConstraints are +-- fully zonked, so that we can see their free variables +-- +-- Postcondition: The returned floated constraints (Cts) are only +-- Wanted or Derived +-- +-- Also performs some unifications (via promoteTyVar), adding to +-- monadically-carried ty_binds. These will be used when processing +-- floated_eqs later +-- +-- Subtleties: Note [Float equalities from under a skolem binding] +-- Note [Skolem escape] +-- Note [What prevents a constraint from floating] +floatEqualities skols given_ids ev_binds_var no_given_eqs + wanteds@(WC { wc_simple = simples }) + | not no_given_eqs -- There are some given equalities, so don't float + = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] + + | otherwise + = do { -- First zonk: the inert set (from whence they came) is fully + -- zonked, but unflattening may have filled in unification + -- variables, and we /must/ see them. Otherwise we may float + -- constraints that mention the skolems! + simples <- TcS.zonkSimples simples + ; binds <- TcS.getTcEvBindsMap ev_binds_var + + -- Now we can pick the ones to float + -- The constraints are un-flattened and de-canonicalised + ; let (candidate_eqs, no_float_cts) = partitionBag is_float_eq_candidate simples + + seed_skols = mkVarSet skols `unionVarSet` + mkVarSet given_ids `unionVarSet` + foldr add_non_flt_ct emptyVarSet no_float_cts `unionVarSet` + foldEvBindMap add_one_bind emptyVarSet binds + -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3) + -- Include the EvIds of any non-floating constraints + + extended_skols = transCloVarSet (add_captured_ev_ids candidate_eqs) seed_skols + -- extended_skols contains the EvIds of all the trapped constraints + -- See Note [What prevents a constraint from floating] (3) + + (flt_eqs, no_flt_eqs) = partitionBag (is_floatable extended_skols) + candidate_eqs + + remaining_simples = no_float_cts `andCts` no_flt_eqs + + -- Promote any unification variables mentioned in the floated equalities + -- See Note [Promoting unification variables] + ; mapM_ promoteTyVarTcS (tyCoVarsOfCtsList flt_eqs) + + ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols + , text "Extended skols =" <+> ppr extended_skols + , text "Simples =" <+> ppr simples + , text "Candidate eqs =" <+> ppr candidate_eqs + , text "Floated eqs =" <+> ppr flt_eqs]) + ; return ( flt_eqs, wanteds { wc_simple = remaining_simples } ) } + + where + add_one_bind :: EvBind -> VarSet -> VarSet + add_one_bind bind acc = extendVarSet acc (evBindVar bind) + + add_non_flt_ct :: Ct -> VarSet -> VarSet + add_non_flt_ct ct acc | isDerivedCt ct = acc + | otherwise = extendVarSet acc (ctEvId ct) + + is_floatable :: VarSet -> Ct -> Bool + is_floatable skols ct + | isDerivedCt ct = not (tyCoVarsOfCt ct `intersectsVarSet` skols) + | otherwise = not (ctEvId ct `elemVarSet` skols) + + add_captured_ev_ids :: Cts -> VarSet -> VarSet + add_captured_ev_ids cts skols = foldr extra_skol emptyVarSet cts + where + extra_skol ct acc + | isDerivedCt ct = acc + | tyCoVarsOfCt ct `intersectsVarSet` skols = extendVarSet acc (ctEvId ct) + | otherwise = acc + + -- Identify which equalities are candidates for floating + -- Float out alpha ~ ty, or ty ~ alpha which might be unified outside + -- See Note [Which equalities to float] + is_float_eq_candidate ct + | pred <- ctPred ct + , EqPred NomEq ty1 ty2 <- classifyPredType pred + = case (tcGetTyVar_maybe ty1, tcGetTyVar_maybe ty2) of + (Just tv1, _) -> float_tv_eq_candidate tv1 ty2 + (_, Just tv2) -> float_tv_eq_candidate tv2 ty1 + _ -> False + | otherwise = False + + float_tv_eq_candidate tv1 ty2 -- See Note [Which equalities to float] + = isMetaTyVar tv1 + && (not (isTyVarTyVar tv1) || isTyVarTy ty2) + + +{- Note [Float equalities from under a skolem binding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Which of the simple equalities can we float out? Obviously, only +ones that don't mention the skolem-bound variables. But that is +over-eager. Consider + [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int +The second constraint doesn't mention 'a'. But if we float it, +we'll promote gamma[2] to gamma'[1]. Now suppose that we learn that +beta := Bool, and F a Bool = a, and G Bool _ = Int. Then we'll +we left with the constraint + [2] forall a. a ~ gamma'[1] +which is insoluble because gamma became untouchable. + +Solution: float only constraints that stand a jolly good chance of +being soluble simply by being floated, namely ones of form + a ~ ty +where 'a' is a currently-untouchable unification variable, but may +become touchable by being floated (perhaps by more than one level). + +We had a very complicated rule previously, but this is nice and +simple. (To see the notes, look at this Note in a version of +GHC.Tc.Solver prior to Oct 2014). + +Note [Which equalities to float] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Which equalities should we float? We want to float ones where there +is a decent chance that floating outwards will allow unification to +happen. In particular, float out equalities that are: + +* Of form (alpha ~# ty) or (ty ~# alpha), where + * alpha is a meta-tyvar. + * And 'alpha' is not a TyVarTv with 'ty' being a non-tyvar. In that + case, floating out won't help either, and it may affect grouping + of error messages. + +* Nominal. No point in floating (alpha ~R# ty), because we do not + unify representational equalities even if alpha is touchable. + See Note [Do not unify representational equalities] in GHC.Tc.Solver.Interact. + +Note [Skolem escape] +~~~~~~~~~~~~~~~~~~~~ +You might worry about skolem escape with all this floating. +For example, consider + [2] forall a. (a ~ F beta[2] delta, + Maybe beta[2] ~ gamma[1]) + +The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and +solve with gamma := beta. But what if later delta:=Int, and + F b Int = b. +Then we'd get a ~ beta[2], and solve to get beta:=a, and now the +skolem has escaped! + +But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2] +to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be. + +Note [What prevents a constraint from floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What /prevents/ a constraint from floating? If it mentions one of the +"bound variables of the implication". What are they? + +The "bound variables of the implication" are + + 1. The skolem type variables `ic_skols` + + 2. The "given" evidence variables `ic_given`. Example: + forall a. (co :: t1 ~# t2) => [W] co2 : (a ~# b |> co) + Here 'co' is bound + + 3. The binders of all evidence bindings in `ic_binds`. Example + forall a. (d :: t1 ~ t2) + EvBinds { (co :: t1 ~# t2) = superclass-sel d } + => [W] co2 : (a ~# b |> co) + Here `co` is gotten by superclass selection from `d`, and the + wanted constraint co2 must not float. + + 4. And the evidence variable of any equality constraint (incl + Wanted ones) whose type mentions a bound variable. Example: + forall k. [W] co1 :: t1 ~# t2 |> co2 + [W] co2 :: k ~# * + Here, since `k` is bound, so is `co2` and hence so is `co1`. + +Here (1,2,3) are handled by the "seed_skols" calculation, and +(4) is done by the transCloVarSet call. + +The possible dependence on givens, and evidence bindings, is more +subtle than we'd realised at first. See #14584. + +How can (4) arise? Suppose we have (k :: *), (a :: k), and ([G} k ~ *). +Then form an equality like (a ~ Int) we might end up with + [W] co1 :: k ~ * + [W] co2 :: (a |> co1) ~ Int + + +********************************************************************************* +* * +* Defaulting and disambiguation * +* * +********************************************************************************* +-} + +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 + + ; 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) } + +findDefaultableGroups + :: ( [Type] + , (Bool,Bool) ) -- (Overloaded strings, extended default rules) + -> WantedConstraints -- Unsolved (wanted or derived) + -> [(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 <- tcGetTyVar_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 -foverloaded-strings is enabled + is_std_class cls = isStandardClass cls || + (ovl_strings && (cls `hasKey` isStringClassKey)) + +------------------------------ +disambigGroup :: [Type] -- The default types + -> (TcTyVar, [Ct]) -- All classes of the form (C a) + -- 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 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 UnkSkol lcl_env + ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred) + wanteds + ; fmap isEmptyWC $ + solveSimpleWanteds $ listToBag $ + map mkNonCanonical wanted_evs } + + | otherwise + = return False + + the_ty = mkTyVarTy the_tv + mb_subst = tcMatchTyKi the_ty default_ty + -- Make sure the kinds match too; hence this call to tcMatchTyKi + -- E.g. suppose the only constraint was (Typeable k (a::k)) + -- With the addition of polykinded defaulting we also want to reject + -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here. + +-- In interactive mode, or with -XExtendedDefaultRules, +-- we default Show a to Show () to avoid graututious errors on "show []" +isInteractiveClass :: Bool -- -XOverloadedStrings? + -> Class -> Bool +isInteractiveClass ovl_strings cls + = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys) + + -- isNumClass adds IsString to the standard numeric classes, + -- when -foverloaded-strings is enabled +isNumClass :: Bool -- -XOverloadedStrings? + -> Class -> Bool +isNumClass ovl_strings cls + = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) + + +{- +Note [Avoiding spurious errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When doing the unification for defaulting, we check for skolem +type variables, and simply don't default them. For example: + f = (*) -- Monomorphic + g :: Num a => a -> a + g x = f x x +Here, we get a complaint when checking the type signature for g, +that g isn't polymorphic enough; but then we get another one when +dealing with the (Num a) context arising from f's definition; +we try to unify a with Int (to default it), but find that it's +already been unified with the rigid variable from g's type sig. + +Note [Multi-parameter defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -XExtendedDefaultRules, we default only based on single-variable +constraints, but do not exclude from defaulting any type variables which also +appear in multi-variable constraints. This means that the following will +default properly: + + default (Integer, Double) + + class A b (c :: Symbol) where + a :: b -> Proxy c + + instance A Integer c where a _ = Proxy + + main = print (a 5 :: Proxy "5") + +Note that if we change the above instance ("instance A Integer") to +"instance A Double", we get an error: + + No instance for (A Integer "5") + +This is because the first defaulted type (Integer) has successfully satisfied +its single-parameter constraints (in this case Num). +-} diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -0,0 +1,2542 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +module GHC.Tc.Solver.Canonical( + canonicalize, + unifyDerived, + makeSuperClasses, maybeSym, + StopOrContinue(..), stopWith, continueWith, + solveCallStack -- For GHC.Tc.Solver + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Unify( swapOverTyVars, metaTyVarUpdateOK, MetaTyVarUpdateResult(..) ) +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Tc.Solver.Flatten +import GHC.Tc.Solver.Monad +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.EvTerm +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking +import GHC.Core.Coercion +import GHC.Core +import GHC.Types.Id( idType, 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 ) +import GHC.Types.Name.Occurrence ( OccName ) +import GHC.Utils.Outputable +import GHC.Driver.Session( DynFlags ) +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Hs.Types( HsIPName(..) ) + +import GHC.Data.Pair +import GHC.Utils.Misc +import GHC.Data.Bag +import GHC.Utils.Monad +import Control.Monad +import Data.Maybe ( isJust ) +import Data.List ( zip4 ) +import GHC.Types.Basic + +import Data.Bifunctor ( bimap ) +import Data.Foldable ( traverse_ ) + +{- +************************************************************************ +* * +* 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 (except for CHoleCans, arising from holes). 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 flattened 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" #-} + 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 OtherCIS ev + ForAllPred tvs theta p -> do traceTcS "canEvNC:forall" (ppr pred) + canForAllNC ev tvs theta p + where + pred = ctEvPred ev + +canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc })) + = canForAll ev pend_sc + +canonicalize (CIrredCan { cc_ev = ev, cc_status = status }) + | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev) + = -- For insolubles (all of which are equalities, do /not/ flatten 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 + canEqNC ev eq_rel ty1 ty2 + + | otherwise + = canIrred status ev + +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 (CTyEqCan { cc_ev = ev + , cc_tyvar = tv + , cc_rhs = xi + , cc_eq_rel = eq_rel }) + = {-# SCC "canEqLeafTyVarEq" #-} + canEqNC ev eq_rel (mkTyVarTy tv) xi + -- NB: Don't use canEqTyVar because that expects flattened types, + -- and tv and xi may not be flat w.r.t. an updated inert set + +canonicalize (CFunEqCan { cc_ev = ev + , cc_fun = fn + , cc_tyargs = xis1 + , cc_fsk = fsk }) + = {-# SCC "canEqLeafFunEq" #-} + canCFunEqCan ev fn xis1 fsk + +canonicalize (CHoleCan { cc_ev = ev, cc_occ = occ, cc_hole = hole }) + = canHole ev occ hole + +{- +************************************************************************ +* * +* 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 } + + | isWanted ev + , Just ip_name <- isCallStackPred cls tys + , OccurrenceOf func <- ctLocOrigin loc + -- 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.Monad + = 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] + + ; new_ev <- newWantedEvVarNC new_loc pred + + -- Then we solve the wanted by pushing the call-site + -- onto the newly emitted CallStack + ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev) + ; solveCallStack ev ev_cs + + ; canClass new_ev cls tys False } + + | otherwise + = canClass ev cls tys (has_scs cls) + + where + has_scs cls = not (null (classSCTheta cls)) + loc = ctEvLoc ev + 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 + ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys ) + do { (xis, cos, _kind_co) <- flattenArgsNom ev cls_tc tys + ; MASSERT( isTcReflCo _kind_co ) + ; let co = mkTcTyConAppCo Nominal cls_tc cos + xi = mkClassPred cls xis + mk_ct new_ev = CDictCan { cc_ev = new_ev + , cc_tyargs = xis + , cc_class = cls + , cc_pend_sc = pend_sc } + ; mb <- rewriteEvidence ev xi co + ; 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], and deriveds [WD], [D], 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 [D] (C Int beta) constraint. It's derived because + we don't actually have to cough up any evidence for it; it's only there + to generate fundep equalities. + +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 Deriveds. 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 -XNoRecursiveSuperClasses + 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 [D] 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 + [D] F a ~ beta + Now we get [D] beta ~ b, and can solve that. + + -- Example (tcfail138) + class L a b | a -> b + class (G a, L a b) => C a b + + instance C a b' => G (Maybe a) + instance C a b => C (Maybe a) a + instance L (Maybe a) a + + When solving the superclasses of the (C (Maybe a) a) instance, we get + [G] C a b, and hance by superclasses, [G] G a, [G] L a b + [W] G (Maybe a) + Use the instance decl to get + [W] C a beta + Generate its derived superclass + [D] L a beta. Now using fundeps, combine with [G] L a b to get + [D] beta ~ b + which is what we want. + +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 + [D] RealOf e ~ fuv + [D] 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. + +Mind you, now that Wanteds cannot rewrite Derived, I think this particular +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 superclasses 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 })) + = ASSERT2( 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 (mk_given_loc loc)) $ + classSCSelIds cls + where + dict_ids = mkTemplateLocals theta + size = sizeTypes tys + + do_one_given given_loc sel_id + | isUnliftedType sc_pred + , not (null tvs && null theta) + = -- See Note [Equality superclasses in quantified constraints] + return [] + | otherwise + = do { given_ev <- newGivenEvVar given_loc $ + mk_given_desc sel_id sc_pred + ; mk_superclasses rec_clss given_ev tvs theta sc_pred } + where + sc_pred = funResultTy (piResultTys (idType 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) = splitForAllTys sc_pred + (sc_theta, sc_inner_pred) = splitFunTys sc_rho + + all_tvs = tvs `chkAppend` sc_tvs + all_theta = theta `chkAppend` 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 + + mk_given_loc loc + | isCTupleClass cls + = loc -- For tuple predicates, just take them apart, without + -- adding their (large) size into the chain. When we + -- get down to a base predicate, we'll include its size. + -- #10335 + + | GivenOrigin skol_info <- ctLocOrigin loc + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + -- for explantation of this transformation for givens + = case skol_info of + InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) } + InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) } + _ -> loc + + | otherwise -- Probably doesn't happen, since this function + = loc -- is only used for Givens, but does no harm + +mk_strict_superclasses rec_clss ev tvs theta cls tys + | all noFreeVarsOfType tys + = return [] -- Wanteds with no variables yield no deriveds. + -- See Note [Improvement from Ground Wanteds] + + | otherwise -- Wanted/Derived case, just add Derived superclasses + -- that can lead to improvement. + = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta ) + concatMapM do_one_derived (immSuperClasses cls tys) + where + loc = ctEvLoc ev + + do_one_derived sc_pred + = do { sc_ev <- newDerivedNC loc 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 [D] C Bool Int? No! The only point of +emitting superclass constraints for W/D 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 :: CtIrredStatus -> CtEvidence -> TcS (StopOrContinue Ct) +-- Precondition: ty not a tuple and no other evidence form +canIrred status ev + = do { let pred = ctEvPred ev + ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred) + ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred + ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> + do { -- Re-classify, in case flattening has improved its shape + ; case classifyPredType (ctEvPred new_ev) of + ClassPred cls tys -> canClassNC new_ev cls tys + EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2 + _ -> continueWith $ + mkIrredCt status new_ev } } + +canHole :: CtEvidence -> OccName -> HoleSort -> TcS (StopOrContinue Ct) +canHole ev occ hole_sort + = do { let pred = ctEvPred ev + ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred + ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> + do { updInertIrreds (`snocCts` (CHoleCan { cc_ev = new_ev + , cc_occ = occ + , cc_hole = hole_sort })) + ; stopWith new_ev "Emit insoluble hole" } } + + +{- ********************************************************************* +* * +* Quantified predicates +* * +********************************************************************* -} + +{- 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 + -- Do not bother with type-family reductions; we can't + -- do them under a forall anyway (c.f. Flatten.flatten_one + -- on a forall type) + let pred = ctEvPred ev + ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred + ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> + + do { -- Now decompose into its pieces and solve it + -- (It takes a lot less code to flatten 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 tvs theta pred pend_sc + | CtWanted { ctev_dest = dest } <- ev + = -- See Note [Solving a Wanted forall-constraint] + do { let skol_info = QuantCtxtSkol + empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs + ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs + ; given_ev_vars <- mapM newEvVar (substTheta subst theta) + + ; (lvl, (w_id, wanteds)) + <- pushLevelNoWorkList (ppr skol_info) $ + do { wanted_ev <- newWantedEvVarNC loc $ + substTy subst pred + ; return ( ctEvEvId wanted_ev + , unitBag (mkNonCanonical wanted_ev)) } + + ; ev_binds <- emitImplicationTcS lvl 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" } + + | isGiven ev -- See Note [Solving a Given forall-constraint] + = do { addInertForAll qci + ; stopWith ev "Given forall-constraint" } + + | otherwise + = do { traceTcS "discarding derived forall-constraint" (ppr ev) + ; stopWith ev "Derived forall-constraint" } + where + loc = ctEvLoc ev + 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. + +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 flattening but similar after flattening. +However, we don't just want to jump in and flatten right away, because +this might be wasted effort. So, after looking for similarities and failing, +we flatten and then try again. Of course, we don't want to loop, so we +track whether or not we've already flattened. + +It is conceivable to do a better job at tracking whether or not a type +is flattened, but this is left as future work. (Mar '15) + + +Note [FunTy and decomposing tycon applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When can_eq_nc' attempts to decompose a tycon application we haven't yet 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. tcRepSplitTyConApp_maybe panics in the event +that it sees such a type as it cannot determine the RuntimeReps which the (->) +is applied to. Consequently, it is vital that we instead use +tcRepSplitTyConApp_maybe', which simply returns Nothing in such a case. + +When this happens can_eq_nc' will fail to decompose, zonk, and try again. +Zonking should fill the variable k, meaning that decomposition will succeed the +second time around. +-} + +canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct) +canEqNC ev eq_rel ty1 ty2 + = do { result <- zonk_eq_types ty1 ty2 + ; case result of + Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2 + Right ty -> canEqReflexive ev eq_rel ty } + +can_eq_nc + :: Bool -- True => both types are flat + -> 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) +can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + = do { traceTcS "can_eq_nc" $ + vcat [ ppr flat, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ] + ; rdr_env <- getGlobalRdrEnvTcS + ; fam_insts <- getFamInstEnvs + ; can_eq_nc' flat rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 } + +can_eq_nc' + :: Bool -- True => both input types are flattened + -> 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) + +-- Expand synonyms first; see Note [Type synonyms and canonicalization] +can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + | Just ty1' <- tcView ty1 = can_eq_nc' flat rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2 + | Just ty2' <- tcView ty2 = can_eq_nc' flat 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 flat because the zonk_eq_types check in canEqNC takes +-- care of the non-flat 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' _flat 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' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2 + | not (isTyVarTy ty2) -- See (3) in Note [Equalities with incompatible kinds] + = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 +can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _ + | not (isTyVarTy ty1) -- See (3) in Note [Equalities with incompatible kinds] + = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1 + +-- NB: pattern match on True: we want only flat types sent to canEqTyVar. +-- See also Note [No top-level newtypes on RHS of representational equalities] +can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2 + = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2 +can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2 + = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1 + +---------------------- +-- Otherwise try to decompose +---------------------- + +-- Literals +can_eq_nc' _flat _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" } + +-- Try to decompose type constructor applications +-- Including FunTy (s -> t) +can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _ + --- See Note [FunTy and decomposing type constructor applications]. + | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1 + , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2 + , not (isTypeFamilyTyCon tc1) + , not (isTypeFamilyTyCon tc2) + = canTyConApp ev eq_rel tc1 tys1 tc2 tys2 + +can_eq_nc' _flat _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 flat types +can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _ + | NomEq <- eq_rel + , Just (t2, s2) <- tcSplitAppTy_maybe ty2 + = can_eq_app ev t1 s1 t2 s2 +can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _ + | NomEq <- eq_rel + , Just (t1, s1) <- tcSplitAppTy_maybe ty1 + = can_eq_app ev t1 s1 t2 s2 + +-- No similarity in type structure detected. Flatten and try again. +can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 + = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1 + ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2 + ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 + ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } + +-- We've flattened 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 OtherCIS ev) + NomEq -> continueWith (mkIrredCt InsolubleCIS ev) } + -- No need to call canEqFailure/canEqHardFailure because they + -- flatten, and the types involved here are already flat + +{- 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 } <- ev + = do { let free_tvs = tyCoVarsOfTypes [s1,s2] + (bndrs1, phi1) = tcSplitForAllVarBndrs s1 + (bndrs2, phi2) = tcSplitForAllVarBndrs s2 + ; if not (equalLength bndrs1 bndrs2) + then do { traceTcS "Forall failure" $ + vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 + , ppr (map binderArgFlag bndrs1) + , ppr (map binderArgFlag bndrs2) ] + ; canEqHardFailure ev s1 s2 } + else + do { traceTcS "Creating implication for polytype equality" $ ppr ev + ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs + ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $ + binderVars bndrs1 + + ; let skol_info = UnifyForAllSkol phi1 + phi1' = substTy subst1 phi1 + + -- Unify the kinds, extend the substitution + go :: [TcTyVar] -> TCvSubst -> [TyVarBinder] + -> TcS (TcCoercion, Cts) + go (skol_tv:skol_tvs) subst (bndr2:bndrs2) + = do { let tv2 = binderVar bndr2 + ; (kind_co, wanteds1) <- unify loc 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 ( mkTcForAllCo skol_tv kind_co co + , wanteds1 `unionBags` wanteds2 ) } + + -- Done: unify phi1 ~ phi2 + go [] subst bndrs2 + = ASSERT( null bndrs2 ) + unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2) + + go _ _ _ = panic "cna_eq_nc_forall" -- case (s:ss) [] + + empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1) + + ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ + go skol_tvs empty_subst2 bndrs2 + ; emitTvImplicationTcS lvl 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 -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts) + -- This version returns the wanted constraint rather + -- than putting it in the work list + unify loc role ty1 ty2 + | ty1 `tcEqType` ty2 + = return (mkTcReflCo role ty1, emptyBag) + | otherwise + = do { (wanted, co) <- newWantedEq loc 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 +-- flattening, 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 ty1 ty2 + | Just (arg1, res1) <- split1 + , Just (arg2, res2) <- split2 + = do { res_a <- go arg1 arg2 + ; res_b <- go res1 res2 + ; return $ combine_rev mkVisFunTy res_b res_a + } + | isJust split1 || isJust split2 + = bale_out ty1 ty2 + where + split1 = tcSplitFunTy_maybe ty1 + split2 = tcSplitFunTy_maybe ty2 + + go ty1 ty2 + | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1 + , Just (tc2, tys2) <- repSplitTyConApp_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) <- tcRepSplitAppTy_maybe ty1 + , Just (ty2a, ty2b) <- tcRepSplitAppTy_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 flattening. 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) + +{- See Note [Unwrap newtypes first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + newtype N m a = MkN (m a) +Then 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. + +Bottom line: unwrap newtypes before decomposing them! +c.f. #9123 comment:52,53 for a compelling example. + +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 when unwrapping newtypes. + +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 flattener 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.) +-} + +------------------------ +-- | 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, co), ty1') ty2 ps_ty2 + = do { traceTcS "can_eq_newtype_nc" $ + vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ] + + -- check for blowing our stack: + -- See Note [Newtypes can blow the stack] + ; checkReductionDepth (ctEvLoc ev) ty1 + + -- Next, we record uses of newtype constructors, since coercing + -- through newtypes is tantamount to using their constructors. + ; addUsedGREs gre_list + -- If a newtype constructor was imported, don't warn about not + -- importing it... + ; traverse_ keepAlive $ map gre_name 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. + + ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2 + (mkTcSymCo co) (mkTcReflCo Representational ps_ty2) + ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 } + where + gre_list = bagToList gres + +--------- +-- ^ Decompose a type application. +-- All input types must be flat. 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 equality], note {4} +can_eq_app ev s1 t1 s2 t2 + | CtDerived {} <- ev + = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2] + ; stopWith ev "Decomposed [D] AppTy" } + | CtWanted { ctev_dest = dest } <- ev + = do { co_s <- unifyWanted loc Nominal s1 s2 + ; let arg_loc + | isNextArgVisible s1 = loc + | otherwise = updateCtLocOrigin loc toInvisibleOrigin + ; co_t <- unifyWanted 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 = mkTcCoVarCo evar + co_s = mkTcLRCo CLeft co + co_t = mkTcLRCo 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 = tcTypeKind s1 + s2k = tcTypeKind 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 flat? + -> CtEvidence + -> EqRel + -> SwapFlag + -> TcType -> Coercion -- LHS (res. RHS), ty1 |> co1 + -> TcType -> TcType -- RHS (res. LHS), ty2 both normal and pretty + -> TcS (StopOrContinue Ct) +canEqCast flat 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 ev swapped ty1 ps_ty2 + (mkTcGReflRightCo role ty1 co1) + (mkTcReflCo role ps_ty2) + ; can_eq_nc flat 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 TyConApps] +canTyConApp ev eq_rel tc1 tys1 tc2 tys2 + | tc1 == tc2 + , tys1 `equalLength` tys2 + = do { inerts <- getTcSInerts + ; if can_decompose inerts + then do { traceTcS "canTyConApp" + (ppr ev $$ ppr eq_rel $$ ppr tc1 $$ ppr tys1 $$ ppr tys2) + ; canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2 + ; stopWith ev "Decomposed TyConApp" } + else canEqFailure ev eq_rel ty1 ty2 } + + -- See Note [Skolem abstract data] (at tyConSkolem) + | tyConSkolem tc1 || tyConSkolem tc2 + = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2) + ; continueWith (mkIrredCt OtherCIS 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 + ty1 = mkTyConApp tc1 tys1 + ty2 = mkTyConApp tc2 tys2 + + loc = ctEvLoc ev + pred = ctEvPred ev + + -- See Note [Decomposing equality] + can_decompose inerts + = isInjectiveTyCon tc1 (eqRelRole eq_rel) + || (ctEvFlavour ev /= Given && isEmptyBag (matchableGivens loc pred inerts)) + +{- +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 [Decomposing equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a constraint (of any flavour and role) that looks like +T tys1 ~ T tys2, what can we conclude about tys1 and tys2? The answer, +of course, is "it depends". This Note spells it all out. + +In this Note, "decomposition" refers to taking the constraint + [fl] (T tys1 ~X T tys2) +(for some flavour fl and some role X) and replacing it with + [fls'] (tys1 ~Xs' tys2) +where that notation indicates a list of new constraints, where the +new constraints may have different flavours and different roles. + +The key property to consider is injectivity. When decomposing a Given the +decomposition is sound if and only if T is injective in all of its type +arguments. When decomposing a Wanted, the decomposition is sound (assuming the +correct roles in the produced equality constraints), but it may be a guess -- +that is, an unforced decision by the constraint solver. Decomposing Wanteds +over injective TyCons does not entail guessing. But sometimes we want to +decompose a Wanted even when the TyCon involved is not injective! (See below.) + +So, in broad strokes, we want this rule: + +(*) Decompose a constraint (T tys1 ~X T tys2) if and only if T is injective +at role X. + +Pursuing the details requires exploring three axes: +* Flavour: Given vs. Derived vs. Wanted +* Role: Nominal vs. Representational +* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable + +(So a type variable isn't a TyCon, but it's convenient to put the AppTy case +in the same table.) + +Right away, we can say that Derived behaves just as Wanted for the purposes +of decomposition. The difference between Derived and Wanted is the handling of +evidence. Since decomposition in these cases isn't a matter of soundness but of +guessing, we want the same behavior regardless of evidence. + +Here is a table (discussion following) detailing where decomposition of + (T s1 ... sn) ~r (T t1 .. tn) +is allowed. The first four lines (Data types ... type family) refer +to TyConApps with various TyCons T; the last line is for AppTy, where +there is presumably a type variable at the head, so it's actually + (s s1 ... sn) ~r (t t1 .. tn) + +NOMINAL GIVEN WANTED + +Datatype YES YES +Newtype YES YES +Data family YES YES +Type family YES, in injective args{1} YES, in injective args{1} +Type variable YES YES + +REPRESENTATIONAL GIVEN WANTED + +Datatype YES YES +Newtype NO{2} MAYBE{2} +Data family NO{3} MAYBE{3} +Type family NO NO +Type variable NO{4} NO{4} + +{1}: Type families can be injective in some, but not all, of their arguments, +so we want to do partial decomposition. This is quite different than the way +other decomposition is done, where the decomposed equalities replace the original +one. We thus proceed much like we do with superclasses: emitting new Givens +when "decomposing" a partially-injective type family Given and new Deriveds +when "decomposing" a partially-injective type family Wanted. (As of the time of +writing, 13 June 2015, the implementation of injective type families has not +been merged, but it should be soon. Please delete this parenthetical if the +implementation is indeed merged.) + +{2}: See Note [Decomposing newtypes at representational role] + +{3}: Because of the possibility of newtype instances, we must treat +data families like newtypes. See also Note [Decomposing newtypes at +representational role]. See #10534 and test case +typecheck/should_fail/T10534. + +{4}: Because type variables can stand in for newtypes, we conservatively do not +decompose AppTys over representational equality. + +In the implementation of can_eq_nc and friends, we don't directly pattern +match using lines like in the tables above, as those tables don't cover +all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity, +boiling the tables above down to rule (*). The exceptions to rule (*) are for +injective type families, which are handled separately from other decompositions, +and the MAYBE entries above. + +Note [Decomposing newtypes at representational role] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This note discusses the 'newtype' line in the REPRESENTATIONAL table +in Note [Decomposing equality]. (At nominal role, newtypes are fully +decomposable.) + +Here is a representative example of why representational equality over +newtypes is tricky: + + 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 + +If we have [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. Here's another example. + + 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: + * Unwrap newtypes before attempting to decompose them. + This is done in can_eq_nc'. + +It all comes from the fact that newtypes aren't necessarily injective +w.r.t. representational equality. + +Furthermore, as explained in Note [NthCo and newtypes] in GHC.Core.TyCo.Rep, we can't use +NthCo on representational coercions over newtypes. NthCo comes into play +only when decomposing givens. + +Conclusion: + * Do not decompose [G] N s ~R N t + +Is it sensible to decompose *Wanted* constraints over newtypes? Yes! +It's the only way we could ever prove (IO Int ~R IO Age), recalling +that IO is a newtype. + +However we must be careful. Consider + + type role Nt representational + + [G] Nt a ~R Nt b (1) + [W] NT alpha ~R Nt b (2) + [W] alpha ~ a (3) + +If we focus on (3) first, we'll substitute in (2), and now it's +identical to the given (1), so we succeed. But if we focus on (2) +first, and decompose it, we'll get (alpha ~R b), which is not soluble. +This is exactly like the question of overlapping Givens for class +constraints: see Note [Instance and Given overlap] in GHC.Tc.Solver.Interact. + +Conclusion: + * Decompose [W] N s ~R N t iff there no given constraint that could + later solve it. + +-} + +canDecomposableTyConAppOK :: CtEvidence -> EqRel + -> TyCon -> [TcType] -> [TcType] + -> TcS () +-- Precondition: tys1 and tys2 are the same length, hence "OK" +canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 + = ASSERT( tys1 `equalLength` tys2 ) + case ev of + CtDerived {} + -> unifyDeriveds loc tc_roles tys1 tys2 + + 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 + -> do { cos <- zipWith4M unifyWanted 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 $ mkNthCo r i ev_co ) + | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] + , r /= Phantom + , not (isCoercionTy ty1) && not (isCoercionTy ty2) ] + ; emitWorkNC given_evs } + where + loc = ctEvLoc ev + role = eqRelRole eq_rel + + -- infinite, as tyConRolesX returns an infinite tail of Nominal + tc_roles = tyConRolesX 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 | isVisibleTyConBinder bndr + = updateCtLocOrigin new_loc0 toInvisibleOrigin + | otherwise + = new_loc0 ] + ++ repeat loc + +-- | 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 { (xi1, co1) <- flatten FM_FlattenAll ev ty1 + ; (xi2, co2) <- flatten FM_FlattenAll ev ty2 + -- We must flatten 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 ty1, ppr ty2, ppr xi1, ppr xi2 ] + ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 + ; continueWith (mkIrredCt OtherCIS 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 { (s1, co1) <- flatten FM_SubstOnly ev ty1 + ; (s2, co2) <- flatten FM_SubstOnly ev ty2 + ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2 + ; continueWith (mkIrredCt InsolubleCIS new_ev) } + +{- +Note [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 decomopose 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 canDecomposableTyCon is a fast-path decomposition that uses +unifyWanted etc to short-cut that work. + +Note [Canonicalising type applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (s1 t1) ~ ty2, how should we proceed? +The simple things is to see if ty2 is of form (s2 t2), and +decompose. By this time s1 and s2 can't be saturated type +function applications, because those have been dealt with +by an earlier equation in can_eq_nc, so it is always sound to +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 flattens 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.Monad. +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 [Combining insoluble constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As this point we have an insoluble constraint, like Int~Bool. + + * If it is Wanted, delete it from the cache, so that subsequent + Int~Bool constraints give rise to separate error messages + + * But if it is Derived, DO NOT delete from cache. A class constraint + may get kicked out of the inert set, and then have its functional + dependency Derived constraints generated a second time. In that + case we don't want to get two (or more) error messages by + generating two (or more) insoluble fundep constraints from the same + class constraint. + +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 canEqTyVar sees [W] a ~R a, after b is flattened +and the Id newtype is unwrapped. This is assured by requiring only flat +types in canEqTyVar *and* having the newtype-unwrapping check above +the tyvar check in can_eq_nc. + +Note [Occurs check error] +~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an occurs check error, are we necessarily hosed? Say our +tyvar is tv1 and the type it appears in is xi2. Because xi2 is function +free, then if we're computing w.r.t. nominal equality, then, yes, we're +hosed. Nothing good can come from (a ~ [a]). If we're computing w.r.t. +representational equality, this is a little subtler. Once again, (a ~R [a]) +is a bad thing, but (a ~R N a) for a newtype N might be just fine. This +means also that (a ~ b a) might be fine, because `b` might become a newtype. + +So, we must check: does tv1 appear in xi2 under any type constructor +that is generative w.r.t. representational equality? That's what +isInsolubleOccursCheck does. + +See also #10715, which induced this addition. + +Note [canCFunEqCan] +~~~~~~~~~~~~~~~~~~~ +Flattening the arguments to a type family can change the kind of the type +family application. As an easy example, consider (Any k) where (k ~ Type) +is in the inert set. The original (Any k :: k) becomes (Any Type :: Type). +The problem here is that the fsk in the CFunEqCan will have the old kind. + +The solution is to come up with a new fsk/fmv of the right kind. For +givens, this is easy: just introduce a new fsk and update the flat-cache +with the new one. For wanteds, we want to solve the old one if favor of +the new one, so we use dischargeFmv. This also kicks out constraints +from the inert set; this behavior is correct, as the kind-change may +allow more constraints to be solved. + +We use `isTcReflexiveCo`, to ensure that we only use the hetero-kinded case +if we really need to. Of course `flattenArgsNom` should return `Refl` +whenever possible, but #15577 was an infinite loop because even +though the coercion was homo-kinded, `kind_co` was not `Refl`, so we +made a new (identical) CFunEqCan, and then the entire process repeated. +-} + +canCFunEqCan :: CtEvidence + -> TyCon -> [TcType] -- LHS + -> TcTyVar -- RHS + -> TcS (StopOrContinue Ct) +-- ^ Canonicalise a CFunEqCan. We know that +-- the arg types are already flat, +-- and the RHS is a fsk, which we must *not* substitute. +-- So just substitute in the LHS +canCFunEqCan ev fn tys fsk + = do { (tys', cos, kind_co) <- flattenArgsNom ev fn tys + -- cos :: tys' ~ tys + + ; let lhs_co = mkTcTyConAppCo Nominal fn cos + -- :: F tys' ~ F tys + new_lhs = mkTyConApp fn tys' + + flav = ctEvFlavour ev + ; (ev', fsk') + <- if isTcReflexiveCo kind_co -- See Note [canCFunEqCan] + then do { traceTcS "canCFunEqCan: refl" (ppr new_lhs) + ; let fsk_ty = mkTyVarTy fsk + ; ev' <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty + lhs_co (mkTcNomReflCo fsk_ty) + ; return (ev', fsk) } + else do { traceTcS "canCFunEqCan: non-refl" $ + vcat [ text "Kind co:" <+> ppr kind_co + , text "RHS:" <+> ppr fsk <+> dcolon <+> ppr (tyVarKind fsk) + , text "LHS:" <+> hang (ppr (mkTyConApp fn tys)) + 2 (dcolon <+> ppr (tcTypeKind (mkTyConApp fn tys))) + , text "New LHS" <+> hang (ppr new_lhs) + 2 (dcolon <+> ppr (tcTypeKind new_lhs)) ] + ; (ev', new_co, new_fsk) + <- newFlattenSkolem flav (ctEvLoc ev) fn tys' + ; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co + -- sym lhs_co :: F tys ~ F tys' + -- new_co :: F tys' ~ new_fsk + -- co :: F tys ~ (new_fsk |> kind_co) + co = mkTcSymCo lhs_co `mkTcTransCo` + mkTcCoherenceRightCo Nominal + (mkTyVarTy new_fsk) + kind_co + new_co + + ; traceTcS "Discharging fmv/fsk due to hetero flattening" (ppr ev) + ; dischargeFunEq ev fsk co xi + ; return (ev', new_fsk) } + + ; extendFlatCache fn tys' (ctEvCoercion ev', mkTyVarTy fsk', ctEvFlavour ev') + ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn + , cc_tyargs = tys', cc_fsk = fsk' }) } + +--------------------- +canEqTyVar :: CtEvidence -- ev :: lhs ~ rhs + -> EqRel -> SwapFlag + -> TcTyVar -- tv1 + -> TcType -- lhs: pretty lhs, already flat + -> TcType -> TcType -- rhs: already flat + -> TcS (StopOrContinue Ct) +canEqTyVar ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2 + | k1 `tcEqType` k2 + = canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2 + + | otherwise + = canEqTyVarHetero ev eq_rel swapped tv1 ps_xi1 k1 xi2 ps_xi2 k2 + + where + k1 = tyVarKind tv1 + k2 = tcTypeKind xi2 + +canEqTyVarHetero :: CtEvidence -- :: (tv1 :: ki1) ~ (xi2 :: ki2) + -> EqRel -> SwapFlag + -> TcTyVar -> TcType -- tv1, pretty tv1 + -> TcKind -- ki1 + -> TcType -> TcType -- xi2, pretty xi2 :: ki2 + -> TcKind -- ki2 + -> TcS (StopOrContinue Ct) +canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2 + -- See Note [Equalities with incompatible kinds] + = do { kind_co <- emit_kind_co -- :: ki2 ~N ki1 + + ; let -- kind_co :: (ki2 :: *) ~N (ki1 :: *) (whether swapped or not) + -- co1 :: kind(tv1) ~N ki1 + rhs' = xi2 `mkCastTy` kind_co -- :: ki1 + ps_rhs' = ps_xi2 `mkCastTy` kind_co -- :: ki1 + rhs_co = mkTcGReflLeftCo role xi2 kind_co + -- rhs_co :: (xi2 |> kind_co) ~ xi2 + + lhs' = mkTyVarTy tv1 -- same as old lhs + lhs_co = mkTcReflCo role lhs' + + ; traceTcS "Hetero equality gives rise to kind equality" + (ppr kind_co <+> dcolon <+> sep [ ppr ki2, text "~#", ppr ki1 ]) + ; type_ev <- rewriteEqEvidence ev swapped lhs' rhs' lhs_co rhs_co + + -- rewriteEqEvidence carries out the swap, so we're NotSwapped any more + ; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' } + where + emit_kind_co :: TcS CoercionN + emit_kind_co + | CtGiven { ctev_evar = evar } <- ev + = do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar) -- :: k2 ~ k1 + ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co) + ; emitWorkNC [kind_ev] + ; return (ctEvCoercion kind_ev) } + + | otherwise + = unifyWanted kind_loc Nominal ki2 ki1 + + loc = ctev_loc ev + role = eqRelRole eq_rel + kind_loc = mkKindLoc (mkTyVarTy tv1) xi2 loc + kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki2 ki1 + + maybe_sym = case swapped of + IsSwapped -> id -- if the input is swapped, then we already + -- will have k2 ~ k1 + NotSwapped -> mkTcSymCo + +-- guaranteed that tcTypeKind lhs == tcTypeKind rhs +canEqTyVarHomo :: CtEvidence + -> EqRel -> SwapFlag + -> TcTyVar -- lhs: tv1 + -> TcType -- pretty lhs, flat + -> TcType -> TcType -- rhs, flat + -> TcS (StopOrContinue Ct) +canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 _ + | Just (tv2, _) <- tcGetCastedTyVar_maybe xi2 + , tv1 == tv2 + = canEqReflexive ev eq_rel (mkTyVarTy tv1) + -- we don't need to check co because it must be reflexive + + -- this guarantees (TyEq:TV) + | Just (tv2, co2) <- tcGetCastedTyVar_maybe xi2 + , swapOverTyVars tv1 tv2 + = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped) + ; let role = eqRelRole eq_rel + sym_co2 = mkTcSymCo co2 + ty1 = mkTyVarTy tv1 + new_lhs = ty1 `mkCastTy` sym_co2 + lhs_co = mkTcGReflLeftCo role ty1 sym_co2 + + new_rhs = mkTyVarTy tv2 + rhs_co = mkTcGReflRightCo role new_rhs co2 + + ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co + + ; dflags <- getDynFlags + ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_xi1 `mkCastTy` sym_co2) } + +canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_xi2 + = do { dflags <- getDynFlags + ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_xi2 } + +-- The RHS here is either not a casted tyvar, or it's a tyvar but we want +-- to rewrite the LHS to the RHS (as per swapOverTyVars) +canEqTyVar2 :: DynFlags + -> CtEvidence -- lhs ~ rhs (or, if swapped, orhs ~ olhs) + -> EqRel + -> SwapFlag + -> TcTyVar -- lhs = tv, flat + -> TcType -- rhs, flat + -> TcS (StopOrContinue Ct) +-- LHS is an inert type variable, +-- and RHS is fully rewritten, but with type synonyms +-- preserved as much as possible +-- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K) +-- the "flat" requirement guarantees (TyEq:AFF) +-- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqTyVarHomo +canEqTyVar2 dflags ev eq_rel swapped tv1 rhs + -- this next line checks also for coercion holes; see + -- Note [Equalities with incompatible kinds] + | MTVU_OK rhs' <- mtvu -- No occurs check + -- Must do the occurs check even on tyvar/tyvar + -- equalities, in case have x ~ (y :: ..x...) + -- #12593 + -- guarantees (TyEq:OC), (TyEq:F), and (TyEq:H) + = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2 + ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1 + , cc_rhs = rhs', cc_eq_rel = eq_rel }) } + + | otherwise -- For some reason (occurs check, or forall) we can't unify + -- We must not use it for further rewriting! + = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs) + ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2 + ; let status | isInsolubleOccursCheck eq_rel tv1 rhs + = InsolubleCIS + -- If we have a ~ [a], it is not canonical, and in particular + -- we don't want to rewrite existing inerts with it, otherwise + -- we'd risk divergence in the constraint solver + + | MTVU_HoleBlocker <- mtvu + = BlockedCIS + -- This is the case detailed in + -- Note [Equalities with incompatible kinds] + + | otherwise + = OtherCIS + -- A representational equality with an occurs-check problem isn't + -- insoluble! For example: + -- a ~R b a + -- We might learn that b is the newtype Id. + -- But, the occurs-check certainly prevents the equality from being + -- canonical, and we might loop if we were to use it in rewriting. + + ; continueWith (mkIrredCt status new_ev) } + where + mtvu = metaTyVarUpdateOK dflags tv1 rhs + + role = eqRelRole eq_rel + + lhs = mkTyVarTy tv1 + + rewrite_co1 = mkTcReflCo role lhs + rewrite_co2 = mkTcReflCo role rhs + +-- | 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 $ + mkTcReflCo (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) + +we go to + + [noDerived X] co :: k2 ~ k1 + [X] (tv :: k1) ~ ((rhs |> co) :: k1) + +where + + noDerived G = G + noDerived _ = W + +Wrinkles: + + (1) The noDerived step is because Derived equalities have no evidence. + And yet we absolutely need evidence to be able to proceed here. + Given evidence will use the KindCo coercion; Wanted evidence will + be a coercion hole. Even a Derived hetero equality begets a Wanted + kind equality. + + (2) Though it would be sound to do so, we must not mark the rewritten Wanted + [W] (tv :: k1) ~ ((rhs |> co) :: k1) + as canonical in the inert set. In particular, we must not unify tv. + If we did, the Wanted becomes a Given (effectively), and then can + rewrite other Wanteds. But that's bad: See Note [Wanteds to not rewrite Wanteds] + in GHC.Tc.Types.Constraint. The problem is about poor error messages. See #11198 for + tales of destruction. + + So, we have an invariant on CTyEqCan (TyEq:H) that the RHS does not have + any coercion holes. This is checked in metaTyVarUpdateOK. We also + must be sure to kick out any constraints that mention coercion holes + when those holes get filled in. + + (2a) We don't want to do this for CoercionHoles that witness + CFunEqCans (that are produced by the flattener), as these will disappear + once we unflatten. So we remember in the CoercionHole structure + whether the presence of the hole should block substitution or not. + A bit gross, this. + + (2b) We must now absolutely make sure to kick out any constraints that + mention a newly-filled-in coercion hole. This is done in + kickOutAfterFillingCoercionHole. + + (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the + algorithm detailed here, producing [W] co :: k2 ~ k1, and adding + [W] (a :: k1) ~ ((rhs |> 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 (2b). + But now, during canonicalization, we see the cast + and remove it, in canEqCast. By the time we get into canEqTyVar, 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 tyvar. 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'. + + (4) Reporting an error for a constraint that is blocked only because + of wrinkle (2) is hard: what would we say to users? And we don't + really need to report, because if a constraint is blocked, then + there is unsolved wanted blocking it; that unsolved wanted will + be reported. We thus push such errors to the bottom of the queue + in the error-reporting code; they should never be printed. + + (4a) It would seem possible to do this filtering just based on the + presence of a blocking coercion hole. However, this is no good, + as it suppresses e.g. no-instance-found errors. We thus record + a CtIrredStatus in CIrredCan and filter based on this status. + This happened in T14584. An alternative approach is to expressly + look for *equalities* with blocking coercion holes, but actually + recording the blockage in a status field seems nicer. + + (4b) The error message might be printed with -fdefer-type-errors, + so it still must exist. This is the only reason why there is + a message at all. Otherwise, we could simply do nothing. + +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 canEqTyVar. + +-} + +{- +************************************************************************ +* * + 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 :: CtEvidence -- old evidence + -> TcPredType -- new predicate + -> TcCoercion -- 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/derived 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 + or Derived 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. + +qThe flattener preserves type synonyms, so they should appear in new_pred +as well as in old_pred; that is important for good error messages. + -} + + +rewriteEvidence old_ev@(CtDerived {}) new_pred _co + = -- If derived, don't even look at the coercion. + -- This is very important, DO NOT re-order the equations for + -- rewriteEvidence to put the isTcReflCo test first! + -- Why? Because for *Derived* constraints, c, the coercion, which + -- was produced by flattening, may contain suspended calls to + -- (ctEvExpr c), which fails for Derived constraints. + -- (Getting this wrong caused #7384.) + continueWith (old_ev { ctev_pred = new_pred }) + +rewriteEvidence old_ev new_pred co + | isTcReflCo co -- See Note [Rewriting with Refl] + = continueWith (old_ev { ctev_pred = new_pred }) + +rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co + = do { new_ev <- newGivenEvVar loc (new_pred, new_tm) + ; continueWith new_ev } + where + -- mkEvCast optimises ReflCo + new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational + (ctEvRole ev) + (mkTcSymCo co)) + +rewriteEvidence ev@(CtWanted { ctev_dest = dest + , ctev_nosh = si + , ctev_loc = loc }) new_pred co + = do { mb_new_ev <- newWanted_SI si loc new_pred + -- The "_SI" variant ensures that we make a new Wanted + -- with the same shadow-info as the existing one + -- with the same shadow-info as the existing one (#16735) + ; MASSERT( tcCoercionRole co == ctEvRole ev ) + ; setWantedEvTerm dest + (mkEvCast (getEvExpr mb_new_ev) + (tcDowngradeRole Representational (ctEvRole ev) co)) + ; case mb_new_ev of + Fresh new_ev -> continueWith new_ev + Cached _ -> stopWith ev "Cached wanted" } + + +rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) + -- or orhs ~ olhs (swapped) + -> SwapFlag + -> TcType -> TcType -- New predicate nlhs ~ nrhs + -> TcCoercion -- lhs_co, of type :: nlhs ~ olhs + -> TcCoercion -- rhs_co, of type :: nrhs ~ orhs + -> TcS CtEvidence -- Of type nlhs ~ nrhs +-- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co) +-- we generate +-- If not swapped +-- g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co +-- If 'swapped' +-- g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co +-- +-- For (Wanted w) we do the dual thing. +-- New w1 : nlhs ~ nrhs +-- If not swapped +-- w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co +-- If swapped +-- w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co +-- +-- It's all a form of rewwriteEvidence, specialised for equalities +rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co + | CtDerived {} <- old_ev -- Don't force the evidence for a Derived + = return (old_ev { ctev_pred = new_pred }) + + | NotSwapped <- swapped + , isTcReflCo lhs_co -- See Note [Rewriting with Refl] + , isTcReflCo rhs_co + = return (old_ev { ctev_pred = new_pred }) + + | CtGiven { ctev_evar = old_evar } <- old_ev + = do { let new_tm = evCoercion (lhs_co + `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar) + `mkTcTransCo` mkTcSymCo rhs_co) + ; newGivenEvVar loc' (new_pred, new_tm) } + + | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev + = case dest of + HoleDest hole -> + do { (new_ev, hole_co) <- newWantedEq_SI (ch_blocker hole) si loc' + (ctEvRole old_ev) nlhs nrhs + -- The "_SI" variant ensures that we make a new Wanted + -- with the same shadow-info as the existing one (#16735) + ; let co = maybeSym swapped $ + mkSymCo lhs_co + `mkTransCo` hole_co + `mkTransCo` rhs_co + ; setWantedEq dest co + ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co]) + ; return new_ev } + + _ -> panic "rewriteEqEvidence" + +#if __GLASGOW_HASKELL__ <= 810 + | otherwise + = panic "rewriteEvidence" +#endif + where + new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs + + -- equality is like a type class. Bumping the depth is necessary because + -- of recursive newtypes, where "reducing" a newtype can actually make + -- it bigger. See Note [Newtypes can blow the stack]. + loc = ctEvLoc old_ev + loc' = bumpCtLocDepth loc + +{- Note [unifyWanted and unifyDerived] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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. +Similar remarks apply for Derived. + +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 :: 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 and unifyDerived] +-- The returned coercion's role matches the input parameter +unifyWanted loc Phantom ty1 ty2 + = do { kind_co <- unifyWanted loc Nominal (tcTypeKind ty1) (tcTypeKind ty2) + ; return (mkPhantomCo kind_co ty1 ty2) } + +unifyWanted loc role orig_ty1 orig_ty2 + = go orig_ty1 orig_ty2 + where + go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 + go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' + + go (FunTy _ s1 t1) (FunTy _ s2 t2) + = do { co_s <- unifyWanted loc role s1 s2 + ; co_t <- unifyWanted loc role t1 t2 + ; return (mkFunCo role 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 loc) + (tyConRolesX 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 (mkTcReflCo role ty1) + -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) + | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2 + +unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS () +-- See Note [unifyWanted and unifyDerived] +unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2 + +unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS () +-- See Note [unifyWanted and unifyDerived] +unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2 + +unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS () +-- Create new Derived and put it in the work list +-- Should do nothing if the two types are equal +-- See Note [unifyWanted and unifyDerived] +unify_derived _ Phantom _ _ = return () +unify_derived loc role orig_ty1 orig_ty2 + = go orig_ty1 orig_ty2 + where + go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 + go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' + + go (FunTy _ s1 t1) (FunTy _ s2 t2) + = do { unify_derived loc role s1 s2 + ; unify_derived loc role t1 t2 } + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + | tc1 == tc2, tys1 `equalLength` tys2 + , isInjectiveTyCon tc1 role + = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2 + 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 ty2 = bale_out ty1 ty2 + + bale_out ty1 ty2 + | ty1 `tcEqType` ty2 = return () + -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) + | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2 + +maybeSym :: SwapFlag -> TcCoercion -> TcCoercion +maybeSym IsSwapped co = mkTcSymCo co +maybeSym NotSwapped co = co diff --git a/compiler/GHC/Tc/Solver/Flatten.hs b/compiler/GHC/Tc/Solver/Flatten.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Solver/Flatten.hs @@ -0,0 +1,1925 @@ +{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns, BangPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Tc.Solver.Flatten( + FlattenMode(..), + flatten, flattenKind, flattenArgsNom, + rewriteTyVar, + + unflattenWanteds + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Types +import GHC.Core.TyCo.Ppr ( pprTyVar ) +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Tc.Types.Evidence +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep -- performs delicate algorithm on types +import GHC.Core.Coercion +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Utils.Outputable +import GHC.Tc.Solver.Monad as TcS +import GHC.Types.Basic( SwapFlag(..) ) + +import GHC.Utils.Misc +import GHC.Data.Bag +import Control.Monad +import GHC.Utils.Monad ( zipWith3M ) +import Data.Foldable ( foldrM ) + +import Control.Arrow ( first ) + +{- +Note [The flattening story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* A CFunEqCan is either of form + [G] : F xis ~ fsk -- fsk is a FlatSkolTv + [W] x : F xis ~ fmv -- fmv is a FlatMetaTv + where + x is the witness variable + xis are function-free + fsk/fmv is a flatten skolem; + it is always untouchable (level 0) + +* CFunEqCans can have any flavour: [G], [W], [WD] or [D] + +* KEY INSIGHTS: + + - A given flatten-skolem, fsk, is known a-priori to be equal to + F xis (the LHS), with evidence. The fsk is still a + unification variable, but it is "owned" by its CFunEqCan, and + is filled in (unflattened) only by unflattenGivens. + + - A unification flatten-skolem, fmv, stands for the as-yet-unknown + type to which (F xis) will eventually reduce. It is filled in + + + - All fsk/fmv variables are "untouchable". To make it simple to test, + we simply give them TcLevel=0. This means that in a CTyVarEq, say, + fmv ~ Int + we NEVER unify fmv. + + - A unification flatten-skolem, fmv, ONLY gets unified when either + a) The CFunEqCan takes a step, using an axiom + b) By unflattenWanteds + They are never unified in any other form of equality. + For example [W] ffmv ~ Int is stuck; it does not unify with fmv. + +* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan. + That would destroy the invariant about the shape of a CFunEqCan, + and it would risk wanted/wanted interactions. The only way we + learn information about fsk is when the CFunEqCan takes a step. + + However we *do* substitute in the LHS of a CFunEqCan (else it + would never get to fire!) + +* Unflattening: + - We unflatten Givens when leaving their scope (see unflattenGivens) + - We unflatten Wanteds at the end of each attempt to simplify the + wanteds; see unflattenWanteds, called from solveSimpleWanteds. + +* Ownership of fsk/fmv. Each canonical [G], [W], or [WD] + CFunEqCan x : F xis ~ fsk/fmv + "owns" a distinct evidence variable x, and flatten-skolem fsk/fmv. + Why? We make a fresh fsk/fmv when the constraint is born; + and we never rewrite the RHS of a CFunEqCan. + + In contrast a [D] CFunEqCan /shares/ its fmv with its partner [W], + but does not "own" it. If we reduce a [D] F Int ~ fmv, where + say type instance F Int = ty, then we don't discharge fmv := ty. + Rather we simply generate [D] fmv ~ ty (in GHC.Tc.Solver.Interact.reduce_top_fun_eq, + and dischargeFmv) + +* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2 + then xis1 /= xis2 + i.e. at most one CFunEqCan with a particular LHS + +* Flattening a type (F xis): + - If we are flattening in a Wanted/Derived constraint + then create new [W] x : F xis ~ fmv + else create new [G] x : F xis ~ fsk + with fresh evidence variable x and flatten-skolem fsk/fmv + + - Add it to the work list + + - Replace (F xis) with fsk/fmv in the type you are flattening + + - You can also add the CFunEqCan to the "flat cache", which + simply keeps track of all the function applications you + have flattened. + + - If (F xis) is in the cache already, just + use its fsk/fmv and evidence x, and emit nothing. + + - No need to substitute in the flat-cache. It's not the end + of the world if we start with, say (F alpha ~ fmv1) and + (F Int ~ fmv2) and then find alpha := Int. Athat will + simply give rise to fmv1 := fmv2 via [Interacting rule] below + +* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv + - Flatten xis (to substitute any tyvars; there are already no functions) + cos :: xis ~ flat_xis + - New wanted x2 :: F flat_xis ~ fsk/fmv + - Add new wanted to flat cache + - Discharge x = F cos ; x2 + +* [Interacting rule] + (inert) [W] x1 : F tys ~ fmv1 + (work item) [W] x2 : F tys ~ fmv2 + Just solve one from the other: + x2 := x1 + fmv2 := fmv1 + This just unites the two fsks into one. + Always solve given from wanted if poss. + +* For top-level reductions, see Note [Top-level reductions for type functions] + in GHC.Tc.Solver.Interact + + +Why given-fsks, alone, doesn't work +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Could we get away with only flatten meta-tyvars, with no flatten-skolems? No. + + [W] w : alpha ~ [F alpha Int] + +---> flatten + w = ...w'... + [W] w' : alpha ~ [fsk] + [G] : F alpha Int ~ fsk + +--> unify (no occurs check) + alpha := [fsk] + +But since fsk = F alpha Int, this is really an occurs check error. If +that is all we know about alpha, we will succeed in constraint +solving, producing a program with an infinite type. + +Even if we did finally get (g : fsk ~ Bool) by solving (F alpha Int ~ fsk) +using axiom, zonking would not see it, so (x::alpha) sitting in the +tree will get zonked to an infinite type. (Zonking always only does +refl stuff.) + +Why flatten-meta-vars, alone doesn't work +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Look at Simple13, with unification-fmvs only + + [G] g : a ~ [F a] + +---> Flatten given + g' = g;[x] + [G] g' : a ~ [fmv] + [W] x : F a ~ fmv + +--> subst a in x + g' = g;[x] + x = F g' ; x2 + [W] x2 : F [fmv] ~ fmv + +And now we have an evidence cycle between g' and x! + +If we used a given instead (ie current story) + + [G] g : a ~ [F a] + +---> Flatten given + g' = g;[x] + [G] g' : a ~ [fsk] + [G] : F a ~ fsk + +---> Substitute for a + [G] g' : a ~ [fsk] + [G] F (sym g'); : F [fsk] ~ fsk + + +Why is it right to treat fmv's differently to ordinary unification vars? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + f :: forall a. a -> a -> Bool + g :: F Int -> F Int -> Bool + +Consider + f (x:Int) (y:Bool) +This gives alpha~Int, alpha~Bool. There is an inconsistency, +but really only one error. SherLoc may tell you which location +is most likely, based on other occurrences of alpha. + +Consider + g (x:Int) (y:Bool) +Here we get (F Int ~ Int, F Int ~ Bool), which flattens to + (fmv ~ Int, fmv ~ Bool) +But there are really TWO separate errors. + + ** We must not complain about Int~Bool. ** + +Moreover these two errors could arise in entirely unrelated parts of +the code. (In the alpha case, there must be *some* connection (eg +v:alpha in common envt).) + +Note [Unflattening can force the solver to iterate] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Look at #10340: + type family Any :: * -- No instances + get :: MonadState s m => m s + instance MonadState s (State s) where ... + + foo :: State Any Any + foo = get + +For 'foo' we instantiate 'get' at types mm ss + [WD] MonadState ss mm, [WD] mm ss ~ State Any Any +Flatten, and decompose + [WD] MonadState ss mm, [WD] Any ~ fmv + [WD] mm ~ State fmv, [WD] fmv ~ ss +Unify mm := State fmv: + [WD] MonadState ss (State fmv) + [WD] Any ~ fmv, [WD] fmv ~ ss +Now we are stuck; the instance does not match!! So unflatten: + fmv := Any + ss := Any (*) + [WD] MonadState Any (State Any) + +The unification (*) represents progress, so we must do a second +round of solving; this time it succeeds. This is done by the 'go' +loop in solveSimpleWanteds. + +This story does not feel right but it's the best I can do; and the +iteration only happens in pretty obscure circumstances. + + +************************************************************************ +* * +* Examples + Here is a long series of examples I had to work through +* * +************************************************************************ + +Simple20 +~~~~~~~~ +axiom F [a] = [F a] + + [G] F [a] ~ a +--> + [G] fsk ~ a + [G] [F a] ~ fsk (nc) +--> + [G] F a ~ fsk2 + [G] fsk ~ [fsk2] + [G] fsk ~ a +--> + [G] F a ~ fsk2 + [G] a ~ [fsk2] + [G] fsk ~ a + +---------------------------------------- +indexed-types/should_compile/T44984 + + [W] H (F Bool) ~ H alpha + [W] alpha ~ F Bool +--> + F Bool ~ fmv0 + H fmv0 ~ fmv1 + H alpha ~ fmv2 + + fmv1 ~ fmv2 + fmv0 ~ alpha + +flatten +~~~~~~~ + fmv0 := F Bool + fmv1 := H (F Bool) + fmv2 := H alpha + alpha := F Bool +plus + fmv1 ~ fmv2 + +But these two are equal under the above assumptions. +Solve by Refl. + + +--- under plan B, namely solve fmv1:=fmv2 eagerly --- + [W] H (F Bool) ~ H alpha + [W] alpha ~ F Bool +--> + F Bool ~ fmv0 + H fmv0 ~ fmv1 + H alpha ~ fmv2 + + fmv1 ~ fmv2 + fmv0 ~ alpha +--> + F Bool ~ fmv0 + H fmv0 ~ fmv1 + H alpha ~ fmv2 fmv2 := fmv1 + + fmv0 ~ alpha + +flatten + fmv0 := F Bool + fmv1 := H fmv0 = H (F Bool) + retain H alpha ~ fmv2 + because fmv2 has been filled + alpha := F Bool + + +---------------------------- +indexed-types/should_failt/T4179 + +after solving + [W] fmv_1 ~ fmv_2 + [W] A3 (FCon x) ~ fmv_1 (CFunEqCan) + [W] A3 (x (aoa -> fmv_2)) ~ fmv_2 (CFunEqCan) + +---------------------------------------- +indexed-types/should_fail/T7729a + +a) [W] BasePrimMonad (Rand m) ~ m1 +b) [W] tt m1 ~ BasePrimMonad (Rand m) + +---> process (b) first + BasePrimMonad (Ramd m) ~ fmv_atH + fmv_atH ~ tt m1 + +---> now process (a) + m1 ~ s_atH ~ tt m1 -- An obscure occurs check + + +---------------------------------------- +typecheck/TcTypeNatSimple + +Original constraint + [W] x + y ~ x + alpha (non-canonical) +==> + [W] x + y ~ fmv1 (CFunEqCan) + [W] x + alpha ~ fmv2 (CFuneqCan) + [W] fmv1 ~ fmv2 (CTyEqCan) + +(sigh) + +---------------------------------------- +indexed-types/should_fail/GADTwrong1 + + [G] Const a ~ () +==> flatten + [G] fsk ~ () + work item: Const a ~ fsk +==> fire top rule + [G] fsk ~ () + work item fsk ~ () + +Surely the work item should rewrite to () ~ ()? Well, maybe not; +it'a very special case. More generally, our givens look like +F a ~ Int, where (F a) is not reducible. + + +---------------------------------------- +indexed_types/should_fail/T8227: + +Why using a different can-rewrite rule in CFunEqCan heads +does not work. + +Assuming NOT rewriting wanteds with wanteds + + Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk + [W] fmv_aBk ~ fsk_aBh + + [G] Scalar fsk_aBg ~ fsk_aBh + [G] V a ~ f_aBg + + Worklist includes [W] Scalar fmv_aBi ~ fmv_aBk + fmv_aBi, fmv_aBk are flatten unification variables + + Work item: [W] V fsk_aBh ~ fmv_aBi + +Note that the inert wanteds are cyclic, because we do not rewrite +wanteds with wanteds. + + +Then we go into a loop when normalise the work-item, because we +use rewriteOrSame on the argument of V. + +Conclusion: Don't make canRewrite context specific; instead use +[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable. + + +---------------------------------------- + +Here is a somewhat similar case: + + type family G a :: * + + blah :: (G a ~ Bool, Eq (G a)) => a -> a + blah = error "urk" + + foo x = blah x + +For foo we get + [W] Eq (G a), G a ~ Bool +Flattening + [W] G a ~ fmv, Eq fmv, fmv ~ Bool +We can't simplify away the Eq Bool unless we substitute for fmv. +Maybe that doesn't matter: we would still be left with unsolved +G a ~ Bool. + +-------------------------- +#9318 has a very simple program leading to + + [W] F Int ~ Int + [W] F Int ~ Bool + +We don't want to get "Error Int~Bool". But if fmv's can rewrite +wanteds, we will + + [W] fmv ~ Int + [W] fmv ~ Bool +---> + [W] Int ~ Bool + + +************************************************************************ +* * +* FlattenEnv & FlatM +* The flattening environment & monad +* * +************************************************************************ + +-} + +type FlatWorkListRef = TcRef [Ct] -- See Note [The flattening work list] + +data FlattenEnv + = FE { fe_mode :: !FlattenMode + , fe_loc :: CtLoc -- See Note [Flattener CtLoc] + -- unbanged because it's bogus in rewriteTyVar + , fe_flavour :: !CtFlavour + , fe_eq_rel :: !EqRel -- See Note [Flattener EqRels] + , fe_work :: !FlatWorkListRef } -- See Note [The flattening work list] + +data FlattenMode -- Postcondition for all three: inert wrt the type substitution + = FM_FlattenAll -- Postcondition: function-free + | FM_SubstOnly -- See Note [Flattening under a forall] + +-- | FM_Avoid TcTyVar Bool -- See Note [Lazy flattening] +-- -- Postcondition: +-- -- * tyvar is only mentioned in result under a rigid path +-- -- e.g. [a] is ok, but F a won't happen +-- -- * If flat_top is True, top level is not a function application +-- -- (but under type constructors is ok e.g. [F a]) + +instance Outputable FlattenMode where + ppr FM_FlattenAll = text "FM_FlattenAll" + ppr FM_SubstOnly = text "FM_SubstOnly" + +eqFlattenMode :: FlattenMode -> FlattenMode -> Bool +eqFlattenMode FM_FlattenAll FM_FlattenAll = True +eqFlattenMode FM_SubstOnly FM_SubstOnly = True +-- FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2 +eqFlattenMode _ _ = False + +-- | The 'FlatM' monad is a wrapper around 'TcS' with the following +-- extra capabilities: (1) it offers access to a 'FlattenEnv'; +-- and (2) it maintains the flattening worklist. +-- See Note [The flattening work list]. +newtype FlatM a + = FlatM { runFlatM :: FlattenEnv -> TcS a } + deriving (Functor) + +instance Monad FlatM where + m >>= k = FlatM $ \env -> + do { a <- runFlatM m env + ; runFlatM (k a) env } + +instance Applicative FlatM where + pure x = FlatM $ const (pure x) + (<*>) = ap + +liftTcS :: TcS a -> FlatM a +liftTcS thing_inside + = FlatM $ const thing_inside + +emitFlatWork :: Ct -> FlatM () +-- See Note [The flattening work list] +emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :) + +-- convenient wrapper when you have a CtEvidence describing +-- the flattening operation +runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS a +runFlattenCtEv mode ev + = runFlatten mode (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev) + +-- Run thing_inside (which does flattening), and put all +-- the work it generates onto the main work list +-- See Note [The flattening work list] +runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a +runFlatten mode loc flav eq_rel thing_inside + = do { flat_ref <- newTcRef [] + ; let fmode = FE { fe_mode = mode + , fe_loc = bumpCtLocDepth loc + -- See Note [Flatten when discharging CFunEqCan] + , fe_flavour = flav + , fe_eq_rel = eq_rel + , fe_work = flat_ref } + ; res <- runFlatM thing_inside fmode + ; new_flats <- readTcRef flat_ref + ; updWorkListTcS (add_flats new_flats) + ; return res } + where + add_flats new_flats wl + = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) } + + add_funeqs [] wl = wl + add_funeqs (f:fs) wl = add_funeqs fs (f:wl) + -- add_funeqs fs ws = reverse fs ++ ws + -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4] + -- = [f3,f2,f1,w1,w2,w3,w4] + +traceFlat :: String -> SDoc -> FlatM () +traceFlat herald doc = liftTcS $ traceTcS herald doc + +getFlatEnvField :: (FlattenEnv -> a) -> FlatM a +getFlatEnvField accessor + = FlatM $ \env -> return (accessor env) + +getEqRel :: FlatM EqRel +getEqRel = getFlatEnvField fe_eq_rel + +getRole :: FlatM Role +getRole = eqRelRole <$> getEqRel + +getFlavour :: FlatM CtFlavour +getFlavour = getFlatEnvField fe_flavour + +getFlavourRole :: FlatM CtFlavourRole +getFlavourRole + = do { flavour <- getFlavour + ; eq_rel <- getEqRel + ; return (flavour, eq_rel) } + +getMode :: FlatM FlattenMode +getMode = getFlatEnvField fe_mode + +getLoc :: FlatM CtLoc +getLoc = getFlatEnvField fe_loc + +checkStackDepth :: Type -> FlatM () +checkStackDepth ty + = do { loc <- getLoc + ; liftTcS $ checkReductionDepth loc ty } + +-- | Change the 'EqRel' in a 'FlatM'. +setEqRel :: EqRel -> FlatM a -> FlatM a +setEqRel new_eq_rel thing_inside + = FlatM $ \env -> + if new_eq_rel == fe_eq_rel env + then runFlatM thing_inside env + else runFlatM thing_inside (env { fe_eq_rel = new_eq_rel }) + +-- | Change the 'FlattenMode' in a 'FlattenEnv'. +setMode :: FlattenMode -> FlatM a -> FlatM a +setMode new_mode thing_inside + = FlatM $ \env -> + if new_mode `eqFlattenMode` fe_mode env + then runFlatM thing_inside env + else runFlatM thing_inside (env { fe_mode = new_mode }) + +-- | Make sure that flattening actually produces a coercion (in other +-- words, make sure our flavour is not Derived) +-- Note [No derived kind equalities] +noBogusCoercions :: FlatM a -> FlatM a +noBogusCoercions thing_inside + = FlatM $ \env -> + -- No new thunk is made if the flavour hasn't changed (note the bang). + let !env' = case fe_flavour env of + Derived -> env { fe_flavour = Wanted WDeriv } + _ -> env + in + runFlatM thing_inside env' + +bumpDepth :: FlatM a -> FlatM a +bumpDepth (FlatM thing_inside) + = FlatM $ \env -> do + -- bumpDepth can be called a lot during flattening so we force the + -- new env to avoid accumulating thunks. + { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) } + ; thing_inside env' } + +{- +Note [The flattening work list] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "flattening work list", held in the fe_work field of FlattenEnv, +is a list of CFunEqCans generated during flattening. The key idea +is this. Consider flattening (Eq (F (G Int) (H Bool)): + * The flattener recursively calls itself on sub-terms before building + the main term, so it will encounter the terms in order + G Int + H Bool + F (G Int) (H Bool) + flattening to sub-goals + w1: G Int ~ fuv0 + w2: H Bool ~ fuv1 + w3: F fuv0 fuv1 ~ fuv2 + + * Processing w3 first is BAD, because we can't reduce i t,so it'll + get put into the inert set, and later kicked out when w1, w2 are + solved. In #9872 this led to inert sets containing hundreds + of suspended calls. + + * So we want to process w1, w2 first. + + * So you might think that we should just use a FIFO deque for the work-list, + so that putting adding goals in order w1,w2,w3 would mean we processed + w1 first. + + * BUT suppose we have 'type instance G Int = H Char'. Then processing + w1 leads to a new goal + w4: H Char ~ fuv0 + We do NOT want to put that on the far end of a deque! Instead we want + to put it at the *front* of the work-list so that we continue to work + on it. + +So the work-list structure is this: + + * The wl_funeqs (in TcS) is a LIFO stack; we push new goals (such as w4) on + top (extendWorkListFunEq), and take new work from the top + (selectWorkItem). + + * When flattening, emitFlatWork pushes new flattening goals (like + w1,w2,w3) onto the flattening work list, fe_work, another + push-down stack. + + * When we finish flattening, we *reverse* the fe_work stack + onto the wl_funeqs stack (which brings w1 to the top). + +The function runFlatten initialises the fe_work stack, and reverses +it onto wl_fun_eqs at the end. + +Note [Flattener EqRels] +~~~~~~~~~~~~~~~~~~~~~~~ +When flattening, we need to know which equality relation -- nominal +or representation -- we should be respecting. The only difference is +that we rewrite variables by representational equalities when fe_eq_rel +is ReprEq, and that we unwrap newtypes when flattening w.r.t. +representational equality. + +Note [Flattener CtLoc] +~~~~~~~~~~~~~~~~~~~~~~ +The flattener does eager type-family reduction. +Type families might loop, and we +don't want GHC to do so. A natural solution is to have a bounded depth +to these processes. A central difficulty is that such a solution isn't +quite compositional. For example, say it takes F Int 10 steps to get to Bool. +How many steps does it take to get from F Int -> F Int to Bool -> Bool? +10? 20? What about getting from Const Char (F Int) to Char? 11? 1? Hard to +know and hard to track. So, we punt, essentially. We store a CtLoc in +the FlattenEnv and just update the environment when recurring. In the +TyConApp case, where there may be multiple type families to flatten, +we just copy the current CtLoc into each branch. If any branch hits the +stack limit, then the whole thing fails. + +A consequence of this is that setting the stack limits appropriately +will be essentially impossible. So, the official recommendation if a +stack limit is hit is to disable the check entirely. Otherwise, there +will be baffling, unpredictable errors. + +Note [Lazy flattening] +~~~~~~~~~~~~~~~~~~~~~~ +The idea of FM_Avoid mode is to flatten less aggressively. If we have + a ~ [F Int] +there seems to be no great merit in lifting out (F Int). But if it was + a ~ [G a Int] +then we *do* want to lift it out, in case (G a Int) reduces to Bool, say, +which gets rid of the occurs-check problem. (For the flat_top Bool, see +comments above and at call sites.) + +HOWEVER, the lazy flattening actually seems to make type inference go +*slower*, not faster. perf/compiler/T3064 is a case in point; it gets +*dramatically* worse with FM_Avoid. I think it may be because +floating the types out means we normalise them, and that often makes +them smaller and perhaps allows more re-use of previously solved +goals. But to be honest I'm not absolutely certain, so I am leaving +FM_Avoid in the code base. What I'm removing is the unique place +where it is *used*, namely in GHC.Tc.Solver.Canonical.canEqTyVar. + +See also Note [Conservative unification check] in GHC.Tc.Utils.Unify, which gives +other examples where lazy flattening caused problems. + +Bottom line: FM_Avoid is unused for now (Nov 14). +Note: T5321Fun got faster when I disabled FM_Avoid + T5837 did too, but it's pathological anyway + +Note [Phantoms in the flattener] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + +data Proxy p = Proxy + +and we're flattening (Proxy ty) w.r.t. ReprEq. Then, we know that `ty` +is really irrelevant -- it will be ignored when solving for representational +equality later on. So, we omit flattening `ty` entirely. This may +violate the expectation of "xi"s for a bit, but the canonicaliser will +soon throw out the phantoms when decomposing a TyConApp. (Or, the +canonicaliser will emit an insoluble, in which case the unflattened version +yields a better error message anyway.) + +Note [No derived kind equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A kind-level coercion can appear in types, via mkCastTy. So, whenever +we are generating a coercion in a dependent context (in other words, +in a kind) we need to make sure that our flavour is never Derived +(as Derived constraints have no evidence). The noBogusCoercions function +changes the flavour from Derived just for this purpose. + +-} + +{- ********************************************************************* +* * +* Externally callable flattening functions * +* * +* They are all wrapped in runFlatten, so their * +* flattening work gets put into the work list * +* * +********************************************************************* + +Note [rewriteTyVar] +~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have an injective function F and + inert_funeqs: F t1 ~ fsk1 + F t2 ~ fsk2 + inert_eqs: fsk1 ~ [a] + a ~ Int + fsk2 ~ [Int] + +We never rewrite the RHS (cc_fsk) of a CFunEqCan. But we /do/ want to get the +[D] t1 ~ t2 from the injectiveness of F. So we flatten cc_fsk of CFunEqCans +when trying to find derived equalities arising from injectivity. +-} + +-- | See Note [Flattening]. +-- If (xi, co) <- flatten mode ev ty, then co :: xi ~r ty +-- where r is the role in @ev@. If @mode@ is 'FM_FlattenAll', +-- then 'xi' is almost function-free (Note [Almost function-free] +-- in GHC.Tc.Types). +flatten :: FlattenMode -> CtEvidence -> TcType + -> TcS (Xi, TcCoercion) +flatten mode ev ty + = do { traceTcS "flatten {" (ppr mode <+> ppr ty) + ; (ty', co) <- runFlattenCtEv mode ev (flatten_one ty) + ; traceTcS "flatten }" (ppr ty') + ; return (ty', co) } + +-- Apply the inert set as an *inert generalised substitution* to +-- a variable, zonking along the way. +-- See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad. +-- Equivalently, this flattens the variable with respect to NomEq +-- in a Derived constraint. (Why Derived? Because Derived allows the +-- most about of rewriting.) Returns no coercion, because we're +-- using Derived constraints. +-- See Note [rewriteTyVar] +rewriteTyVar :: TcTyVar -> TcS TcType +rewriteTyVar tv + = do { traceTcS "rewriteTyVar {" (ppr tv) + ; (ty, _) <- runFlatten FM_SubstOnly fake_loc Derived NomEq $ + flattenTyVar tv + ; traceTcS "rewriteTyVar }" (ppr ty) + ; return ty } + where + fake_loc = pprPanic "rewriteTyVar used a CtLoc" (ppr tv) + +-- specialized to flattening kinds: never Derived, always Nominal +-- See Note [No derived kind equalities] +-- See Note [Flattening] +flattenKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN) +flattenKind loc flav ty + = do { traceTcS "flattenKind {" (ppr flav <+> ppr ty) + ; let flav' = case flav of + Derived -> Wanted WDeriv -- the WDeriv/WOnly choice matters not + _ -> flav + ; (ty', co) <- runFlatten FM_FlattenAll loc flav' NomEq (flatten_one ty) + ; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic + ; return (ty', co) } + +-- See Note [Flattening] +flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN) +-- Externally-callable, hence runFlatten +-- Flatten a vector of types all at once; in fact they are +-- always the arguments of type family or class, so +-- ctEvFlavour ev = Nominal +-- and we want to flatten all at nominal role +-- The kind passed in is the kind of the type family or class, call it T +-- The last coercion returned has type (tcTypeKind(T xis) ~N tcTypeKind(T tys)) +-- +-- For Derived constraints the returned coercion may be undefined +-- because flattening may use a Derived equality ([D] a ~ ty) +flattenArgsNom ev tc tys + = do { traceTcS "flatten_args {" (vcat (map ppr tys)) + ; (tys', cos, kind_co) + <- runFlattenCtEv FM_FlattenAll ev (flatten_args_tc tc (repeat Nominal) tys) + ; traceTcS "flatten }" (vcat (map ppr tys')) + ; return (tys', cos, kind_co) } + + +{- ********************************************************************* +* * +* The main flattening functions +* * +********************************************************************* -} + +{- Note [Flattening] +~~~~~~~~~~~~~~~~~~~~ + flatten ty ==> (xi, co) + where + xi has no type functions, unless they appear under ForAlls + has no skolems that are mapped in the inert set + has no filled-in metavariables + co :: xi ~ ty + +Key invariants: + (F0) co :: xi ~ zonk(ty) + (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind + (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) + +Note that it is flatten's job to flatten *every type function it sees*. +flatten is only called on *arguments* to type functions, by canEqGiven. + +Flattening also: + * zonks, removing any metavariables, and + * applies the substitution embodied in the inert set + +The result of flattening is *almost function-free*. See +Note [Almost function-free] in GHC.Tc.Utils. + +Because flattening zonks and the returned coercion ("co" above) is also +zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead, +we can rely on this fact: + + (F0) co :: xi ~ zonk(ty) + +Note that the left-hand type of co is *always* precisely xi. The right-hand +type may or may not be ty, however: if ty has unzonked filled-in metavariables, +then the right-hand type of co will be the zonked version of ty. +It is for this reason that we +occasionally have to explicitly zonk, when (co :: xi ~ ty) is important +even before we zonk the whole program. For example, see the FTRNotFollowed +case in flattenTyVar. + +Why have these invariants on flattening? Because we sometimes use tcTypeKind +during canonicalisation, and we want this kind to be zonked (e.g., see +GHC.Tc.Solver.Canonical.canEqTyVar). + +Flattening is always homogeneous. That is, the kind of the result of flattening is +always the same as the kind of the input, modulo zonking. More formally: + + (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) + +This invariant means that the kind of a flattened type might not itself be flat. + +Recall that in comments we use alpha[flat = ty] to represent a +flattening skolem variable alpha which has been generated to stand in +for ty. + +----- Example of flattening a constraint: ------ + flatten (List (F (G Int))) ==> (xi, cc) + where + xi = List alpha + cc = { G Int ~ beta[flat = G Int], + F beta ~ alpha[flat = F beta] } +Here + * alpha and beta are 'flattening skolem variables'. + * All the constraints in cc are 'given', and all their coercion terms + are the identity. + +NB: Flattening Skolems only occur in canonical constraints, which +are never zonked, so we don't need to worry about zonking doing +accidental unflattening. + +Note that we prefer to leave type synonyms unexpanded when possible, +so when the flattener encounters one, it first asks whether its +transitive expansion contains any type function applications. If so, +it expands the synonym and proceeds; if not, it simply returns the +unexpanded synonym. + +Note [flatten_args performance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In programs with lots of type-level evaluation, flatten_args becomes +part of a tight loop. For example, see test perf/compiler/T9872a, which +calls flatten_args a whopping 7,106,808 times. It is thus important +that flatten_args be efficient. + +Performance testing showed that the current implementation is indeed +efficient. It's critically important that zipWithAndUnzipM be +specialized to TcS, and it's also quite helpful to actually `inline` +it. On test T9872a, here are the allocation stats (Dec 16, 2014): + + * Unspecialized, uninlined: 8,472,613,440 bytes allocated in the heap + * Specialized, uninlined: 6,639,253,488 bytes allocated in the heap + * Specialized, inlined: 6,281,539,792 bytes allocated in the heap + +To improve performance even further, flatten_args_nom is split off +from flatten_args, as nominal equality is the common case. This would +be natural to write using mapAndUnzipM, but even inlined, that function +is not as performant as a hand-written loop. + + * mapAndUnzipM, inlined: 7,463,047,432 bytes allocated in the heap + * hand-written recursion: 5,848,602,848 bytes allocated in the heap + +If you make any change here, pay close attention to the T9872{a,b,c} tests +and T5321Fun. + +If we need to make this yet more performant, a possible way forward is to +duplicate the flattener code for the nominal case, and make that case +faster. This doesn't seem quite worth it, yet. + +Note [flatten_exact_fam_app_fully performance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The refactor of GRefl seems to cause performance trouble for T9872x: the allocation of flatten_exact_fam_app_fully_performance increased. See note [Generalized reflexive coercion] in GHC.Core.TyCo.Rep for more information about GRefl and #15192 for the current state. + +The explicit pattern match in homogenise_result helps with T9872a, b, c. + +Still, it increases the expected allocation of T9872d by ~2%. + +TODO: a step-by-step replay of the refactor to analyze the performance. + +-} + +{-# INLINE flatten_args_tc #-} +flatten_args_tc + :: TyCon -- T + -> [Role] -- Role r + -> [Type] -- Arg types [t1,..,tn] + -> FlatM ( [Xi] -- List of flattened args [x1,..,xn] + -- 1-1 corresp with [t1,..,tn] + , [Coercion] -- List of arg coercions [co1,..,con] + -- 1-1 corresp with [t1,..,tn] + -- coi :: xi ~r ti + , CoercionN) -- Result coercion, rco + -- rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con)) +flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet + -- NB: TyCon kinds are always closed + where + (bndrs, named) + = ty_con_binders_ty_binders' (tyConBinders tc) + -- it's possible that the result kind has arrows (for, e.g., a type family) + -- so we must split it + (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc) + !all_bndrs = bndrs `chkAppend` inner_bndrs + !any_named_bndrs = named || inner_named + -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%. + +{-# INLINE flatten_args #-} +flatten_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are + -- named. + -> Kind -> TcTyCoVarSet -- function kind; kind's free vars + -> [Role] -> [Type] -- these are in 1-to-1 correspondence + -> FlatM ([Xi], [Coercion], CoercionN) +-- Coercions :: Xi ~ Type, at roles given +-- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys) +-- That is, the third coercion relates the kind of some function (whose kind is +-- passed as the first parameter) instantiated at xis to the kind of that +-- function instantiated at the tys. This is useful in keeping flattening +-- homoegeneous. The list of roles must be at least as long as the list of +-- types. +flatten_args orig_binders + any_named_bndrs + orig_inner_ki + orig_fvs + orig_roles + orig_tys + = if any_named_bndrs + then flatten_args_slow orig_binders + orig_inner_ki + orig_fvs + orig_roles + orig_tys + else flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys + +{-# INLINE flatten_args_fast #-} +-- | fast path flatten_args, in which none of the binders are named and +-- therefore we can avoid tracking a lifting context. +-- There are many bang patterns in here. It's been observed that they +-- greatly improve performance of an optimized build. +-- The T9872 test cases are good witnesses of this fact. +flatten_args_fast :: [TyCoBinder] + -> Kind + -> [Role] + -> [Type] + -> FlatM ([Xi], [Coercion], CoercionN) +flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys + = fmap finish (iterate orig_tys orig_roles orig_binders) + where + + iterate :: [Type] + -> [Role] + -> [TyCoBinder] + -> FlatM ([Xi], [Coercion], [TyCoBinder]) + iterate (ty:tys) (role:roles) (_:binders) = do + (xi, co) <- go role ty + (xis, cos, binders) <- iterate tys roles binders + pure (xi : xis, co : cos, binders) + iterate [] _ binders = pure ([], [], binders) + iterate _ _ _ = pprPanic + "flatten_args wandered into deeper water than usual" (vcat []) + -- This debug information is commented out because leaving it in + -- causes a ~2% increase in allocations in T9872{a,c,d}. + {- + (vcat [ppr orig_binders, + ppr orig_inner_ki, + ppr (take 10 orig_roles), -- often infinite! + ppr orig_tys]) + -} + + {-# INLINE go #-} + go :: Role + -> Type + -> FlatM (Xi, Coercion) + go role ty + = case role of + -- In the slow path we bind the Xi and Coercion from the recursive + -- call and then use it such + -- + -- let kind_co = mkTcSymCo $ mkReflCo Nominal (tyBinderType binder) + -- casted_xi = xi `mkCastTy` kind_co + -- casted_co = xi |> kind_co ~r xi ; co + -- + -- but this isn't necessary: + -- mkTcSymCo (Refl a b) = Refl a b, + -- mkCastTy x (Refl _ _) = x + -- mkTcGReflLeftCo _ ty (Refl _ _) `mkTransCo` co = co + -- + -- Also, no need to check isAnonTyCoBinder or isNamedBinder, since + -- we've already established that they're all anonymous. + Nominal -> setEqRel NomEq $ flatten_one ty + Representational -> setEqRel ReprEq $ flatten_one ty + Phantom -> -- See Note [Phantoms in the flattener] + do { ty <- liftTcS $ zonkTcType ty + ; return (ty, mkReflCo Phantom ty) } + + + {-# INLINE finish #-} + finish :: ([Xi], [Coercion], [TyCoBinder]) -> ([Xi], [Coercion], CoercionN) + finish (xis, cos, binders) = (xis, cos, kind_co) + where + final_kind = mkPiTys binders orig_inner_ki + kind_co = mkNomReflCo final_kind + +{-# INLINE flatten_args_slow #-} +-- | Slow path, compared to flatten_args_fast, because this one must track +-- a lifting context. +flatten_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet + -> [Role] -> [Type] + -> FlatM ([Xi], [Coercion], CoercionN) +flatten_args_slow binders inner_ki fvs roles tys +-- Arguments used dependently must be flattened with proper coercions, but +-- we're not guaranteed to get a proper coercion when flattening with the +-- "Derived" flavour. So we must call noBogusCoercions when flattening arguments +-- corresponding to binders that are dependent. However, we might legitimately +-- have *more* arguments than binders, in the case that the inner_ki is a variable +-- that gets instantiated with a Π-type. We conservatively choose not to produce +-- bogus coercions for these, too. Note that this might miss an opportunity for +-- a Derived rewriting a Derived. The solution would be to generate evidence for +-- Deriveds, thus avoiding this whole noBogusCoercions idea. See also +-- Note [No derived kind equalities] + = do { flattened_args <- zipWith3M fl (map isNamedBinder binders ++ repeat True) + roles tys + ; return (simplifyArgsWorker binders inner_ki fvs roles flattened_args) } + where + {-# INLINE fl #-} + fl :: Bool -- must we ensure to produce a real coercion here? + -- see comment at top of function + -> Role -> Type -> FlatM (Xi, Coercion) + fl True r ty = noBogusCoercions $ fl1 r ty + fl False r ty = fl1 r ty + + {-# INLINE fl1 #-} + fl1 :: Role -> Type -> FlatM (Xi, Coercion) + fl1 Nominal ty + = setEqRel NomEq $ + flatten_one ty + + fl1 Representational ty + = setEqRel ReprEq $ + flatten_one ty + + fl1 Phantom ty + -- See Note [Phantoms in the flattener] + = do { ty <- liftTcS $ zonkTcType ty + ; return (ty, mkReflCo Phantom ty) } + +------------------ +flatten_one :: TcType -> FlatM (Xi, Coercion) +-- Flatten a type to get rid of type function applications, returning +-- the new type-function-free type, and a collection of new equality +-- constraints. See Note [Flattening] for more detail. +-- +-- Postcondition: Coercion :: Xi ~ TcType +-- The role on the result coercion matches the EqRel in the FlattenEnv + +flatten_one xi@(LitTy {}) + = do { role <- getRole + ; return (xi, mkReflCo role xi) } + +flatten_one (TyVarTy tv) + = flattenTyVar tv + +flatten_one (AppTy ty1 ty2) + = flatten_app_tys ty1 [ty2] + +flatten_one (TyConApp tc tys) + -- Expand type synonyms that mention type families + -- on the RHS; see Note [Flattening synonyms] + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' + = do { mode <- getMode + ; case mode of + FM_FlattenAll | not (isFamFreeTyCon tc) + -> flatten_one expanded_ty + _ -> flatten_ty_con_app tc tys } + + -- Otherwise, it's a type function application, and we have to + -- flatten it away as well, and generate a new given equality constraint + -- between the application and a newly generated flattening skolem variable. + | isTypeFamilyTyCon tc + = flatten_fam_app tc tys + + -- For * a normal data type application + -- * data family application + -- we just recursively flatten the arguments. + | otherwise +-- FM_Avoid stuff commented out; see Note [Lazy flattening] +-- , let fmode' = case fmode of -- Switch off the flat_top bit in FM_Avoid +-- FE { fe_mode = FM_Avoid tv _ } +-- -> fmode { fe_mode = FM_Avoid tv False } +-- _ -> fmode + = flatten_ty_con_app tc tys + +flatten_one ty@(FunTy _ ty1 ty2) + = do { (xi1,co1) <- flatten_one ty1 + ; (xi2,co2) <- flatten_one ty2 + ; role <- getRole + ; return (ty { ft_arg = xi1, ft_res = xi2 } + , mkFunCo role co1 co2) } + +flatten_one ty@(ForAllTy {}) +-- TODO (RAE): This is inadequate, as it doesn't flatten the kind of +-- the bound tyvar. Doing so will require carrying around a substitution +-- and the usual substTyVarBndr-like silliness. Argh. + +-- We allow for-alls when, but only when, no type function +-- applications inside the forall involve the bound type variables. + = do { let (bndrs, rho) = tcSplitForAllVarBndrs ty + tvs = binderVars bndrs + ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho + -- Substitute only under a forall + -- See Note [Flattening under a forall] + ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) } + +flatten_one (CastTy ty g) + = do { (xi, co) <- flatten_one ty + ; (g', _) <- flatten_co g + + ; role <- getRole + ; return (mkCastTy xi g', castCoercionKind co role xi ty g' g) } + +flatten_one (CoercionTy co) = first mkCoercionTy <$> flatten_co co + +-- | "Flatten" a coercion. Really, just zonk it so we can uphold +-- (F1) of Note [Flattening] +flatten_co :: Coercion -> FlatM (Coercion, Coercion) +flatten_co co + = do { co <- liftTcS $ zonkCo co + ; env_role <- getRole + ; let co' = mkTcReflCo env_role (mkCoercionTy co) + ; return (co, co') } + +-- flatten (nested) AppTys +flatten_app_tys :: Type -> [Type] -> FlatM (Xi, Coercion) +-- commoning up nested applications allows us to look up the function's kind +-- only once. Without commoning up like this, we would spend a quadratic amount +-- of time looking up functions' types +flatten_app_tys (AppTy ty1 ty2) tys = flatten_app_tys ty1 (ty2:tys) +flatten_app_tys fun_ty arg_tys + = do { (fun_xi, fun_co) <- flatten_one fun_ty + ; flatten_app_ty_args fun_xi fun_co arg_tys } + +-- Given a flattened function (with the coercion produced by flattening) and +-- a bunch of unflattened arguments, flatten the arguments and apply. +-- The coercion argument's role matches the role stored in the FlatM monad. +-- +-- The bang patterns used here were observed to improve performance. If you +-- wish to remove them, be sure to check for regeressions in allocations. +flatten_app_ty_args :: Xi -> Coercion -> [Type] -> FlatM (Xi, Coercion) +flatten_app_ty_args fun_xi fun_co [] + -- this will be a common case when called from flatten_fam_app, so shortcut + = return (fun_xi, fun_co) +flatten_app_ty_args fun_xi fun_co arg_tys + = do { (xi, co, kind_co) <- case tcSplitTyConApp_maybe fun_xi of + Just (tc, xis) -> + do { let tc_roles = tyConRolesRepresentational tc + arg_roles = dropList xis tc_roles + ; (arg_xis, arg_cos, kind_co) + <- flatten_vector (tcTypeKind fun_xi) arg_roles arg_tys + + -- Here, we have fun_co :: T xi1 xi2 ~ ty + -- and we need to apply fun_co to the arg_cos. The problem is + -- that using mkAppCo is wrong because that function expects + -- its second coercion to be Nominal, and the arg_cos might + -- not be. The solution is to use transitivity: + -- T arg_cos ;; fun_co + ; eq_rel <- getEqRel + ; let app_xi = mkTyConApp tc (xis ++ arg_xis) + app_co = case eq_rel of + NomEq -> mkAppCos fun_co arg_cos + ReprEq -> mkTcTyConAppCo Representational tc + (zipWith mkReflCo tc_roles xis ++ arg_cos) + `mkTcTransCo` + mkAppCos fun_co (map mkNomReflCo arg_tys) + ; return (app_xi, app_co, kind_co) } + Nothing -> + do { (arg_xis, arg_cos, kind_co) + <- flatten_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys + ; let arg_xi = mkAppTys fun_xi arg_xis + arg_co = mkAppCos fun_co arg_cos + ; return (arg_xi, arg_co, kind_co) } + + ; role <- getRole + ; return (homogenise_result xi co role kind_co) } + +flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) +flatten_ty_con_app tc tys + = do { role <- getRole + ; (xis, cos, kind_co) <- flatten_args_tc tc (tyConRolesX role tc) tys + ; let tyconapp_xi = mkTyConApp tc xis + tyconapp_co = mkTyConAppCo role tc cos + ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) } + +-- Make the result of flattening homogeneous (Note [Flattening] (F2)) +homogenise_result :: Xi -- a flattened type + -> Coercion -- :: xi ~r original ty + -> Role -- r + -> CoercionN -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty) + -> (Xi, Coercion) -- (xi |> kind_co, (xi |> kind_co) + -- ~r original ty) +homogenise_result xi co r kind_co + -- the explicit pattern match here improves the performance of T9872a, b, c by + -- ~2% + | isGReflCo kind_co = (xi `mkCastTy` kind_co, co) + | otherwise = (xi `mkCastTy` kind_co + , (mkSymCo $ GRefl r xi (MCo kind_co)) `mkTransCo` co) +{-# INLINE homogenise_result #-} + +-- Flatten a vector (list of arguments). +flatten_vector :: Kind -- of the function being applied to these arguments + -> [Role] -- If we're flatten w.r.t. ReprEq, what roles do the + -- args have? + -> [Type] -- the args to flatten + -> FlatM ([Xi], [Coercion], CoercionN) +flatten_vector ki roles tys + = do { eq_rel <- getEqRel + ; case eq_rel of + NomEq -> flatten_args bndrs + any_named_bndrs + inner_ki + fvs + (repeat Nominal) + tys + ReprEq -> flatten_args bndrs + any_named_bndrs + inner_ki + fvs + roles + tys + } + where + (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki + fvs = tyCoVarsOfType ki +{-# INLINE flatten_vector #-} + +{- +Note [Flattening synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Not expanding synonyms aggressively improves error messages, and +keeps types smaller. But we need to take care. + +Suppose + type T a = a -> a +and we want to flatten the type (T (F a)). Then we can safely flatten +the (F a) to a skolem, and return (T fsk). We don't need to expand the +synonym. This works because TcTyConAppCo can deal with synonyms +(unlike TyConAppCo), see Note [TcCoercions] in GHC.Tc.Types.Evidence. + +But (#8979) for + type T a = (F a, a) where F is a type function +we must expand the synonym in (say) T Int, to expose the type function +to the flattener. + + +Note [Flattening under a forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Under a forall, we + (a) MUST apply the inert substitution + (b) MUST NOT flatten type family applications +Hence FMSubstOnly. + +For (a) consider c ~ a, a ~ T (forall b. (b, [c])) +If we don't apply the c~a substitution to the second constraint +we won't see the occurs-check error. + +For (b) consider (a ~ forall b. F a b), we don't want to flatten +to (a ~ forall b.fsk, F a b ~ fsk) +because now the 'b' has escaped its scope. We'd have to flatten to + (a ~ forall b. fsk b, forall b. F a b ~ fsk b) +and we have not begun to think about how to make that work! + +************************************************************************ +* * + Flattening a type-family application +* * +************************************************************************ +-} + +flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) + -- flatten_fam_app can be over-saturated + -- flatten_exact_fam_app is exactly saturated + -- flatten_exact_fam_app_fully lifts out the application to top level + -- Postcondition: Coercion :: Xi ~ F tys +flatten_fam_app tc tys -- Can be over-saturated + = ASSERT2( tys `lengthAtLeast` tyConArity tc + , ppr tc $$ ppr (tyConArity tc) $$ ppr tys) + + do { mode <- getMode + ; case mode of + { FM_SubstOnly -> flatten_ty_con_app tc tys + ; FM_FlattenAll -> + + -- Type functions are saturated + -- The type function might be *over* saturated + -- in which case the remaining arguments should + -- be dealt with by AppTys + do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys + ; (xi1, co1) <- flatten_exact_fam_app_fully tc tys1 + -- co1 :: xi1 ~ F tys1 + + ; flatten_app_ty_args xi1 co1 tys_rest } } } + +-- the [TcType] exactly saturate the TyCon +-- See note [flatten_exact_fam_app_fully performance] +flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion) +flatten_exact_fam_app_fully tc tys + -- See Note [Reduce type family applications eagerly] + -- the following tcTypeKind should never be evaluated, as it's just used in + -- casting, and casts by refl are dropped + = do { mOut <- try_to_reduce_nocache tc tys + ; case mOut of + Just out -> pure out + Nothing -> do + { -- First, flatten the arguments + ; (xis, cos, kind_co) + <- setEqRel NomEq $ -- just do this once, instead of for + -- each arg + flatten_args_tc tc (repeat Nominal) tys + -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys) + ; eq_rel <- getEqRel + ; cur_flav <- getFlavour + ; let role = eqRelRole eq_rel + ret_co = mkTyConAppCo role tc cos + -- ret_co :: F xis ~ F tys; might be heterogeneous + + -- Now, look in the cache + ; mb_ct <- liftTcS $ lookupFlatCache tc xis + ; case mb_ct of + Just (co, rhs_ty, flav) -- co :: F xis ~ fsk + -- flav is [G] or [WD] + -- See Note [Type family equations] in GHC.Tc.Solver.Monad + | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav + -> -- Usable hit in the flat-cache + do { traceFlat "flatten/flat-cache hit" $ + (ppr tc <+> ppr xis $$ ppr rhs_ty) + ; (fsk_xi, fsk_co) <- flatten_one rhs_ty + -- The fsk may already have been unified, so + -- flatten it + -- fsk_co :: fsk_xi ~ fsk + ; let xi = fsk_xi `mkCastTy` kind_co + co' = mkTcCoherenceLeftCo role fsk_xi kind_co fsk_co + `mkTransCo` + maybeTcSubCo eq_rel (mkSymCo co) + `mkTransCo` ret_co + ; return (xi, co') + } + -- :: fsk_xi ~ F xis + + -- Try to reduce the family application right now + -- See Note [Reduce type family applications eagerly] + _ -> do { mOut <- try_to_reduce tc + xis + kind_co + (`mkTransCo` ret_co) + ; case mOut of + Just out -> pure out + Nothing -> do + { loc <- getLoc + ; (ev, co, fsk) <- liftTcS $ + newFlattenSkolem cur_flav loc tc xis + + -- The new constraint (F xis ~ fsk) is not + -- necessarily inert (e.g. the LHS may be a + -- redex) so we must put it in the work list + ; let ct = CFunEqCan { cc_ev = ev + , cc_fun = tc + , cc_tyargs = xis + , cc_fsk = fsk } + ; emitFlatWork ct + + ; traceFlat "flatten/flat-cache miss" $ + (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev) + + -- NB: fsk's kind is already flattened because + -- the xis are flattened + ; let fsk_ty = mkTyVarTy fsk + xi = fsk_ty `mkCastTy` kind_co + co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeTcSubCo eq_rel (mkSymCo co)) + `mkTransCo` ret_co + ; return (xi, co') + } + } + } + } + + where + + -- try_to_reduce and try_to_reduce_nocache (below) could be unified into + -- a more general definition, but it was observed that separating them + -- gives better performance (lower allocation numbers in T9872x). + + try_to_reduce :: TyCon -- F, family tycon + -> [Type] -- args, not necessarily flattened + -> CoercionN -- kind_co :: tcTypeKind(F args) ~N + -- tcTypeKind(F orig_args) + -- where + -- orig_args is what was passed to the outer + -- function + -> ( Coercion -- :: (xi |> kind_co) ~ F args + -> Coercion ) -- what to return from outer function + -> FlatM (Maybe (Xi, Coercion)) + try_to_reduce tc tys kind_co update_co + = do { checkStackDepth (mkTyConApp tc tys) + ; mb_match <- liftTcS $ matchFam tc tys + ; case mb_match of + -- NB: norm_co will always be homogeneous. All type families + -- are homogeneous. + Just (norm_co, norm_ty) + -> do { traceFlat "Eager T.F. reduction success" $ + vcat [ ppr tc, ppr tys, ppr norm_ty + , ppr norm_co <+> dcolon + <+> ppr (coercionKind norm_co) + ] + ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty + ; eq_rel <- getEqRel + ; let co = maybeTcSubCo eq_rel norm_co + `mkTransCo` mkSymCo final_co + ; flavour <- getFlavour + -- NB: only extend cache with nominal equalities + ; when (eq_rel == NomEq) $ + liftTcS $ + extendFlatCache tc tys ( co, xi, flavour ) + ; let role = eqRelRole eq_rel + xi' = xi `mkCastTy` kind_co + co' = update_co $ + mkTcCoherenceLeftCo role xi kind_co (mkSymCo co) + ; return $ Just (xi', co') } + Nothing -> pure Nothing } + + try_to_reduce_nocache :: TyCon -- F, family tycon + -> [Type] -- args, not necessarily flattened + -> FlatM (Maybe (Xi, Coercion)) + try_to_reduce_nocache tc tys + = do { checkStackDepth (mkTyConApp tc tys) + ; mb_match <- liftTcS $ matchFam tc tys + ; case mb_match of + -- NB: norm_co will always be homogeneous. All type families + -- are homogeneous. + Just (norm_co, norm_ty) + -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty + ; eq_rel <- getEqRel + ; let co = mkSymCo (maybeTcSubCo eq_rel norm_co + `mkTransCo` mkSymCo final_co) + ; return $ Just (xi, co) } + Nothing -> pure Nothing } + +{- Note [Reduce type family applications eagerly] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we come across a type-family application like (Append (Cons x Nil) t), +then, rather than flattening to a skolem etc, we may as well just reduce +it on the spot to (Cons x t). This saves a lot of intermediate steps. +Examples that are helped are tests T9872, and T5321Fun. + +Performance testing indicates that it's best to try this *twice*, once +before flattening arguments and once after flattening arguments. +Adding the extra reduction attempt before flattening arguments cut +the allocation amounts for the T9872{a,b,c} tests by half. + +An example of where the early reduction appears helpful: + + type family Last x where + Last '[x] = x + Last (h ': t) = Last t + + workitem: (x ~ Last '[1,2,3,4,5,6]) + +Flattening the argument never gets us anywhere, but trying to flatten +it at every step is quadratic in the length of the list. Reducing more +eagerly makes simplifying the right-hand type linear in its length. + +Testing also indicated that the early reduction should *not* use the +flat-cache, but that the later reduction *should*. (Although the +effect was not large.) Hence the Bool argument to try_to_reduce. To +me (SLPJ) this seems odd; I get that eager reduction usually succeeds; +and if don't use the cache for eager reduction, we will miss most of +the opportunities for using it at all. More exploration would be good +here. + +At the end, once we've got a flat rhs, we extend the flatten-cache to record +the result. Doing so can save lots of work when the same redex shows up more +than once. Note that we record the link from the redex all the way to its +*final* value, not just the single step reduction. Interestingly, using the +flat-cache for the first reduction resulted in an increase in allocations +of about 3% for the four T9872x tests. However, using the flat-cache in +the later reduction is a similar gain. I (Richard E) don't currently (Dec '14) +have any knowledge as to *why* these facts are true. + +************************************************************************ +* * + Flattening a type variable +* * +********************************************************************* -} + +-- | The result of flattening a tyvar "one step". +data FlattenTvResult + = FTRNotFollowed + -- ^ The inert set doesn't make the tyvar equal to anything else + + | FTRFollowed TcType Coercion + -- ^ The tyvar flattens to a not-necessarily flat other type. + -- co :: new type ~r old type, where the role is determined by + -- the FlattenEnv + +flattenTyVar :: TyVar -> FlatM (Xi, Coercion) +flattenTyVar tv + = do { mb_yes <- flatten_tyvar1 tv + ; case mb_yes of + FTRFollowed ty1 co1 -- Recur + -> do { (ty2, co2) <- flatten_one ty1 + -- ; traceFlat "flattenTyVar2" (ppr tv $$ ppr ty2) + ; return (ty2, co2 `mkTransCo` co1) } + + FTRNotFollowed -- Done, but make sure the kind is zonked + -- Note [Flattening] invariant (F0) and (F1) + -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv + ; role <- getRole + ; let ty' = mkTyVarTy tv' + ; return (ty', mkTcReflCo role ty') } } + +flatten_tyvar1 :: TcTyVar -> FlatM FlattenTvResult +-- "Flattening" a type variable means to apply the substitution to it +-- Specifically, look up the tyvar in +-- * the internal MetaTyVar box +-- * the inerts +-- See also the documentation for FlattenTvResult + +flatten_tyvar1 tv + = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv + ; case mb_ty of + Just ty -> do { traceFlat "Following filled tyvar" + (ppr tv <+> equals <+> ppr ty) + ; role <- getRole + ; return (FTRFollowed ty (mkReflCo role ty)) } ; + Nothing -> do { traceFlat "Unfilled tyvar" (pprTyVar tv) + ; fr <- getFlavourRole + ; flatten_tyvar2 tv fr } } + +flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult +-- The tyvar is not a filled-in meta-tyvar +-- Try in the inert equalities +-- See Definition [Applying a generalised substitution] in GHC.Tc.Solver.Monad +-- See Note [Stability of flattening] in GHC.Tc.Solver.Monad + +flatten_tyvar2 tv fr@(_, eq_rel) + = do { ieqs <- liftTcS $ getInertEqs + ; mode <- getMode + ; case lookupDVarEnv ieqs tv of + Just (ct:_) -- If the first doesn't work, + -- the subsequent ones won't either + | CTyEqCan { cc_ev = ctev, cc_tyvar = tv + , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct + , let ct_fr = (ctEvFlavour ctev, ct_eq_rel) + , ct_fr `eqCanRewriteFR` fr -- This is THE key call of eqCanRewriteFR + -> do { traceFlat "Following inert tyvar" + (ppr mode <+> + ppr tv <+> + equals <+> + ppr rhs_ty $$ ppr ctev) + ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev) + rewrite_co = case (ct_eq_rel, eq_rel) of + (ReprEq, _rel) -> ASSERT( _rel == ReprEq ) + -- if this ASSERT fails, then + -- eqCanRewriteFR answered incorrectly + rewrite_co1 + (NomEq, NomEq) -> rewrite_co1 + (NomEq, ReprEq) -> mkSubCo rewrite_co1 + + ; return (FTRFollowed rhs_ty rewrite_co) } + -- NB: ct is Derived then fmode must be also, hence + -- we are not going to touch the returned coercion + -- so ctEvCoercion is fine. + + _other -> return FTRNotFollowed } + +{- +Note [An alternative story for the inert substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(This entire note is just background, left here in case we ever want + to return the previous state of affairs) + +We used (GHC 7.8) to have this story for the inert substitution inert_eqs + + * 'a' is not in fvs(ty) + * They are *inert* in the weaker sense that there is no infinite chain of + (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc + +This means that flattening must be recursive, but it does allow + [G] a ~ [b] + [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 + (b) the inert cannot rewrite the work item + +This is significantly harder to think about. It can save a LOT of work +in occurs-check cases, but we don't care about them much. #5837 +is an example; all the constraints here are Givens + + [G] a ~ TF (a,Int) + --> + work TF (a,Int) ~ fsk + inert fsk ~ a + + ---> + work fsk ~ (TF a, TF Int) + inert fsk ~ a + + ---> + work a ~ (TF a, TF Int) + inert fsk ~ a + + ---> (attempting to flatten (TF a) so that it does not mention a + work TF a ~ fsk2 + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> (substitute for a) + work TF (fsk2, TF Int) ~ fsk2 + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> (top-level reduction, re-orient) + work fsk2 ~ (TF fsk2, TF Int) + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> (attempt to flatten (TF fsk2) to get rid of fsk2 + work TF fsk2 ~ fsk3 + work fsk2 ~ (fsk3, TF Int) + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> + work TF fsk2 ~ fsk3 + inert fsk2 ~ (fsk3, TF Int) + inert a ~ ((fsk3, TF Int), TF Int) + inert fsk ~ ((fsk3, TF Int), TF Int) + +Because the incoming given rewrites all the inert givens, we get more and +more duplication in the inert set. But this really only happens in pathological +casee, so we don't care. + + +************************************************************************ +* * + Unflattening +* * +************************************************************************ + +An unflattening example: + [W] F a ~ alpha +flattens to + [W] F a ~ fmv (CFunEqCan) + [W] fmv ~ alpha (CTyEqCan) +We must solve both! +-} + +unflattenWanteds :: Cts -> Cts -> TcS Cts +unflattenWanteds tv_eqs funeqs + = do { tclvl <- getTcLevel + + ; traceTcS "Unflattening" $ braces $ + vcat [ text "Funeqs =" <+> pprCts funeqs + , text "Tv eqs =" <+> pprCts tv_eqs ] + + -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check + -- Occurs check: consider [W] alpha ~ [F alpha] + -- ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv] + -- ==> (unify) [W] F [fmv] ~ fmv + -- See Note [Unflatten using funeqs first] + ; funeqs <- foldrM unflatten_funeq emptyCts funeqs + ; traceTcS "Unflattening 1" $ braces (pprCts funeqs) + + -- Step 2: unify the tv_eqs, if possible + ; tv_eqs <- foldrM (unflatten_eq tclvl) emptyCts tv_eqs + ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs) + + -- Step 3: fill any remaining fmvs with fresh unification variables + ; funeqs <- mapBagM finalise_funeq funeqs + ; traceTcS "Unflattening 3" $ braces (pprCts funeqs) + + -- Step 4: remove any tv_eqs that look like ty ~ ty + ; tv_eqs <- foldrM finalise_eq emptyCts tv_eqs + + ; let all_flat = tv_eqs `andCts` funeqs + ; traceTcS "Unflattening done" $ braces (pprCts all_flat) + + ; return all_flat } + where + ---------------- + unflatten_funeq :: Ct -> Cts -> TcS Cts + unflatten_funeq ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis + , cc_fsk = fmv, cc_ev = ev }) rest + = do { -- fmv should be an un-filled flatten meta-tv; + -- we now fix its final value by filling it, being careful + -- to observe the occurs check. Zonking will eliminate it + -- altogether in due course + rhs' <- zonkTcType (mkTyConApp tc xis) + ; case occCheckExpand [fmv] rhs' of + Just rhs'' -- Normal case: fill the tyvar + -> do { setReflEvidence ev NomEq rhs'' + ; unflattenFmv fmv rhs'' + ; return rest } + + Nothing -> -- Occurs check + return (ct `consCts` rest) } + + unflatten_funeq other_ct _ + = pprPanic "unflatten_funeq" (ppr other_ct) + + ---------------- + finalise_funeq :: Ct -> TcS Ct + finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev }) + = do { demoteUnfilledFmv fmv + ; return (mkNonCanonical ev) } + finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct) + + ---------------- + unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts + unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv + , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest + + | NomEq <- eq_rel -- See Note [Do not unify representational equalities] + -- in GHC.Tc.Solver.Interact + , isFmvTyVar tv -- Previously these fmvs were untouchable, + -- but now they are touchable + -- NB: unlike unflattenFmv, filling a fmv here /does/ + -- bump the unification count; it is "improvement" + -- Note [Unflattening can force the solver to iterate] + = ASSERT2( tyVarKind tv `eqType` tcTypeKind rhs, ppr ct ) + -- CTyEqCan invariant (TyEq:K) should ensure this is true + do { is_filled <- isFilledMetaTyVar tv + ; elim <- case is_filled of + False -> do { traceTcS "unflatten_eq 2" (ppr ct) + ; tryFill ev tv rhs } + True -> do { traceTcS "unflatten_eq 3" (ppr ct) + ; try_fill_rhs ev tclvl tv rhs } + ; if elim + then do { setReflEvidence ev eq_rel (mkTyVarTy tv) + ; return rest } + else return (ct `consCts` rest) } + + | otherwise + = return (ct `consCts` rest) + + unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct) + + ---------------- + try_fill_rhs ev tclvl lhs_tv rhs + -- Constraint is lhs_tv ~ rhs_tv, + -- and lhs_tv is filled, so try RHS + | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs + -- co :: kind(rhs_tv) ~ kind(lhs_tv) + , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv + && not (isTyVarTyVar rhs_tv)) + -- LHS is a filled fmv, and so is a type + -- family application, which a TyVarTv should + -- not unify with + = do { is_filled <- isFilledMetaTyVar rhs_tv + ; if is_filled then return False + else tryFill ev rhs_tv + (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) } + + | otherwise + = return False + + ---------------- + finalise_eq :: Ct -> Cts -> TcS Cts + finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv + , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest + | isFmvTyVar tv + = do { ty1 <- zonkTcTyVar tv + ; rhs' <- zonkTcType rhs + ; if ty1 `tcEqType` rhs' + then do { setReflEvidence ev eq_rel rhs' + ; return rest } + else return (mkNonCanonical ev `consCts` rest) } + + | otherwise + = return (mkNonCanonical ev `consCts` rest) + + finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct) + +tryFill :: CtEvidence -> TcTyVar -> TcType -> TcS Bool +-- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv +-- If tv does not appear in 'rhs', it set tv := rhs, +-- binds the evidence (which should be a CtWanted) to Refl +-- and return True. Otherwise returns False +tryFill ev tv rhs + = ASSERT2( not (isGiven ev), ppr ev ) + do { rhs' <- zonkTcType rhs + ; case () of + _ | Just tv' <- tcGetTyVar_maybe rhs' + , tv == tv' -- tv == rhs + -> return True + + _ | Just rhs'' <- occCheckExpand [tv] rhs' + -> do { -- Fill the tyvar + unifyTyVar tv rhs'' + ; return True } + + _ | otherwise -- Occurs check + -> return False + } + +setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS () +setReflEvidence ev eq_rel rhs + = setEvBindIfWanted ev (evCoercion refl_co) + where + refl_co = mkTcReflCo (eqRelRole eq_rel) rhs + +{- +Note [Unflatten using funeqs first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + [W] G a ~ Int + [W] F (G a) ~ G a + +do not want to end up with + [W] F Int ~ Int +because that might actually hold! Better to end up with the two above +unsolved constraints. The flat form will be + + G a ~ fmv1 (CFunEqCan) + F fmv1 ~ fmv2 (CFunEqCan) + fmv1 ~ Int (CTyEqCan) + fmv1 ~ fmv2 (CTyEqCan) + +Flatten using the fun-eqs first. +-} + +-- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at +-- least one named binder. +split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool) +split_pi_tys' ty = split ty ty + where + split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' + split _ (ForAllTy b res) = let (bs, ty, _) = split res res + in (Named b : bs, ty, True) + split _ (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) + = let (bs, ty, named) = split res res + in (Anon af arg : bs, ty, named) + split orig_ty _ = ([], orig_ty, False) +{-# INLINE split_pi_tys' #-} + +-- | Like 'tyConBindersTyCoBinders' but you also get a 'Bool' which is true iff +-- there is at least one named binder. +ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool) +ty_con_binders_ty_binders' = foldr go ([], False) + where + go (Bndr tv (NamedTCB vis)) (bndrs, _) + = (Named (Bndr tv vis) : bndrs, True) + go (Bndr tv (AnonTCB af)) (bndrs, n) + = (Anon af (tyVarKind tv) : bndrs, n) + {-# INLINE go #-} +{-# INLINE ty_con_binders_ty_binders' #-} diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -0,0 +1,2700 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Tc.Solver.Interact ( + solveSimpleGivens, -- Solves [Ct] + solveSimpleWanteds, -- Solves Cts + ) where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Types.Basic ( SwapFlag(..), isSwapped, + infinity, IntWithInf, intGtLimit ) +import GHC.Tc.Solver.Canonical +import GHC.Tc.Solver.Flatten +import GHC.Tc.Utils.Unify( canSolveByUnification ) +import GHC.Types.Var.Set +import GHC.Core.Type as Type +import GHC.Core.Coercion ( BlockSubstFlag(..) ) +import GHC.Core.InstEnv ( DFunInstType ) +import GHC.Core.Coercion.Axiom ( sfInteractTop, sfInteractInert ) + +import GHC.Types.Var +import GHC.Tc.Utils.TcType +import GHC.Builtin.Names ( coercibleTyConKey, + heqTyConKey, eqTyConKey, ipClassKey ) +import GHC.Core.Coercion.Axiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches ) +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Tc.Instance.FunDeps +import GHC.Tc.Instance.Family +import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap ) +import GHC.Core.FamInstEnv +import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) + +import GHC.Tc.Types.Evidence +import GHC.Utils.Outputable + +import GHC.Tc.Types +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Solver.Monad +import GHC.Data.Bag +import GHC.Utils.Monad ( concatMapM, foldlM ) + +import GHC.Core +import Data.List( partition, deleteFirstsBy ) +import GHC.Types.SrcLoc +import GHC.Types.Var.Env + +import Control.Monad +import GHC.Data.Maybe( isJust ) +import GHC.Data.Pair (Pair(..)) +import GHC.Types.Unique( hasKey ) +import GHC.Driver.Session +import GHC.Utils.Misc +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe + +{- +********************************************************************** +* * +* 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 sideffected + 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 him 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. + +Note [Unflatten after solving the simple wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We unflatten after solving the wc_simples of an implication, and before attempting +to float. This means that + + * The fsk/fmv flatten-skolems only survive during solveSimples. We don't + need to worry about them across successive passes over the constraint tree. + (E.g. we don't need the old ic_fsk field of an implication. + + * When floating an equality outwards, we don't need to worry about floating its + associated flattening constraints. + + * Another tricky case becomes easy: #4935 + type instance F True a b = a + type instance F False a b = b + + [w] F c a b ~ gamma + (c ~ True) => a ~ gamma + (c ~ False) => b ~ gamma + + Obviously this is soluble with gamma := F c a b, and unflattening + will do exactly that after solving the simple constraints and before + attempting the implications. Before, when we were not unflattening, + we had to push Wanted funeqs in as new givens. Yuk! + + Another example that becomes easy: indexed_types/should_fail/T7786 + [W] BuriedUnder sub k Empty ~ fsk + [W] Intersect fsk inv ~ s + [w] xxx[1] ~ s + [W] forall[2] . (xxx[1] ~ Empty) + => Intersect (BuriedUnder sub k Empty) inv ~ Empty + +Note [Running plugins on unflattened wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is an annoying mismatch between solveSimpleGivens and +solveSimpleWanteds, because the latter needs to fiddle with the inert +set, unflatten and zonk the wanteds. It passes the zonked wanteds +to runTcPluginsWanteds, which produces a replacement set of wanteds, +some additional insolubles and a flag indicating whether to go round +the loop again. If so, prepareInertsForImplications is used to remove +the previous wanteds (which will still be in the inert set). Note +that prepareInertsForImplications will discard the insolubles, so we +must keep track of them separately. +-} + +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 +-- NB: 'simples' may contain /derived/ equalities, floated +-- out from a nested implication. So don't discard deriveds! +-- 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 (hang (text "solveSimpleWanteds: too many iterations" + <+> parens (text "limit =" <+> ppr limit)) + 2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" + , text "Simples =" <+> ppr simples + , text "WC =" <+> ppr wc ])) + + | isEmptyBag (wc_simple wc) + = return (n,wc) + + | otherwise + = do { -- Solve + (unif_count, wc1) <- solve_simple_wanteds wc + + -- Run plugins + ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1 + -- See Note [Running plugins on unflattened wanteds] + + ; if unif_count == 0 && not rerun_plugin + then return (n, wc2) -- Done + else do { traceTcS "solveSimple going round again:" $ + ppr unif_count $$ ppr rerun_plugin + ; go (n+1) limit wc2 } } -- Loop + + +solve_simple_wanteds :: WantedConstraints -> TcS (Int, 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 }) + = nestTcS $ + do { solveSimples simples1 + ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts + ; (unif_count, unflattened_eqs) <- reportUnifications $ + unflattenWanteds tv_eqs fun_eqs + -- See Note [Unflatten after solving the simple wanteds] + ; return ( unif_count + , WC { wc_simple = others `andCts` unflattened_eqs + , wc_impl = implics1 `unionBags` implics2 }) } + +{- 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; unflattening may lead to improvement that + was not exploitable during solving + 2. Try the plugin + 3. If step 1 did improvement during unflattening; or if the plugin + wants to run again, go back to step 1 + +Non-obviously, improvement can also take place during +the unflattening that takes place in step (1). See GHC.Tc.Solver.Flatten, +See Note [Unflattening can force the solver to iterate] +-} + +-- 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 { plugins <- getTcPlugins + ; if null plugins then return [] else + do { givens <- getInertGivens + ; if null givens then return [] else + do { p <- runTcPlugins plugins (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 (flattened, 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, wc_impl = implics1 }) + | isEmptyBag simples1 + = return (False, wc) + | otherwise + = do { plugins <- getTcPlugins + ; if null plugins then return (False, wc) else + + do { given <- getInertGivens + ; simples1 <- zonkSimples simples1 -- Plugin requires zonked inputs + ; let (wanted, derived) = partition isWantedCt (bagToList simples1) + ; p <- runTcPlugins plugins (given, derived, wanted) + ; let (_, _, solved_wanted) = pluginSolvedCts p + (_, unsolved_derived, unsolved_wanted) = pluginInputCts p + new_wanted = pluginNewCts p + insols = pluginBadCts p + +-- SLPJ: I'm deeply suspicious of this +-- ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds) + + ; mapM_ setEv solved_wanted + ; return ( notNull (pluginNewCts p) + , WC { wc_simple = listToBag new_wanted `andCts` + listToBag unsolved_wanted `andCts` + listToBag unsolved_derived `andCts` + listToBag insols + , wc_impl = implics1 } ) } } + 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 triple of (given, derived, wanted) constraints to pass to plugins +type SplitCts = ([Ct], [Ct], [Ct]) + +-- | A solved triple of constraints, with evidence for wanteds +type SolvedCts = ([Ct], [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 + } + +getTcPlugins :: TcS [TcPluginSolver] +getTcPlugins = do { tcg_env <- getGblEnv; return (tcg_tc_plugins tcg_env) } + +-- | Starting from a triple of (given, derived, wanted) constraints, +-- invoke each of the typechecker 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. +runTcPlugins :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress +runTcPlugins plugins all_cts + = foldM do_plugin initialProgress plugins + where + do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress + do_plugin p solver = do + result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p)) + return $ progress p result + + progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress + progress p (TcPluginContradiction bad_cts) = + p { pluginInputCts = discard bad_cts (pluginInputCts p) + , pluginBadCts = bad_cts ++ pluginBadCts p + } + progress p (TcPluginOk solved_cts new_cts) = + p { pluginInputCts = discard (map snd solved_cts) (pluginInputCts p) + , pluginSolvedCts = add solved_cts (pluginSolvedCts p) + , pluginNewCts = new_cts ++ pluginNewCts p + } + + initialProgress = TcPluginProgress all_cts ([], [], []) [] [] + + discard :: [Ct] -> SplitCts -> SplitCts + discard cts (xs, ys, zs) = + (xs `without` cts, ys `without` cts, zs `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, deriveds, wanteds) (ev,ct) = case ctEvidence ct of + CtGiven {} -> (ct:givens, deriveds, wanteds) + CtDerived{} -> (givens, ct:deriveds, wanteds) + CtWanted {} -> (givens, deriveds, (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/Derived + then there is no reaction +-} + +-- Interaction result of WorkItem <~> Ct + +interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct) +-- Precondition: if the workitem is a CTyEqCan then it will not be able to +-- react with anything at this stage. + +interactWithInertsStage wi + = do { inerts <- getTcSInerts + ; let ics = inert_cans inerts + ; case wi of + CTyEqCan {} -> interactTyVarEq ics wi + CFunEqCan {} -> interactFunEq ics wi + CIrredCan {} -> interactIrred ics wi + CDictCan {} -> interactDict ics wi + _ -> pprPanic "interactWithInerts" (ppr wi) } + -- CHoleCan are put straight into inert_frozen, so never get here + -- CNonCanonical have been canonicalised + +data InteractResult + = 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 intert item from it + +instance Outputable InteractResult where + ppr KeepInert = text "keep inert" + ppr KeepWork = text "keep work-item" + +solveOneFromTheOther :: CtEvidence -- Inert + -> CtEvidence -- WorkItem + -> TcS InteractResult +-- Precondition: +-- * inert and work item represent evidence for the /same/ predicate +-- +-- 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 ev_i ev_w + | isDerived ev_w -- Work item is Derived; just discard it + = return KeepInert + + | isDerived ev_i -- The inert item is Derived, we can just throw it away, + = return KeepWork -- The ev_w is inert wrt earlier inert-set items, + -- so it's safe to continue on from this point + + | CtWanted { ctev_loc = loc_w } <- ev_w + , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w + = -- inert must be Given + do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w) + ; return KeepWork } + + | CtWanted {} <- ev_w + -- Inert is Given or Wanted + = return KeepInert + + -- From here on the work-item is Given + + | CtWanted { ctev_loc = loc_i } <- ev_i + , prohibitedSuperClassSolve (ctEvLoc ev_w) loc_i + = do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w) + ; return KeepInert } -- Just discard the un-usable Given + -- This never actually happens because + -- Givens get processed first + + | CtWanted {} <- ev_i + = return KeepWork + + -- From here on both are Given + -- See Note [Replacement vs keeping] + + | lvl_i == lvl_w + = do { ev_binds_var <- getTcEvBindsVar + ; binds <- getTcEvBindsMap ev_binds_var + ; return (same_level_strategy binds) } + + | otherwise -- Both are Given, levels differ + = return different_level_strategy + where + pred = ctEvPred ev_i + loc_i = ctEvLoc ev_i + loc_w = ctEvLoc ev_w + lvl_i = ctLocLevel loc_i + lvl_w = ctLocLevel loc_w + ev_id_i = ctEvEvId ev_i + ev_id_w = ctEvEvId ev_w + + different_level_strategy -- Both Given + | isIPPred 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] (the different-level bullet) + -- For the isIPPred case see Note [Shadowing of Implicit Parameters] + + same_level_strategy binds -- Both Given + | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i + = case ctLocOrigin loc_w of + GivenOrigin (InstSC s_w) | s_w < s_i -> KeepWork + | otherwise -> KeepInert + _ -> KeepWork + + | GivenOrigin (InstSC {}) <- ctLocOrigin loc_w + = KeepInert + + | has_binding binds ev_id_w + , not (has_binding binds ev_id_i) + , not (ev_id_i `elemVarSet` findNeededEvVars binds (unitVarSet ev_id_w)) + = KeepWork + + | otherwise + = KeepInert + + has_binding binds ev_id = isJust (lookupEvBind binds ev_id) + +{- +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! + + * 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. + + * Constraints coming from the same level (i.e. same implication) + + (a) Always get rid of InstSC ones if possible, since they are less + useful for solving. If both are InstSC, choose the one with + the smallest TypeSize + See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + + (b) Keep the one that has a non-trivial evidence binding. + Example: f :: (Eq a, Ord a) => blah + then we may find [G] d3 :: Eq a + [G] d2 :: Eq a + with bindings d3 = sc_sel (d1::Ord a) + We want to discard d2 in favour of the superclass selection from + the Ord dictionary. + Why? See Note [Tracking redundant constraints] in GHC.Tc.Solver again. + + (c) But don't do (b) if the evidence binding depends transitively on the + one without a binding. Example (with RecursiveSuperClasses) + class C a => D a + class D a => C a + Inert: d1 :: C a, d2 :: D a + Binds: d3 = sc_sel d2, d2 = sc_sel d1 + Work item: d3 :: C a + Then it'd be ridiculous to replace d1 with d3 in the inert set! + Hence the findNeedEvVars test. See #14774. + + * 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 depth-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 depth-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 workItem@(CIrredCan { cc_ev = ev_w, cc_status = status }) + | InsolubleCIS <- status + -- 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 + -- See Note [Do not add duplicate derived insolubles] + , not (isDroppableCt workItem) + = continueWith workItem + + | 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 { what_next <- solveOneFromTheOther ev_i ev_w + ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i) + ; case what_next of + KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i) + ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) } + KeepWork -> do { setEvBindIfWanted ev_i (swap_me swap ev_w) + ; updInertIrreds (\_ -> others) + ; continueWith workItem } } + + | otherwise + = continueWith workItem + + where + swap_me :: SwapFlag -> CtEvidence -> EvTerm + swap_me swap ev + = case swap of + NotSwapped -> ctEvTerm ev + IsSwapped -> evCoercion (mkTcSymCo (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. + +Note [Do not add duplicate derived insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we *must* add an insoluble (Int ~ Bool) even if there is +one such there already, because they may come from distinct call +sites. Not only do we want an error message for each, but with +-fdefer-type-errors we must generate evidence for each. But for +*derived* insolubles, we only want to report each one once. Why? + +(a) A constraint (C r s t) where r -> s, say, may generate the same fundep + equality many times, as the original constraint is successively rewritten. + +(b) Ditto the successive iterations of the main solver itself, as it traverses + the constraint tree. See example below. + +Also for *given* insolubles we may get repeated errors, as we +repeatedly traverse the constraint tree. These are relatively rare +anyway, so removing duplicates seems ok. (Alternatively we could take +the SrcLoc into account.) + +Note that the test does not need to be particularly efficient because +it is only used if the program has a type error anyway. + +Example of (b): assume a top-level class and instance declaration: + + class D a b | a -> b + instance D [a] [a] + +Assume we have started with an implication: + + forall c. Eq c => { wc_simple = D [c] c [W] } + +which we have simplified to: + + forall c. Eq c => { wc_simple = D [c] c [W] + (c ~ [c]) [D] } + +For some reason, e.g. because we floated an equality somewhere else, +we might try to re-solve this implication. If we do not do a +dropDerivedWC, then we will end up trying to solve the following +constraints the second time: + + (D [c] c) [W] + (c ~ [c]) [D] + +which will result in two Deriveds to end up in the insoluble set: + + wc_simple = D [c] c [W] + (c ~ [c]) [D], (c ~ [c]) [D] +-} + +{- +********************************************************************************* +* * + 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 flatten 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 MultiParamTypeClasses, FlexibleInstances #-} + module B where + + import A + + instance A a where + int _ = 1 + + instance C a [b] where + m _ = id + +######### + {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} + {-# LANGUAGE IncoherentInstances #-} + 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 augmennt 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. +-} + +interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) +interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) + | Just ev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys + = -- 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" + else + + do { -- Ths short-cut solver didn't fire, so we + -- solve ev_w from the matching inert ev_i we found + what_next <- solveOneFromTheOther ev_i ev_w + ; traceTcS "lookupInertDict" (ppr what_next) + ; case what_next of + KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i) + ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) } + KeepWork -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w) + ; updInertDicts $ \ ds -> delDict ds cls tys + ; continueWith workItem } } } + + | cls `hasKey` ipClassKey + , isGiven ev_w + = interactGivenIP inerts workItem + + | otherwise + = do { addFunDepWork inerts ev_w cls + ; continueWith workItem } + +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 (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 <- ASSERT2( 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 + + ; evc_vs <- mapM (new_wanted_cached 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 :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew + new_wanted_cached 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 pty + | otherwise = mzero + +addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS () +-- Add derived constraints from type-class functional dependencies. +addFunDepWork inerts work_ev cls + | isImprovable work_ev + = 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) + | otherwise + = return () + where + work_pred = ctEvPred work_ev + work_loc = ctEvLoc work_ev + + add_fds inert_ct + | isImprovable inert_ev + = 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) ]) ; + + emitFunDepDeriveds $ + improveFromAnother derived_loc inert_pred work_pred + -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok + -- NB: We do create FDs for given to report insoluble equations that arise + -- from pairs of Givens, and also because of floating when we approximate + -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs + } + | otherwise + = return () + where + inert_ev = ctEvidence inert_ct + inert_pred = ctEvPred inert_ev + inert_loc = ctEvLoc 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) } + +{- +********************************************************************** +* * + 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 +* * +********************************************************************** +-} + +interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) +-- Try interacting the work item with the inert set +interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc + , cc_tyargs = args, cc_fsk = fsk }) + | Just inert_ct@(CFunEqCan { cc_ev = ev_i + , cc_fsk = fsk_i }) + <- findFunEq (inert_funeqs inerts) tc args + , pr@(swap_flag, upgrade_flag) <- ev_i `funEqCanDischarge` ev + = do { traceTcS "reactFunEq (rewrite inert item):" $ + vcat [ text "work_item =" <+> ppr work_item + , text "inertItem=" <+> ppr ev_i + , text "(swap_flag, upgrade)" <+> ppr pr ] + ; if isSwapped swap_flag + then do { -- Rewrite inert using work-item + let work_item' | upgrade_flag = upgradeWanted work_item + | otherwise = work_item + ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args work_item' + -- Do the updInertFunEqs before the reactFunEq, so that + -- we don't kick out the inertItem as well as consuming it! + ; reactFunEq ev fsk ev_i fsk_i + ; stopWith ev "Work item rewrites inert" } + else do { -- Rewrite work-item using inert + ; when upgrade_flag $ + updInertFunEqs $ \ feqs -> insertFunEq feqs tc args + (upgradeWanted inert_ct) + ; reactFunEq ev_i fsk_i ev fsk + ; stopWith ev "Inert rewrites work item" } } + + | otherwise -- Try improvement + = do { improveLocalFunEqs ev inerts tc args fsk + ; continueWith work_item } + +interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item) + +upgradeWanted :: Ct -> Ct +-- We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2 +-- so upgrade the [W] to [WD] before putting it in the inert set +upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) } + where + upgrade_ev ev = ASSERT2( isWanted ev, ppr ct ) + ev { ctev_nosh = WDeriv } + +improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar + -> TcS () +-- Generate derived improvement equalities, by comparing +-- the current work item with inert CFunEqs +-- E.g. x + y ~ z, x + y' ~ z => [D] y ~ y' +-- +-- See Note [FunDep and implicit parameter reactions] +improveLocalFunEqs work_ev inerts fam_tc args fsk + | isGiven work_ev -- See Note [No FunEq improvement for Givens] + || not (isImprovable work_ev) + = return () + + | otherwise + = do { eqns <- improvement_eqns + ; if not (null eqns) + then do { traceTcS "interactFunEq improvements: " $ + vcat [ text "Eqns:" <+> ppr eqns + , text "Candidates:" <+> ppr funeqs_for_tc + , text "Inert eqs:" <+> ppr (inert_eqs inerts) ] + ; emitFunDepDeriveds eqns } + else return () } + + where + funeqs = inert_funeqs inerts + funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc + work_loc = ctEvLoc work_ev + work_pred = ctEvPred work_ev + fam_inj_info = tyConInjectivityInfo fam_tc + + -------------------- + improvement_eqns :: TcS [FunDepEqn CtLoc] + improvement_eqns + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = -- Try built-in families, notably for arithmethic + do { rhs <- rewriteTyVar fsk + ; concatMapM (do_one_built_in ops rhs) funeqs_for_tc } + + | Injective injective_args <- fam_inj_info + = -- Try improvement from type families with injectivity annotations + do { rhs <- rewriteTyVar fsk + ; concatMapM (do_one_injective injective_args rhs) funeqs_for_tc } + + | otherwise + = return [] + + -------------------- + do_one_built_in ops rhs (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev }) + = do { inert_rhs <- rewriteTyVar ifsk + ; return $ mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs inert_rhs) } + + 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 (CFunEqCan { cc_tyargs = inert_args + , cc_fsk = ifsk, cc_ev = inert_ev }) + | isImprovable inert_ev + = do { inert_rhs <- rewriteTyVar ifsk + ; return $ if rhs `tcEqType` inert_rhs + then mk_fd_eqns inert_ev $ + [ Pair arg iarg + | (arg, iarg, True) <- zip3 args inert_args inj_args ] + else [] } + | otherwise + = return [] + + do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) + + -------------------- + mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc] + mk_fd_eqns inert_ev eqns + | null eqns = [] + | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns + , fd_pred1 = work_pred + , fd_pred2 = ctEvPred inert_ev + , fd_loc = loc } ] + where + inert_loc = ctEvLoc inert_ev + loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` + ctl_depth work_loc } + +------------- +reactFunEq :: CtEvidence -> TcTyVar -- From this :: F args1 ~ fsk1 + -> CtEvidence -> TcTyVar -- Solve this :: F args2 ~ fsk2 + -> TcS () +reactFunEq from_this fsk1 solve_this fsk2 + = do { traceTcS "reactFunEq" + (vcat [ppr from_this, ppr fsk1, ppr solve_this, ppr fsk2]) + ; dischargeFunEq solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1) + ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$ + ppr solve_this $$ ppr fsk2) } + +{- 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 two CFunEqCan constraints for F with the same RHS + F s1 t1 ~ rhs + F s2 t2 ~ rhs +then we can use the injectivity to get a new Derived constraint on +the injective argument + [D] 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 simply *Derived* constraints; they have no 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). + +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. + + +Note [Efficient Orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are interacting two FunEqCans with the same LHS: + (inert) ci :: (F ty ~ xi_i) + (work) cw :: (F ty ~ xi_w) +We prefer to keep the inert (else we pass the work item on down +the pipeline, which is a bit silly). If we keep the inert, we +will (a) discharge 'cw' + (b) produce a new equality work-item (xi_w ~ xi_i) +Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w): + new_work :: xi_w ~ xi_i + cw := ci ; sym new_work +Why? Consider the simplest case when xi1 is a type variable. If +we generate xi1~xi2, processing that constraint will kick out 'ci'. +If we generate xi2~xi1, there is less chance of that happening. +Of course it can and should still happen if xi1=a, xi1=Int, say. +But we want to avoid it happening needlessly. + +Similarly, if we *can't* keep the inert item (because inert is Wanted, +and work is Given, say), we prefer to orient the new equality (xi_i ~ +xi_w). + +Note [Carefully solve the right CFunEqCan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ---- OLD COMMENT, NOW NOT NEEDED + ---- because we now allow multiple + ---- wanted FunEqs with the same head +Consider the constraints + c1 :: F Int ~ a -- Arising from an application line 5 + c2 :: F Int ~ Bool -- Arising from an application line 10 +Suppose that 'a' is a unification variable, arising only from +flattening. So there is no error on line 5; it's just a flattening +variable. But there is (or might be) an error on line 10. + +Two ways to combine them, leaving either (Plan A) + c1 :: F Int ~ a -- Arising from an application line 5 + c3 :: a ~ Bool -- Arising from an application line 10 +or (Plan B) + c2 :: F Int ~ Bool -- Arising from an application line 10 + c4 :: a ~ Bool -- Arising from an application line 5 + +Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error +on the *totally innocent* line 5. An example is test SimpleFail16 +where the expected/actual message comes out backwards if we use +the wrong plan. + +The second is the right thing to do. Hence the isMetaTyVarTy +test when solving pairwise CFunEqCan. + + +********************************************************************** +* * + interactTyVarEq +* * +********************************************************************** +-} + +inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtFlavourRole + -> Maybe ( CtEvidence -- The evidence for the inert + , SwapFlag -- Whether we need mkSymCo + , Bool) -- True <=> keep a [D] version + -- of the [WD] constraint +inertsCanDischarge inerts tv rhs fr + | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i + , cc_eq_rel = eq_rel } + <- findTyEqs inerts tv + , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr + , rhs_i `tcEqType` rhs ] + = -- Inert: a ~ ty + -- Work item: a ~ ty + Just (ev_i, NotSwapped, keep_deriv ev_i) + + | Just tv_rhs <- getTyVar_maybe rhs + , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i + , cc_eq_rel = eq_rel } + <- findTyEqs inerts tv_rhs + , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr + , rhs_i `tcEqType` mkTyVarTy tv ] + = -- Inert: a ~ b + -- Work item: b ~ a + Just (ev_i, IsSwapped, keep_deriv ev_i) + + | otherwise + = Nothing + + where + keep_deriv ev_i + | Wanted WOnly <- ctEvFlavour ev_i -- inert is [W] + , (Wanted WDeriv, _) <- fr -- work item is [WD] + = True -- Keep a derived version of the work item + | otherwise + = False -- Work item is fully discharged + +interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) +-- CTyEqCans are always consumed, so always returns Stop +interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv + , cc_rhs = rhs + , cc_ev = ev + , cc_eq_rel = eq_rel }) + | Just (ev_i, swapped, keep_deriv) + <- inertsCanDischarge inerts tv rhs (ctEvFlavour ev, eq_rel) + = do { setEvBindIfWanted ev $ + evCoercion (maybeSym swapped $ + tcDowngradeRole (eqRelRole eq_rel) + (ctEvRole ev_i) + (ctEvCoercion ev_i)) + + ; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev + , ctev_loc = ctEvLoc ev } + ; when keep_deriv $ + emitWork [workItem { cc_ev = deriv_ev }] + -- As a Derived it might not be fully rewritten, + -- so we emit it as new work + + ; 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 } + + | isGiven ev -- See Note [Touchables and givens] + = continueWith workItem + + | otherwise + = do { tclvl <- getTcLevel + ; if canSolveByUnification tclvl tv rhs + then do { solveByUnification ev tv rhs + ; n_kicked <- kickOutAfterUnification tv + ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) } + + else continueWith workItem } + +interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi) + +solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS () +-- Solve with the identity coercion +-- Precondition: kind(xi) equals kind(tv) +-- Precondition: CtEvidence is Wanted or Derived +-- 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 CTyEqCan, 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 (tcTypeKind tv_ty), + text "Right Kind is:" <+> ppr (tcTypeKind xi) ] + + ; unifyTyVar tv xi + ; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi)) } + +{- 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 he 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 (in the unflattener). + + +************************************************************************ +* * +* 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 Derived 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 :d 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, but that requires those equalities to carry +evidence and derived do not carry evidence. + +If that were the case with the same inert set and work item we might dischard +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 [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; + [D] K Bool ~ K [a] + [D] 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. +-} + +emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS () +-- See Note [FunDep and implicit parameter reactions] +emitFunDepDeriveds fd_eqns + = mapM_ do_one_FDEqn fd_eqns + where + do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc }) + | null tvs -- Common shortcut + = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc)) + ; mapM_ (unifyDerived loc Nominal) eqs } + | otherwise + = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs) + ; subst <- instFlexi tvs -- Takes account of kind substitution + ; mapM_ (do_one_eq loc subst) eqs } + + do_one_eq loc subst (Pair ty1 ty2) + = unifyDerived loc Nominal $ + Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2) + +{- +********************************************************************** +* * + 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. Note: +topReactionsStage work_item + = do { traceTcS "doTopReact" (ppr work_item) + ; case work_item of + CDictCan {} -> do { inerts <- getTcSInerts + ; doTopReactDict inerts work_item } + CFunEqCan {} -> doTopReactFunEq work_item + CIrredCan {} -> doTopReactOther work_item + CTyEqCan {} -> 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 +-- CTyEqCan e.g. (a ~# 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 work_item res + _ -> continueWith work_item } + + where + ev = ctEvidence work_item + loc = ctEvLoc ev + pred = ctEvPred ev + +doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct) +doTopReactEqPred work_item eq_rel t1 t2 + -- See Note [Looking up primitive equalities in quantified constraints] + | Just (cls, tys) <- boxEqPred eq_rel t1 t2 + = do { res <- matchLocalInst (mkClassPred cls tys) loc + ; case res of + OneInst { cir_mk_ev = mk_ev } + -> chooseInstance work_item + (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) + _ -> continueWith work_item } + + | otherwise + = continueWith work_item + where + ev = ctEvidence work_item + loc = ctEvLoc ev + + 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 [Flatten when discharging CFunEqCan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have the following scenario (#16512): + +type family LV (as :: [Type]) (b :: Type) = (r :: Type) | r -> as b where + LV (a ': as) b = a -> LV as b + +[WD] w1 :: LV as0 (a -> b) ~ fmv1 (CFunEqCan) +[WD] w2 :: fmv1 ~ (a -> fmv2) (CTyEqCan) +[WD] w3 :: LV as0 b ~ fmv2 (CFunEqCan) + +We start with w1. Because LV is injective, we wish to see if the RHS of the +equation matches the RHS of the CFunEqCan. The RHS of a CFunEqCan is always an +fmv, so we "look through" to get (a -> fmv2). Then we run tcUnifyTyWithTFs. +That performs the match, but it allows a type family application (such as the +LV in the RHS of the equation) to match with anything. (See "Injective type +families" by Stolarek et al., HS'15, Fig. 2) The matching succeeds, which +means we can improve as0 (and b, but that's not interesting here). However, +because the RHS of w1 can't see through fmv2 (we have no way of looking up a +LHS of a CFunEqCan from its RHS, and this use case isn't compelling enough), +we invent a new unification variable here. We thus get (as0 := a : as1). +Rewriting: + +[WD] w1 :: LV (a : as1) (a -> b) ~ fmv1 +[WD] w2 :: fmv1 ~ (a -> fmv2) +[WD] w3 :: LV (a : as1) b ~ fmv2 + +We can now reduce both CFunEqCans, using the equation for LV. We get + +[WD] w2 :: (a -> LV as1 (a -> b)) ~ (a -> a -> LV as1 b) + +Now we decompose (and flatten) to + +[WD] w4 :: LV as1 (a -> b) ~ fmv3 +[WD] w5 :: fmv3 ~ (a -> fmv1) +[WD] w6 :: LV as1 b ~ fmv4 + +which is exactly where we started. These goals really are insoluble, but +we would prefer not to loop. We thus need to find a way to bump the reduction +depth, so that we can detect the loop and abort. + +The key observation is that we are performing a reduction. We thus wish +to bump the level when discharging a CFunEqCan. Where does this bumped +level go, though? It can't just go on the reduct, as that's a type. Instead, +it must go on any CFunEqCans produced after flattening. We thus flatten +when discharging, making sure that the level is bumped in the new +fun-eqs. The flattening happens in reduce_top_fun_eq and the level +is bumped when setting up the FlatM monad in GHC.Tc.Solver.Flatten.runFlatten. +(This bumping will happen for call sites other than this one, but that +makes sense -- any constraints emitted by the flattener are offshoots +the work item and should have a higher level. We don't have any test +cases that require the bumping in this other cases, but it's convenient +and causes no harm to bump at every flatten.) + +Test case: typecheck/should_fail/T16512a + +-} + +-------------------- +doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct) +doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc + , cc_tyargs = args, cc_fsk = fsk }) + + | fsk `elemVarSet` tyCoVarsOfTypes args + = no_reduction -- See Note [FunEq occurs-check principle] + + | otherwise -- Note [Reduction for Derived CFunEqCans] + = do { match_res <- matchFam fam_tc args + -- Look up in top-level instances, or built-in axiom + -- See Note [MATCHING-SYNONYMS] + ; case match_res of + Nothing -> no_reduction + Just match_info -> reduce_top_fun_eq old_ev fsk match_info } + where + no_reduction + = do { improveTopFunEqs old_ev fam_tc args fsk + ; continueWith work_item } + +doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w) + +reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType) + -> TcS (StopOrContinue Ct) +-- We have found an applicable top-level axiom: use it to reduce +-- Precondition: fsk is not free in rhs_ty +-- ax_co :: F tys ~ rhs_ty, where F tys is the LHS of the old_ev +reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty) + | not (isDerived old_ev) -- Precondition of shortCutReduction + , Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty + , isTypeFamilyTyCon tc + , tc_args `lengthIs` tyConArity tc -- Short-cut + = -- RHS is another type-family application + -- Try shortcut; see Note [Top-level reductions for type functions] + do { shortCutReduction old_ev fsk ax_co tc tc_args + ; stopWith old_ev "Fun/Top (shortcut)" } + + | otherwise + = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty) + , ppr old_ev $$ ppr rhs_ty ) + -- Guaranteed by Note [FunEq occurs-check principle] + do { (rhs_xi, flatten_co) <- flatten FM_FlattenAll old_ev rhs_ty + -- flatten_co :: rhs_xi ~ rhs_ty + -- See Note [Flatten when discharging CFunEqCan] + ; let total_co = ax_co `mkTcTransCo` mkTcSymCo flatten_co + ; dischargeFunEq old_ev fsk total_co rhs_xi + ; traceTcS "doTopReactFunEq" $ + vcat [ text "old_ev:" <+> ppr old_ev + , nest 2 (text ":=") <+> ppr ax_co ] + ; stopWith old_ev "Fun/Top" } + +improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS () +-- See Note [FunDep and implicit parameter reactions] +improveTopFunEqs ev fam_tc args fsk + | isGiven ev -- See Note [No FunEq improvement for Givens] + || not (isImprovable ev) + = return () + + | otherwise + = do { fam_envs <- getFamInstEnvs + ; rhs <- rewriteTyVar fsk + ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs + ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs + , ppr eqns ]) + ; mapM_ (unifyDerived loc Nominal) eqns } + where + loc = bumpCtLocDepth (ctEvLoc ev) + -- 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 + 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], TCvSubst, [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 + , Just subst <- [tcUnifyTyWithTFs False 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], TCvSubst, [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 (substTyUnchecked 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 ] } + + +shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion + -> TyCon -> [TcType] -> TcS () +-- See Note [Top-level reductions for type functions] +-- Previously, we flattened the tc_args here, but there's no need to do so. +-- And, if we did, this function would have all the complication of +-- GHC.Tc.Solver.Canonical.canCFunEqCan. See Note [canCFunEqCan] +shortCutReduction old_ev fsk ax_co fam_tc tc_args + = ASSERT( ctEvEqRel old_ev == NomEq) + -- ax_co :: F args ~ G tc_args + -- old_ev :: F args ~ fsk + do { new_ev <- case ctEvFlavour old_ev of + Given -> newGivenEvVar deeper_loc + ( mkPrimEqPred (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk) + , evCoercion (mkTcSymCo ax_co + `mkTcTransCo` ctEvCoercion old_ev) ) + + Wanted {} -> + -- See TcCanonical Note [Equalities with incompatible kinds] about NoBlockSubst + do { (new_ev, new_co) <- newWantedEq_SI NoBlockSubst WDeriv deeper_loc Nominal + (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk) + ; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co + ; return new_ev } + + Derived -> pprPanic "shortCutReduction" (ppr old_ev) + + ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc + , cc_tyargs = tc_args, cc_fsk = fsk } + ; updWorkListTcS (extendWorkListFunEq new_ct) } + where + deeper_loc = bumpCtLocDepth (ctEvLoc old_ev) + +{- Note [Top-level reductions for type functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +c.f. Note [The flattening story] in GHC.Tc.Solver.Flatten + +Suppose we have a CFunEqCan F tys ~ fmv/fsk, and a matching axiom. +Here is what we do, in four cases: + +* Wanteds: general firing rule + (work item) [W] x : F tys ~ fmv + instantiate axiom: ax_co : F tys ~ rhs + + Then: + Discharge fmv := rhs + Discharge x := ax_co ; sym x2 + This is *the* way that fmv's get unified; even though they are + "untouchable". + + NB: Given Note [FunEq occurs-check principle], fmv does not appear + in tys, and hence does not appear in the instantiated RHS. So + the unification can't make an infinite type. + +* Wanteds: short cut firing rule + Applies when the RHS of the axiom is another type-function application + (work item) [W] x : F tys ~ fmv + instantiate axiom: ax_co : F tys ~ G rhs_tys + + It would be a waste to create yet another fmv for (G rhs_tys). + Instead (shortCutReduction): + - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis) + - Add G rhs_xis ~ fmv to flat cache (note: the same old fmv) + - New canonical wanted [W] x2 : G rhs_xis ~ fmv (CFunEqCan) + - Discharge x := ax_co ; G cos ; x2 + +* Givens: general firing rule + (work item) [G] g : F tys ~ fsk + instantiate axiom: ax_co : F tys ~ rhs + + Now add non-canonical given (since rhs is not flat) + [G] (sym g ; ax_co) : fsk ~ rhs (Non-canonical) + +* Givens: short cut firing rule + Applies when the RHS of the axiom is another type-function application + (work item) [G] g : F tys ~ fsk + instantiate axiom: ax_co : F tys ~ G rhs_tys + + It would be a waste to create yet another fsk for (G rhs_tys). + Instead (shortCutReduction): + - Flatten rhs_tys: flat_cos : tys ~ flat_tys + - Add new Canonical given + [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk (CFunEqCan) + +Note [FunEq occurs-check principle] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I have spent a lot of time finding a good way to deal with +CFunEqCan constraints like + F (fuv, a) ~ fuv +where flatten-skolem occurs on the LHS. Now in principle we +might may progress by doing a reduction, but in practice its +hard to find examples where it is useful, and easy to find examples +where we fall into an infinite reduction loop. A rule that works +very well is this: + + *** FunEq occurs-check principle *** + + Do not reduce a CFunEqCan + F tys ~ fsk + if fsk appears free in tys + Instead we treat it as stuck. + +Examples: + +* #5837 has [G] a ~ TF (a,Int), with an instance + type instance TF (a,b) = (TF a, TF b) + This readily loops when solving givens. But with the FunEq occurs + check principle, it rapidly gets stuck which is fine. + +* #12444 is a good example, explained in comment:2. We have + type instance F (Succ x) = Succ (F x) + [W] alpha ~ Succ (F alpha) + If we allow the reduction to happen, we get an infinite loop + +Note [Cached solved FunEqs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When trying to solve, say (FunExpensive big-type ~ ty), it's important +to see if we have reduced (FunExpensive big-type) before, lest we +simply repeat it. Hence the lookup in inert_solved_funeqs. Moreover +we must use `funEqCanDischarge` because both uses might (say) be Wanteds, +and we *still* want to save the re-computation. + +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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A very delicate point is the orientation of derived 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 derived constraints + + [D] gamma1 ~ alpha + [D] 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 + [D] 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 derived +equality with the template on the left. Delicate, but it works. + +Note [No FunEq improvement for Givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't do improvements (injectivity etc) for Givens. Why? + +* It generates Derived constraints on skolems, which don't do us + much good, except perhaps identify inaccessible branches. + (They'd be perfectly valid though.) + +* For type-nat stuff the derived constraints include type families; + e.g. (a < b), (b < c) ==> a < c If we generate a Derived for this, + we'll generate a Derived/Wanted CFunEqCan; and, since the same + InertCans (after solving Givens) are used for each iteration, that + massively confused the unflattening step (GHC.Tc.Solver.Flatten.unflatten). + + In fact it led to some infinite loops: + indexed-types/should_compile/T10806 + indexed-types/should_compile/T10507 + polykinds/T10742 + +Note [Reduction for Derived CFunEqCans] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You may wonder if it's important to use top-level instances to +simplify [D] CFunEqCan's. But it is. Here's an example (T10226). + + type instance F Int = Int + type instance FInv Int = Int + +Suppose we have to solve + [WD] FInv (F alpha) ~ alpha + [WD] F alpha ~ Int + + --> flatten + [WD] F alpha ~ fuv0 + [WD] FInv fuv0 ~ fuv1 -- (A) + [WD] fuv1 ~ alpha + [WD] fuv0 ~ Int -- (B) + + --> Rewwrite (A) with (B), splitting it + [WD] F alpha ~ fuv0 + [W] FInv fuv0 ~ fuv1 + [D] FInv Int ~ fuv1 -- (C) + [WD] fuv1 ~ alpha + [WD] fuv0 ~ Int + + --> Reduce (C) with top-level instance + **** This is the key step *** + [WD] F alpha ~ fuv0 + [W] FInv fuv0 ~ fuv1 + [D] fuv1 ~ Int -- (D) + [WD] fuv1 ~ alpha -- (E) + [WD] fuv0 ~ Int + + --> Rewrite (D) with (E) + [WD] F alpha ~ fuv0 + [W] FInv fuv0 ~ fuv1 + [D] alpha ~ Int -- (F) + [WD] fuv1 ~ alpha + [WD] fuv0 ~ Int + + --> unify (F) alpha := Int, and that solves it + +Another example is indexed-types/should_compile/T10634 +-} + +{- ******************************************************************* +* * + 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 + = do { try_fundep_improvement + ; continueWith work_item } + + | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis -- Cached + = do { setEvBindIfWanted ev (ctEvTerm solved_ev) + ; stopWith ev "Dict/Top (cached)" } + + | otherwise -- Wanted or Derived, 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 work_item lkup_res } + _ -> -- NoInstance or NotSure + do { when (isImprovable ev) $ + try_fundep_improvement + ; continueWith work_item } } + where + dict_pred = mkClassPred cls xis + dict_loc = ctEvLoc ev + dict_origin = ctLocOrigin dict_loc + + -- We didn't solve it; so try functional dependencies with + -- the instance environment, and return + -- See also Note [Weird fundeps] + try_fundep_improvement + = do { traceTcS "try_fundeps" (ppr work_item) + ; instEnvs <- getInstEnvs + ; emitFunDepDeriveds $ + improveFromInstEnv instEnvs mk_ct_loc dict_pred } + + mk_ct_loc :: PredType -- From instance decl + -> SrcSpan -- also from instance deol + -> CtLoc + mk_ct_loc inst_pred inst_loc + = dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin + inst_pred inst_loc } + +doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w) + + +chooseInstance :: Ct -> 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 ev + ; deeper_loc <- checkInstanceOK loc what pred + ; if isDerived ev then finish_derived deeper_loc theta + else finish_wanted deeper_loc theta mk_ev } + where + ev = ctEvidence work_item + pred = ctEvPred ev + loc = ctEvLoc ev + + finish_wanted :: CtLoc -> [TcPredType] + -> ([EvExpr] -> EvTerm) -> TcS (StopOrContinue Ct) + -- Precondition: evidence term matches the predicate workItem + finish_wanted loc theta mk_ev + = do { evb <- getTcEvBindsVar + ; if isCoEvBindsVar evb + then -- See Note [Instances in no-evidence implications] + continueWith work_item + else + do { evc_vars <- mapM (newWanted loc) theta + ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars)) + ; emitWorkNC (freshGoals evc_vars) + ; stopWith ev "Dict/Top (solved wanted)" } } + + finish_derived loc theta + = -- Use type-class instances for Deriveds, in the hope + -- of generating some improvements + -- C.f. Example 3 of Note [The improvement story] + -- It's easy because no evidence is involved + do { emitNewDeriveds loc theta + ; traceTcS "finish_derived" (ppr (ctl_depth loc)) + ; stopWith ev "Dict/Top (solved derived)" } + +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 insstance: +-- (a) the use is well staged in the Template Haskell sense +-- (b) we have not recursed too deep +-- Returns the CtLoc to used for sub-goals +checkInstanceOK loc what pred + = do { checkWellStagedDFun loc what pred + ; checkReductionDepth deeper_loc 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 + -- infinity, so that prohibitedSuperClassSolve never fires + | ScOrigin {} <- origin + = setCtLocOrigin loc (ScOrigin infinity) + | 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. +-- ee Note [Instance and Given overlap] + | not (xopt LangExt.IncoherentInstances dflags) + , not (naturallyCoherentClass clas) + , let matchable_givens = matchableGivens loc pred inerts + , not (isEmptyBag matchable_givens) + = do { traceTcS "Delaying instance application" $ + vcat [ text "Work item=" <+> pprClassPred clas tys + , text "Potential matching givens:" <+> ppr matchable_givens ] + ; 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 class 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 +#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 + +* Flatten-skolems: we do not treat a flatten-skolem as unifiable + for this purpose. + E.g. f :: Eq (F a) => [a] -> [a] + f xs = ....(xs==xs)..... + Here we get [W] Eq [a], and we don't want to refrain from solving + it because of the given (Eq (F a)) constraint! + +* 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.Monad + 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 + +Exammples: 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. + +Consdider 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 { ics <- getInertCans + ; case match_local_inst (inert_insts ics) of + ([], False) -> do { traceTcS "No local instance for" (ppr pred) + ; return NoInstance } + ([(dfun_ev, inst_tys)], unifs) + | not unifs + -> do { let dfun_id = ctEvEvId dfun_ev + ; (tys, theta) <- instDFunType dfun_id inst_tys + ; let result = OneInst { cir_new_theta = theta + , cir_mk_ev = evDFunApp dfun_id tys + , cir_what = LocalInstance } + ; traceTcS "Local inst found:" (ppr result) + ; return result } + _ -> do { traceTcS "Multiple local instances for" (ppr pred) + ; return NotSure }} + where + pred_tv_set = tyCoVarsOfType pred + + match_local_inst :: [QCInst] + -> ( [(CtEvidence, [DFunInstType])] + , Bool ) -- True <=> Some unify but do not match + match_local_inst [] + = ([], False) + match_local_inst (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred + , qci_ev = ev }) + : 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 = (ev, map (lookupVarEnv tv_subst) qtvs) + = (match:matches, unif) + + | otherwise + = ASSERT2( disjointVarSet qtv_set (tyCoVarsOfType pred) + , ppr qci $$ ppr pred ) + -- ASSERT: unification relies on the + -- quantified variables being fresh + (matches, unif || this_unif) + where + qtv_set = mkVarSet qtvs + this_unif = mightMatchLater qpred (ctEvLoc ev) pred loc + (matches, unif) = match_local_inst qcis diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -0,0 +1,3643 @@ +{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Type definitions for the constraint solver +module GHC.Tc.Solver.Monad ( + + -- The work list + WorkList(..), isEmptyWorkList, emptyWorkList, + extendWorkListNonEq, extendWorkListCt, + extendWorkListCts, extendWorkListEq, extendWorkListFunEq, + appendWorkList, + selectNextWorkItem, + workListSize, workListWantedCount, + getWorkList, updWorkListTcS, pushLevelNoWorkList, + + -- The TcS monad + TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, + failTcS, warnTcS, addErrTcS, + runTcSEqualities, + nestTcS, nestImplicTcS, setEvBindsTcS, + emitImplicationTcS, emitTvImplicationTcS, + + runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive, + matchGlobalInst, TcM.ClsInstResult(..), + + QCInst(..), + + -- Tracing etc + panicTcS, traceTcS, + traceFireTcS, bumpStepCountTcS, csTraceTcS, + wrapErrTcS, wrapWarnTcS, + + -- Evidence creation and transformation + MaybeNew(..), freshGoals, isFresh, getEvExpr, + + newTcEvBinds, newNoTcEvBinds, + newWantedEq, newWantedEq_SI, emitNewWantedEq, + newWanted, newWanted_SI, newWantedEvVar, + newWantedNC, newWantedEvVarNC, + newDerivedNC, + newBoundEvVarId, + unifyTyVar, unflattenFmv, reportUnifications, + setEvBind, setWantedEq, + setWantedEvTerm, setEvBindIfWanted, + newEvVar, newGivenEvVar, newGivenEvVars, + emitNewDeriveds, emitNewDerivedEq, + checkReductionDepth, + getSolvedDicts, setSolvedDicts, + + getInstEnvs, getFamInstEnvs, -- Getting the environments + getTopEnv, getGblEnv, getLclEnv, + getTcEvBindsVar, getTcLevel, + getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, + tcLookupClass, tcLookupId, + + -- Inerts + InertSet(..), InertCans(..), + updInertTcS, updInertCans, updInertDicts, updInertIrreds, + getNoGivenEqs, setInertCans, + getInertEqs, getInertCans, getInertGivens, + getInertInsols, + getTcSInerts, setTcSInerts, + matchableGivens, prohibitedSuperClassSolve, mightMatchLater, + getUnsolvedInerts, + removeInertCts, getPendingGivenScs, + addInertCan, insertFunEq, addInertForAll, + emitWorkNC, emitWork, + isImprovable, + + -- The Model + kickOutAfterUnification, + + -- Inert Safe Haskell safe-overlap failures + addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask, + getSafeOverlapFailures, + + -- Inert CDictCans + DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict, + addDictsByClass, delDict, foldDicts, filterDicts, findDict, + + -- Inert CTyEqCans + EqualCtList, findTyEqs, foldTyEqs, isInInertEqs, + lookupInertTyVar, + + -- Inert solved dictionaries + addSolvedDict, lookupSolvedDict, + + -- Irreds + foldIrreds, + + -- The flattening cache + lookupFlatCache, extendFlatCache, newFlattenSkolem, -- Flatten skolems + dischargeFunEq, pprKicked, + + -- Inert CFunEqCans + updInertFunEqs, findFunEq, + findFunEqsByTyCon, + + instDFunType, -- Instantiation + + -- MetaTyVars + newFlexiTcSTy, instFlexi, instFlexiX, + cloneMetaTyVar, demoteUnfilledFmv, + 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 +) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Types + +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 ) +import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) +import GHC.Tc.Utils.TcType +import GHC.Driver.Session +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Unify + +import GHC.Utils.Error +import GHC.Tc.Types.Evidence +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Tc.Errors ( solverDepthErrorTcS ) + +import GHC.Types.Name +import GHC.Unit.Module ( HasModule, getModule ) +import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt ) +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.Data.Bag as Bag +import GHC.Types.Unique.Supply +import GHC.Utils.Misc +import GHC.Tc.Types +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate + +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Data.Maybe + +import GHC.Core.Map +import Control.Monad +import GHC.Utils.Monad +import Data.IORef +import Data.List ( partition, mapAccumL ) + +#if defined(DEBUG) +import GHC.Data.Graph.Directed +import GHC.Types.Unique.Set +#endif + +{- +************************************************************************ +* * +* Worklists * +* Canonical and non-canonical constraints that the simplifier has to * +* work on. Including their simplification depths. * +* * +* * +************************************************************************ + +Note [WorkList priorities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A WorkList contains canonical and non-canonical items (of all flavors). +Notice that each Ct now has a simplification depth. We may +consider using this depth for prioritization as well in the future. + +As a simple form of priority queue, our worklist separates out + +* equalities (wl_eqs); see Note [Prioritise equalities] +* type-function equalities (wl_funeqs) +* all the rest (wl_rest) + +Note [Prioritise equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very important to process equalities /first/: + +* (Efficiency) The general reason to do so is that if we process a + class constraint first, we may end up putting it into the inert set + and then kicking it out later. That's extra work compared to just + doing the equality first. + +* (Avoiding fundep iteration) As #14723 showed, it's possible to + get non-termination if we + - Emit the Derived fundep equalities for a class constraint, + generating some fresh unification variables. + - That leads to some unification + - Which kicks out the class constraint + - Which isn't solved (because there are still some more Derived + equalities in the work-list), but generates yet more fundeps + Solution: prioritise derived equalities over class constraints + +* (Class equalities) We need to prioritise equalities even if they + are hidden inside a class constraint; + see Note [Prioritise class equalities] + +* (Kick-out) We want to apply this priority scheme to kicked-out + constraints too (see the call to extendWorkListCt in kick_out_rewritable + E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become + homo-kinded when kicked out, and hence we want to prioritise it. + +* (Derived equalities) Originally we tried to postpone processing + Derived equalities, in the hope that we might never need to deal + with them at all; but in fact we must process Derived equalities + eagerly, partly for the (Efficiency) reason, and more importantly + for (Avoiding fundep iteration). + +Note [Prioritise class equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We prioritise equalities in the solver (see selectWorkItem). But class +constraints like (a ~ b) and (a ~~ b) are actually equalities too; +see Note [The equality types story] in GHC.Builtin.Types.Prim. + +Failing to prioritise these is inefficient (more kick-outs etc). +But, worse, it can prevent us spotting a "recursive knot" among +Wanted constraints. See comment:10 of #12734 for a worked-out +example. + +So we arrange to put these particular class constraints in the wl_eqs. + + NB: since we do not currently apply the substitution to the + inert_solved_dicts, the knot-tying still seems a bit fragile. + But this makes it better. + +-} + +-- See Note [WorkList priorities] +data WorkList + = WL { wl_eqs :: [Ct] -- CTyEqCan, CDictCan, CIrredCan + -- Given, Wanted, and Derived + -- Contains both equality constraints and their + -- class-level variants (a~b) and (a~~b); + -- See Note [Prioritise equalities] + -- See Note [Prioritise class equalities] + + , wl_funeqs :: [Ct] + + , wl_rest :: [Ct] + + , wl_implics :: Bag Implication -- See Note [Residual implications] + } + +appendWorkList :: WorkList -> WorkList -> WorkList +appendWorkList + (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1 + , wl_implics = implics1 }) + (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2 + , wl_implics = implics2 }) + = WL { wl_eqs = eqs1 ++ eqs2 + , wl_funeqs = funeqs1 ++ funeqs2 + , wl_rest = rest1 ++ rest2 + , wl_implics = implics1 `unionBags` implics2 } + +workListSize :: WorkList -> Int +workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest }) + = length eqs + length funeqs + length rest + +workListWantedCount :: WorkList -> Int +-- Count the things we need to solve +-- excluding the insolubles (c.f. inert_count) +workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest }) + = count isWantedCt eqs + count is_wanted rest + where + is_wanted ct + | CIrredCan { cc_status = InsolubleCIS } <- ct + = False + | otherwise + = isWantedCt ct + +extendWorkListEq :: Ct -> WorkList -> WorkList +extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl } + +extendWorkListFunEq :: Ct -> WorkList -> WorkList +extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl } + +extendWorkListNonEq :: Ct -> WorkList -> WorkList +-- Extension by non equality +extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } + +extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList +extendWorkListDeriveds evs wl + = extendWorkListCts (map mkNonCanonical evs) wl + +extendWorkListImplic :: Implication -> WorkList -> WorkList +extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl } + +extendWorkListCt :: Ct -> WorkList -> WorkList +-- Agnostic +extendWorkListCt ct wl + = case classifyPredType (ctPred ct) of + EqPred NomEq ty1 _ + | Just tc <- tcTyConAppTyCon_maybe ty1 + , isTypeFamilyTyCon tc + -> extendWorkListFunEq ct wl + + EqPred {} + -> extendWorkListEq ct wl + + ClassPred cls _ -- See Note [Prioritise class equalities] + | isEqPredClass cls + -> extendWorkListEq ct wl + + _ -> extendWorkListNonEq ct wl + +extendWorkListCts :: [Ct] -> WorkList -> WorkList +-- Agnostic +extendWorkListCts cts wl = foldr extendWorkListCt wl cts + +isEmptyWorkList :: WorkList -> Bool +isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs + , wl_rest = rest, wl_implics = implics }) + = null eqs && null rest && null funeqs && isEmptyBag implics + +emptyWorkList :: WorkList +emptyWorkList = WL { wl_eqs = [], wl_rest = [] + , wl_funeqs = [], wl_implics = emptyBag } + +selectWorkItem :: WorkList -> Maybe (Ct, WorkList) +-- See Note [Prioritise equalities] +selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs + , wl_rest = rest }) + | ct:cts <- eqs = Just (ct, wl { wl_eqs = cts }) + | ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes }) + | ct:cts <- rest = Just (ct, wl { wl_rest = cts }) + | otherwise = Nothing + +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) } } } + +-- Pretty printing +instance Outputable WorkList where + ppr (WL { wl_eqs = eqs, wl_funeqs = feqs + , wl_rest = rest, wl_implics = implics }) + = text "WL" <+> (braces $ + vcat [ ppUnless (null eqs) $ + text "Eqs =" <+> vcat (map ppr eqs) + , ppUnless (null feqs) $ + text "Funeqs =" <+> vcat (map ppr feqs) + , ppUnless (null rest) $ + text "Non-eqs =" <+> vcat (map ppr rest) + , ppUnless (isEmptyBag implics) $ + ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics))) + (text "(Implics omitted)") + ]) + + +{- ********************************************************************* +* * + InertSet: the inert set +* * +* * +********************************************************************* -} + +data InertSet + = IS { inert_cans :: InertCans + -- Canonical Given, Wanted, Derived + -- Sometimes called "the inert set" + + , inert_fsks :: [(TcTyVar, TcType)] + -- A list of (fsk, ty) pairs; we add one element when we flatten + -- a function application in a Given constraint, creating + -- a new fsk in newFlattenSkolem. When leaving a nested scope, + -- unflattenGivens unifies fsk := ty + -- + -- We could also get this info from inert_funeqs, filtered by + -- level, but it seems simpler and more direct to capture the + -- fsk as we generate them. + + , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour) + -- See Note [Type family equations] + -- If F tys :-> (co, rhs, flav), + -- then co :: F tys ~ rhs + -- flav is [G] or [WD] + -- + -- Just a hash-cons cache for use when flattening only + -- These include entirely un-processed goals, so don't use + -- them to solve a top-level goal, else you may end up solving + -- (w:F ty ~ a) by setting w:=w! We just use the flat-cache + -- when allocating a new flatten-skolem. + -- Not necessarily inert wrt top-level equations (or inert_cans) + + -- NB: An ExactFunEqMap -- this doesn't match via loose types! + + , inert_solved_dicts :: DictMap CtEvidence + -- All Wanteds, of form ev :: C t1 .. tn + -- See Note [Solved dictionaries] + -- and Note [Do not add superclasses of solved dictionaries] + } + +instance Outputable InertSet where + ppr (IS { inert_cans = ics + , inert_fsks = ifsks + , inert_solved_dicts = solved_dicts }) + = vcat [ ppr ics + , text "Inert fsks =" <+> ppr ifsks + , ppUnless (null dicts) $ + text "Solved dicts =" <+> vcat (map ppr dicts) ] + where + dicts = bagToList (dictsToBag solved_dicts) + +emptyInertCans :: InertCans +emptyInertCans + = IC { inert_count = 0 + , inert_eqs = emptyDVarEnv + , inert_dicts = emptyDicts + , inert_safehask = emptyDicts + , inert_funeqs = emptyFunEqs + , inert_insts = [] + , inert_irreds = emptyCts } + +emptyInert :: InertSet +emptyInert + = IS { inert_cans = emptyInertCans + , inert_fsks = [] + , inert_flat_cache = emptyExactFunEqs + , inert_solved_dicts = emptyDictMap } + + +{- Note [Solved dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we apply a top-level instance declaration, we add the "solved" +dictionary to the inert_solved_dicts. In general, we use it to avoid +creating a new EvVar when we have a new goal that we have solved in +the past. + +But in particular, we can use it to create *recursive* dictionaries. +The simplest, degenerate case is + instance C [a] => C [a] where ... +If we have + [W] d1 :: C [x] +then we can apply the instance to get + d1 = $dfCList d + [W] d2 :: C [x] +Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1. + d1 = $dfCList d + d2 = d1 + +See Note [Example of recursive dictionaries] + +VERY IMPORTANT INVARIANT: + + (Solved Dictionary Invariant) + Every member of the inert_solved_dicts is the result + of applying an instance declaration that "takes a step" + + An instance "takes a step" if it has the form + dfunDList d1 d2 = MkD (...) (...) (...) + That is, the dfun is lazy in its arguments, and guarantees to + immediately return a dictionary constructor. NB: all dictionary + data constructors are lazy in their arguments. + + This property is crucial to ensure that all dictionaries are + non-bottom, which in turn ensures that the whole "recursive + dictionary" idea works at all, even if we get something like + rec { d = dfunDList d dx } + See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance. + + Reason: + - All instances, except two exceptions listed below, "take a step" + in the above sense + + - Exception 1: local quantified constraints have no such guarantee; + indeed, adding a "solved dictionary" when appling a quantified + constraint led to the ability to define unsafeCoerce + in #17267. + + - Exception 2: the magic built-in instance for (~) has no + such guarantee. It behaves as if we had + class (a ~# b) => (a ~ b) where {} + instance (a ~# b) => (a ~ b) where {} + The "dfun" for the instance is strict in the coercion. + Anyway there's no point in recording a "solved dict" for + (t1 ~ t2); it's not going to allow a recursive dictionary + to be constructed. Ditto (~~) and Coercible. + +THEREFORE we only add a "solved dictionary" + - when applying an instance declaration + - subject to Exceptions 1 and 2 above + +In implementation terms + - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary, + conditional on the kind of instance + + - It is only called when applying an instance decl, + in GHC.Tc.Solver.Interact.doTopReactDict + + - ClsInst.InstanceWhat says what kind of instance was + used to solve the constraint. In particular + * LocalInstance identifies quantified constraints + * BuiltinEqInstance identifies the strange built-in + instances for equality. + + - ClsInst.instanceReturnsDictCon says which kind of + instance guarantees to return a dictionary constructor + +Other notes about solved dictionaries + +* See also Note [Do not add superclasses of solved dictionaries] + +* The inert_solved_dicts field is not rewritten by equalities, + so it may get out of date. + +* The inert_solved_dicts are all Wanteds, never givens + +* We only cache dictionaries from top-level instances, not from + local quantified constraints. Reason: if we cached the latter + we'd need to purge the cache when bringing new quantified + constraints into scope, because quantified constraints "shadow" + top-level instances. + +Note [Do not add superclasses of solved dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every member of inert_solved_dicts is the result of applying a +dictionary function, NOT of applying superclass selection to anything. +Consider + + class Ord a => C a where + instance Ord [a] => C [a] where ... + +Suppose we are trying to solve + [G] d1 : Ord a + [W] d2 : C [a] + +Then we'll use the instance decl to give + + [G] d1 : Ord a Solved: d2 : C [a] = $dfCList d3 + [W] d3 : Ord [a] + +We must not add d4 : Ord [a] to the 'solved' set (by taking the +superclass of d2), otherwise we'll use it to solve d3, without ever +using d1, which would be a catastrophe. + +Solution: when extending the solved dictionaries, do not add superclasses. +That's why each element of the inert_solved_dicts is the result of applying +a dictionary function. + +Note [Example of recursive dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +--- Example 1 + + data D r = ZeroD | SuccD (r (D r)); + + instance (Eq (r (D r))) => Eq (D r) where + ZeroD == ZeroD = True + (SuccD a) == (SuccD b) = a == b + _ == _ = False; + + equalDC :: D [] -> D [] -> Bool; + equalDC = (==); + +We need to prove (Eq (D [])). Here's how we go: + + [W] d1 : Eq (D []) +By instance decl of Eq (D r): + [W] d2 : Eq [D []] where d1 = dfEqD d2 +By instance decl of Eq [a]: + [W] d3 : Eq (D []) where d2 = dfEqList d3 + d1 = dfEqD d2 +Now this wanted can interact with our "solved" d1 to get: + d3 = d1 + +-- Example 2: +This code arises in the context of "Scrap Your Boilerplate with Class" + + class Sat a + class Data ctx a + instance Sat (ctx Char) => Data ctx Char -- dfunData1 + instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] -- dfunData2 + + class Data Maybe a => Foo a + + instance Foo t => Sat (Maybe t) -- dfunSat + + instance Data Maybe a => Foo a -- dfunFoo1 + instance Foo a => Foo [a] -- dfunFoo2 + instance Foo [Char] -- dfunFoo3 + +Consider generating the superclasses of the instance declaration + instance Foo a => Foo [a] + +So our problem is this + [G] d0 : Foo t + [W] d1 : Data Maybe [t] -- Desired superclass + +We may add the given in the inert set, along with its superclasses + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + WorkList + [W] d1 : Data Maybe [t] + +Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3 + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + WorkList: + [W] d2 : Sat (Maybe [t]) + [W] d3 : Data Maybe t + +Now, we may simplify d2 using dfunSat; d2 := dfunSat d4 + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + WorkList: + [W] d3 : Data Maybe t + [W] d4 : Foo [t] + +Now, we can just solve d3 from d01; d3 := d01 + Inert + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + WorkList + [W] d4 : Foo [t] + +Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5 + Inert + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + d4 : Foo [t] + WorkList: + [W] d5 : Foo t + +Now, d5 can be solved! d5 := d0 + +Result + d1 := dfunData2 d2 d3 + d2 := dfunSat d4 + d3 := d01 + d4 := dfunFoo2 d5 + d5 := d0 +-} + +{- ********************************************************************* +* * + InertCans: the canonical inerts +* * +* * +********************************************************************* -} + +data InertCans -- See Note [Detailed InertCans Invariants] for more + = IC { inert_eqs :: InertEqs + -- See Note [inert_eqs: the inert equalities] + -- All CTyEqCans; index is the LHS tyvar + -- Domain = skolems and untouchables; a touchable would be unified + + , inert_funeqs :: FunEqMap Ct + -- All CFunEqCans; index is the whole family head type. + -- All Nominal (that's an invariant of all CFunEqCans) + -- LHS is fully rewritten (modulo eqCanRewrite constraints) + -- wrt inert_eqs + -- Can include all flavours, [G], [W], [WD], [D] + -- See Note [Type family equations] + + , inert_dicts :: DictMap Ct + -- Dictionaries only + -- All fully rewritten (modulo flavour constraints) + -- wrt inert_eqs + + , inert_insts :: [QCInst] + + , inert_safehask :: DictMap Ct + -- Failed dictionary resolution due to Safe Haskell overlapping + -- instances restriction. We keep this separate from inert_dicts + -- as it doesn't cause compilation failure, just safe inference + -- failure. + -- + -- ^ See Note [Safe Haskell Overlapping Instances Implementation] + -- in GHC.Tc.Solver + + , inert_irreds :: Cts + -- Irreducible predicates that cannot be made canonical, + -- and which don't interact with others (e.g. (c a)) + -- and insoluble predicates (e.g. Int ~ Bool, or a ~ [a]) + + , inert_count :: Int + -- Number of Wanted goals in + -- inert_eqs, inert_dicts, inert_safehask, inert_irreds + -- Does not include insolubles + -- When non-zero, keep trying to solve + } + +type InertEqs = DTyVarEnv EqualCtList +type EqualCtList = [Ct] -- See Note [EqualCtList invariants] + +{- Note [Detailed InertCans Invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The InertCans represents a collection of constraints with the following properties: + + * All canonical + + * No two dictionaries with the same head + * No two CIrreds with the same type + + * Family equations inert wrt top-level family axioms + + * Dictionaries have no matching top-level instance + + * Given family or dictionary constraints don't mention touchable + unification variables + + * Non-CTyEqCan constraints are fully rewritten with respect + to the CTyEqCan equalities (modulo canRewrite of course; + eg a wanted cannot rewrite a given) + + * CTyEqCan equalities: see Note [inert_eqs: the inert equalities] + Also see documentation in Constraint.Ct for a list of invariants + +Note [EqualCtList invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * All are equalities + * All these equalities have the same LHS + * The list is never empty + * No element of the list can rewrite any other + * Derived before Wanted + +From the fourth invariant it follows that the list is + - A single [G], or + - Zero or one [D] or [WD], followed by any number of [W] + +The Wanteds can't rewrite anything which is why we put them last + +Note [Type family equations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type-family equations, CFunEqCans, of form (ev : F tys ~ ty), +live in three places + + * The work-list, of course + + * The inert_funeqs are un-solved but fully processed, and in + the InertCans. They can be [G], [W], [WD], or [D]. + + * The inert_flat_cache. This is used when flattening, to get maximal + sharing. Everything in the inert_flat_cache is [G] or [WD] + + It contains lots of things that are still in the work-list. + E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the + work list. Then we flatten w1, dumping (w3: G a ~ f1) in the work + list. Now if we flatten w2 before we get to w3, we still want to + share that (G a). + Because it contains work-list things, DO NOT use the flat cache to solve + a top-level goal. Eg in the above example we don't want to solve w3 + using w3 itself! + +The CFunEqCan Ownership Invariant: + + * Each [G/W/WD] CFunEqCan has a distinct fsk or fmv + It "owns" that fsk/fmv, in the sense that: + - reducing a [W/WD] CFunEqCan fills in the fmv + - unflattening a [W/WD] CFunEqCan fills in the fmv + (in both cases unless an occurs-check would result) + + * In contrast a [D] CFunEqCan does not "own" its fmv: + - reducing a [D] CFunEqCan does not fill in the fmv; + it just generates an equality + - unflattening ignores [D] CFunEqCans altogether + + +Note [inert_eqs: the inert equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Definition [Can-rewrite relation] +A "can-rewrite" relation between flavours, written f1 >= f2, is a +binary relation with the following properties + + (R1) >= is transitive + (R2) If f1 >= f, and f2 >= f, + then either f1 >= f2 or f2 >= f1 + +Lemma. If f1 >= f then f1 >= f1 +Proof. By property (R2), with f1=f2 + +Definition [Generalised substitution] +A "generalised substitution" S is a set of triples (a -f-> t), where + a is a type variable + t is a type + f is a flavour +such that + (WF1) if (a -f1-> t1) in S + (a -f2-> t2) in S + then neither (f1 >= f2) nor (f2 >= f1) hold + (WF2) if (a -f-> t) is in S, then t /= a + +Definition [Applying a generalised substitution] +If S is a generalised substitution + S(f,a) = t, if (a -fs-> t) in S, and fs >= f + = a, otherwise +Application extends naturally to types S(f,t), modulo roles. +See Note [Flavours with roles]. + +Theorem: S(f,a) is well defined as a function. +Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S, + and f1 >= f and f2 >= f + Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1) + +Notation: repeated application. + S^0(f,t) = t + S^(n+1)(f,t) = S(f, S^n(t)) + +Definition: inert generalised substitution +A generalised substitution S is "inert" iff + + (IG1) there is an n such that + for every f,t, S^n(f,t) = S^(n+1)(f,t) + +By (IG1) we define S*(f,t) to be the result of exahaustively +applying S(f,_) to t. + +---------------------------------------------------------------- +Our main invariant: + the inert CTyEqCans should be an inert generalised substitution +---------------------------------------------------------------- + +Note that inertness is not the same as idempotence. To apply S to a +type, you may have to apply it recursive. But inertness does +guarantee that this recursive use will terminate. + +Note [Extending the inert equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Main Theorem [Stability under extension] + Suppose we have a "work item" + a -fw-> t + and an inert generalised substitution S, + THEN the extended substitution T = S+(a -fw-> t) + is an inert generalised substitution + PROVIDED + (T1) S(fw,a) = a -- LHS of work-item is a fixpoint of S(fw,_) + (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_) + (T3) a not in t -- No occurs check in the work item + + AND, for every (b -fs-> s) in S: + (K0) not (fw >= fs) + Reason: suppose we kick out (a -fs-> s), + and add (a -fw-> t) to the inert set. + The latter can't rewrite the former, + so the kick-out achieved nothing + + OR { (K1) not (a = b) + Reason: if fw >= fs, WF1 says we can't have both + a -fw-> t and a -fs-> s + + AND (K2): guarantees inertness of the new substitution + { (K2a) not (fs >= fs) + OR (K2b) fs >= fw + OR (K2d) a not in s } + + AND (K3) See Note [K3: completeness of solving] + { (K3a) If the role of fs is nominal: s /= a + (K3b) If the role of fs is representational: + s is not of form (a t1 .. tn) } } + + +Conditions (T1-T3) are established by the canonicaliser +Conditions (K1-K3) are established by GHC.Tc.Solver.Monad.kickOutRewritable + +The idea is that +* (T1-2) are guaranteed by exhaustively rewriting the work-item + with S(fw,_). + +* T3 is guaranteed by a simple occurs-check on the work item. + This is done during canonicalisation, in canEqTyVar; invariant + (TyEq:OC) of CTyEqCan. + +* (K1-3) are the "kick-out" criteria. (As stated, they are really the + "keep" criteria.) If the current inert S contains a triple that does + not satisfy (K1-3), then we remove it from S by "kicking it out", + and re-processing it. + +* Note that kicking out is a Bad Thing, because it means we have to + re-process a constraint. The less we kick out, the better. + TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed + this but haven't done the empirical study to check. + +* Assume we have G>=G, G>=W and that's all. Then, when performing + a unification we add a new given a -G-> ty. But doing so does NOT require + us to kick out an inert wanted that mentions a, because of (K2a). This + is a common case, hence good not to kick out. + +* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing + Proof: using Definition [Can-rewrite relation], fw can't rewrite anything + and so K0 holds. Intuitively, since fw can't rewrite anything, + adding it cannot cause any loops + This is a common case, because Wanteds cannot rewrite Wanteds. + It's used to avoid even looking for constraint to kick out. + +* Lemma (L1): The conditions of the Main Theorem imply that there is no + (a -fs-> t) in S, s.t. (fs >= fw). + Proof. Suppose the contrary (fs >= fw). Then because of (T1), + S(fw,a)=a. But since fs>=fw, S(fw,a) = s, hence s=a. But now we + have (a -fs-> a) in S, which contradicts (WF2). + +* The extended substitution satisfies (WF1) and (WF2) + - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1). + - (T3) guarantees (WF2). + +* (K2) is about inertness. Intuitively, any infinite chain T^0(f,t), + T^1(f,t), T^2(f,T).... must pass through the new work item infinitely + often, since the substitution without the work item is inert; and must + pass through at least one of the triples in S infinitely often. + + - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f), + and hence this triple never plays a role in application S(f,a). + It is always safe to extend S with such a triple. + + (NB: we could strengten K1) in this way too, but see K3. + + - (K2b): If this holds then, by (T2), b is not in t. So applying the + work item does not generate any new opportunities for applying S + + - (K2c): If this holds, we can't pass through this triple infinitely + often, because if we did then fs>=f, fw>=f, hence by (R2) + * either fw>=fs, contradicting K2c + * or fs>=fw; so by the argument in K2b we can't have a loop + + - (K2d): if a not in s, we hae no further opportunity to apply the + work item, similar to (K2b) + + NB: Dimitrios has a PDF that does this in more detail + +Key lemma to make it watertight. + Under the conditions of the Main Theorem, + forall f st fw >= f, a is not in S^k(f,t), for any k + +Also, consider roles more carefully. See Note [Flavours with roles] + +Note [K3: completeness of solving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(K3) is not necessary for the extended substitution +to be inert. In fact K1 could be made stronger by saying + ... then (not (fw >= fs) or not (fs >= fs)) +But it's not enough for S to be inert; we also want completeness. +That is, we want to be able to solve all soluble wanted equalities. +Suppose we have + + work-item b -G-> a + inert-item a -W-> b + +Assuming (G >= W) but not (W >= W), this fulfills all the conditions, +so we could extend the inerts, thus: + + inert-items b -G-> a + a -W-> b + +But if we kicked-out the inert item, we'd get + + work-item a -W-> b + inert-item b -G-> a + +Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl. +So we add one more clause to the kick-out criteria + +Another way to understand (K3) is that we treat an inert item + a -f-> b +in the same way as + b -f-> a +So if we kick out one, we should kick out the other. The orientation +is somewhat accidental. + +When considering roles, we also need the second clause (K3b). Consider + + work-item c -G/N-> a + inert-item a -W/R-> b c + +The work-item doesn't get rewritten by the inert, because (>=) doesn't hold. +But we don't kick out the inert item because not (W/R >= W/R). So we just +add the work item. But then, consider if we hit the following: + + work-item b -G/N-> Id + inert-items a -W/R-> b c + c -G/N-> a +where + newtype Id x = Id x + +For similar reasons, if we only had (K3a), we wouldn't kick the +representational inert out. And then, we'd miss solving the inert, which +now reduced to reflexivity. + +The solution here is to kick out representational inerts whenever the +tyvar of a work item is "exposed", where exposed means being at the +head of the top-level application chain (a t1 .. tn). See +TcType.isTyVarHead. This is encoded in (K3b). + +Beware: if we make this test succeed too often, we kick out too much, +and the solver might loop. Consider (#14363) + work item: [G] a ~R f b + inert item: [G] b ~R f a +In GHC 8.2 the completeness tests more aggressive, and kicked out +the inert item; but no rewriting happened and there was an infinite +loop. All we need is to have the tyvar at the head. + +Note [Flavours with roles] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The system described in Note [inert_eqs: the inert equalities] +discusses an abstract +set of flavours. In GHC, flavours have two components: the flavour proper, +taken from {Wanted, Derived, Given} and the equality relation (often called +role), taken from {NomEq, ReprEq}. +When substituting w.r.t. the inert set, +as described in Note [inert_eqs: the inert equalities], +we must be careful to respect all components of a flavour. +For example, if we have + + inert set: a -G/R-> Int + b -G/R-> Bool + + type role T nominal representational + +and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT +T Int Bool. The reason is that T's first parameter has a nominal role, and +thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of +substitution means that the proof in Note [The inert equalities] may need +to be revisited, but we don't think that the end conclusion is wrong. +-} + +instance Outputable InertCans where + ppr (IC { inert_eqs = eqs + , inert_funeqs = funeqs, inert_dicts = dicts + , inert_safehask = safehask, inert_irreds = irreds + , inert_insts = insts + , inert_count = count }) + = braces $ vcat + [ ppUnless (isEmptyDVarEnv eqs) $ + text "Equalities:" + <+> pprCts (foldDVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs) + , ppUnless (isEmptyTcAppMap funeqs) $ + text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs) + , ppUnless (isEmptyTcAppMap dicts) $ + text "Dictionaries =" <+> pprCts (dictsToBag dicts) + , ppUnless (isEmptyTcAppMap safehask) $ + text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask) + , ppUnless (isEmptyCts irreds) $ + text "Irreds =" <+> pprCts irreds + , ppUnless (null insts) $ + text "Given instances =" <+> vcat (map ppr insts) + , text "Unsolved goals =" <+> int count + ] + +{- ********************************************************************* +* * + Shadow constraints and improvement +* * +************************************************************************ + +Note [The improvement story and derived shadows] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not +rewrite Wanteds] in GHC.Tc.Types.Constraint), we may miss some opportunities for +solving. Here's a classic example (indexed-types/should_fail/T4093a) + + Ambiguity check for f: (Foo e ~ Maybe e) => Foo e + + We get [G] Foo e ~ Maybe e + [W] Foo e ~ Foo ee -- ee is a unification variable + [W] Foo ee ~ Maybe ee + + Flatten: [G] Foo e ~ fsk + [G] fsk ~ Maybe e -- (A) + + [W] Foo ee ~ fmv + [W] fmv ~ fsk -- (B) From Foo e ~ Foo ee + [W] fmv ~ Maybe ee + + --> rewrite (B) with (A) + [W] Foo ee ~ fmv + [W] fmv ~ Maybe e + [W] fmv ~ Maybe ee + + But now we appear to be stuck, since we don't rewrite Wanteds with + Wanteds. This is silly because we can see that ee := e is the + only solution. + +The basic plan is + * generate Derived constraints that shadow Wanted constraints + * allow Derived to rewrite Derived + * in order to cause some unifications to take place + * that in turn solve the original Wanteds + +The ONLY reason for all these Derived equalities is to tell us how to +unify a variable: that is, what Mark Jones calls "improvement". + +The same idea is sometimes also called "saturation"; find all the +equalities that must hold in any solution. + +Or, equivalently, you can think of the derived shadows as implementing +the "model": a non-idempotent but no-occurs-check substitution, +reflecting *all* *Nominal* equalities (a ~N ty) that are not +immediately soluble by unification. + +More specifically, here's how it works (Oct 16): + +* Wanted constraints are born as [WD]; this behaves like a + [W] and a [D] paired together. + +* When we are about to add a [WD] to the inert set, if it can + be rewritten by a [D] a ~ ty, then we split it into [W] and [D], + putting the latter into the work list (see maybeEmitShadow). + +In the example above, we get to the point where we are stuck: + [WD] Foo ee ~ fmv + [WD] fmv ~ Maybe e + [WD] fmv ~ Maybe ee + +But now when [WD] fmv ~ Maybe ee is about to be added, we'll +split it into [W] and [D], since the inert [WD] fmv ~ Maybe e +can rewrite it. Then: + work item: [D] fmv ~ Maybe ee + inert: [W] fmv ~ Maybe ee + [WD] fmv ~ Maybe e -- (C) + [WD] Foo ee ~ fmv + +See Note [Splitting WD constraints]. Now the work item is rewritten +by (C) and we soon get ee := e. + +Additional notes: + + * The derived shadow equalities live in inert_eqs, along with + the Givens and Wanteds; see Note [EqualCtList invariants]. + + * We make Derived shadows only for Wanteds, not Givens. So we + have only [G], not [GD] and [G] plus splitting. See + Note [Add derived shadows only for Wanteds] + + * We also get Derived equalities from functional dependencies + and type-function injectivity; see calls to unifyDerived. + + * This splitting business applies to CFunEqCans too; and then + we do apply type-function reductions to the [D] CFunEqCan. + See Note [Reduction for Derived CFunEqCans] + + * It's worth having [WD] rather than just [W] and [D] because + * efficiency: silly to process the same thing twice + * inert_funeqs, inert_dicts is a finite map keyed by + the type; it's inconvenient for it to map to TWO constraints + +Note [Splitting WD constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are about to add a [WD] constraint to the inert set; and we +know that the inert set has fully rewritten it. Should we split +it into [W] and [D], and put the [D] in the work list for further +work? + +* CDictCan (C tys) or CFunEqCan (F tys ~ fsk): + Yes if the inert set could rewrite tys to make the class constraint, + or type family, fire. That is, yes if the inert_eqs intersects + with the free vars of tys. For this test we use + (anyRewritableTyVar True) which ignores casts and coercions in tys, + because rewriting the casts or coercions won't make the thing fire + more often. + +* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'. + We need to check both 'a' and 'ty' against the inert set: + - Inert set contains [D] a ~ ty2 + Then we want to put [D] a ~ ty in the worklist, so we'll + get [D] ty ~ ty2 with consequent good things + + - Inert set contains [D] b ~ a, where b is in ty. + We can't just add [WD] a ~ ty[b] to the inert set, because + that breaks the inert-set invariants. If we tried to + canonicalise another [D] constraint mentioning 'a', we'd + get an infinite loop + + Moreover we must use (anyRewritableTyVar False) for the RHS, + because even tyvars in the casts and coercions could give + an infinite loop if we don't expose it + +* CIrredCan: Yes if the inert set can rewrite the constraint. + We used to think splitting irreds was unnecessary, but + see Note [Splitting Irred WD constraints] + +* Others: nothing is gained by splitting. + +Note [Splitting Irred WD constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Splitting Irred constraints can make a difference. Here is the +scenario: + + a[sk] :: F v -- F is a type family + beta :: alpha + + work item: [WD] a ~ beta + +This is heterogeneous, so we try flattening the kinds. + + co :: F v ~ fmv + [WD] (a |> co) ~ beta + +This is still hetero, so we emit a kind equality and make the work item an +inert Irred. + + work item: [D] fmv ~ alpha + inert: [WD] (a |> co) ~ beta (CIrredCan) + +Can't make progress on the work item. Add to inert set. This kicks out the +old inert, because a [D] can rewrite a [WD]. + + work item: [WD] (a |> co) ~ beta + inert: [D] fmv ~ alpha (CTyEqCan) + +Can't make progress on this work item either (although GHC tries by +decomposing the cast and reflattening... but that doesn't make a difference), +which is still hetero. Emit a new kind equality and add to inert set. But, +critically, we split the Irred. + + work list: + [D] fmv ~ alpha (CTyEqCan) + [D] (a |> co) ~ beta (CIrred) -- this one was split off + inert: + [W] (a |> co) ~ beta + [D] fmv ~ alpha + +We quickly solve the first work item, as it's the same as an inert. + + work item: [D] (a |> co) ~ beta + inert: + [W] (a |> co) ~ beta + [D] fmv ~ alpha + +We decompose the cast, yielding + + [D] a ~ beta + +We then flatten the kinds. The lhs kind is F v, which flattens to fmv which +then rewrites to alpha. + + co' :: F v ~ alpha + [D] (a |> co') ~ beta + +Now this equality is homo-kinded. So we swizzle it around to + + [D] beta ~ (a |> co') + +and set beta := a |> co', and go home happy. + +If we don't split the Irreds, we loop. This is all dangerously subtle. + +This is triggered by test case typecheck/should_compile/SplitWD. + +Note [Examples of how Derived shadows helps completeness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#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] UnF (F a) ~ a + [WD] UnF (F beta) ~ beta + [WD] F a ~ F beta + Flatten: + [G] g1: F a ~ fsk1 fsk1 := F a + [G] g2: UnF fsk1 ~ fsk2 fsk2 := UnF fsk1 + [G] g3: fsk2 ~ a + + [WD] w1: F beta ~ fmv1 + [WD] w2: UnF fmv1 ~ fmv2 + [WD] w3: fmv2 ~ beta + [WD] w4: fmv1 ~ fsk1 -- From F a ~ F beta using flat-cache + -- and re-orient to put meta-var on left + +Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2 +React that with g2: [D] d2: fmv2 ~ fsk2 +React that with w3: [D] beta ~ fsk2 + and g3: [D] beta ~ a -- Hooray beta := a +And that is enough to solve everything + +Note [Add derived shadows only for Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only add shadows for Wanted constraints. That is, we have +[WD] but not [GD]; and maybeEmitShaodw looks only at [WD] +constraints. + +It does just possibly make sense ot add a derived shadow for a +Given. If we created a Derived shadow of a Given, it could be +rewritten by other Deriveds, and that could, conceivably, lead to a +useful unification. + +But (a) I have been unable to come up with an example of this + happening + (b) see #12660 for how adding the derived shadows + of a Given led to an infinite loop. + (c) It's unlikely that rewriting derived Givens will lead + to a unification because Givens don't mention touchable + unification variables + +For (b) there may be other ways to solve the loop, but simply +reraining from adding derived shadows of Givens is particularly +simple. And it's more efficient too! + +Still, here's one possible reason for adding derived shadows +for Givens. Consider + work-item [G] a ~ [b], inerts has [D] b ~ a. +If we added the derived shadow (into the work list) + [D] a ~ [b] +When we process it, we'll rewrite to a ~ [a] and get an +occurs check. Without it we'll miss the occurs check (reporting +inaccessible code); but that's probably OK. + +Note [Keep CDictCan shadows as CDictCan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + class C a => D a b +and [G] D a b, [G] C a in the inert set. Now we insert +[D] b ~ c. We want to kick out a derived shadow for [D] D a b, +so we can rewrite it with the new constraint, and perhaps get +instance reduction or other consequences. + +BUT we do not want to kick out a *non-canonical* (D a b). If we +did, we would do this: + - rewrite it to [D] D a c, with pend_sc = True + - use expandSuperClasses to add C a + - go round again, which solves C a from the givens +This loop goes on for ever and triggers the simpl_loop limit. + +Solution: kick out the CDictCan which will have pend_sc = False, +because we've already added its superclasses. So we won't re-add +them. If we forget the pend_sc flag, our cunning scheme for avoiding +generating superclasses repeatedly will fail. + +See #11379 for a case of this. + +Note [Do not do improvement for WOnly] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do improvement between two constraints (e.g. for injectivity +or functional dependencies) only if both are "improvable". And +we improve a constraint wrt the top-level instances only if +it is improvable. + +Improvable: [G] [WD] [D} +Not improvable: [W] + +Reasons: + +* It's less work: fewer pairs to compare + +* Every [W] has a shadow [D] so nothing is lost + +* Consider [WD] C Int b, where 'b' is a skolem, and + class C a b | a -> b + instance C Int Bool + We'll do a fundep on it and emit [D] b ~ Bool + That will kick out constraint [WD] C Int b + Then we'll split it to [W] C Int b (keep in inert) + and [D] C Int b (in work list) + When processing the latter we'll rewrite it to + [D] C Int Bool + At that point it would be /stupid/ to interact it + with the inert [W] C Int b in the inert set; after all, + it's the very constraint from which the [D] C Int Bool + was split! We can avoid this by not doing improvement + on [W] constraints. This came up in #12860. +-} + +maybeEmitShadow :: InertCans -> Ct -> TcS Ct +-- See Note [The improvement story and derived shadows] +maybeEmitShadow ics ct + | let ev = ctEvidence ct + , CtWanted { ctev_pred = pred, ctev_loc = loc + , ctev_nosh = WDeriv } <- ev + , shouldSplitWD (inert_eqs ics) ct + = do { traceTcS "Emit derived shadow" (ppr ct) + ; let derived_ev = CtDerived { ctev_pred = pred + , ctev_loc = loc } + shadow_ct = ct { cc_ev = derived_ev } + -- Te shadow constraint keeps the canonical shape. + -- This just saves work, but is sometimes important; + -- see Note [Keep CDictCan shadows as CDictCan] + ; emitWork [shadow_ct] + + ; let ev' = ev { ctev_nosh = WOnly } + ct' = ct { cc_ev = ev' } + -- Record that it now has a shadow + -- This is /the/ place we set the flag to WOnly + ; return ct' } + + | otherwise + = return ct + +shouldSplitWD :: InertEqs -> Ct -> Bool +-- Precondition: 'ct' is [WD], and is inert +-- True <=> we should split ct ito [W] and [D] because +-- the inert_eqs can make progress on the [D] +-- See Note [Splitting WD constraints] + +shouldSplitWD inert_eqs (CFunEqCan { cc_tyargs = tys }) + = should_split_match_args inert_eqs tys + -- We don't need to split if the tv is the RHS fsk + +shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys }) + = should_split_match_args inert_eqs tys + -- NB True: ignore coercions + -- See Note [Splitting WD constraints] + +shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty + , cc_eq_rel = eq_rel }) + = tv `elemDVarEnv` inert_eqs + || anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty + -- NB False: do not ignore casts and coercions + -- See Note [Splitting WD constraints] + +shouldSplitWD inert_eqs (CIrredCan { cc_ev = ev }) + = anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev) + +shouldSplitWD _ _ = False -- No point in splitting otherwise + +should_split_match_args :: InertEqs -> [TcType] -> Bool +-- True if the inert_eqs can rewrite anything in the argument +-- types, ignoring casts and coercions +should_split_match_args inert_eqs tys + = any (anyRewritableTyVar True NomEq (canRewriteTv inert_eqs)) tys + -- NB True: ignore casts coercions + -- See Note [Splitting WD constraints] + +canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool +canRewriteTv inert_eqs eq_rel tv + | Just (ct : _) <- lookupDVarEnv inert_eqs tv + , CTyEqCan { cc_eq_rel = eq_rel1 } <- ct + = eq_rel1 `eqCanRewrite` eq_rel + | otherwise + = False + +isImprovable :: CtEvidence -> Bool +-- See Note [Do not do improvement for WOnly] +isImprovable (CtWanted { ctev_nosh = WOnly }) = False +isImprovable _ = True + + +{- ********************************************************************* +* * + Inert equalities +* * +********************************************************************* -} + +addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs +addTyEq old_eqs tv ct + = extendDVarEnv_C add_eq old_eqs tv [ct] + where + add_eq old_eqs _ + | isWantedCt ct + , (eq1 : eqs) <- old_eqs + = eq1 : ct : eqs + | otherwise + = ct : old_eqs + +foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b +foldTyEqs k eqs z + = foldDVarEnv (\cts z -> foldr k z cts) z eqs + +findTyEqs :: InertCans -> TyVar -> EqualCtList +findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` [] + +delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs +delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv + where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1 + isThisOne _ = False + +lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType +lookupInertTyVar ieqs tv + = case lookupDVarEnv ieqs tv of + Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs + _ -> Nothing + +{- ********************************************************************* +* * + Inert instances: inert_insts +* * +********************************************************************* -} + +addInertForAll :: QCInst -> TcS () +-- Add a local Given instance, typically arising from a type signature +addInertForAll new_qci + = do { ics <- getInertCans + ; insts' <- add_qci (inert_insts ics) + ; setInertCans (ics { inert_insts = insts' }) } + where + add_qci :: [QCInst] -> TcS [QCInst] + -- See Note [Do not add duplicate quantified instances] + add_qci qcis + | any same_qci qcis + = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci) + ; return qcis } + + | otherwise + = do { traceTcS "adding new inert quantified instance" (ppr new_qci) + ; return (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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#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 ... + +Then in f's RHS there are two identical quantified constraints +available, one via the superclasses of C and one via the superclasses +of D. The two are identical, and it seems wrong to reject the program +because of that. But without doing duplicate-elimination we will have +two matching QCInsts when we try to solve constraints arising from f's +RHS. + +The simplest thing is simply to eliminate duplicates, which we do here. +-} + +{- ********************************************************************* +* * + Adding an inert +* * +************************************************************************ + +Note [Adding an equality to the InertCans] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When adding an equality to the inerts: + +* Split [WD] into [W] and [D] if the inerts can rewrite the latter; + done by maybeEmitShadow. + +* 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 [Kicking out CFunEqCan for fundeps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + New: [D] fmv1 ~ fmv2 + Inert: [W] F alpha ~ fmv1 + [W] F beta ~ fmv2 + +where F is injective. The new (derived) equality certainly can't +rewrite the inerts. But we *must* kick out the first one, to get: + + New: [W] F alpha ~ fmv1 + Inert: [W] F beta ~ fmv2 + [D] fmv1 ~ fmv2 + +and now improvement will discover [D] alpha ~ beta. This is important; +eg in #9587. + +So in kickOutRewritable we look at all the tyvars of the +CFunEqCan, including the fsk. +-} + +addInertCan :: Ct -> TcS () -- Constraints *other than* equalities +-- Precondition: item /is/ canonical +-- See Note [Adding an equality to the InertCans] +addInertCan ct + = do { traceTcS "insertInertCan {" $ + text "Trying to insert new inert item:" <+> ppr ct + + ; ics <- getInertCans + ; ct <- maybeEmitShadow ics ct + ; ics <- maybeKickOut ics ct + ; setInertCans (add_item ics ct) + + ; traceTcS "addInertCan }" $ empty } + +maybeKickOut :: InertCans -> Ct -> TcS InertCans +-- For a CTyEqCan, kick out any inert that can be rewritten by the CTyEqCan +maybeKickOut ics ct + | CTyEqCan { cc_tyvar = tv, cc_ev = ev, cc_eq_rel = eq_rel } <- ct + = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics + ; return ics' } + | otherwise + = return ics + +add_item :: InertCans -> Ct -> InertCans +add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys }) + = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item } + +add_item ics item@(CTyEqCan { cc_tyvar = tv, cc_ev = ev }) + = ics { inert_eqs = addTyEq (inert_eqs ics) tv item + , inert_count = bumpUnsolvedCount ev (inert_count ics) } + +add_item ics@(IC { inert_irreds = irreds, inert_count = count }) + item@(CIrredCan { cc_ev = ev, cc_status = status }) + = ics { inert_irreds = irreds `Bag.snocBag` item + , inert_count = case status of + InsolubleCIS -> count + _ -> bumpUnsolvedCount ev count } + -- inert_count does not include insolubles + + +add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys }) + = ics { inert_dicts = addDict (inert_dicts ics) cls tys item + , inert_count = bumpUnsolvedCount ev (inert_count ics) } + +add_item _ item + = pprPanic "upd_inert set: can't happen! Inserting " $ + ppr item -- Can't be CNonCanonical, CHoleCan, + -- because they only land in inert_irreds + +bumpUnsolvedCount :: CtEvidence -> Int -> Int +bumpUnsolvedCount ev n | isWanted ev = n+1 + | otherwise = n + + +----------------------------------------- +kickOutRewritable :: CtFlavourRole -- Flavour/role of the equality that + -- is being added to the inert set + -> TcTyVar -- The new equality is tv ~ ty + -> InertCans + -> TcS (Int, InertCans) +kickOutRewritable new_fr new_tv ics + = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics + n_kicked = workListSize kicked_out + + ; unless (n_kicked == 0) $ + do { updWorkListTcS (appendWorkList kicked_out) + ; csTraceTcS $ + hang (text "Kick out, tv =" <+> ppr new_tv) + 2 (vcat [ text "n-kicked =" <+> int n_kicked + , text "kicked_out =" <+> ppr kicked_out + , text "Residual inerts =" <+> ppr ics' ]) } + + ; return (n_kicked, ics') } + +kick_out_rewritable :: CtFlavourRole -- Flavour/role of the equality that + -- is being added to the inert set + -> TcTyVar -- The new equality is tv ~ ty + -> InertCans + -> (WorkList, InertCans) +-- See Note [kickOutRewritable] +kick_out_rewritable new_fr new_tv + ics@(IC { inert_eqs = tv_eqs + , inert_dicts = dictmap + , inert_safehask = safehask + , inert_funeqs = funeqmap + , inert_irreds = irreds + , inert_insts = old_insts + , inert_count = n }) + | not (new_fr `eqMayRewriteFR` new_fr) + = (emptyWorkList, ics) + -- If new_fr can't rewrite itself, it can't rewrite + -- anything else, so no need to kick out anything. + -- (This is a common case: wanteds can't rewrite wanteds) + -- Lemma (L2) in Note [Extending the inert equalities] + + | otherwise + = (kicked_out, inert_cans_in) + where + inert_cans_in = IC { inert_eqs = tv_eqs_in + , inert_dicts = dicts_in + , inert_safehask = safehask -- ?? + , inert_funeqs = feqs_in + , inert_irreds = irs_in + , inert_insts = insts_in + , inert_count = n - workListWantedCount kicked_out } + + kicked_out :: WorkList + -- NB: use extendWorkList to ensure that kicked-out equalities get priority + -- See Note [Prioritise equalities] (Kick-out). + -- The irreds may include non-canonical (hetero-kinded) equality + -- constraints, which perhaps may have become soluble after new_tv + -- is substituted; ditto the dictionaries, which may include (a~b) + -- or (a~~b) constraints. + kicked_out = foldr extendWorkListCt + (emptyWorkList { wl_eqs = tv_eqs_out + , wl_funeqs = feqs_out }) + ((dicts_out `andCts` irs_out) + `extendCtsList` insts_out) + + (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs + (feqs_out, feqs_in) = partitionFunEqs kick_out_ct funeqmap + -- See Note [Kicking out CFunEqCan for fundeps] + (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap + (irs_out, irs_in) = partitionBag kick_out_ct irreds + -- Kick out even insolubles: See Note [Rewrite insolubles] + -- Of course we must kick out irreducibles like (c a), in case + -- we can rewrite 'c' to something more useful + + -- Kick-out for inert instances + -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical + insts_out :: [Ct] + insts_in :: [QCInst] + (insts_out, insts_in) + | fr_may_rewrite (Given, NomEq) -- All the insts are Givens + = partitionWith kick_out_qci old_insts + | otherwise + = ([], old_insts) + kick_out_qci qci + | let ev = qci_ev qci + , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci)) + = Left (mkNonCanonical ev) + | otherwise + = Right qci + + (_, new_role) = new_fr + + fr_can_rewrite_ty :: EqRel -> Type -> Bool + fr_can_rewrite_ty role ty = anyRewritableTyVar False role + fr_can_rewrite_tv ty + fr_can_rewrite_tv :: EqRel -> TyVar -> Bool + fr_can_rewrite_tv role tv = new_role `eqCanRewrite` role + && tv == new_tv + + fr_may_rewrite :: CtFlavourRole -> Bool + fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs + -- Can the new item rewrite the inert item? + + kick_out_ct :: Ct -> Bool + -- Kick it out if the new CTyEqCan can rewrite the inert one + -- See Note [kickOutRewritable] + kick_out_ct ct | let fs@(_,role) = ctFlavourRole ct + = fr_may_rewrite fs + && fr_can_rewrite_ty role (ctPred ct) + -- False: ignore casts and coercions + -- NB: this includes the fsk of a CFunEqCan. It can't + -- actually be rewritten, but we need to kick it out + -- so we get to take advantage of injectivity + -- See Note [Kicking out CFunEqCan for fundeps] + + kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList) + -> ([Ct], DTyVarEnv EqualCtList) + kick_out_eqs eqs (acc_out, acc_in) + = (eqs_out ++ acc_out, case eqs_in of + [] -> acc_in + (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in) + where + (eqs_out, eqs_in) = partition kick_out_eq eqs + + -- Implements criteria K1-K3 in Note [Extending the inert equalities] + kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty + , cc_ev = ev, cc_eq_rel = eq_rel }) + | not (fr_may_rewrite fs) + = False -- Keep it in the inert set if the new thing can't rewrite it + + -- Below here (fr_may_rewrite fs) is True + | tv == new_tv = True -- (K1) + | kick_out_for_inertness = True + | kick_out_for_completeness = True + | otherwise = False + + where + fs = (ctEvFlavour ev, eq_rel) + kick_out_for_inertness + = (fs `eqMayRewriteFR` fs) -- (K2a) + && not (fs `eqMayRewriteFR` new_fr) -- (K2b) + && fr_can_rewrite_ty eq_rel rhs_ty -- (K2d) + -- (K2c) is guaranteed by the first guard of keep_eq + + kick_out_for_completeness + = case eq_rel of + NomEq -> rhs_ty `eqType` mkTyVarTy new_tv + ReprEq -> isTyVarHead new_tv rhs_ty + + kick_out_eq ct = pprPanic "keep_eq" (ppr ct) + +kickOutAfterUnification :: TcTyVar -> TcS Int +kickOutAfterUnification new_tv + = do { ics <- getInertCans + ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq) + 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 (2b) in Note [Equalities with incompatible kinds] in TcCanonical +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_irreds = irreds }) + = let (to_kick, to_keep) = partitionBag kick_ct irreds + + kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList + ics' = ics { inert_irreds = to_keep } + in + (kicked_out, ics') + + kick_ct :: Ct -> Bool + -- This is not particularly efficient. Ways to do better: + -- 1) Have a custom function that looks for a coercion hole and returns a Bool + -- 2) Keep co-hole-blocked constraints in a separate part of the inert set, + -- keyed by their co-hole. (Is it possible for more than one co-hole to be + -- in a constraint? I doubt it.) + kick_ct (CIrredCan { cc_ev = ev, cc_status = BlockedCIS }) + = coHoleCoVar hole `elemVarSet` tyCoVarsOfType (ctEvPred ev) + kick_ct _other = False + +{- Note [kickOutRewritable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [inert_eqs: the inert equalities]. + +When we add a new inert equality (a ~N ty) to the inert set, +we must kick out any inert items that could be rewritten by the +new equality, to maintain the inert-set invariants. + + - We want to kick out an existing inert constraint if + a) the new constraint can rewrite the inert one + b) 'a' is free in the inert constraint (so that it *will*) + rewrite it if we kick it out. + + For (b) we use tyCoVarsOfCt, which returns the type variables /and + the kind variables/ that are directly visible in the type. Hence + we will have exposed all the rewriting we care about to make the + most precise kinds visible for matching classes etc. No need to + kick out constraints that mention type variables whose kinds + contain this variable! + + - A Derived equality can kick out [D] constraints in inert_eqs, + inert_dicts, inert_irreds etc. + + - We don't kick out constraints from inert_solved_dicts, and + inert_solved_funeqs optimistically. But when we lookup we have to + take the substitution into account + + +Note [Rewrite insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have an insoluble alpha ~ [alpha], which is insoluble +because an occurs check. And then we unify alpha := [Int]. Then we +really want to rewrite the insoluble to [Int] ~ [[Int]]. Now it can +be decomposed. Otherwise we end up with a "Can't match [Int] ~ +[[Int]]" which is true, but a bit confusing because the outer type +constructors match. + +Similarly, if we have a CHoleCan, we'd like to rewrite it with any +Givens, to give as informative an error messasge as possible +(#12468, #11325). + +Hence: + * In the main simplifier loops in GHC.Tc.Solver (solveWanteds, + simpl_loop), we feed the insolubles in solveSimpleWanteds, + so that they get rewritten (albeit not solved). + + * We kick insolubles out of the inert set, if they can be + rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable) + + * We rewrite those insolubles in GHC.Tc.Solver.Canonical. + See Note [Make sure that insolubles are fully rewritten] +-} + + + +-------------- +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] +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) } + +updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS () +-- Modify the inert set with the supplied function +updInertFunEqs upd_fn + = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs 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 (DTyVarEnv EqualCtList) +getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } + +getInertInsols :: TcS Cts +-- Returns insoluble equality constraints +-- specifically including Givens +getInertInsols = do { inert <- getInertCans + ; return (filterBag insolubleEqCt (inert_irreds inert)) } + +getInertGivens :: TcS [Ct] +-- Returns the Given constraints in the inert set, +-- with type functions *not* unflattened +getInertGivens + = do { inerts <- getInertCans + ; let all_cts = foldDicts (:) (inert_dicts inerts) + $ foldFunEqs (:) (inert_funeqs inerts) + $ concat (dVarEnvElts (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 }) + = ASSERT2( 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' <- isPendingScDict 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' <- isPendingScInst 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 -- Tyvar eqs: a ~ ty + , Cts -- Fun eqs: F a ~ ty + , Cts ) -- All others +-- Return all the unsolved [Wanted] or [Derived] 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_wanted fun_eqs emptyCts + unsolved_irreds = Bag.filterBag is_unsolved irreds + unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts + unsolved_others = unsolved_irreds `unionBags` 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, unsolved_fun_eqs, unsolved_others) } + where + add_if_unsolved :: Ct -> Cts -> Cts + add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts + | otherwise = cts + + is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived + + -- For CFunEqCans we ignore the Derived ones, and keep + -- only the Wanteds for flattening. The Derived ones + -- share a unification variable with the corresponding + -- Wanted, so we definitely don't want to participate + -- in unflattening + -- See Note [Type family equations] + add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts + | otherwise = cts + +isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool +-- True if (a ~N ty) is in the inert set, in either Given or Wanted +isInInertEqs eqs tv rhs + = case lookupDVarEnv eqs tv of + Nothing -> False + Just cts -> any (same_pred rhs) cts + where + same_pred rhs ct + | CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct + , NomEq <- eq_rel + , rhs `eqType` rhs2 = True + | otherwise = False + +getNoGivenEqs :: TcLevel -- TcLevel of this implication + -> [TcTyVar] -- Skolems of this implication + -> TcS ( Bool -- True <=> definitely no residual given equalities + , Cts ) -- Insoluble equalities arising from givens +-- See Note [When does an implication have given equalities?] +getNoGivenEqs tclvl skol_tvs + = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds }) + <- getInertCans + ; let has_given_eqs = foldr ((||) . ct_given_here) False irreds + || anyDVarEnv eqs_given_here ieqs + insols = filterBag insolubleEqCt irreds + -- Specifically includes ones that originated in some + -- outer context but were refined to an insoluble by + -- a local equality; so do /not/ add ct_given_here. + + ; traceTcS "getNoGivenEqs" $ + vcat [ if has_given_eqs then text "May have given equalities" + else text "No given equalities" + , text "Skols:" <+> ppr skol_tvs + , text "Inerts:" <+> ppr inerts + , text "Insols:" <+> ppr insols] + ; return (not has_given_eqs, insols) } + where + eqs_given_here :: EqualCtList -> Bool + eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })] + -- Givens are always a singleton + = not (skolem_bound_here tv) && ct_given_here ct + eqs_given_here _ = False + + ct_given_here :: Ct -> Bool + -- True for a Given bound by the current implication, + -- i.e. the current level + ct_given_here ct = isGiven ev + && tclvl == ctLocLevel (ctEvLoc ev) + where + ev = ctEvidence ct + + skol_tv_set = mkVarSet skol_tvs + skolem_bound_here tv -- See Note [Let-bound skolems] + = case tcTyVarDetails tv of + SkolemTv {} -> tv `elemVarSet` skol_tv_set + _ -> False + +-- | Returns Given constraints that might, +-- potentially, match the given pred. This is used when checking to see if a +-- Given might overlap with an instance. See Note [Instance and Given overlap] +-- in GHC.Tc.Solver.Interact. +matchableGivens :: CtLoc -> PredType -> InertSet -> Cts +matchableGivens loc_w pred_w (IS { inert_cans = inert_cans }) + = filterBag matchable_given all_relevant_givens + where + -- just look in class constraints and irreds. matchableGivens does get called + -- for ~R constraints, but we don't need to look through equalities, because + -- canonical equalities are used for rewriting. We'll only get caught by + -- non-canonical -- that is, irreducible -- equalities. + all_relevant_givens :: Cts + all_relevant_givens + | Just (clas, _) <- getClassPredTys_maybe pred_w + = findDictsByClass (inert_dicts inert_cans) clas + `unionBags` inert_irreds inert_cans + | otherwise + = inert_irreds inert_cans + + matchable_given :: Ct -> Bool + matchable_given ct + | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct + = mightMatchLater pred_g loc_g pred_w loc_w + + | otherwise + = False + +mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool +mightMatchLater given_pred given_loc wanted_pred wanted_loc + = not (prohibitedSuperClassSolve given_loc wanted_loc) + && isJust (tcUnifyTys bind_meta_tv [given_pred] [wanted_pred]) + where + bind_meta_tv :: TcTyVar -> BindFlag + -- Any meta tyvar may be unified later, so we treat it as + -- bindable when unifying with givens. That ensures that we + -- conservatively assume that a meta tyvar might get unified with + -- something that matches the 'given', until demonstrated + -- otherwise. More info in Note [Instance and Given overlap] + -- in GHC.Tc.Solver.Interact + bind_meta_tv tv | isMetaTyVar tv + , not (isFskTyVar tv) = BindMe + | otherwise = Skolem + +prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool +-- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance +prohibitedSuperClassSolve from_loc solve_loc + | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc + , ScOrigin wanted_size <- ctLocOrigin solve_loc + = given_size >= wanted_size + | otherwise + = False + +{- Note [Unsolved Derived equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In getUnsolvedInerts, we return a derived equality from the inert_eqs +because it is a candidate for floating out of this implication. We +only float equalities with a meta-tyvar on the left, so we only pull +those out here. + +Note [When does an implication have given equalities?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider an implication + beta => alpha ~ Int +where beta is a unification variable that has already been unified +to () in an outer scope. Then we can float the (alpha ~ Int) out +just fine. So when deciding whether the givens contain an equality, +we should canonicalise first, rather than just looking at the original +givens (#8644). + +So we simply look at the inert, canonical Givens and see if there are +any equalities among them, the calculation of has_given_eqs. There +are some wrinkles: + + * We must know which ones are bound in *this* implication and which + are bound further out. We can find that out from the TcLevel + of the Given, which is itself recorded in the tcl_tclvl field + of the TcLclEnv stored in the Given (ev_given_here). + + What about interactions between inner and outer givens? + - Outer given is rewritten by an inner given, then there must + have been an inner given equality, hence the “given-eq” flag + will be true anyway. + + - Inner given rewritten by outer, retains its level (ie. The inner one) + + * We must take account of *potential* equalities, like the one above: + beta => ...blah... + If we still don't know what beta is, we conservatively treat it as potentially + becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs. + + * When flattening givens, we generate Given equalities like + : F [a] ~ f, + with Refl evidence, and we *don't* want those to count as an equality + in the givens! After all, the entire flattening business is just an + internal matter, and the evidence does not mention any of the 'givens' + of this implication. So we do not treat inert_funeqs as a 'given equality'. + + * See Note [Let-bound skolems] for another wrinkle + + * We do *not* need to worry about representational equalities, because + these do not affect the ability to float constraints. + +Note [Let-bound skolems] +~~~~~~~~~~~~~~~~~~~~~~~~ +If * the inert set contains a canonical Given CTyEqCan (a ~ ty) +and * 'a' is a skolem bound in this very implication, + +then: +a) The Given is pretty much a let-binding, like + f :: (a ~ b->c) => a -> a + Here the equality constraint is like saying + let a = b->c in ... + It is not adding any new, local equality information, + and hence can be ignored by has_given_eqs + +b) 'a' will have been completely substituted out in the inert set, + so we can safely discard it. Notably, it doesn't need to be + returned as part of 'fsks' + +For an example, see #9211. + +See also GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure +that the right variable is on the left of the equality when both are +tyvars. + +You might wonder whether the skokem really needs to be bound "in the +very same implication" as the equuality constraint. +(c.f. #15009) Consider this: + + data S a where + MkS :: (a ~ Int) => S a + + g :: forall a. S a -> a -> blah + g x y = let h = \z. ( z :: Int + , case x of + MkS -> [y,z]) + in ... + +From the type signature for `g`, we get `y::a` . Then when when we +encounter the `\z`, we'll assign `z :: alpha[1]`, say. Next, from the +body of the lambda we'll get + + [W] alpha[1] ~ Int -- From z::Int + [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a -- From [y,z] + +Now, suppose we decide to float `alpha ~ a` out of the implication +and then unify `alpha := a`. Now we are stuck! But if treat +`alpha ~ Int` first, and unify `alpha := Int`, all is fine. +But we absolutely cannot float that equality or we will get stuck. +-} + +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 } + + CFunEqCan { cc_fun = tf, cc_tyargs = tys } -> + is { inert_funeqs = delFunEq (inert_funeqs is) tf tys } + + CTyEqCan { cc_tyvar = x, cc_rhs = ty } -> + is { inert_eqs = delTyEq (inert_eqs is) x ty } + + CQuantCan {} -> panic "removeInertCt: CQuantCan" + CIrredCan {} -> panic "removeInertCt: CIrredEvCan" + CNonCanonical {} -> panic "removeInertCt: CNonCanonical" + CHoleCan {} -> panic "removeInertCt: CHoleCan" + + +lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour)) +lookupFlatCache fam_tc tys + = do { IS { inert_flat_cache = flat_cache + , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts + ; return (firstJusts [lookup_inerts inert_funeqs, + lookup_flats flat_cache]) } + where + lookup_inerts inert_funeqs + | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis }) + <- findFunEq inert_funeqs fam_tc tys + , tys `eqTypes` xis -- The lookup might find a near-match; see + -- Note [Use loose types in inert set] + = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev) + | otherwise = Nothing + + lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys + + +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 + ; return (lookupSolvedDict inerts loc cls tys `mplus` + lookupInertDict (inert_cans inerts) loc cls tys) } + | otherwise -- NB: No caching for equalities, IPs, holes, or errors + = return Nothing + +-- | Look up a dictionary inert. NB: the returned 'CtEvidence' might not +-- match the input exactly. Note [Use loose types in inert set]. +lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe CtEvidence +lookupInertDict (IC { inert_dicts = dicts }) loc cls tys + = case findDict dicts loc cls tys of + Just ct -> Just (ctEvidence ct) + _ -> Nothing + +-- | Look up a solved inert. NB: the returned 'CtEvidence' might not +-- match the input exactly. See Note [Use loose types in inert set]. +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 + +{- ********************************************************************* +* * + Irreds +* * +********************************************************************* -} + +foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b +foldIrreds k irreds z = foldr k z irreds + + +{- ********************************************************************* +* * + TcAppMap +* * +************************************************************************ + +Note [Use loose types in inert set] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Say we know (Eq (a |> c1)) and we need (Eq (a |> c2)). One is clearly +solvable from the other. So, we do lookup in the inert set using +loose types, which omit the kind-check. + +We must be careful when using the result of a lookup because it may +not match the requested info exactly! + +-} + +type TcAppMap a = UniqDFM (ListMap LooseTypeMap a) + -- Indexed by tycon then the arg types, using "loose" matching, where + -- we don't require kind equality. This allows, for example, (a |> co) + -- to match (a). + -- See Note [Use loose types in inert set] + -- Used for types and classes; hence UniqDFM + -- See Note [foldTM determinism] for why we use UniqDFM here + +isEmptyTcAppMap :: TcAppMap a -> Bool +isEmptyTcAppMap m = isNullUDFM m + +emptyTcAppMap :: TcAppMap a +emptyTcAppMap = emptyUDFM + +findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a +findTcApp m u tys = do { tys_map <- lookupUDFM m u + ; lookupTM tys tys_map } + +delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a +delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls + +insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a +insertTcApp m cls tys ct = alterUDFM alter_tm m cls + where + alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM)) + +-- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b +-- mapTcApp f = mapUDFM (mapTM f) + +filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct +filterTcAppMap f m + = mapUDFM do_tm m + where + do_tm tm = foldTM insert_mb tm emptyTM + insert_mb ct tm + | f ct = insertTM tys ct tm + | otherwise = tm + where + tys = case ct of + CFunEqCan { cc_tyargs = tys } -> tys + CDictCan { cc_tyargs = tys } -> tys + _ -> pprPanic "filterTcAppMap" (ppr ct) + +tcAppMapToBag :: TcAppMap a -> Bag a +tcAppMapToBag m = foldTcAppMap consBag m emptyBag + +foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b +foldTcAppMap k m z = foldUDFM (foldTM k) z m + + +{- ********************************************************************* +* * + DictMap +* * +********************************************************************* -} + + +{- Note [Tuples hiding implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 we always fail when looking up a +tuple constraint that hides an implicit parameter. Not that this applies + * both to the inert_dicts (lookupInertDict) + * and to the solved_dicts (looukpSolvedDict) +An alternative would be not to extend these sets with such tuple +constraints, but it seemed more direct to deal with the lookup. + +Note [Solving CallStack constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose f :: HasCallStack => blah. Then + +* Each call to 'f' gives rise to + [W] s1 :: IP "callStack" CallStack -- CtOrigin = OccurrenceOf f + with a CtOrigin that says "OccurrenceOf f". + Remember that HasCallStack is just shorthand for + IP "callStack CallStack + See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence + +* We cannonicalise such constraints, in GHC.Tc.Solver.Canonical.canClassNC, by + pushing the call-site info on the stack, and changing the CtOrigin + to record that has been done. + Bind: s1 = pushCallStack s2 + [W] s2 :: IP "callStack" CallStack -- CtOrigin = IPOccOrigin + +* Then, and only then, we can solve the constraint from an enclosing + Given. + +So we must be careful /not/ to solve 's1' from the Givens. Again, +we ensure this by arranging that findDict always misses when looking +up souch constraints. +-} + +type DictMap a = TcAppMap a + +emptyDictMap :: DictMap a +emptyDictMap = emptyTcAppMap + +findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a +findDict m loc cls tys + | isCTupleClass cls + , any hasIPPred tys -- See Note [Tuples hiding implicit parameters] + = Nothing + + | Just {} <- isCallStackPred cls tys + , OccurrenceOf {} <- ctLocOrigin loc + = Nothing -- See Note [Solving CallStack constraints] + + | otherwise + = findTcApp m (getUnique cls) tys + +findDictsByClass :: DictMap a -> Class -> Bag a +findDictsByClass m cls + | Just tm <- lookupUDFM m cls = foldTM consBag tm emptyBag + | otherwise = emptyBag + +delDict :: DictMap a -> Class -> [Type] -> DictMap a +delDict m cls tys = delTcApp m (getUnique cls) tys + +addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a +addDict m cls tys item = insertTcApp m (getUnique cls) tys item + +addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct +addDictsByClass m cls items + = addToUDFM m cls (foldr add emptyTM items) + where + add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm + add ct _ = pprPanic "addDictsByClass" (ppr ct) + +filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct +filterDicts f m = filterTcAppMap f m + +partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct) +partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts) + where + k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes) + | otherwise = (yeses, add ct noes) + add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m + = addDict m cls tys ct + add ct _ = pprPanic "partitionDicts" (ppr ct) + +dictsToBag :: DictMap a -> Bag a +dictsToBag = tcAppMapToBag + +foldDicts :: (a -> b -> b) -> DictMap a -> b -> b +foldDicts = foldTcAppMap + +emptyDicts :: DictMap a +emptyDicts = emptyTcAppMap + + +{- ********************************************************************* +* * + FunEqMap +* * +********************************************************************* -} + +type FunEqMap a = TcAppMap a -- A map whose key is a (TyCon, [Type]) pair + +emptyFunEqs :: TcAppMap a +emptyFunEqs = emptyTcAppMap + +findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a +findFunEq m tc tys = findTcApp m (getUnique tc) tys + +funEqsToBag :: FunEqMap a -> Bag a +funEqsToBag m = foldTcAppMap consBag m emptyBag + +findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a] +-- Get inert function equation constraints that have the given tycon +-- in their head. Not that the constraints remain in the inert set. +-- We use this to check for derived interactions with built-in type-function +-- constructors. +findFunEqsByTyCon m tc + | Just tm <- lookupUDFM m tc = foldTM (:) tm [] + | otherwise = [] + +foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b +foldFunEqs = foldTcAppMap + +-- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b +-- mapFunEqs = mapTcApp + +-- filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct +-- filterFunEqs = filterTcAppMap + +insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a +insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val + +partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct) +-- Optimise for the case where the predicate is false +-- partitionFunEqs is called only from kick-out, and kick-out usually +-- kicks out very few equalities, so we want to optimise for that case +partitionFunEqs f m = (yeses, foldr del m yeses) + where + yeses = foldTcAppMap k m [] + k ct yeses | f ct = ct : yeses + | otherwise = yeses + del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m + = delFunEq m tc tys + del ct _ = pprPanic "partitionFunEqs" (ppr ct) + +delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a +delFunEq m tc tys = delTcApp m (getUnique tc) tys + +------------------------------ +type ExactFunEqMap a = UniqFM (ListMap TypeMap a) + +emptyExactFunEqs :: ExactFunEqMap a +emptyExactFunEqs = emptyUFM + +findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a +findExactFunEq m tc tys = do { tys_map <- lookupUFM m (getUnique tc) + ; lookupTM tys tys_map } + +insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a +insertExactFunEq m tc tys val = alterUFM alter_tm m (getUnique tc) + where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM)) + +{- +************************************************************************ +* * +* 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_count :: IORef Int, -- Global step count + + tcs_inerts :: IORef InertSet, -- Current inert set + + -- The main work-list and the flattening worklist + -- See Note [Work list priorities] and + tcs_worklist :: IORef WorkList -- Current worklist + } + +--------------- +newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor) + +instance Applicative TcS where + pure x = TcS (\_ -> return x) + (<*>) = ap + +instance Monad TcS where + m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs) + +instance MonadFail TcS where + fail err = TcS (\_ -> 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 = TcS . const -- a TcM action will not use the TcEvBinds + +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 + +failTcS, panicTcS :: SDoc -> TcS a +warnTcS :: WarningFlag -> SDoc -> TcS () +addErrTcS :: SDoc -> TcS () +failTcS = wrapTcS . TcM.failWith +warnTcS flag = wrapTcS . TcM.addWarn (Reason flag) +addErrTcS = wrapTcS . TcM.addErr +panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc + +traceTcS :: String -> SDoc -> TcS () +traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) + +runTcPluginTcS :: TcPluginM a -> TcS a +runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar + +instance HasDynFlags TcS where + getDynFlags = wrapTcS getDynFlags + +getGlobalRdrEnvTcS :: TcS GlobalRdrEnv +getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv + +bumpStepCountTcS :: TcS () +bumpStepCountTcS = TcS $ \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) + +traceFireTcS :: CtEvidence -> SDoc -> TcS () +-- Dump a rule-firing trace +traceFireTcS ev doc + = TcS $ \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)) } + +csTraceTcM :: TcM SDoc -> TcM () +-- Constraint-solver tracing, -ddump-cs-trace +csTraceTcM mk_doc + = do { dflags <- getDynFlags + ; when ( dopt Opt_D_dump_cs_trace dflags + || dopt Opt_D_dump_tc_trace dflags ) + ( do { msg <- mk_doc + ; TcM.dumpTcRn False + (dumpOptionsFromFlag Opt_D_dump_cs_trace) + "" FormatText + msg }) } + +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 keep solving, even when only Deriveds +-- are left around. It also doesn't return any evidence, as callers won't +-- need it. +runTcSDeriveds :: TcS a -> TcM a +runTcSDeriveds tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; runTcSWithEvBinds 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 } + +runTcSWithEvBinds :: EvBindsVar + -> TcS a + -> TcM a +runTcSWithEvBinds 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 + ; let env = TcSEnv { tcs_ev_binds = ev_binds_var + , tcs_unified = unified_var + , tcs_count = step_count + , tcs_inerts = inert_var + , 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) + + ; unflattenGivens inert_var + +#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 + } -> + do { inerts <- TcM.readTcRef old_inert_var + ; let nest_inert = emptyInert + { inert_cans = inert_cans inerts + , inert_solved_dicts = inert_solved_dicts inerts } + -- See Note [Do not inherit the flat cache] + ; new_inert_var <- TcM.newTcRef nest_inert + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; let nest_env = TcSEnv { tcs_ev_binds = ref + , tcs_unified = unified_var + , tcs_count = count + , tcs_inerts = new_inert_var + , tcs_worklist = new_wl_var } + ; res <- TcM.setTcLevel inner_tclvl $ + thing_inside nest_env + + ; unflattenGivens new_inert_var + +#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 } + +{- Note [Do not inherit the flat cache] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not want to inherit the flat cache when processing nested +implications. Consider + a ~ F b, forall c. b~Int => blah +If we have F b ~ fsk in the flat-cache, and we push that into the +nested implication, we might miss that F b can be rewritten to F Int, +and hence perhaps solve it. Moreover, the fsk from outside is +flattened out after solving the outer level, but and we don't +do that flattening recursively. +-} + +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_flat_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 -> SkolemInfo + -> [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 -> SkolemInfo + -> [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 + = ASSERT2( 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) } + +getDefaultInfo :: TcS ([Type], (Bool, Bool)) +getDefaultInfo = wrapTcS TcM.tcGetDefaultTys + +-- 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 + +tcLookupClass :: Name -> TcS Class +tcLookupClass c = wrapTcS $ TcM.tcLookupClass c + +tcLookupId :: Name -> TcS Id +tcLookupId n = wrapTcS $ TcM.tcLookupId n + +-- Setting names as used (used in the deriving of Coercible evidence) +-- Too hackish to expose it to TcS? In that case somehow extract the used +-- constructors from the result of solveInteract +addUsedGREs :: [GlobalRdrElt] -> TcS () +addUsedGREs gres = wrapTcS $ TcM.addUsedGREs gres + +addUsedGRE :: Bool -> GlobalRdrElt -> TcS () +addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre + +keepAlive :: Name -> TcS () +keepAlive = wrapTcS . TcM.keepAlive + +-- 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 + | TopLevInstance { iw_dfun_id = dfun_id } <- what + , let bind_lvl = TcM.topIdLvl dfun_id + , bind_lvl > impLevel + = wrapTcS $ TcM.setCtLocM loc $ + do { use_stage <- TcM.getStage + ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) } + + | otherwise + = return () -- Fast path for common case + where + pp_thing = text "instance for" <+> quotes (ppr pred) + +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) + +{- ********************************************************************* +* * +* Flatten skolems * +* * +********************************************************************* -} + +newFlattenSkolem :: CtFlavour -> CtLoc + -> TyCon -> [TcType] -- F xis + -> TcS (CtEvidence, Coercion, TcTyVar) -- [G/WD] x:: F xis ~ fsk +newFlattenSkolem flav loc tc xis + = do { stuff@(ev, co, fsk) <- new_skolem + ; let fsk_ty = mkTyVarTy fsk + ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev) + ; return stuff } + where + fam_ty = mkTyConApp tc xis + + new_skolem + | Given <- flav + = do { fsk <- wrapTcS (TcM.newFskTyVar fam_ty) + + -- Extend the inert_fsks list, for use by unflattenGivens + ; updInertTcS $ \is -> is { inert_fsks = (fsk, fam_ty) : inert_fsks is } + + -- Construct the Refl evidence + ; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk) + co = mkNomReflCo fam_ty + ; ev <- newGivenEvVar loc (pred, evCoercion co) + ; return (ev, co, fsk) } + + | otherwise -- Generate a [WD] for both Wanted and Derived + -- See Note [No Derived CFunEqCans] + = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty) + -- See (2a) in TcCanonical + -- Note [Equalities with incompatible kinds] + ; (ev, hole_co) <- newWantedEq_SI NoBlockSubst WDeriv loc Nominal + fam_ty (mkTyVarTy fmv) + ; return (ev, hole_co, fmv) } + +---------------------------- +unflattenGivens :: IORef InertSet -> TcM () +-- Unflatten all the fsks created by flattening types in Given +-- constraints. We must be sure to do this, else we end up with +-- flatten-skolems buried in any residual Wanteds +-- +-- NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv) +-- is filled in. Nothing else does so. +-- +-- It's here (rather than in GHC.Tc.Solver.Flatten) because the Right Places +-- to call it are in runTcSWithEvBinds/nestImplicTcS, where it +-- is nicely paired with the creation an empty inert_fsks list. +unflattenGivens inert_var + = do { inerts <- TcM.readTcRef inert_var + ; TcM.traceTc "unflattenGivens" (ppr (inert_fsks inerts)) + ; mapM_ flatten_one (inert_fsks inerts) } + where + flatten_one (fsk, ty) = TcM.writeMetaTyVar fsk ty + +---------------------------- +extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS () +extendFlatCache tc xi_args stuff@(_, ty, fl) + | isGivenOrWDeriv fl -- Maintain the invariant that inert_flat_cache + -- only has [G] and [WD] CFunEqCans + = do { dflags <- getDynFlags + ; when (gopt Opt_FlatCache dflags) $ + do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args + , ppr fl, ppr ty ]) + -- 'co' can be bottom, in the case of derived items + ; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) -> + is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } } + + | otherwise + = return () + +---------------------------- +unflattenFmv :: TcTyVar -> TcType -> TcS () +-- Fill a flatten-meta-var, simply by unifying it. +-- This does NOT count as a unification in tcs_unified. +unflattenFmv tv ty + = ASSERT2( isMetaTyVar tv, ppr tv ) + TcS $ \ _ -> + do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty) + ; TcM.writeMetaTyVar tv ty } + +---------------------------- +demoteUnfilledFmv :: TcTyVar -> TcS () +-- If a flatten-meta-var is still un-filled, +-- turn it into an ordinary meta-var +demoteUnfilledFmv fmv + = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv + ; unless is_filled $ + do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv) + ; TcM.writeMetaTyVar fmv tv_ty } } + +----------------------------- +dischargeFunEq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS () +-- (dischargeFunEq tv co ty) +-- Preconditions +-- - ev :: F tys ~ tv is a CFunEqCan +-- - tv is a FlatMetaTv of FlatSkolTv +-- - co :: F tys ~ xi +-- - fmv/fsk `notElem` xi +-- - fmv not filled (for Wanteds) +-- - xi is flattened (and obeys Note [Almost function-free] in GHC.Tc.Types) +-- +-- Then for [W] or [WD], we actually fill in the fmv: +-- set fmv := xi, +-- set ev := co +-- kick out any inert things that are now rewritable +-- +-- For [D], we instead emit an equality that must ultimately hold +-- [D] xi ~ fmv +-- Does not evaluate 'co' if 'ev' is Derived +-- +-- For [G], emit this equality +-- [G] (sym ev; co) :: fsk ~ xi + +-- See GHC.Tc.Solver.Flatten Note [The flattening story], +-- especially "Ownership of fsk/fmv" +dischargeFunEq (CtGiven { ctev_evar = old_evar, ctev_loc = loc }) fsk co xi + = do { new_ev <- newGivenEvVar loc ( new_pred, evCoercion new_co ) + ; emitWorkNC [new_ev] } + where + new_pred = mkPrimEqPred (mkTyVarTy fsk) xi + new_co = mkTcSymCo (mkTcCoVarCo old_evar) `mkTcTransCo` co + +dischargeFunEq ev@(CtWanted { ctev_dest = dest }) fmv co xi + = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi ) + do { setWantedEvTerm dest (evCoercion co) + ; unflattenFmv fmv xi + ; n_kicked <- kickOutAfterUnification fmv + ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ pprKicked n_kicked) } + +dischargeFunEq (CtDerived { ctev_loc = loc }) fmv _co xi + = emitNewDerivedEq loc Nominal xi (mkTyVarTy fmv) + -- FunEqs are always at Nominal role + +pprKicked :: Int -> SDoc +pprKicked 0 = empty +pprKicked n = parens (int n <+> text "kicked out") + +{- ********************************************************************* +* * +* 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) + +instFlexi :: [TKVar] -> TcS TCvSubst +instFlexi = instFlexiX emptyTCvSubst + +instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst +instFlexiX subst tvs + = wrapTcS (foldlM instFlexiHelper subst tvs) + +instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst +instFlexiHelper subst tv + = do { uniq <- TcM.newUnique + ; details <- TcM.newMetaDetails TauTv + ; let name = setNameUnique (tyVarName tv) uniq + kind = substTyUnchecked subst (tyVarKind tv) + ty' = mkTyVarTy (mkTcTyVar name kind details) + ; TcM.traceTc "instFlexi" (ppr ty') + ; return (extendTvSubst subst tv ty') } + +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 :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar]) +tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX 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 :: TcEvDest -> Coercion -> TcS () +setWantedEq (HoleDest hole) co + = do { useVars (coVarsOfCo co) + ; fillCoercionHole hole co } +setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (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 (mkTcCoVarCo 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 -> Role -> TcType -> TcType -> TcS Coercion +-- | Emit a new Wanted equality into the work-list +emitNewWantedEq loc role ty1 ty2 + = do { (ev, co) <- newWantedEq loc role ty1 ty2 + ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) + ; return co } + +-- | Make a new equality CtEvidence +newWantedEq :: CtLoc -> Role -> TcType -> TcType + -> TcS (CtEvidence, Coercion) +newWantedEq = newWantedEq_SI YesBlockSubst WDeriv + +newWantedEq_SI :: BlockSubstFlag -> ShadowInfo -> CtLoc -> Role + -> TcType -> TcType + -> TcS (CtEvidence, Coercion) +newWantedEq_SI blocker si loc role ty1 ty2 + = do { hole <- wrapTcS $ TcM.newCoercionHole blocker pty + ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty) + ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole + , ctev_nosh = si + , ctev_loc = loc} + , mkHoleCo hole ) } + where + pty = mkPrimEqPredRole role ty1 ty2 + +-- no equalities here. Use newWantedEq instead +newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence +newWantedEvVarNC = newWantedEvVarNC_SI WDeriv + +newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence +-- Don't look up in the solved/inerts; we know it's not there +newWantedEvVarNC_SI si loc 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_nosh = si + , ctev_loc = loc })} + +newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew +newWantedEvVar = newWantedEvVar_SI WDeriv + +newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew +-- For anything except ClassPred, this is the same as newWantedEvVarNC +newWantedEvVar_SI si loc pty + = do { mb_ct <- lookupInInerts loc pty + ; case mb_ct of + Just ctev + | not (isDerived ctev) + -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev + ; return $ Cached (ctEvExpr ctev) } + _ -> do { ctev <- newWantedEvVarNC_SI si loc pty + ; return (Fresh ctev) } } + +newWanted :: CtLoc -> PredType -> TcS MaybeNew +-- Deals with both equalities and non equalities. Tries to look +-- up non-equalities in the cache +newWanted = newWanted_SI WDeriv + +newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew +newWanted_SI si loc pty + | Just (role, ty1, ty2) <- getEqPredTys_maybe pty + = Fresh . fst <$> newWantedEq_SI YesBlockSubst si loc role ty1 ty2 + | otherwise + = newWantedEvVar_SI si loc pty + +-- deals with both equalities and non equalities. Doesn't do any cache lookups. +newWantedNC :: CtLoc -> PredType -> TcS CtEvidence +newWantedNC loc pty + | Just (role, ty1, ty2) <- getEqPredTys_maybe pty + = fst <$> newWantedEq loc role ty1 ty2 + | otherwise + = newWantedEvVarNC loc pty + +emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS () +emitNewDeriveds loc preds + | null preds + = return () + | otherwise + = do { evs <- mapM (newDerivedNC loc) preds + ; traceTcS "Emitting new deriveds" (ppr evs) + ; updWorkListTcS (extendWorkListDeriveds evs) } + +emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS () +-- Create new equality Derived and put it in the work list +-- There's no caching, no lookupInInerts +emitNewDerivedEq loc role ty1 ty2 + = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2) + ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc) + ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) } + -- Very important: put in the wl_eqs + -- See Note [Prioritise equalities] (Avoiding fundep iteration) + +newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence +newDerivedNC loc pred + = do { -- checkReductionDepth loc pred + ; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) } + +-- --------- 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 $ + solverDepthErrorTcS loc ty } + +matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType)) +-- Given (F tys) return (ty, co), where co :: F tys ~N ty +matchFam tycon args = wrapTcS $ matchFamTcM tycon args + +matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType)) +-- 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 (co,ty)) = hang (text "Match succeeded:") + 2 (vcat [ text "Rewrites to:" <+> ppr ty + , text "Coercion:" <+> ppr co ]) + +{- +Note [Residual implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The wl_implics in the WorkList are the residual implication +constraints that are generated while solving or canonicalising the +current worklist. Specifically, when canonicalising + (forall a. t1 ~ forall a. t2) +from which we get the implication + (forall a. t1 ~ t2) +See GHC.Tc.Solver.Monad.deferTcSForAllEq +-} diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/TyCl.hs @@ -0,0 +1,4880 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + +-} + +{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Typecheck type and class declarations +module GHC.Tc.TyCl ( + tcTyAndClassDecls, + + -- Functions used by GHC.Tc.TyCl.Instance to check + -- data/type family instance declarations + kcConDecls, tcConDecls, dataDeclChecks, checkValidTyCon, + tcFamTyPats, tcTyFamInstEqn, + tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, + unravelFamInstPats, addConsistencyConstraints, + wrongKindOfFamily + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Driver.Types +import GHC.Tc.TyCl.Build +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Validity +import GHC.Tc.Utils.Zonk +import GHC.Tc.TyCl.Utils +import GHC.Tc.TyCl.Class +import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 ) +import GHC.Tc.Deriv (DerivInfo(..)) +import GHC.Tc.Utils.Unify ( checkTvConstraints ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Instance.Class( AssocInstInfo(..) ) +import GHC.Tc.Utils.TcMType +import GHC.Builtin.Types ( unitTy, makeRecoveryTyCon ) +import GHC.Tc.Utils.TcType +import GHC.Rename.Env( lookupConstructorFields ) +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Core.Coercion +import GHC.Tc.Types.Origin +import GHC.Core.Type +import GHC.Core.TyCo.Rep -- for checkValidRoles +import GHC.Core.TyCo.Ppr( pprTyVars, pprWithExplicitKindsWhen ) +import GHC.Core.Class +import GHC.Core.Coercion.Axiom +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Utils.Outputable +import GHC.Data.Maybe +import GHC.Core.Unify +import GHC.Utils.Misc +import GHC.Types.SrcLoc +import GHC.Data.List.SetOps +import GHC.Driver.Session +import GHC.Types.Unique +import GHC.Core.ConLike( ConLike(..) ) +import GHC.Types.Basic +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.Foldable +import Data.Function ( on ) +import Data.Functor.Identity +import Data.List +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.Set as Set +import Data.Tuple( swap ) + +{- +************************************************************************ +* * +\subsection{Type checking for type and class declarations} +* * +************************************************************************ + +Note [Grouping of type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly +connected component of mutually dependent types and classes. We kind check and +type check each group separately to enhance kind polymorphism. Take the +following example: + + type Id a = a + data X = X (Id Int) + +If we were to kind check the two declarations together, we would give Id the +kind * -> *, since we apply it to an Int in the definition of X. But we can do +better than that, since Id really is kind polymorphic, and should get kind +forall (k::*). k -> k. Since it does not depend on anything else, it can be +kind-checked by itself, hence getting the most general kind. We then kind check +X, which works fine because we then know the polymorphic kind of Id, and simply +instantiate k to *. + +Note [Check role annotations in a second pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Role inference potentially depends on the types of all of the datacons declared +in a mutually recursive group. The validity of a role annotation, in turn, +depends on the result of role inference. Because the types of datacons might +be ill-formed (see #7175 and Note [Checking GADT return types]) we must check +*all* the tycons in a group for validity before checking *any* of the roles. +Thus, we take two passes over the resulting tycons, first checking for general +validity and then checking for valid role annotations. +-} + +tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in + -- dependency order + -> TcM ( TcGblEnv -- Input env extended by types and + -- classes + -- and their implicit Ids,DataCons + , [InstInfo GhcRn] -- Source-code instance decls info + , [DerivInfo] -- Deriving info + ) +-- Fails if there are any errors +tcTyAndClassDecls tyclds_s + -- The code recovers internally, but if anything gave rise to + -- an error we'd better stop now, to avoid a cascade + -- Type check each group in dependency order folding the global env + = checkNoErrs $ fold_env [] [] tyclds_s + where + fold_env :: [InstInfo GhcRn] + -> [DerivInfo] + -> [TyClGroup GhcRn] + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) + fold_env inst_info deriv_info [] + = do { gbl_env <- getGblEnv + ; return (gbl_env, inst_info, deriv_info) } + fold_env inst_info deriv_info (tyclds:tyclds_s) + = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds + ; setGblEnv tcg_env $ + -- remaining groups are typechecked in the extended global env. + fold_env (inst_info' ++ inst_info) + (deriv_info' ++ deriv_info) + tyclds_s } + +tcTyClGroup :: TyClGroup GhcRn + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) +-- Typecheck one strongly-connected component of type, class, and instance decls +-- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls +tcTyClGroup (TyClGroup { group_tyclds = tyclds + , group_roles = roles + , group_kisigs = kisigs + , group_instds = instds }) + = do { let role_annots = mkRoleAnnotEnv roles + + -- Step 1: Typecheck the standalone kind signatures and type/class declarations + ; traceTc "---- tcTyClGroup ---- {" empty + ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds)) + ; (tyclss, data_deriv_info) <- + tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution] + do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs + ; tcTyClDecls tyclds kisig_env role_annots } + + -- Step 1.5: Make sure we don't have any type synonym cycles + ; traceTc "Starting synonym cycle check" (ppr tyclss) + ; this_uid <- fmap thisPackage getDynFlags + ; checkSynCycles this_uid tyclss tyclds + ; traceTc "Done synonym cycle check" (ppr tyclss) + + -- Step 2: Perform the validity check on those types/classes + -- We can do this now because we are done with the recursive knot + -- Do it before Step 3 (adding implicit things) because the latter + -- expects well-formed TyCons + ; traceTc "Starting validity check" (ppr tyclss) + ; tyclss <- concatMapM checkValidTyCl tyclss + ; traceTc "Done validity check" (ppr tyclss) + ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss + -- See Note [Check role annotations in a second pass] + + ; traceTc "---- end tcTyClGroup ---- }" empty + + -- Step 3: Add the implicit things; + -- we want them in the environment because + -- they may be mentioned in interface files + ; gbl_env <- addTyConsToGblEnv tyclss + + -- Step 4: check instance declarations + ; (gbl_env', inst_info, datafam_deriv_info) <- + setGblEnv gbl_env $ + tcInstDecls1 instds + + ; let deriv_info = datafam_deriv_info ++ data_deriv_info + ; return (gbl_env', inst_info, deriv_info) } + +-- Gives the kind for every TyCon that has a standalone kind signature +type KindSigEnv = NameEnv Kind + +tcTyClDecls + :: [LTyClDecl GhcRn] + -> KindSigEnv + -> RoleAnnotEnv + -> TcM ([TyCon], [DerivInfo]) +tcTyClDecls tyclds kisig_env role_annots + = 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 <- kcTyClGroup kisig_env tyclds + ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons)) + + -- Step 2: type-check all groups together, returning + -- the final TyCons and Classes + -- + -- NB: We have to be careful here to NOT eagerly unfold + -- type synonyms, as we have not tested for type synonym + -- loops yet and could fall into a black hole. + ; fixM $ \ ~(rec_tyclss, _) -> do + { tcg_env <- getGblEnv + ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss + + -- Populate environment with knot-tied ATyCon for TyCons + -- NB: if the decls mention any ill-staged data cons + -- (see Note [Recursion and promoting data constructors]) + -- we will have failed already in kcTyClGroup, so no worries here + ; (tycons, data_deriv_infos) <- + tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $ + + -- Also extend the local type envt with bindings giving + -- a TcTyCon for each each knot-tied TyCon or Class + -- See Note [Type checking recursive type and class declarations] + -- and Note [Type environment evolution] + tcExtendKindEnvWithTyCons tc_tycons $ + + -- Kind and type check declarations for this group + mapAndUnzipM (tcTyClDecl roles) tyclds + ; return (tycons, concat data_deriv_infos) + } } + where + ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma + , ppr (tyConBinders tc) <> comma + , ppr (tyConResKind tc) + , ppr (isTcTyCon tc) ]) + +zipRecTyClss :: [TcTyCon] + -> [TyCon] -- Knot-tied + -> [(Name,TyThing)] +-- Build a name-TyThing mapping for the TyCons bound by decls +-- being careful not to look at the knot-tied [TyThing] +-- The TyThings in the result list must have a visible ATyCon, +-- because typechecking types (in, say, tcTyClDecl) looks at +-- this outer constructor +zipRecTyClss tc_tycons rec_tycons + = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ] + where + rec_tc_env :: NameEnv TyCon + rec_tc_env = foldr add_tc emptyNameEnv rec_tycons + + add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon + add_tc tc env = foldr add_one_tc env (tc : tyConATs tc) + + add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon + add_one_tc tc env = extendNameEnv env (tyConName tc) tc + + get name = case lookupNameEnv rec_tc_env name of + Just tc -> tc + other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other) + +{- +************************************************************************ +* * + Kind checking +* * +************************************************************************ + +Note [Kind checking for type and class decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Kind checking is done thus: + + 1. Make up a kind variable for each parameter of the declarations, + and extend the kind environment (which is in the TcLclEnv) + + 2. Kind check the declarations + +We need to kind check all types in the mutually recursive group +before we know the kind of the type variables. For example: + + class C a where + op :: D b => a -> b -> b + + class D c where + bop :: (Monad c) => ... + +Here, the kind of the locally-polymorphic type variable "b" +depends on *all the uses of class D*. For example, the use of +Monad c in bop's type signature means that D must have kind Type->Type. + +Note: we don't treat type synonyms specially (we used to, in the past); +in particular, even if we have a type synonym cycle, we still kind check +it normally, and test for cycles later (checkSynCycles). The reason +we can get away with this is because we have more systematic TYPE r +inference, which means that we can do unification between kinds that +aren't lifted (this historically was not true.) + +The downside of not directly reading off the kinds of the RHS of +type synonyms in topological order is that we don't transparently +support making synonyms of types with higher-rank kinds. But +you can always specify a CUSK directly to make this work out. +See tc269 for an example. + +Note [CUSKs and PolyKinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T (a :: *) = MkT (S a) -- Has CUSK + data S a = MkS (T Int) (S a) -- No CUSK + +Via inferInitialKinds we get + T :: * -> * + S :: kappa -> * + +Then we call kcTyClDecl on each decl in the group, to constrain the +kind unification variables. BUT we /skip/ the RHS of any decl with +a CUSK. Here we skip the RHS of T, so we eventually get + S :: forall k. k -> * + +This gets us more polymorphism than we would otherwise get, similar +(but implemented strangely differently from) the treatment of type +signatures in value declarations. + +However, we only want to do so when we have PolyKinds. +When we have NoPolyKinds, we don't skip those decls, because we have defaulting +(#16609). Skipping won't bring us more polymorphism when we have defaulting. +Consider + + data T1 a = MkT1 T2 -- No CUSK + data T2 = MkT2 (T1 Maybe) -- Has CUSK + +If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved. +With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the +program type-checks. +But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens +in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking +(T1 Maybe) will throw a type error. + +Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip. + +Open type families +~~~~~~~~~~~~~~~~~~ +This treatment of type synonyms only applies to Haskell 98-style synonyms. +General type functions can be recursive, and hence, appear in `alg_decls'. + +The kind of an open type family is solely determinded by its kind signature; +hence, only kind signatures participate in the construction of the initial +kind environment (as constructed by `inferInitialKind'). In fact, we ignore +instances of families altogether in the following. However, we need to include +the kinds of *associated* families into the construction of the initial kind +environment. (This is handled by `allDecls'). + +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. + + S1) First, we use inferInitialKinds to look over the user-provided + kind signature of a tycon (including, for example, the number + of parameters written to the tycon) to get an initial shape of + the tycon's kind. We record that shape in a TcTyCon. + + For CUSK tycons, the TcTyCon has the final, generalised kind. + For non-CUSK tycons, the TcTyCon has as its tyConBinders only + the explicit arguments given -- no kind variables, etc. + + S2) Then, using these initial kinds, we kind-check the body of the + tycon (class methods, data constructors, etc.), filling in the + metavariables in the tycon's initial kind. + + S3) We then generalize to get the (non-CUSK) tycon's final, fixed + kind. Finally, once this has happened for all tycons in a + mutually recursive group, we can desugar the lot. + + For convenience, we store partially-known tycons in TcTyCons, which + might store meta-variables. These TcTyCons are stored in the local + environment in GHC.Tc.TyCl, until the real full TyCons can be created + during desugaring. A desugared program should never have a TcTyCon. + +3. In a TcTyCon, everything is zonked after the kind-checking pass (S2). + +4. 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 the TcTyCon. + These tyvars are brought into scope in GHC.Tc.Gen.HsType.bindTyClTyVars. + + 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. +If there is a separate kind signature, or a CUSK, we take an entirely +different code path. + +For inference, consider + class C (f :: k) x where + type T f + op :: D f => blah + class D (g :: j) y where + op :: C g => y -> blah + +Here C and D are considered mutually recursive. Neither has a CUSK. +Just before generalisation we have the (un-quantified) kinds + C :: k1 -> k2 -> Constraint + T :: k1 -> Type + D :: k1 -> Type -> Constraint +Notice that f's kind and g's kind have been unified to 'k1'. We say +that k1 is the "representative" of k in C's decl, and of j in D's decl. + +Now when quantifying, we'd like to end up with + C :: forall {k2}. forall k. k -> k2 -> Constraint + T :: forall k. k -> Type + D :: forall j. j -> Type -> Constraint + +That is, we want to swizzle the representative to have the Name given +by the user. Partly this is to improve error messages and the output of +:info in GHCi. But it is /also/ important because the code for a +default method may mention the class variable(s), but at that point +(tcClassDecl2), we only have the final class tyvars available. +(Alternatively, we could record the scoped type variables in the +TyCon, but it's a nuisance to do so.) + +Notes: + +* On the input to generaliseTyClDecl, the mapping between the + user-specified Name and the representative TyVar is recorded in the + tyConScopedTyVars of the TcTyCon. NB: you first need to zonk to see + this representative TyVar. + +* The swizzling is actually performed by swizzleTcTyConBndrs + +* We must do the swizzling across the whole class decl. Consider + class C f where + type S (f :: k) + type T f + Here f's kind k is a parameter of C, and its identity is shared + with S and T. So if we swizzle the representative k at all, we + must do so consistently for the entire declaration. + + Hence the call to check_duplicate_tc_binders is in generaliseTyClDecl, + rather than in generaliseTcTyCon. + +There are errors to catch here. Suppose we had + class E (f :: j) (g :: k) where + op :: SameKind f g -> blah + +Then, just before generalisation we will have the (unquantified) + E :: k1 -> k1 -> Constraint + +That's bad! Two distinctly-named tyvars (j and k) have ended up with +the same representative k1. So when swizzling, we check (in +check_duplicate_tc_binders) that two distinct source names map +to the same representative. + +Here's an interesting case: + class C1 f where + type S (f :: k1) + type T (f :: k2) +Here k1 and k2 are different Names, but they end up mapped to the +same representative TyVar. To make the swizzling consistent (remember +we must have a single k across C1, S and T) we reject the program. + +Another interesting case + class C2 f where + type S (f :: k) (p::Type) + type T (f :: k) (p::Type->Type) + +Here the two k's (and the two p's) get distinct Uniques, because they +are seen by the renamer as locally bound in S and T resp. But again +the two (distinct) k's end up bound to the same representative TyVar. +You might argue that this should be accepted, but it's definitely +rejected (via an entirely different code path) if you add a kind sig: + type C2' :: j -> Constraint + class C2' f where + type S (f :: k) (p::Type) +We get + • Expected kind ‘j’, but ‘f’ has kind ‘k’ + • In the associated type family declaration for ‘S’ + +So we reject C2 too, even without the kind signature. We have +to do a bit of work to get a good error message, since both k's +look the same to the user. + +Another case + class C3 (f :: k1) where + type S (f :: k2) + +This will be rejected too. + + +Note [Type environment evolution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As we typecheck a group of declarations the type environment evolves. +Consider for example: + data B (a :: Type) = MkB (Proxy 'MkB) + +We do the following steps: + + 1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the + type env with promotion errors + B :-> TyConPE + MkB :-> DataConPE + + 2. kcTyCLGroup + - Do inferInitialKinds, which will signal a promotion + error if B is used in any of the kinds needed to initialise + B's kind (e.g. (a :: Type)) here + + - Extend the type env with these initial kinds (monomorphic for + decls that lack a CUSK) + B :-> TcTyCon + (thereby overriding the B :-> TyConPE binding) + and do kcLTyClDecl on each decl to get equality constraints on + all those initial kinds + + - Generalise the initial kind, making a poly-kinded TcTyCon + + 3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded + TcTyCons, again overriding the promotion-error bindings. + + But note that the data constructor promotion errors are still in place + so that (in our example) a use of MkB will still be signalled as + an error. + + 4. Typecheck the decls. + + 5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons + + +Note [Missed opportunity to retain higher-rank kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In 'kcTyClGroup', there is a missed opportunity to make kind +inference work in a few more cases. The idea is analogous +to Note [Single function non-recursive binding special-case]: + + * If we have an SCC with a single decl, which is non-recursive, + instead of creating a unification variable representing the + kind of the decl and unifying it with the rhs, we can just + read the type directly of the rhs. + + * Furthermore, we can update our SCC analysis to ignore + dependencies on declarations which have CUSKs: we don't + have to kind-check these all at once, since we can use + the CUSK to initialize the kind environment. + +Unfortunately this requires reworking a bit of the code in +'kcLTyClDecl' so I've decided to punt unless someone shouts about it. + +Note [Don't process associated types in getInitialKind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously, we processed associated types in the thing_inside in getInitialKind, +but this was wrong -- we want to do ATs sepearately. +The consequence for not doing it this way is #15142: + + class ListTuple (tuple :: Type) (as :: [(k, Type)]) where + type ListToTuple as :: Type + +We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify +kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring +`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't +unified with Type. And then, when we generalize the kind of ListToTuple (which +indeed has a CUSK, according to the rules), we skolemize the free metavariable +kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple, +because the solveEqualities in kcInferDeclHeader is at TcLevel 1 and so kappa[1] +will unify with Type. + +Bottom line: as associated types should have no effect on a CUSK enclosing class, +we move processing them to a separate action, run after the outer kind has +been generalized. + +-} + +kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM [TcTyCon] + +-- Kind check this group, kind generalize, and return the resulting local env +-- This binds the TyCons and Classes of the group, but not the DataCons +-- See Note [Kind checking for type and class decls] +-- and Note [Inferring kinds for type declarations] +kcTyClGroup kisig_env decls + = do { mod <- getModule + ; traceTc "---- kcTyClGroup ---- {" + (text "module" <+> ppr mod $$ vcat (map ppr decls)) + + -- Kind checking; + -- 1. Bind kind variables for decls + -- 2. Kind-check decls + -- 3. Generalise the inferred kinds + -- See Note [Kind checking for type and class decls] + + ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds + -- See Note [CUSKs and PolyKinds] + ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls + + get_kind d + | Just ki <- lookupNameEnv kisig_env (tcdName (unLoc d)) + = Right (d, SAKS ki) + + | cusks_enabled && hsDeclHasCusk (unLoc d) + = Right (d, CUSK) + + | otherwise = Left d + + ; checked_tcs <- checkInitialKinds kinded_decls + ; inferred_tcs + <- tcExtendKindEnvWithTyCons checked_tcs $ + pushTcLevelM_ $ -- We are going to kind-generalise, so + -- unification variables in here must + -- be one level in + solveEqualities $ + do { -- Step 1: Bind kind variables for all decls + mono_tcs <- inferInitialKinds kindless_decls + + ; traceTc "kcTyClGroup: initial kinds" $ + ppr_tc_kinds mono_tcs + + -- Step 2: Set extended envt, kind-check the decls + -- NB: the environment extension overrides the tycon + -- promotion-errors bindings + -- See Note [Type environment evolution] + ; tcExtendKindEnvWithTyCons mono_tcs $ + mapM_ kcLTyClDecl kindless_decls + + ; return mono_tcs } + + -- Step 3: generalisation + -- Finally, go through each tycon and give it its final kind, + -- with all the required, specified, and inferred variables + -- in order. + ; let inferred_tc_env = mkNameEnv $ + map (\tc -> (tyConName tc, tc)) inferred_tcs + ; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env) + kindless_decls + + ; let poly_tcs = checked_tcs ++ generalized_tcs + ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs) + ; return poly_tcs } + where + ppr_tc_kinds tcs = vcat (map pp_tc tcs) + pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc) + +type ScopedPairs = [(Name, TcTyVar)] + -- The ScopedPairs for a TcTyCon are precisely + -- specified-tvs ++ required-tvs + -- You can distinguish them because there are tyConArity required-tvs + +generaliseTyClDecl :: NameEnv TcTyCon -> LTyClDecl GhcRn -> TcM [TcTyCon] +-- See Note [Swizzling the tyvars before generaliseTcTyCon] +generaliseTyClDecl inferred_tc_env (L _ decl) + = 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 + + -- 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 + + -- Swizzle + ; swizzled_infos <- tcAddDeclCtxt decl (swizzleTcTyConBndrs tc_infos) + + -- And finally generalise + ; mapAndReportM generaliseTcTyCon swizzled_infos } + where + tycld_names :: TyClDecl GhcRn -> [Name] + tycld_names decl = tcdName decl : at_names decl + + at_names :: TyClDecl GhcRn -> [Name] + at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats + at_names _ = [] -- Only class decls have associated types + + skolemise_tc_tycon :: Name -> TcM (TcTyCon, ScopedPairs) + -- Zonk and skolemise the Specified and Required binders + skolemise_tc_tycon tc_name + = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name + -- This lookup should not fail + ; scoped_prs <- mapSndM zonkAndSkolemise (tcTyConScopedTyVars tc) + ; return (tc, scoped_prs) } + + zonk_tc_tycon :: (TcTyCon, ScopedPairs) -> TcM (TcTyCon, ScopedPairs, TcKind) + zonk_tc_tycon (tc, scoped_prs) + = do { scoped_prs <- mapSndM zonkTcTyVarToTyVar scoped_prs + -- We really have to do this again, even though + -- we have just done zonkAndSkolemise + ; res_kind <- zonkTcType (tyConResKind tc) + ; return (tc, scoped_prs, res_kind) } + +swizzleTcTyConBndrs :: [(TcTyCon, ScopedPairs, TcKind)] + -> TcM [(TcTyCon, ScopedPairs, TcKind)] +swizzleTcTyConBndrs tc_infos + | all no_swizzle swizzle_prs + -- This fast path happens almost all the time + -- See Note [Non-cloning for tyvar binders] in GHC.Tc.Gen.HsType + = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr (map fstOf3 tc_infos)) + ; return tc_infos } + + | otherwise + = do { check_duplicate_tc_binders + + ; traceTc "swizzleTcTyConBndrs" $ + vcat [ text "before" <+> ppr_infos tc_infos + , text "swizzle_prs" <+> ppr swizzle_prs + , text "after" <+> ppr_infos swizzled_infos ] + + ; return swizzled_infos } + + where + swizzled_infos = [ (tc, mapSnd swizzle_var scoped_prs, swizzle_ty kind) + | (tc, scoped_prs, kind) <- tc_infos ] + + swizzle_prs :: [(Name,TyVar)] + -- Pairs the user-specifed Name with its representative TyVar + -- See Note [Swizzling the tyvars before generaliseTcTyCon] + swizzle_prs = [ pr | (_, prs, _) <- tc_infos, pr <- prs ] + + no_swizzle :: (Name,TyVar) -> Bool + no_swizzle (nm, tv) = nm == tyVarName tv + + ppr_infos infos = vcat [ ppr tc <+> pprTyVars (map snd prs) + | (tc, prs, _) <- infos ] + + -- Check for duplicates + -- E.g. data SameKind (a::k) (b::k) + -- data T (a::k1) (b::k2) = MkT (SameKind a b) + -- Here k1 and k2 start as TyVarTvs, and get unified with each other + -- If this happens, things get very confused later, so fail fast + check_duplicate_tc_binders :: TcM () + check_duplicate_tc_binders = unless (null err_prs) $ + do { mapM_ report_dup err_prs; failM } + + -------------- Error reporting ------------ + err_prs :: [(Name,Name)] + err_prs = [ (n1,n2) + | pr :| prs <- findDupsEq ((==) `on` snd) swizzle_prs + , (n1,_):(n2,_):_ <- [nubBy ((==) `on` fst) (pr:prs)] ] + -- This nubBy avoids bogus error reports when we have + -- [("f", f), ..., ("f",f)....] in swizzle_prs + -- which happens with class C f where { type T f } + + report_dup :: (Name,Name) -> TcM () + report_dup (n1,n2) + = setSrcSpan (getSrcSpan n2) $ addErrTc $ + hang (text "Different names for the same type variable:") 2 info + where + info | nameOccName n1 /= nameOccName n2 + = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2) + | otherwise -- Same OccNames! See C2 in + -- Note [Swizzling the tyvars before generaliseTcTyCon] + = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1) + , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ] + + -------------- The swizzler ------------ + -- This does a deep traverse, simply doing a + -- Name-to-Name change, governed by swizzle_env + -- The 'swap' is what gets from the representative TyVar + -- back to the original user-specified Name + swizzle_env = mkVarEnv (map swap swizzle_prs) + + swizzleMapper :: TyCoMapper () Identity + swizzleMapper = TyCoMapper { tcm_tyvar = swizzle_tv + , tcm_covar = swizzle_cv + , tcm_hole = swizzle_hole + , tcm_tycobinder = swizzle_bndr + , tcm_tycon = swizzle_tycon } + swizzle_hole _ hole = pprPanic "swizzle_hole" (ppr hole) + -- These types are pre-zonked + swizzle_tycon tc = pprPanic "swizzle_tc" (ppr tc) + -- TcTyCons can't appear in kinds (yet) + swizzle_tv _ tv = return (mkTyVarTy (swizzle_var tv)) + swizzle_cv _ cv = return (mkCoVarCo (swizzle_var cv)) + + swizzle_bndr _ tcv _ + = return ((), swizzle_var tcv) + + swizzle_var :: Var -> Var + swizzle_var v + | Just nm <- lookupVarEnv swizzle_env v + = updateVarType swizzle_ty (v `setVarName` nm) + | otherwise + = updateVarType swizzle_ty v + + (map_type, _, _, _) = mapTyCo swizzleMapper + swizzle_ty ty = runIdentity (map_type ty) + + +generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon +generaliseTcTyCon (tc, scoped_prs, tc_res_kind) + -- See Note [Required, Specified, and Inferred for types] + = setSrcSpan (getSrcSpan tc) $ + addTyConCtxt tc $ + do { -- Step 1: Separate Specified from Required variables + -- NB: spec_req_tvs = spec_tvs ++ req_tvs + -- And req_tvs is 1-1 with tyConTyVars + -- See Note [Scoped tyvars in a TcTyCon] in GHC.Core.TyCon + ; let spec_req_tvs = map snd scoped_prs + n_spec = length spec_req_tvs - tyConArity tc + (spec_tvs, req_tvs) = splitAt n_spec spec_req_tvs + sorted_spec_tvs = scopedSort spec_tvs + -- NB: We can't do the sort until we've zonked + -- Maintain the L-R order of scoped_tvs + + -- Step 2a: find all the Inferred variables we want to quantify over + ; dvs1 <- candidateQTyVarsOfKinds $ + (tc_res_kind : map tyVarKind spec_req_tvs) + ; let dvs2 = dvs1 `delCandidates` spec_req_tvs + + -- Step 2b: quantify, mainly meaning skolemise the free variables + -- Returned 'inferred' are scope-sorted and skolemised + ; inferred <- quantifyTyVars dvs2 + + ; traceTc "generaliseTcTyCon: pre zonk" + (vcat [ text "tycon =" <+> ppr tc + , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs + , text "tc_res_kind =" <+> ppr tc_res_kind + , text "dvs1 =" <+> ppr dvs1 + , text "inferred =" <+> pprTyVars inferred ]) + + -- Step 3: Final zonk (following kind generalisation) + -- See Note [Swizzling the tyvars before generaliseTcTyCon] + ; ze <- emptyZonkEnv + ; (ze, inferred) <- zonkTyBndrsX ze inferred + ; (ze, sorted_spec_tvs) <- zonkTyBndrsX ze sorted_spec_tvs + ; (ze, req_tvs) <- zonkTyBndrsX ze req_tvs + ; tc_res_kind <- zonkTcTypeToTypeX ze tc_res_kind + + ; traceTc "generaliseTcTyCon: post zonk" $ + vcat [ text "tycon =" <+> ppr tc + , text "inferred =" <+> pprTyVars inferred + , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs + , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs + , text "req_tvs =" <+> ppr req_tvs + , text "zonk-env =" <+> ppr ze ] + + -- Step 4: Make the TyConBinders. + ; let dep_fv_set = candidateKindVars dvs1 + inferred_tcbs = mkNamedTyConBinders Inferred inferred + specified_tcbs = mkNamedTyConBinders Specified sorted_spec_tvs + required_tcbs = map (mkRequiredTyConBinder dep_fv_set) req_tvs + + -- Step 5: Assemble the final list. + final_tcbs = concat [ inferred_tcbs + , specified_tcbs + , required_tcbs ] + + -- Step 6: Make the result TcTyCon + tycon = mkTcTyCon (tyConName tc) final_tcbs tc_res_kind + (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs)) + True {- it's generalised now -} + (tyConFlavour tc) + + ; traceTc "generaliseTcTyCon done" $ + vcat [ text "tycon =" <+> ppr tc + , text "tc_res_kind =" <+> ppr tc_res_kind + , text "dep_fv_set =" <+> ppr dep_fv_set + , text "inferred_tcbs =" <+> ppr inferred_tcbs + , text "specified_tcbs =" <+> ppr specified_tcbs + , text "required_tcbs =" <+> ppr required_tcbs + , text "final_tcbs =" <+> ppr final_tcbs ] + + -- Step 7: Check for validity. + -- We do this here because we're about to put the tycon into the + -- the environment, and we don't want anything malformed there + ; checkTyConTelescope tycon + + ; return tycon } + +{- Note [Required, Specified, and Inferred for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each forall'd type variable in a type or kind is one of + + * Required: an argument must be provided at every call site + + * Specified: the argument can be inferred at call sites, but + may be instantiated with visible type/kind application + + * Inferred: the must be inferred at call sites; it + is unavailable for use with visible type/kind application. + +Why have Inferred at all? Because we just can't make user-facing +promises about the ordering of some variables. These might swizzle +around even between minor released. By forbidding visible type +application, we ensure users aren't caught unawares. + +Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. + +The question for this Note is this: + given a TyClDecl, how are its quantified type variables classified? +Much of the debate is memorialized in #15743. + +Here is our design choice. When inferring the ordering of variables +for a TyCl declaration (that is, for those variables that he user +has not specified the order with an explicit `forall`), we use the +following order: + + 1. Inferred variables + 2. Specified variables; in the left-to-right order in which + the user wrote them, modified by scopedSort (see below) + to put them in depdendency order. + 3. Required variables before a top-level :: + 4. All variables after a top-level :: + +If this ordering does not make a valid telescope, we reject the definition. + +Example: + data SameKind :: k -> k -> * + data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) + +For Bad: + - a, c, d, x are Required; they are explicitly listed by the user + as the positional arguments of Bad + - b is Specified; it appears explicitly in a kind signature + - k, the kind of a, is Inferred; it is not mentioned explicitly at all + +Putting variables in the order Inferred, Specified, Required +gives us this telescope: + Inferred: k + Specified: b : Proxy a + Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d) + +But this order is ill-scoped, because b's kind mentions a, which occurs +after b in the telescope. So we reject Bad. + +Associated types +~~~~~~~~~~~~~~~~ +For associated types everything above is determined by the +associated-type declaration alone, ignoring the class header. +Here is an example (#15592) + class C (a :: k) b where + type F (x :: b a) + +In the kind of C, 'k' is Specified. But what about F? +In the kind of F, + + * Should k be Inferred or Specified? It's Specified for C, + but not mentioned in F's declaration. + + * In which order should the Specified variables a and b occur? + It's clearly 'a' then 'b' in C's declaration, but the L-R ordering + in F's declaration is 'b' then 'a'. + +In both cases we make the choice by looking at F's declaration alone, +so it gets the kind + F :: forall {k}. forall b a. b a -> Type + +How it works +~~~~~~~~~~~~ +These design choices are implemented by two completely different code +paths for + + * Declarations with a standalone kind signature or a complete user-specified + kind signature (CUSK). Handled by the kcCheckDeclHeader. + + * Declarations without a kind signature (standalone or CUSK) are handled by + kcInferDeclHeader; see Note [Inferring kinds for type declarations]. + +Note that neither code path worries about point (4) above, as this +is nicely handled by not mangling the res_kind. (Mangling res_kinds is done +*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.) + +We can tell Inferred apart from Specified by looking at the scoped +tyvars; Specified are always included there. + +Design alternatives +~~~~~~~~~~~~~~~~~~~ +* For associated types we considered putting the class variables + before the local variables, in a nod to the treatment for class + methods. But it got too compilicated; see #15592, comment:21ff. + +* We rigidly require the ordering above, even though we could be much more + permissive. Relevant musings are at + https://gitlab.haskell.org/ghc/ghc/issues/15743#note_161623 + The bottom line conclusion is that, if the user wants a different ordering, + then can specify it themselves, and it is better to be predictable and dumb + than clever and capricious. + + I (Richard) conjecture we could be fully permissive, allowing all classes + of variables to intermix. We would have to augment ScopedSort to refuse to + reorder Required variables (or check that it wouldn't have). But this would + allow more programs. See #15743 for examples. Interestingly, Idris seems + to allow this intermixing. The intermixing would be fully specified, in that + we can be sure that inference wouldn't change between versions. However, + would users be able to predict it? That I cannot answer. + +Test cases (and tickets) relevant to these design decisions +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + T15591* + T15592* + T15743* + +Note [Inferring kinds for type declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This note deals with /inference/ for type declarations +that do not have a CUSK. 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) + +We do kind inference as follows: + +* Step 1: inferInitialKinds, and in particular kcInferDeclHeader. + Make a unification variable for each of the Required and Specified + type variables in the header. + + Record the connection between the Names the user wrote and the + fresh unification variables in the tcTyConScopedTyVars field + of the TcTyCon we are making + [ (a, aa) + , (k1, kk1) + , (k2, kk2) + , (x, xx) ] + (I'm using the convention that double letter like 'aa' or 'kk' + mean a unification variable.) + + These unification variables + - Are TyVarTvs: that is, unification variables that can + unify only with other type variables. + See Note [Signature skolems] in GHC.Tc.Utils.TcType + + - Have complete fresh Names; see GHC.Tc.Utils.TcMType + Note [Unification variables need fresh Names] + + Assign initial monomorphic kinds to S, T + T :: kk1 -> * -> kk2 -> * + S :: kk3 -> * -> kk4 -> * + +* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and + T, with these monomorphic kinds. Now kind-check the declarations, + and solve the resulting equalities. The goal here is to discover + constraints on all these unification variables. + + Here we find that kk1 := kk3, and kk2 := kk4. + + This is why we can't use skolems for kk1 etc; they have to + unify with each other. + +* Step 3: generaliseTcTyCon. Generalise each TyCon in turn. + We find the free variables of the kind, skolemise them, + sort them out into Inferred/Required/Specified (see the above + Note [Required, Specified, and Inferred for types]), + and perform some validity checks. + + This makes the utterly-final TyConBinders for the TyCon. + + All this is very similar at the level of terms: see GHC.Tc.Gen.Bind + Note [Quantified variables in partial type signatures] + + But there some tricky corners: Note [Tricky scoping in generaliseTcTyCon] + +* Step 4. Extend the type environment with a TcTyCon for S and T, now + with their utterly-final polymorphic kinds (needed for recursive + occurrences of S, T). Now typecheck the declarations, and build the + final AlgTyCon for S and T resp. + +The first three steps are in kcTyClGroup; the fourth is in +tcTyClDecls. + +There are some wrinkles + +* Do not default TyVarTvs. We always want to kind-generalise over + TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is + not allowed to unify with a type; it must stand for a type + variable. Hence the check in GHC.Tc.Solver.defaultTyVarTcS, and + GHC.Tc.Utils.TcMType.defaultTyVar. Here's another example (#14555): + data Exp :: [TYPE rep] -> TYPE rep -> Type where + Lam :: Exp (a:xs) b -> Exp xs (a -> b) + We want to kind-generalise over the 'rep' variable. + #14563 is another example. + +* Duplicate type variables. Consider #11203 + data SameKind :: k -> k -> * + data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) + Here we will unify k1 with k2, but this time doing so is an error, + because k1 and k2 are bound in the same declaration. + + We spot this during validity checking (findDupTyVarTvs), + in generaliseTcTyCon. + +* Required arguments. Even the Required arguments should be made + into TyVarTvs, not skolems. Consider + data T k (a :: k) + Here, k is a Required, dependent variable. For uniformity, it is helpful + to have k be a TyVarTv, in parallel with other dependent variables. + +* Duplicate skolemisation is expected. When generalising in Step 3, + we may find that one of the variables we want to quantify has + already been skolemised. For example, suppose we have already + generalise S. When we come to T we'll find that kk1 (now the same as + kk3) has already been skolemised. + + That's fine -- but it means that + a) when collecting quantification candidates, in + candidateQTyVarsOfKind, we must collect skolems + b) quantifyTyVars should be a no-op on such a skolem + +Note [Tricky scoping in generaliseTcTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider #16342 + class C (a::ka) x where + cop :: D a x => x -> Proxy a -> Proxy a + cop _ x = x :: Proxy (a::ka) + + class D (b::kb) y where + dop :: C b y => y -> Proxy b -> Proxy b + dop _ x = x :: Proxy (b::kb) + +C and D are mutually recursive, by the time we get to +generaliseTcTyCon we'll have unified kka := kkb. + +But when typechecking the default declarations for 'cop' and 'dop' in +tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope. +But at that point all we have is the utterly-final Class itself. + +Conclusion: the classTyVars of a class must have the same Name as +that originally assigned by the user. In our example, C must have +classTyVars {a, ka, x} while D has classTyVars {a, kb, y}. Despite +the fact that kka and kkb got unified! + +We achieve this sleight of hand in generaliseTcTyCon, using +the specialised function zonkRecTyVarBndrs. We make the call + zonkRecTyVarBndrs [ka,a,x] [kkb,aa,xxx] +where the [ka,a,x] are the Names originally assigned by the user, and +[kkb,aa,xx] are the corresponding (post-zonking, skolemised) TcTyVars. +zonkRecTyVarBndrs builds a recursive ZonkEnv that binds + kkb :-> (ka :: ) + aa :-> (a :: ) + etc +That is, it maps each skolemised TcTyVars to the utterly-final +TyVar to put in the class, with its correct user-specified name. +When generalising D we'll do the same thing, but the ZonkEnv will map + kkb :-> (kb :: ) + bb :-> (b :: ) + etc +Note that 'kkb' again appears in the domain of the mapping, but this +time mapped to 'kb'. That's how C and D end up with differently-named +final TyVars despite the fact that we unified kka:=kkb + +zonkRecTyVarBndrs we need to do knot-tying because of the need to +apply this same substitution to the kind of each. + +Note [Inferring visible dependent quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T k :: k -> Type where + MkT1 :: T Type Int + MkT2 :: T (Type -> Type) Maybe + +This looks like it should work. However, it is polymorphically recursive, +as the uses of T in the constructor types specialize the k in the kind +of T. This trips up our dear users (#17131, #17541), and so we add +a "landmark" context (which cannot be suppressed) whenever we +spot inferred visible dependent quantification (VDQ). + +It's hard to know when we've actually been tripped up by polymorphic recursion +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). + +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. + + +-} + +-------------- +tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a +tcExtendKindEnvWithTyCons tcs + = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ] + +-------------- +mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv +-- Maps each tycon/datacon to a suitable promotion error +-- tc :-> APromotionErr TyConPE +-- dc :-> APromotionErr RecDataConPE +-- See Note [Recursion and promoting data constructors] + +mkPromotionErrorEnv decls + = foldr (plusNameEnv . mk_prom_err_env . unLoc) + emptyNameEnv decls + +mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv +mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) + = unitNameEnv nm (APromotionErr ClassPE) + `plusNameEnv` + mkNameEnv [ (familyDeclName at, APromotionErr TyConPE) + | L _ at <- ats ] + +mk_prom_err_env (DataDecl { tcdLName = L _ name + , tcdDataDefn = HsDataDefn { dd_cons = cons } }) + = unitNameEnv name (APromotionErr TyConPE) + `plusNameEnv` + mkNameEnv [ (con, APromotionErr RecDataConPE) + | L _ con' <- cons + , L _ con <- getConNames con' ] + +mk_prom_err_env decl + = unitNameEnv (tcdName decl) (APromotionErr TyConPE) + -- Works for family declarations too + +-------------- +inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon] +-- Returns a TcTyCon for each TyCon bound by the decls, +-- each with its initial kind + +inferInitialKinds decls + = do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls) + ; tcs <- concatMapM infer_initial_kind decls + ; traceTc "inferInitialKinds done }" empty + ; return tcs } + where + infer_initial_kind = addLocM (getInitialKind InitialKindInfer) + +-- Check type/class declarations against their standalone kind signatures or +-- CUSKs, producing a generalized TcTyCon for each. +checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon] +checkInitialKinds decls + = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls) + ; tcs <- concatMapM check_initial_kind decls + ; traceTc "checkInitialKinds done }" empty + ; return tcs } + where + check_initial_kind (ldecl, msig) = + addLocM (getInitialKind (InitialKindCheck msig)) ldecl + +-- | Get the initial kind of a TyClDecl, either generalized or non-generalized, +-- depending on the 'InitialKindStrategy'. +getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon] + +-- Allocate a fresh kind variable for each TyCon and Class +-- For each tycon, return a TcTyCon with kind k +-- where k is the kind of tc, derived from the LHS +-- of the definition (and probably including +-- kind unification variables) +-- Example: data T a b = ... +-- return (T, kv1 -> kv2 -> kv3) +-- +-- This pass deals with (ie incorporates into the kind it produces) +-- * The kind signatures on type-variable binders +-- * The result kinds signature on a TyClDecl +-- +-- No family instances are passed to checkInitialKinds/inferInitialKinds +getInitialKind strategy + (ClassDecl { tcdLName = L _ name + , tcdTyVars = ktvs + , tcdATs = ats }) + = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $ + return (TheKind constraintKind) + ; let parent_tv_prs = tcTyConScopedTyVars cls + -- See Note [Don't process associated types in getInitialKind] + ; inner_tcs <- + tcExtendNameTyVarEnv parent_tv_prs $ + mapM (addLocM (getAssocFamInitialKind cls)) ats + ; return (cls : inner_tcs) } + where + getAssocFamInitialKind cls = + case strategy of + InitialKindInfer -> get_fam_decl_initial_kind (Just cls) + InitialKindCheck _ -> check_initial_kind_assoc_fam cls + +getInitialKind strategy + (DataDecl { tcdLName = L _ name + , tcdTyVars = ktvs + , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig + , dd_ND = new_or_data } }) + = do { let flav = newOrDataToFlavour new_or_data + ctxt = DataKindCtxt name + ; tc <- kcDeclHeader strategy name flav ktvs $ + case m_sig of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> return $ dataDeclDefaultResultKind new_or_data + ; return [tc] } + +getInitialKind InitialKindInfer (FamDecl { tcdFam = decl }) + = do { tc <- get_fam_decl_initial_kind Nothing decl + ; return [tc] } + +getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam = + FamilyDecl { fdLName = unLoc -> name + , fdTyVars = ktvs + , fdResultSig = unLoc -> resultSig + , fdInfo = info } } ) + = do { let flav = getFamFlav Nothing info + ctxt = TyFamResKindCtxt name + ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $ + case famResultKindSignature resultSig of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> + case msig of + CUSK -> return (TheKind liftedTypeKind) + SAKS _ -> return AnyKind + ; return [tc] } + +getInitialKind strategy + (SynDecl { tcdLName = L _ name + , tcdTyVars = ktvs + , tcdRhs = rhs }) + = do { let ctxt = TySynKindCtxt name + ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $ + case hsTyKindSig rhs of + Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig + Nothing -> return AnyKind + ; return [tc] } + +get_fam_decl_initial_kind + :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls + -> FamilyDecl GhcRn + -> TcM TcTyCon +get_fam_decl_initial_kind mb_parent_tycon + FamilyDecl { fdLName = L _ name + , fdTyVars = ktvs + , fdResultSig = L _ resultSig + , fdInfo = info } + = kcDeclHeader InitialKindInfer name flav ktvs $ + case resultSig of + KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki + TyVarSig _ (L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki + _ -- open type families have * return kind by default + | tcFlavourIsOpen flav -> return (TheKind liftedTypeKind) + -- closed type families have their return kind inferred + -- by default + | otherwise -> return AnyKind + where + flav = getFamFlav mb_parent_tycon info + ctxt = TyFamResKindCtxt name + +-- See Note [Standalone kind signatures for associated types] +check_initial_kind_assoc_fam + :: TcTyCon -- parent class + -> FamilyDecl GhcRn + -> TcM TcTyCon +check_initial_kind_assoc_fam cls + FamilyDecl + { fdLName = unLoc -> name + , fdTyVars = ktvs + , fdResultSig = unLoc -> resultSig + , fdInfo = info } + = kcDeclHeader (InitialKindCheck CUSK) name flav ktvs $ + case famResultKindSignature resultSig of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> return (TheKind liftedTypeKind) + where + ctxt = TyFamResKindCtxt name + flav = getFamFlav (Just cls) info + +{- Note [Standalone kind signatures for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If associated types had standalone kind signatures, would they wear them + +---------------------------+------------------------------ + like this? (OUT) | or like this? (IN) +---------------------------+------------------------------ + type T :: Type -> Type | class C a where + class C a where | type T :: Type -> Type + type T a | type T a + +The (IN) variant is syntactically ambiguous: + + class C a where + type T :: a -- standalone kind signature? + type T :: a -- declaration header? + +The (OUT) variant does not suffer from this issue, but it might not be the +direction in which we want to take Haskell: we seek to unify type families and +functions, and, by extension, associated types with class methods. And yet we +give class methods their signatures inside the class, not outside. Neither do +we have the counterpart of InstanceSigs for StandaloneKindSignatures. + +For now, we dodge the question by using CUSKs for associated types instead of +standalone kind signatures. This is a simple addition to the rule we used to +have before standalone kind signatures: + + old rule: associated type has a CUSK iff its parent class has a CUSK + new rule: associated type has a CUSK iff its parent class has a CUSK or a standalone kind signature + +-} + +-- See Note [Data declaration default result kind] +dataDeclDefaultResultKind :: NewOrData -> ContextKind +dataDeclDefaultResultKind NewType = OpenKind + -- See Note [Implementation of UnliftedNewtypes], point . +dataDeclDefaultResultKind DataType = TheKind liftedTypeKind + +{- Note [Data declaration default result kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When the user has not written an inline result kind annotation on a data +declaration, we assume it to be 'Type'. That is, the following declarations +D1 and D2 are considered equivalent: + + data D1 where ... + data D2 :: Type where ... + +The consequence of this assumption is that we reject D3 even though we +accept D4: + + data D3 where + MkD3 :: ... -> D3 param + + data D4 :: Type -> Type where + MkD4 :: ... -> D4 param + +However, there's a twist: for newtypes, we must relax +the assumed result kind to (TYPE r): + + newtype D5 where + MkD5 :: Int# -> D5 + +See Note [Implementation of UnliftedNewtypes], STEP 1 and it's sub-note +. +-} + +--------------------------------- +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] + -- Called only for declarations without a signature (no CUSKs or SAKs here) +kcLTyClDecl (L loc decl) + = setSrcSpan loc $ + do { tycon <- tcLookupTcTyCon tc_name + ; traceTc "kcTyClDecl {" (ppr tc_name) + ; addVDQNote tycon $ -- See Note [Inferring visible dependent quantification] + addErrCtxt (tcMkDeclCtxt decl) $ + kcTyClDecl decl tycon + ; traceTc "kcTyClDecl done }" (ppr tc_name) } + where + tc_name = tcdName decl + +kcTyClDecl :: TyClDecl GhcRn -> TcTyCon -> TcM () +-- This function is used solely for its side effect on kind variables +-- NB kind signatures on the type variables and +-- result kind signature have already been dealt with +-- by inferInitialKind, so we can ignore them here. + +kcTyClDecl (DataDecl { tcdLName = (L _ name) + , tcdDataDefn = defn }) tyCon + | HsDataDefn { dd_cons = cons@((L _ (ConDeclGADT {})) : _) + , dd_ctxt = (L _ []) + , dd_ND = new_or_data } <- defn + = -- See Note [Implementation of UnliftedNewtypes] STEP 2 + kcConDecls new_or_data (tyConResKind tyCon) cons + + -- hs_tvs and dd_kindSig already dealt with in inferInitialKind + -- This must be a GADT-style decl, + -- (see invariants of DataDefn declaration) + -- so (a) we don't need to bring the hs_tvs into scope, because the + -- ConDecls bind all their own variables + -- (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it + + | HsDataDefn { dd_ctxt = ctxt + , dd_cons = cons + , dd_ND = new_or_data } <- defn + = bindTyClTyVars name $ \ _ _ _ -> + do { _ <- tcHsContext ctxt + ; kcConDecls new_or_data (tyConResKind tyCon) cons + } + +kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon + = bindTyClTyVars name $ \ _ _ res_kind -> + discardResult $ tcCheckLHsType rhs (TheKind res_kind) + -- NB: check against the result kind that we allocated + -- in inferInitialKinds. + +kcTyClDecl (ClassDecl { tcdLName = L _ name + , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon + = bindTyClTyVars name $ \ _ _ _ -> + do { _ <- tcHsContext ctxt + ; mapM_ (wrapLocM_ kc_sig) sigs } + where + kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType skol_info nms op_ty + kc_sig _ = return () + + skol_info = TyConSkol ClassFlavour name + +kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc +-- closed type families look at their equations, but other families don't +-- do anything here + = case fd_info of + ClosedTypeFamily (Just eqns) -> mapM_ (kcTyFamInstEqn fam_tc) eqns + _ -> return () + +------------------- + +-- Type check the types of the arguments to a data constructor. +-- This includes doing kind unification if the type is a newtype. +-- See Note [Implementation of UnliftedNewtypes] for why we need +-- the first two arguments. +kcConArgTys :: NewOrData -> Kind -> [LHsType GhcRn] -> TcM () +kcConArgTys new_or_data res_kind arg_tys = do + { let exp_kind = getArgExpKind new_or_data res_kind + ; mapM_ (flip tcCheckLHsType exp_kind . getBangType) arg_tys + -- See Note [Implementation of UnliftedNewtypes], STEP 2 + } + +kcConDecls :: NewOrData + -> Kind -- The result kind signature + -> [LConDecl GhcRn] -- The data constructors + -> TcM () +kcConDecls new_or_data res_kind cons + = mapM_ (wrapLocM_ (kcConDecl new_or_data final_res_kind)) cons + where + (_, final_res_kind) = splitPiTys res_kind + -- See Note [kcConDecls result kind] + +-- Kind check a data constructor. In additional to the data constructor, +-- we also need to know about whether or not its corresponding type was +-- declared with data or newtype, and we need to know the result kind of +-- this type. See Note [Implementation of UnliftedNewtypes] for why +-- we need the first two arguments. +kcConDecl :: NewOrData + -> Kind -- Result kind of the type constructor + -- Usually Type but can be TYPE UnliftedRep + -- or even TYPE r, in the case of unlifted newtype + -> ConDecl GhcRn + -> TcM () +kcConDecl new_or_data res_kind (ConDeclH98 + { con_name = name, con_ex_tvs = ex_tvs + , con_mb_cxt = ex_ctxt, con_args = args }) + = addErrCtxt (dataConCtxtName [name]) $ + discardResult $ + bindExplicitTKBndrs_Tv ex_tvs $ + do { _ <- tcHsMbContext ex_ctxt + ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) + -- We don't need to check the telescope here, + -- because that's done in tcConDecl + } + +kcConDecl new_or_data res_kind (ConDeclGADT + { con_names = names, con_qvars = qtvs, con_mb_cxt = cxt + , con_args = args, con_res_ty = res_ty }) + | HsQTvs { hsq_ext = implicit_tkv_nms + , hsq_explicit = explicit_tkv_nms } <- qtvs + = -- Even though the GADT-style data constructor's type is closed, + -- we must still kind-check the type, because that may influence + -- the inferred kind of the /type/ constructor. Example: + -- data T f a where + -- MkT :: f a -> T f a + -- If we don't look at MkT we won't get the correct kind + -- for the type constructor T + addErrCtxt (dataConCtxtName names) $ + discardResult $ + bindImplicitTKBndrs_Tv implicit_tkv_nms $ + bindExplicitTKBndrs_Tv explicit_tkv_nms $ + -- Why "_Tv"? See Note [Kind-checking for GADTs] + do { _ <- tcHsMbContext cxt + ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) + ; _ <- tcHsOpenType res_ty + ; return () } + +{- Note [kcConDecls result kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We might have e.g. + data T a :: Type -> Type where ... +or + newtype instance N a :: Type -> Type where .. +in which case, the 'res_kind' passed to kcConDecls will be + Type->Type + +We must look past those arrows, or even foralls, to the Type in the +corner, to pass to kcConDecl c.f. #16828. Hence the splitPiTys here. + +I am a bit concerned about tycons with a declaration like + data T a :: Type -> forall k. k -> Type where ... + +It does not have a CUSK, so kcInferDeclHeader will make a TcTyCon +with tyConResKind of Type -> forall k. k -> Type. Even that is fine: +the splitPiTys will look past the forall. But I'm bothered about +what if the type "in the corner" mentions k? This is incredibly +obscure but something like this could be bad: + data T a :: Type -> foral k. k -> TYPE (F k) where ... + +I bet we are not quite right here, but my brain suffered a buffer +overflow and I thought it best to nail the common cases right now. + +Note [Recursion and promoting data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't want to allow promotion in a strongly connected component +when kind checking. + +Consider: + data T f = K (f (K Any)) + +When kind checking the `data T' declaration the local env contains the +mappings: + T -> ATcTyCon + K -> APromotionErr + +APromotionErr is only used for DataCons, and only used during type checking +in tcTyClGroup. + +Note [Kind-checking for GADTs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data Proxy a where + MkProxy1 :: forall k (b :: k). Proxy b + MkProxy2 :: forall j (c :: j). Proxy c + +It seems reasonable that this should be accepted. But something very strange +is going on here: when we're kind-checking this declaration, we need to unify +the kind of `a` with k and j -- even though k and j's scopes are local to the type of +MkProxy{1,2}. The best approach we've come up with is to use TyVarTvs during +the kind-checking pass. First off, note that it's OK if the kind-checking pass +is too permissive: we'll snag the problems in the type-checking pass later. +(This extra permissiveness might happen with something like + + data SameKind :: k -> k -> Type + data Bad a where + MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b) + +which would be accepted if k1 and k2 were TyVarTvs. This is correctly rejected +in the second pass, though. Test case: polykinds/TyVarTvKinds3) +Recall that the kind-checking pass exists solely to collect constraints +on the kinds and to power unification. + +To achieve the use of TyVarTvs, we must be careful to use specialized functions +that produce TyVarTvs, not ordinary skolems. This is why we need +kcExplicitTKBndrs and kcImplicitTKBndrs in GHC.Tc.Gen.HsType, separate from their +tc... variants. + +The drawback of this approach is sometimes it will accept a definition that +a (hypothetical) declarative specification would likely reject. As a general +rule, we don't want to allow polymorphic recursion without a CUSK. Indeed, +the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs +approach allows a limited form of polymorphic recursion *without* a CUSK. + +To wit: + data T a = forall k (b :: k). MkT (T b) Int + (test case: dependent/should_compile/T14066a) + +Note that this is polymorphically recursive, with the recursive occurrence +of T used at a kind other than a's kind. The approach outlined here accepts +this definition, because this kind is still a kind variable (and so the +TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a +way to describe exactly what declarations will be accepted and which will +be rejected (without a CUSK). However, the accepted definitions are indeed +well-kinded and any rejected definitions would be accepted with a CUSK, +and so this wrinkle need not cause anyone to lose sleep. + +************************************************************************ +* * +\subsection{Type checking} +* * +************************************************************************ + +Note [Type checking recursive type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At this point we have completed *kind-checking* of a mutually +recursive group of type/class decls (done in kcTyClGroup). However, +we discarded the kind-checked types (eg RHSs of data type decls); +note that kcTyClDecl returns (). There are two reasons: + + * It's convenient, because we don't have to rebuild a + kinded HsDecl (a fairly elaborate type) + + * It's necessary, because after kind-generalisation, the + TyCons/Classes may now be kind-polymorphic, and hence need + to be given kind arguments. + +Example: + data T f a = MkT (f a) (T f a) +During kind-checking, we give T the kind T :: k1 -> k2 -> * +and figure out constraints on k1, k2 etc. Then we generalise +to get T :: forall k. (k->*) -> k -> * +So now the (T f a) in the RHS must be elaborated to (T k f a). + +However, during tcTyClDecl of T (above) we will be in a recursive +"knot". So we aren't allowed to look at the TyCon T itself; we are only +allowed to put it (lazily) in the returned structures. But when +kind-checking the RHS of T's decl, we *do* need to know T's kind (so +that we can correctly elaboarate (T k f a). How can we get T's kind +without looking at T? Delicate answer: during tcTyClDecl, we extend + + *Global* env with T -> ATyCon (the (not yet built) final TyCon for T) + *Local* env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T) + +Then: + + * 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) + we look in the *global* env to get the TyCon. + +This fancy footwork (with two bindings for T) is only necessary for the +TyCons or Classes of this recursive group. Earlier, finished groups, +live in the global env only. + +See also Note [Kind checking recursive type and class declarations] + +Note [Kind checking recursive type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before we can type-check the decls, we must kind check them. This +is done by establishing an "initial kind", which is a rather uninformed +guess at a tycon's kind (by counting arguments, mainly) and then +using this initial kind for recursive occurrences. + +The initial kind is stored in exactly the same way during +kind-checking as it is during type-checking (Note [Type checking +recursive type and class declarations]): in the *local* environment, +with ATcTyCon. But we still must store *something* in the *global* +environment. Even though we discard the result of kind-checking, we +sometimes need to produce error messages. These error messages will +want to refer to the tycons being checked, except that they don't +exist yet, and it would be Terribly Annoying to get the error messages +to refer back to HsSyn. So we create a TcTyCon and put it in the +global env. This tycon can print out its name and knows its kind, but +any other action taken on it will panic. Note that TcTyCons are *not* +knot-tied, unlike the rather valid but knot-tied ones that occur +during type-checking. + +Note [Declarations for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For wired-in things we simply ignore the declaration +and take the wired-in information. That avoids complications. +e.g. the need to make the data constructor worker name for + a constraint tuple match the wired-in one + +Note [Implementation of UnliftedNewtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Expected behavior of UnliftedNewtypes: + +* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0013-unlifted-newtypes.rst +* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/98 + +What follows is a high-level overview of the implementation of the +proposal. + +STEP 1: Getting the initial kind, as done by inferInitialKind. We have +two sub-cases: + +* With a SAK/CUSK: no change in kind-checking; the tycon is given the kind + the user writes, whatever it may be. + +* Without a SAK/CUSK: If there is no kind signature, the tycon is given + a kind `TYPE r`, for a fresh unification variable `r`. We do this even + when -XUnliftedNewtypes is not on; see , below. + +STEP 2: Kind-checking, as done by kcTyClDecl. This step is skipped for CUSKs. +The key function here is kcConDecl, which looks at an individual constructor +declaration. When we are processing a newtype (but whether or not -XUnliftedNewtypes +is enabled; see , below), we generate a correct ContextKind +for the checking argument types: see getArgExpKind. + +Examples of newtypes affected by STEP 2, assuming -XUnliftedNewtypes is +enabled (we use r0 to denote a unification variable): + +newtype Foo rep = MkFoo (forall (a :: TYPE rep). a) ++ kcConDecl unifies (TYPE r0) with (TYPE rep), where (TYPE r0) + is the kind that inferInitialKind invented for (Foo rep). + +data Color = Red | Blue +type family Interpret (x :: Color) :: RuntimeRep where + Interpret 'Red = 'IntRep + Interpret 'Blue = 'WordRep +data family Foo (x :: Color) :: TYPE (Interpret x) +newtype instance Foo 'Red = FooRedC Int# ++ kcConDecl unifies TYPE (Interpret 'Red) with TYPE 'IntRep + +Note that, in the GADT case, we might have a kind signature with arrows +(newtype XYZ a b :: Type -> Type where ...). We want only the final +component of the kind for checking in kcConDecl, so we call etaExpandAlgTyCon +in kcTyClDecl. + +STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function +here is tcConDecl. Once again, we must use getArgExpKind to ensure that the +representation type's kind matches that of the newtype, for two reasons: + + A. It is possible that a GADT has a CUSK. (Note that this is *not* + possible for H98 types.) Recall that CUSK types don't go through + kcTyClDecl, so we might not have done this kind check. + B. We need to produce the coercion to put on the argument type + if the kinds are different (for both H98 and GADT). + +Example of (B): + +type family F a where + F Int = LiftedRep + +newtype N :: TYPE (F Int) where + MkN :: Int -> N + +We really need to have the argument to MkN be (Int |> TYPE (sym axF)), where +axF :: F Int ~ LiftedRep. That way, the argument kind is the same as the +newtype kind, which is the principal correctness condition for newtypes. + +Wrinkle: Consider (#17021, typecheck/should_fail/T17021) + + type family Id (x :: a) :: a where + Id x = x + + newtype T :: TYPE (Id LiftedRep) where + MkT :: Int -> T + + In the type of MkT, we must end with (Int |> TYPE (sym axId)) -> T, never Int -> (T |> + TYPE axId); otherwise, the result type of the constructor wouldn't match the + datatype. However, type-checking the HsType T might reasonably result in + (T |> hole). We thus must ensure that this cast is dropped, forcing the + type-checker to add one to the Int instead. + + Why is it always safe to drop the cast? This result type is type-checked by + tcHsOpenType, so its kind definitely looks like TYPE r, for some r. It is + important that even after dropping the cast, the type's kind has the form + TYPE r. This is guaranteed by restrictions on the kinds of datatypes. + For example, a declaration like `newtype T :: Id Type` is rejected: a + newtype's final kind always has the form TYPE r, just as we want. + +Note that this is possible in the H98 case only for a data family, because +the H98 syntax doesn't permit a kind signature on the newtype itself. + +There are also some changes for deailng with families: + +1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if + UnliftedNewtypes is on. This allows us to write things like: + data family Foo :: TYPE 'IntRep + +2. In a newtype instance (with -XUnliftedNewtypes), if the user does + not write a kind signature, we want to allow the possibility that + the kind is not Type, so we use newOpenTypeKind instead of liftedTypeKind. + This is done in tcDataFamInstHeader in GHC.Tc.TyCl.Instance. Example: + + data family Bar (a :: RuntimeRep) :: TYPE a + newtype instance Bar 'IntRep = BarIntC Int# + newtype instance Bar 'WordRep :: TYPE 'WordRep where + BarWordC :: Word# -> Bar 'WordRep + + The data instance corresponding to IntRep does not specify a kind signature, + so tc_kind_sig just returns `TYPE r0` (where `r0` is a fresh metavariable). + The data instance corresponding to WordRep does have a kind signature, so + we use that kind signature. + +3. A data family and its newtype instance may be declared with slightly + different kinds. See point 7 in Note [Datatype return kinds]. + +There's also a change in the renamer: + +* In GHC.RenameSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means + for a newtype to have a CUSK. This is necessary since UnliftedNewtypes + means that, for newtypes without kind signatures, we must use the field + inside the data constructor to determine the result kind. + See Note [Unlifted Newtypes and CUSKs] for more detail. + +For completeness, it was also necessary to make coerce work on +unlifted types, resolving #13595. + +: It's tempting to think that the expected kind for a newtype +constructor argument when -XUnliftedNewtypes is *not* enabled should just be Type. +But this leads to difficulty in suggesting to enable UnliftedNewtypes. Here is +an example: + + newtype A = MkA Int# + +If we expect the argument to MkA to have kind Type, then we get a kind-mismatch +error. The problem is that there is no way to connect this mismatch error to +-XUnliftedNewtypes, and suggest enabling the extension. So, instead, we allow +the A to type-check, but then find the problem when doing validity checking (and +where we get make a suitable error message). One potential worry is + + {-# LANGUAGE PolyKinds #-} + newtype B a = MkB a + +This turns out OK, because unconstrained RuntimeReps default to LiftedRep, just +as we would like. Another potential problem comes in a case like + + -- no UnliftedNewtypes + + data family D :: k + newtype instance D = MkD Any + +Here, we want inference to tell us that k should be instantiated to Type in +the instance. With the approach described here (checking for Type only in +the validity checker), that will not happen. But I cannot think of a non-contrived +example that will notice this lack of inference, so it seems better to improve +error messages than be able to infer this instantiation. + +-} + +tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) +tcTyClDecl roles_info (L loc decl) + | Just thing <- wiredInNameTyThing_maybe (tcdName decl) + = case thing of -- See Note [Declarations for wired-in things] + ATyCon tc -> return (tc, wiredInDerivInfo tc decl) + _ -> pprPanic "tcTyClDecl" (ppr thing) + + | otherwise + = setSrcSpan loc $ tcAddDeclCtxt decl $ + do { traceTc "---- tcTyClDecl ---- {" (ppr decl) + ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl + ; traceTc "---- tcTyClDecl end ---- }" (ppr tc) + ; return (tc, deriv_infos) } + +noDerivInfos :: a -> (a, [DerivInfo]) +noDerivInfos a = (a, []) + +wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo] +wiredInDerivInfo tycon decl + | DataDecl { tcdDataDefn = dataDefn } <- decl + , HsDataDefn { dd_derivs = derivs } <- dataDefn + = [ DerivInfo { di_rep_tc = tycon + , di_scoped_tvs = + if isFunTyCon tycon || isPrimTyCon tycon + then [] -- no tyConTyVars + else mkTyVarNamePairs (tyConTyVars tycon) + , di_clauses = unLoc derivs + , di_ctxt = tcMkDeclCtxt decl } ] +wiredInDerivInfo _ _ = [] + + -- "type family" declarations +tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) +tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) + = fmap noDerivInfos $ + tcFamDecl1 parent fd + + -- "type" synonym declaration +tcTyClDecl1 _parent roles_info + (SynDecl { tcdLName = L _ tc_name + , tcdRhs = rhs }) + = ASSERT( isNothing _parent ) + fmap noDerivInfos $ + tcTySynRhs roles_info tc_name rhs + + -- "data/newtype" declaration +tcTyClDecl1 _parent roles_info + decl@(DataDecl { tcdLName = L _ tc_name + , tcdDataDefn = defn }) + = ASSERT( isNothing _parent ) + tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn + +tcTyClDecl1 _parent roles_info + (ClassDecl { tcdLName = L _ class_name + , tcdCtxt = hs_ctxt + , tcdMeths = meths + , tcdFDs = fundeps + , tcdSigs = sigs + , tcdATs = ats + , tcdATDefs = at_defs }) + = ASSERT( isNothing _parent ) + do { clas <- tcClassDecl1 roles_info class_name hs_ctxt + meths fundeps sigs ats at_defs + ; return (noDerivInfos (classTyCon clas)) } + + +{- ********************************************************************* +* * + Class declarations +* * +********************************************************************* -} + +tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn + -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn] + -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn] + -> TcM Class +tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs + = fixM $ \ clas -> + -- We need the knot because 'clas' is passed into tcClassATs + bindTyClTyVars class_name $ \ _ binders res_kind -> + do { checkClassKindSig res_kind + ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders) + ; let tycon_name = class_name -- We use the same name + roles = roles_info tycon_name -- for TyCon and Class + + ; (ctxt, fds, sig_stuff, at_stuff) + <- pushTcLevelM_ $ + solveEqualities $ + checkTvConstraints skol_info (binderVars binders) $ + -- The checkTvConstraints is needed bring into scope the + -- skolems bound by the class decl header (#17841) + do { ctxt <- tcHsContext hs_ctxt + ; fds <- mapM (addLocM tc_fundep) fundeps + ; sig_stuff <- tcClassSigs class_name sigs meths + ; at_stuff <- tcClassATs class_name clas ats at_defs + ; return (ctxt, fds, sig_stuff, at_stuff) } + + -- The solveEqualities 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 <- emptyZonkEnv + ; ctxt <- zonkTcTypesToTypesX ze ctxt + ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff + -- ToDo: do we need to zonk at_stuff? + + -- TODO: Allow us to distinguish between abstract class, + -- and concrete class with no methods (maybe by + -- specifying a trailing where or not + + ; mindef <- tcClassMinimalDef class_name sigs sig_stuff + ; is_boot <- tcIsHsBootOrSig + ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff + = Nothing + | otherwise + = Just (ctxt, at_stuff, sig_stuff, mindef) + + ; clas <- buildClass class_name binders roles fds body + ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$ + ppr fds) + ; return clas } + where + skol_info = TyConSkol ClassFlavour class_name + tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; + ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ; + ; return (tvs1', tvs2') } + + +{- Note [Associated type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The following is an example of associated type defaults: + class C a where + data D a + + type F a b :: * + type F a b = [a] -- Default + +Note that we can get default definitions only for type families, not data +families. +-} + +tcClassATs :: Name -- The class name (not knot-tied) + -> Class -- The class parent of this associated type + -> [LFamilyDecl GhcRn] -- Associated types. + -> [LTyFamDefltDecl GhcRn] -- Associated type defaults. + -> TcM [ClassATItem] +tcClassATs class_name cls ats at_defs + = do { -- Complain about associated type defaults for non associated-types + sequence_ [ failWithTc (badATErr class_name n) + | n <- map at_def_tycon at_defs + , not (n `elemNameSet` at_names) ] + ; mapM tc_at ats } + where + at_def_tycon :: LTyFamDefltDecl GhcRn -> Name + at_def_tycon = tyFamInstDeclName . unLoc + + at_fam_name :: LFamilyDecl GhcRn -> Name + at_fam_name = familyDeclName . unLoc + + at_names = mkNameSet (map at_fam_name ats) + + at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn] + -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' + at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv + (at_def_tycon at_def) [at_def]) + emptyNameEnv at_defs + + tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at + ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) + `orElse` [] + ; atd <- tcDefaultAssocDecl fam_tc at_defs + ; return (ATI fam_tc atd) } + +------------------------- +tcDefaultAssocDecl :: + TyCon -- ^ Family TyCon (not knot-tied) + -> [LTyFamDefltDecl GhcRn] -- ^ Defaults + -> TcM (Maybe (KnotTied Type, SrcSpan)) -- ^ Type checked RHS +tcDefaultAssocDecl _ [] + = return Nothing -- No default declaration + +tcDefaultAssocDecl _ (d1:_:_) + = failWithTc (text "More than one default declaration for" + <+> ppr (tyFamInstDeclName (unLoc d1))) + +tcDefaultAssocDecl fam_tc + [L loc (TyFamInstDecl { tfid_eqn = + HsIB { hsib_ext = imp_vars + , hsib_body = FamEqn { feqn_tycon = L _ tc_name + , feqn_bndrs = mb_expl_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty }}})] + = -- See Note [Type-checking default assoc decls] + setSrcSpan loc $ + tcAddFamInstCtxt (text "default type instance") tc_name $ + do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name) + ; let fam_tc_name = tyConName fam_tc + vis_arity = length (tyConVisibleTyVars fam_tc) + vis_pats = numVisibleArgs hs_pats + + -- Kind of family check + ; ASSERT( fam_tc_name == tc_name ) + checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + + -- Arity check + ; checkTc (vis_pats == vis_arity) + (wrongNumberOfParmsErr vis_arity) + + -- Typecheck RHS + -- + -- You might think we should pass in some AssocInstInfo, as we're looking + -- at an associated type. But this would be wrong, because an associated + -- type default LHS can mention *different* type variables than the + -- enclosing class. So it's treated more as a freestanding beast. + ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated + imp_vars (mb_expl_bndrs `orElse` []) + hs_pats hs_rhs_ty + + ; let fam_tvs = tyConTyVars fam_tc + ppr_eqn = ppr_default_eqn pats rhs_ty + pats_vis = tyConArgFlags fam_tc pats + ; traceTc "tcDefaultAssocDecl 2" (vcat + [ text "fam_tvs" <+> ppr fam_tvs + , text "qtvs" <+> ppr qtvs + , text "pats" <+> ppr pats + , text "rhs_ty" <+> ppr rhs_ty + ]) + ; cpt_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis + ; check_all_distinct_tvs ppr_eqn $ zip cpt_tvs pats_vis + ; let subst = zipTvSubst cpt_tvs (mkTyVarTys fam_tvs) + ; pure $ Just (substTyUnchecked subst rhs_ty, loc) + -- We also perform other checks for well-formedness and validity + -- later, in checkValidClass + } + where + -- Checks that a pattern on the LHS of a default is a type + -- variable. If so, return the underlying type variable, and if + -- not, throw an error. + -- See Note [Type-checking default assoc decls] + extract_tv :: SDoc -- The pretty-printed default equation + -- (only used for error message purposes) + -> Type -- The particular type pattern from which to extract + -- its underlying type variable + -> ArgFlag -- The visibility of the type pattern + -- (only used for error message purposes) + -> TcM TyVar + extract_tv ppr_eqn pat pat_vis = + case getTyVar_maybe pat of + Just tv -> pure tv + Nothing -> failWithTc $ + pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ + hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:") + 2 (vcat [ppr_eqn, suggestion]) + + + -- Checks that no type variables in an associated default declaration are + -- duplicated. If that is the case, throw an error. + -- See Note [Type-checking default assoc decls] + check_all_distinct_tvs :: + SDoc -- The pretty-printed default equation (only used + -- for error message purposes) + -> [(TyVar, ArgFlag)] -- The type variable arguments in the associated + -- default declaration, along with their respective + -- visibilities (the latter are only used for error + -- message purposes) + -> TcM () + check_all_distinct_tvs ppr_eqn cpt_tvs_vis = + let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in + traverse_ + (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $ + pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ + hang (text "Illegal duplicate variable" + <+> quotes (ppr pat_tv) <+> text "in:") + 2 (vcat [ppr_eqn, suggestion])) + dups + + ppr_default_eqn :: [Type] -> Type -> SDoc + ppr_default_eqn pats rhs_ty = + quotes (text "type" <+> ppr (mkTyConApp fam_tc pats) + <+> equals <+> ppr rhs_ty) + + suggestion :: SDoc + suggestion = text "The arguments to" <+> quotes (ppr fam_tc) + <+> text "must all be distinct type variables" + + +{- Note [Type-checking default assoc decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this default declaration for an associated type + + class C a where + type F (a :: k) b :: Type + type F (x :: j) y = Proxy x -> y + +Note that the class variable 'a' doesn't scope over the default assoc +decl (rather oddly I think), and (less oddly) neither does the second +argument 'b' of the associated type 'F', or the kind variable 'k'. +Instead, the default decl is treated more like a top-level type +instance. + +However we store the default rhs (Proxy x -> y) in F's TyCon, using +F's own type variables, so we need to convert it to (Proxy a -> b). +We do this by creating a substitution [j |-> k, x |-> a, b |-> y] and +applying this substitution to the RHS. + +In order to create this substitution, we must first ensure that all of +the arguments in the default instance consist of distinct type variables. +One might think that this is a simple task that could be implemented earlier +in the compiler, perhaps in the parser or the renamer. However, there are some +tricky corner cases that really do require the full power of typechecking to +weed out, as the examples below should illustrate. + +First, we must check that all arguments are type variables. As a motivating +example, consider this erroneous program (inspired by #11361): + + class C a where + type F (a :: k) b :: Type + type F x b = x + +If you squint, you'll notice that the kind of `x` is actually Type. However, +we cannot substitute from [Type |-> k], so we reject this default. + +Next, we must check that all arguments are distinct. Here is another offending +example, this time taken from #13971: + + class C2 (a :: j) where + type F2 (a :: j) (b :: k) + type F2 (x :: z) y = SameKind x y + data SameKind :: k -> k -> Type + +All of the arguments in the default equation for `F2` are type variables, so +that passes the first check. However, if we were to build this substitution, +then both `j` and `k` map to `z`! In terms of visible kind application, it's as +if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear +that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is +also rejected. + +Since the LHS of an associated type family default is always just variables, +it won't contain any tycons. Accordingly, the patterns used in the substitution +won't actually be knot-tied, even though we're in the knot. This is too +delicate for my taste, but it works. + +Note [Datatype return kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several poorly lit corners around datatype/newtype return kinds. +This Note explains these. Within this note, always understand "instance" +to mean data or newtype instance, and understand "family" to mean data +family. No type families or classes here. Some examples: + +data T a :: where ... -- See Point 4 +newtype T a :: where ... -- See Point 5 + +data family T a :: -- See Point 6 + +data instance T [a] :: where ... -- See Point 4 +newtype instance T [a] :: where ... -- See Point 5 + +1. Where this applies: Only GADT syntax for data/newtype/instance declarations + can have declared return kinds. This Note does not apply to Haskell98 + syntax. + +2. Where these kinds come from: Return kinds are processed through several + different code paths: + + data/newtypes: The return kind is part of the TyCon kind, gotten either + by checkInitialKind (standalone kind signature / CUSK) or + inferInitialKind. It is extracted by bindTyClTyVars in tcTyClDecl1. It is + then passed to tcDataDefn. + + families: The return kind is either written in a standalone signature + or extracted from a family declaration in getInitialKind. + If a family declaration is missing a result kind, it is assumed to be + Type. This assumption is in getInitialKind for CUSKs or + get_fam_decl_initial_kind for non-signature & non-CUSK cases. + + instances: The data family already has a known kind. The return kind + of an instance is then calculated by applying the data family tycon + to the patterns provided, as computed by the typeKind lhs_ty in the + end of tcDataFamInstHeader. In the case of an instance written in GADT + syntax, there are potentially *two* return kinds: the one computed from + applying the data family tycon to the patterns, and the one given by + the user. This second kind is checked by the tc_kind_sig function within + tcDataFamInstHeader. + +3. Eta-expansion: Any forall-bound variables and function arguments in a result kind + become parameters to the type. That is, when we say + + data T a :: Type -> Type where ... + + we really mean for T to have two parameters. The second parameter + is produced by processing the return kind in etaExpandAlgTyCon, + called in tcDataDefn for data/newtypes and in tcDataFamInstDecl + for instances. This is true for data families as well, though their + arity only matters for pretty-printing. + + See also Note [TyConBinders for the result kind signatures of a data type] + in GHC.Tc.Gen.HsType. + +4. Datatype return kind restriction: A data/data-instance return kind must end + in a type that, after type-synonym expansion, yields `TYPE LiftedRep`. By + "end in", we mean we strip any foralls and function arguments off before + checking: this remaining part of the type is returned from + etaExpandAlgTyCon. Note that we do *not* do type family reduction here. + Examples: + + data T1 :: Type -- good + data T2 :: Bool -> Type -- good + data T3 :: Bool -> forall k. Type -- strange, but still accepted + data T4 :: forall k. k -> Type -- good + data T5 :: Bool -- bad + data T6 :: Type -> Bool -- bad + + type Arrow = (->) + data T7 :: Arrow Bool Type -- good + + type family ARROW where + ARROW = (->) + data T8 :: ARROW Bool Type -- bad + + type Star = Type + data T9 :: Bool -> Star -- good + + type family F a where + F Int = Bool + F Bool = Type + data T10 :: Bool -> F Bool -- bad + + This check is done in checkDataKindSig. For data declarations, this + call is in tcDataDefn; for data instances, this call is in tcDataFamInstDecl. + + However, because data instances in GADT syntax can have two return kinds (see + point (2) above), we must check both return kinds. The user-written return + kind is checked in tc_kind_sig within tcDataFamInstHeader. Examples: + + data family D (a :: Nat) :: k -- good (see Point 6) + + data instance D 1 :: Type -- good + data instance D 2 :: F Bool -- bad + +5. Newtype return kind restriction: If -XUnliftedNewtypes is on, then + a newtype/newtype-instance return kind must end in TYPE xyz, for some + xyz (after type synonym expansion). The "xyz" may include type families, + but the TYPE part must be visible with expanding type families (only synonyms). + This kind is unified with the kind of the representation type (the type + of the one argument to the one constructor). See also steps (2) and (3) + of Note [Implementation of UnliftedNewtypes]. + + If -XUnliftedNewtypes is not on, then newtypes are treated just like datatypes. + + The checks are done in the same places as for datatypes. + Examples (assume -XUnliftedNewtypes): + + newtype N1 :: Type -- good + newtype N2 :: Bool -> Type -- good + newtype N3 :: forall r. Bool -> TYPE r -- good + + type family F (t :: Type) :: RuntimeRep + newtype N4 :: forall t -> TYPE (F t) -- good + + type family STAR where + STAR = Type + newtype N5 :: Bool -> STAR -- bad + +6. Family return kind restrictions: The return kind of a data family must + be either TYPE xyz (for some xyz) or a kind variable. The idea is that + instances may specialise the kind variable to fit one of the restrictions + above. This is checked by the call to checkDataKindSig in tcFamDecl1. + Examples: + + data family D1 :: Type -- good + data family D2 :: Bool -> Type -- good + data family D3 k :: k -- good + data family D4 :: forall k -> k -- good + data family D5 :: forall k. k -> k -- good + data family D6 :: forall r. TYPE r -- good + data family D7 :: Bool -> STAR -- bad (see STAR from point 5) + +7. Two return kinds for instances: If an instance has two return kinds, + one from the family declaration and one from the instance declaration + (see point (2) above), they are unified. More accurately, we make sure + that the kind of the applied data family is a subkind of the user-written + kind. GHC.Tc.Gen.HsType.checkExpectedKind normally does this check for types, but + that's overkill for our needs here. Instead, we just instantiate any + invisible binders in the (instantiated) kind of the data family + (called lhs_kind in tcDataFamInstHeader) with tcInstInvisibleTyBinders + and then unify the resulting kind with the kind written by the user. + This unification naturally produces a coercion, which we can drop, as + the kind annotation on the instance is redundant (except perhaps for + effects of unification). + + Example: + + data Color = Red | Blue + type family Interpret (x :: Color) :: RuntimeRep where + Interpret 'Red = 'IntRep + Interpret 'Blue = 'WordRep + data family Foo (x :: Color) :: TYPE (Interpret x) + newtype instance Foo 'Red :: TYPE IntRep where + FooRedC :: Int# -> Foo 'Red + + Here we get that Foo 'Red :: TYPE (Interpret Red) and we have to + unify the kind with TYPE IntRep. + + Example requiring subkinding: + + data family D :: forall k. k + data instance D :: Type -- forall k. k <: Type + data instance D :: Type -> Type -- forall k. k <: Type -> Type + -- NB: these do not overlap + + This all is Wrinkle (3) in Note [Implementation of UnliftedNewtypes]. + +-} + +{- ********************************************************************* +* * + Type family declarations +* * +********************************************************************* -} + +tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon +tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info + , fdLName = tc_lname@(L _ tc_name) + , fdResultSig = L _ sig + , fdInjectivityAnn = inj }) + | DataFamily <- fam_info + = bindTyClTyVars tc_name $ \ _ binders res_kind -> do + { traceTc "data family:" (ppr tc_name) + ; checkFamFlag tc_name + + -- Check that the result kind is OK + -- We allow things like + -- data family T (a :: Type) :: forall k. k -> Type + -- We treat T as having arity 1, but result kind forall k. k -> Type + -- But we want to check that the result kind finishes in + -- Type or a kind-variable + -- For the latter, consider + -- data family D a :: forall k. Type -> k + -- When UnliftedNewtypes is enabled, we loosen this restriction + -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1). + -- See also Note [Datatype return kinds] + ; let (_, final_res_kind) = splitPiTys res_kind + ; checkDataKindSig DataFamilySort final_res_kind + ; tc_rep_name <- newTyConRepName tc_name + ; let inj = Injective $ replicate (length binders) True + tycon = mkFamilyTyCon tc_name binders + res_kind + (resultVariableName sig) + (DataFamilyTyCon tc_rep_name) + parent inj + ; return tycon } + + | OpenTypeFamily <- fam_info + = bindTyClTyVars tc_name $ \ _ binders res_kind -> do + { traceTc "open type family:" (ppr tc_name) + ; checkFamFlag tc_name + ; inj' <- tcInjectivity binders inj + ; checkResultSigFlag tc_name sig -- check after injectivity for better errors + ; let tycon = mkFamilyTyCon tc_name binders res_kind + (resultVariableName sig) OpenSynFamilyTyCon + parent inj' + ; return tycon } + + | ClosedTypeFamily mb_eqns <- fam_info + = -- Closed type families are a little tricky, because they contain the definition + -- of both the type family and the equations for a CoAxiom. + do { traceTc "Closed type family:" (ppr tc_name) + -- the variables in the header scope only over the injectivity + -- declaration but this is not involved here + ; (inj', binders, res_kind) + <- bindTyClTyVars tc_name $ \ _ binders res_kind -> + do { inj' <- tcInjectivity binders inj + ; return (inj', binders, res_kind) } + + ; checkFamFlag tc_name -- make sure we have -XTypeFamilies + ; checkResultSigFlag tc_name sig + + -- If Nothing, this is an abstract family in a hs-boot file; + -- but eqns might be empty in the Just case as well + ; case mb_eqns of + Nothing -> + return $ mkFamilyTyCon tc_name binders res_kind + (resultVariableName sig) + AbstractClosedSynFamilyTyCon parent + inj' + Just eqns -> do { + + -- Process the equations, creating CoAxBranches + ; let tc_fam_tc = mkTcTyCon tc_name binders res_kind + noTcTyConScopedTyVars + False {- this doesn't matter here -} + ClosedTypeFamilyFlavour + + ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns + -- Do not attempt to drop equations dominated by earlier + -- ones here; in the case of mutual recursion with a data + -- type, we get a knot-tying failure. Instead we check + -- for this afterwards, in GHC.Tc.Validity.checkValidCoAxiom + -- Example: tc265 + + -- Create a CoAxiom, with the correct src location. + ; co_ax_name <- newFamInstAxiomName tc_lname [] + + ; let mb_co_ax + | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list + | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) + + fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig) + (ClosedSynFamilyTyCon mb_co_ax) parent inj' + + -- We check for instance validity later, when doing validity + -- checking for the tycon. Exception: checking equations + -- overlap done by dropDominatedAxioms + ; return fam_tc } } + +#if __GLASGOW_HASKELL__ <= 810 + | otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker +#endif + +-- | Maybe return a list of Bools that say whether a type family was declared +-- injective in the corresponding type arguments. Length of the list is equal to +-- the number of arguments (including implicit kind/coercion arguments). +-- True on position +-- N means that a function is injective in its Nth argument. False means it is +-- not. +tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) + -> TcM Injectivity +tcInjectivity _ Nothing + = return NotInjective + + -- User provided an injectivity annotation, so for each tyvar argument we + -- check whether a type family was declared injective in that argument. We + -- return a list of Bools, where True means that corresponding type variable + -- was mentioned in lInjNames (type family is injective in that argument) and + -- False means that it was not mentioned in lInjNames (type family is not + -- injective in that type variable). We also extend injectivity information to + -- kind variables, so if a user declares: + -- + -- type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a + -- + -- then we mark both `a` and `k1` as injective. + -- NB: the return kind is considered to be *input* argument to a type family. + -- Since injectivity allows to infer input arguments from the result in theory + -- we should always mark the result kind variable (`k3` in this example) as + -- injective. The reason is that result type has always an assigned kind and + -- therefore we can always infer the result kind if we know the result type. + -- But this does not seem to be useful in any way so we don't do it. (Another + -- reason is that the implementation would not be straightforward.) +tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) + = setSrcSpan loc $ + do { let tvs = binderVars tcbs + ; dflags <- getDynFlags + ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) + (text "Illegal injectivity annotation" $$ + text "Use TypeFamilyDependencies to allow this") + ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames + ; inj_tvs <- mapM zonkTcTyVarToTyVar 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 + ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs + , ppr inj_ktvs, ppr inj_bools ]) + ; return $ Injective inj_bools } + +tcTySynRhs :: RolesInfo -> Name + -> LHsType GhcRn -> TcM TyCon +tcTySynRhs roles_info tc_name hs_ty + = bindTyClTyVars tc_name $ \ _ binders res_kind -> + do { env <- getLclEnv + ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) + ; rhs_ty <- pushTcLevelM_ $ + solveEqualities $ + tcCheckLHsType hs_ty (TheKind res_kind) + ; rhs_ty <- zonkTcTypeToType rhs_ty + ; let roles = roles_info tc_name + tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty + ; return tycon } + +tcDataDefn :: SDoc -> RolesInfo -> Name + -> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo]) + -- NB: not used for newtype/data instances (whether associated or not) +tcDataDefn err_ctxt roles_info tc_name + (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = ctxt + , dd_kindSig = mb_ksig -- Already in tc's kind + -- via inferInitialKinds + , dd_cons = cons + , dd_derivs = derivs }) + = bindTyClTyVars tc_name $ \ tctc tycon_binders res_kind -> + -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need + -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon' + -- + -- The TyCon tyvars must scope over + -- - the stupid theta (dd_ctxt) + -- - for H98 constructors only, the ConDecl + -- But it does no harm to bring them into scope + -- over GADT ConDecls as well; and it's awkward not to + do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons + -- see Note [Datatype return kinds] + ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind + + ; tcg_env <- getGblEnv + ; let hsc_src = tcg_src tcg_env + ; unless (mk_permissive_kind hsc_src cons) $ + checkDataKindSig (DataDeclSort new_or_data) final_res_kind + + ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt + ; stupid_theta <- zonkTcTypesToTypes stupid_tc_theta + ; kind_signatures <- xoptM LangExt.KindSignatures + + -- Check that we don't use kind signatures without Glasgow extensions + ; when (isJust mb_ksig) $ + checkTc (kind_signatures) (badSigTyDecl tc_name) + + ; tycon <- fixM $ \ tycon -> do + { let final_bndrs = tycon_binders `chkAppend` extra_bndrs + res_ty = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs)) + roles = roles_info tc_name + ; data_cons <- tcConDecls + tycon + new_or_data + final_bndrs + final_res_kind + res_ty + cons + ; tc_rhs <- mk_tc_rhs hsc_src tycon data_cons + ; tc_rep_nm <- newTyConRepName tc_name + ; return (mkAlgTyCon tc_name + final_bndrs + final_res_kind + roles + (fmap unLoc cType) + stupid_theta tc_rhs + (VanillaAlgTyCon tc_rep_nm) + gadt_syntax) } + ; let deriv_info = DerivInfo { di_rep_tc = tycon + , di_scoped_tvs = tcTyConScopedTyVars tctc + , di_clauses = unLoc derivs + , di_ctxt = err_ctxt } + ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs) + ; return (tycon, [deriv_info]) } + where + -- Abstract data types in hsig files can have arbitrary kinds, + -- because they may be implemented by type synonyms + -- (which themselves can have arbitrary kinds, not just *). See #13955. + -- + -- Note that this is only a property that data type declarations possess, + -- so one could not have, say, a data family instance in an hsig file that + -- has kind `Bool`. Therefore, this check need only occur in the code that + -- typechecks data type declarations. + mk_permissive_kind HsigFile [] = True + mk_permissive_kind _ _ = False + + -- In hs-boot, a 'data' declaration with no constructors + -- indicates a nominally distinct abstract data type. + mk_tc_rhs HsBootFile _ [] + = return AbstractTyCon + + mk_tc_rhs HsigFile _ [] -- ditto + = return AbstractTyCon + + mk_tc_rhs _ tycon data_cons + = case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs tc_name tycon (head data_cons) + + +------------------------- +kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () +-- Used for the equations of a closed type family only +-- Not used for data/type instances +kcTyFamInstEqn tc_fam_tc + (L loc (HsIB { hsib_ext = imp_vars + , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name + , feqn_bndrs = mb_expl_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty }})) + = setSrcSpan loc $ + do { traceTc "kcTyFamInstEqn" (vcat + [ text "tc_name =" <+> ppr eqn_tc_name + , text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc) + , text "hsib_vars =" <+> ppr imp_vars + , text "feqn_bndrs =" <+> ppr mb_expl_bndrs + , text "feqn_pats =" <+> ppr hs_pats ]) + -- this check reports an arity error instead of a kind error; easier for user + ; let vis_pats = numVisibleArgs hs_pats + ; checkTc (vis_pats == vis_arity) $ + wrongNumberOfParmsErr vis_arity + ; discardResult $ + bindImplicitTKBndrs_Q_Tv imp_vars $ + bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $ + do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats + ; tcCheckLHsType hs_rhs_ty (TheKind res_kind) } + -- Why "_Tv" here? Consider (#14066 + -- type family Bar x y where + -- Bar (x :: a) (y :: b) = Int + -- Bar (x :: c) (y :: d) = Bool + -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately + } + where + vis_arity = length (tyConVisibleTyVars tc_fam_tc) + + +-------------------------- +tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn + -> TcM (KnotTied CoAxBranch) +-- Needs to be here, not in GHC.Tc.TyCl.Instance, because closed families +-- (typechecked here) have TyFamInstEqns + +tcTyFamInstEqn fam_tc mb_clsinfo + (L loc (HsIB { hsib_ext = imp_vars + , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name + , feqn_bndrs = mb_expl_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty }})) + = ASSERT( getName fam_tc == eqn_tc_name ) + setSrcSpan loc $ + do { traceTc "tcTyFamInstEqn" $ + vcat [ ppr fam_tc <+> ppr hs_pats + , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc) + , case mb_clsinfo of + NotAssociated -> empty + InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ] + + -- First, check the arity of visible arguments + -- If we wait until validity checking, we'll get kind errors + -- below when an arity error will be much easier to understand. + ; let vis_arity = length (tyConVisibleTyVars fam_tc) + vis_pats = numVisibleArgs hs_pats + ; checkTc (vis_pats == vis_arity) $ + wrongNumberOfParmsErr vis_arity + ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo + imp_vars (mb_expl_bndrs `orElse` []) + hs_pats hs_rhs_ty + -- Don't print results they may be knot-tied + -- (tcFamInstEqnGuts zonks to Type) + ; return (mkCoAxBranch qtvs [] [] fam_tc pats rhs_ty + (map (const Nominal) qtvs) + loc) } + +{- +Kind check type patterns and kind annotate the embedded type variables. + type instance F [a] = rhs + + * Here we check that a type instance matches its kind signature, but we do + not check whether there is a pattern for each type index; the latter + check is only required for type synonym instances. + +Note [Instantiating a family tycon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's possible that kind-checking the result of a family tycon applied to +its patterns will instantiate the tycon further. For example, we might +have + + type family F :: k where + F = Int + F = Maybe + +After checking (F :: forall k. k) (with no visible patterns), we still need +to instantiate the k. With data family instances, this problem can be even +more intricate, due to Note [Arity of data families] in GHC.Core.FamInstEnv. See +indexed-types/should_compile/T12369 for an example. + +So, the kind-checker must return the new skolems and args (that is, Type +or (Type -> Type) for the equations above) and the instantiated kind. + +Note [Generalising in tcTyFamInstEqnGuts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have something like + type instance forall (a::k) b. F t1 t2 = rhs + +Then imp_vars = [k], exp_bndrs = [a::k, b] + +We want to quantify over + * k, a, and b (all user-specified) + * and any inferred free kind vars from + - the kinds of k, a, b + - the types t1, t2 + +However, unlike a type signature like + f :: forall (a::k). blah + +we do /not/ care about the Inferred/Specified designation +or order for the final quantified tyvars. Type-family +instances are not invoked directly in Haskell source code, +so visible type application etc plays no role. + +So, the simple thing is + - gather candidates from [k, a, b] and pats + - quantify over them + +Hence the slightly mysterious call: + candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs) + +Simple, neat, but a little non-obvious! + +See also Note [Re-quantify type variables in rules] in GHC.Tc.Gen.Rule, which explains +a very similar design when generalising over the type of a rewrite rule. +-} + +-------------------------- +tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo + -> [Name] -> [LHsTyVarBndr GhcRn] -- Implicit and explicicit binder + -> HsTyPats GhcRn -- Patterns + -> LHsType GhcRn -- RHS + -> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs) +-- Used only for type families, not data families +tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty + = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc) + + -- By now, for type families (but not data families) we should + -- have checked that the number of patterns matches tyConArity + + -- This code is closely related to the code + -- in GHC.Tc.Gen.HsType.kcCheckDeclHeader_cusk + ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty))) + <- pushTcLevelM_ $ + solveEqualities $ + bindImplicitTKBndrs_Q_Skol imp_vars $ + bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ + do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats + -- Ensure that the instance is consistent with its + -- parent class (#16008) + ; addConsistencyConstraints mb_clsinfo lhs_ty + ; rhs_ty <- tcCheckLHsType hs_rhs_ty (TheKind rhs_kind) + ; return (lhs_ty, rhs_ty) } + + -- See Note [Generalising in tcTyFamInstEqnGuts] + -- This code (and the stuff immediately above) is very similar + -- to that in tcDataFamInstHeader. Maybe we should abstract the + -- common code; but for the moment I concluded that it's + -- clearer to duplicate it. Still, if you fix a bug here, + -- check there too! + ; let scoped_tvs = imp_tvs ++ exp_tvs + ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) + ; qtvs <- quantifyTyVars dvs + + ; traceTc "tcTyFamInstEqnGuts 2" $ + vcat [ ppr fam_tc + , text "scoped_tvs" <+> pprTyVars scoped_tvs + , text "lhs_ty" <+> ppr lhs_ty + , text "dvs" <+> ppr dvs + , text "qtvs" <+> pprTyVars qtvs ] + + ; (ze, qtvs) <- zonkTyBndrs qtvs + ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty + ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty + + ; let pats = unravelFamInstPats lhs_ty + -- Note that we do this after solveEqualities + -- so that any strange coercions inside lhs_ty + -- have been solved before we attempt to unravel it + ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs) + ; return (qtvs, pats, rhs_ty) } + +----------------- +tcFamTyPats :: TyCon + -> HsTyPats GhcRn -- Patterns + -> TcM (TcType, TcKind) -- (lhs_type, lhs_kind) +-- Used for both type and data families +tcFamTyPats fam_tc hs_pats + = do { traceTc "tcFamTyPats {" $ + vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ] + + ; let fun_ty = mkTyConApp fam_tc [] + + ; (fam_app, res_kind) <- unsetWOptM Opt_WarnPartialTypeSignatures $ + setXOptM LangExt.PartialTypeSignatures $ + -- See Note [Wildcards in family instances] in + -- GHC.Rename.Module + tcInferApps typeLevelMode lhs_fun fun_ty hs_pats + + ; traceTc "End tcFamTyPats }" $ + vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ] + + ; return (fam_app, res_kind) } + where + fam_name = tyConName fam_tc + fam_arity = tyConArity fam_tc + lhs_fun = noLoc (HsTyVar noExtField NotPromoted (noLoc fam_name)) + +unravelFamInstPats :: TcType -> [TcType] +-- Decompose fam_app to get the argument patterns +-- +-- We expect fam_app to look like (F t1 .. tn) +-- tcInferApps is capable of returning ((F ty1 |> co) ty2), +-- but that can't happen here because we already checked the +-- arity of F matches the number of pattern +unravelFamInstPats fam_app + = case splitTyConApp_maybe fam_app of + Just (_, pats) -> pats + Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance" + -- The Nothing case cannot happen for type families, because + -- we don't call unravelFamInstPats until we've solved the + -- equalities. For data families, it shouldn't happen either, + -- we need to fail hard and early if it does. See trac issue #15905 + -- for an example of this happening. + +addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM () +-- In the corresponding positions of the class and type-family, +-- ensure the the family argument is the same as the class argument +-- E.g class C a b c d where +-- F c x y a :: Type +-- Here the first arg of F should be the same as the third of C +-- and the fourth arg of F should be the same as the first of C +-- +-- We emit /Derived/ constraints (a bit like fundeps) to encourage +-- unification to happen, but without actually reporting errors. +-- If, despite the efforts, corresponding positions do not match, +-- checkConsistentFamInst will complain +addConsistencyConstraints mb_clsinfo fam_app + | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo + , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app + = do { let eqs = [ (cls_ty, pat) + | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats + , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ] + ; traceTc "addConsistencyConstraints" (ppr eqs) + ; emitDerivedEqs AssocFamPatOrigin eqs } + -- Improve inference + -- Any mis-match is reports by checkConsistentFamInst + | otherwise + = return () + +{- Note [Constraints in patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: This isn't the whole story. See comment in tcFamTyPats. + +At first glance, it seems there is a complicated story to tell in tcFamTyPats +around constraint solving. After all, type family patterns can now do +GADT pattern-matching, which is jolly complicated. But, there's a key fact +which makes this all simple: everything is at top level! There cannot +be untouchable type variables. There can't be weird interaction between +case branches. There can't be global skolems. + +This means that the semantics of type-level GADT matching is a little +different than term level. If we have + + data G a where + MkGBool :: G Bool + +And then + + type family F (a :: G k) :: k + type instance F MkGBool = True + +we get + + axF : F Bool (MkGBool ) ~ True + +Simple! No casting on the RHS, because we can affect the kind parameter +to F. + +If we ever introduce local type families, this all gets a lot more +complicated, and will end up looking awfully like term-level GADT +pattern-matching. + + +** The new story ** + +Here is really what we want: + +The matcher really can't deal with covars in arbitrary spots in coercions. +But it can deal with covars that are arguments to GADT data constructors. +So we somehow want to allow covars only in precisely those spots, then use +them as givens when checking the RHS. TODO (RAE): Implement plan. + +Note [Quantified kind variables of a family pattern] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider type family KindFam (p :: k1) (q :: k1) + data T :: Maybe k1 -> k2 -> * + type instance KindFam (a :: Maybe k) b = T a b -> Int +The HsBSig for the family patterns will be ([k], [a]) + +Then in the family instance we want to + * Bring into scope [ "k" -> k:*, "a" -> a:k ] + * Kind-check the RHS + * Quantify the type instance over k and k', as well as a,b, thus + type instance [k, k', a:Maybe k, b:k'] + KindFam (Maybe k) k' a b = T k k' a b -> Int + +Notice that in the third step we quantify over all the visibly-mentioned +type variables (a,b), but also over the implicitly mentioned kind variables +(k, k'). In this case one is bound explicitly but often there will be +none. The role of the kind signature (a :: Maybe k) is to add a constraint +that 'a' must have that kind, and to bring 'k' into scope. + + + +************************************************************************ +* * + Data types +* * +************************************************************************ +-} + +dataDeclChecks :: Name -> NewOrData + -> LHsContext GhcRn -> [LConDecl GhcRn] + -> TcM Bool +dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons + = do { -- Check that we don't use GADT syntax in H98 world + gadtSyntax_ok <- xoptM LangExt.GADTSyntax + ; let gadt_syntax = consUseGadtSyntax cons + ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name) + + -- Check that the stupid theta is empty for a GADT-style declaration + ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name) + + -- Check that a newtype has exactly one constructor + -- Do this before checking for empty data decls, so that + -- we don't suggest -XEmptyDataDecls for newtypes + ; checkTc (new_or_data == DataType || isSingleton cons) + (newtypeConError tc_name (length cons)) + + -- 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) + ; return gadt_syntax } + + +----------------------------------- +consUseGadtSyntax :: [LConDecl a] -> Bool +consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True +consUseGadtSyntax _ = False + -- All constructors have same shape + +----------------------------------- +tcConDecls :: KnotTied TyCon -> NewOrData + -> [TyConBinder] -> TcKind -- binders and result kind of tycon + -> KnotTied Type -> [LConDecl GhcRn] -> TcM [DataCon] +tcConDecls rep_tycon new_or_data tmpl_bndrs res_kind res_tmpl + = concatMapM $ addLocM $ + tcConDecl rep_tycon (mkTyConTagMap rep_tycon) + tmpl_bndrs res_kind res_tmpl new_or_data + -- It's important that we pay for tag allocation here, once per TyCon, + -- See Note [Constructor tag allocation], fixes #14657 + +tcConDecl :: KnotTied TyCon -- Representation tycon. Knot-tied! + -> NameEnv ConTag + -> [TyConBinder] -> TcKind -- tycon binders and result kind + -> KnotTied Type + -- Return type template (T tys), where T is the family TyCon + -> NewOrData + -> ConDecl GhcRn + -> TcM [DataCon] + +tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data + (ConDeclH98 { con_name = name + , con_ex_tvs = explicit_tkv_nms + , con_mb_cxt = hs_ctxt + , con_args = hs_args }) + = addErrCtxt (dataConCtxtName [name]) $ + do { -- NB: the tyvars from the declaration header are in scope + + -- Get hold of the existential type variables + -- e.g. data T a = forall k (b::k) f. MkT a (f b) + -- Here tmpl_bndrs = {a} + -- hs_qvars = HsQTvs { hsq_implicit = {k} + -- , hsq_explicit = {f,b} } + + ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ]) + + ; (exp_tvs, (ctxt, arg_tys, field_lbls, stricts)) + <- pushTcLevelM_ $ + solveEqualities $ + bindExplicitTKBndrs_Skol explicit_tkv_nms $ + do { ctxt <- tcHsMbContext hs_ctxt + ; let exp_kind = getArgExpKind new_or_data res_kind + ; btys <- tcConArgs exp_kind hs_args + ; field_lbls <- lookupConstructorFields (unLoc name) + ; let (arg_tys, stricts) = unzip btys + ; return (ctxt, arg_tys, field_lbls, stricts) + } + + -- exp_tvs have explicit, user-written binding sites + -- the kvs below are those kind variables entirely unmentioned by the user + -- and discovered only by generalization + + ; kvs <- kindGeneralizeAll (mkSpecForAllTys (binderVars tmpl_bndrs) $ + mkSpecForAllTys exp_tvs $ + mkPhiTy ctxt $ + mkVisFunTys arg_tys $ + unitTy) + -- That type is a lie, of course. (It shouldn't end in ()!) + -- And we could construct a proper result type from the info + -- at hand. But the result would mention only the tmpl_tvs, + -- and so it just creates more work to do it right. Really, + -- we're only doing this to find the right kind variables to + -- quantify over, and this type is fine for that purpose. + + -- Zonk to Types + ; (ze, qkvs) <- zonkTyBndrs kvs + ; (ze, user_qtvs) <- zonkTyBndrsX ze exp_tvs + ; arg_tys <- zonkTcTypesToTypesX ze arg_tys + ; ctxt <- zonkTcTypesToTypesX ze ctxt + + ; fam_envs <- tcGetFamInstEnvs + + -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here + ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) + ; let + univ_tvbs = tyConTyVarBinders tmpl_bndrs + univ_tvs = binderVars univ_tvbs + ex_tvbs = mkTyVarBinders Inferred qkvs ++ + mkTyVarBinders Specified user_qtvs + ex_tvs = qkvs ++ user_qtvs + -- For H98 datatypes, the user-written tyvar binders are precisely + -- the universals followed by the existentials. + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. + user_tvbs = univ_tvbs ++ ex_tvbs + buildOneDataCon (L _ name) = do + { is_infix <- tcConIsInfixH98 name hs_args + ; rep_nm <- newTyConRepName name + + ; buildDataCon fam_envs name is_infix rep_nm + stricts Nothing field_lbls + univ_tvs ex_tvs user_tvbs + [{- no eq_preds -}] ctxt arg_tys + res_tmpl rep_tycon tag_map + -- NB: we put data_tc, the type constructor gotten from the + -- constructor type signature into the data constructor; + -- that way checkValidDataCon can complain if it's wrong. + } + ; traceTc "tcConDecl 2" (ppr name) + ; mapM buildOneDataCon [name] + } + +tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data + -- NB: don't use res_kind here, as it's ill-scoped. Instead, we get + -- the res_kind by typechecking the result type. + (ConDeclGADT { con_names = names + , con_qvars = qtvs + , con_mb_cxt = cxt, con_args = hs_args + , con_res_ty = hs_res_ty }) + | HsQTvs { hsq_ext = implicit_tkv_nms + , hsq_explicit = explicit_tkv_nms } <- qtvs + = addErrCtxt (dataConCtxtName names) $ + do { traceTc "tcConDecl 1 gadt" (ppr names) + ; let (L _ name : _) = names + + ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) + <- pushTcLevelM_ $ -- We are going to generalise + solveEqualities $ -- We won't get another crack, and we don't + -- want an error cascade + bindImplicitTKBndrs_Skol implicit_tkv_nms $ + bindExplicitTKBndrs_Skol explicit_tkv_nms $ + do { ctxt <- tcHsMbContext cxt + ; casted_res_ty <- tcHsOpenType hs_res_ty + ; res_ty <- if not debugIsOn then return $ discardCast casted_res_ty + else case splitCastTy_maybe casted_res_ty of + Just (ty, _) -> do unlifted_nts <- xoptM LangExt.UnliftedNewtypes + MASSERT( unlifted_nts ) + MASSERT( new_or_data == NewType ) + return ty + _ -> return casted_res_ty + -- See Note [Datatype return kinds] + ; let exp_kind = getArgExpKind new_or_data (typeKind res_ty) + ; btys <- tcConArgs exp_kind hs_args + ; let (arg_tys, stricts) = unzip btys + ; field_lbls <- lookupConstructorFields name + ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) + } + ; imp_tvs <- zonkAndScopedSort imp_tvs + ; let user_tvs = imp_tvs ++ exp_tvs + + ; tkvs <- kindGeneralizeAll (mkSpecForAllTys user_tvs $ + mkPhiTy ctxt $ + mkVisFunTys arg_tys $ + res_ty) + + -- Zonk to Types + ; (ze, tkvs) <- zonkTyBndrs tkvs + ; (ze, user_tvs) <- zonkTyBndrsX ze user_tvs + ; arg_tys <- zonkTcTypesToTypesX ze arg_tys + ; ctxt <- zonkTcTypesToTypesX ze ctxt + ; res_ty <- zonkTcTypeToTypeX ze res_ty + + ; let (univ_tvs, ex_tvs, tkvs', user_tvs', eq_preds, arg_subst) + = rejigConRes tmpl_bndrs res_tmpl tkvs user_tvs res_ty + -- NB: this is a /lazy/ binding, so we pass six thunks to + -- buildDataCon without yet forcing the guards in rejigConRes + -- See Note [Checking GADT return types] + + -- Compute the user-written tyvar binders. These have the same + -- tyvars as univ_tvs/ex_tvs, but perhaps in a different order. + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. + tkv_bndrs = mkTyVarBinders Inferred tkvs' + user_tv_bndrs = mkTyVarBinders Specified user_tvs' + all_user_bndrs = tkv_bndrs ++ user_tv_bndrs + + ctxt' = substTys arg_subst ctxt + arg_tys' = substTys arg_subst arg_tys + res_ty' = substTy arg_subst res_ty + + + ; fam_envs <- tcGetFamInstEnvs + + -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here + ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) + ; let + buildOneDataCon (L _ name) = do + { is_infix <- tcConIsInfixGADT name hs_args + ; rep_nm <- newTyConRepName name + + ; buildDataCon fam_envs name is_infix + rep_nm + stricts Nothing field_lbls + univ_tvs ex_tvs all_user_bndrs eq_preds + ctxt' arg_tys' res_ty' rep_tycon tag_map + -- NB: we put data_tc, the type constructor gotten from the + -- constructor type signature into the data constructor; + -- that way checkValidDataCon can complain if it's wrong. + } + ; traceTc "tcConDecl 2" (ppr names) + ; mapM buildOneDataCon names + } + +-- | Produce an "expected kind" for the arguments of a data/newtype. +-- If the declaration is indeed for a newtype, +-- then this expected kind will be the kind provided. Otherwise, +-- it is OpenKind for datatypes and liftedTypeKind. +-- Why do we not check for -XUnliftedNewtypes? See point +-- in Note [Implementation of UnliftedNewtypes] +getArgExpKind :: NewOrData -> Kind -> ContextKind +getArgExpKind NewType res_ki = TheKind res_ki +getArgExpKind DataType _ = OpenKind + +tcConIsInfixH98 :: Name + -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) + -> TcM Bool +tcConIsInfixH98 _ details + = case details of + InfixCon {} -> return True + _ -> return False + +tcConIsInfixGADT :: Name + -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) + -> TcM Bool +tcConIsInfixGADT con details + = case details of + InfixCon {} -> return True + RecCon {} -> return False + PrefixCon arg_tys -- See Note [Infix GADT constructors] + | isSymOcc (getOccName con) + , [_ty1,_ty2] <- arg_tys + -> do { fix_env <- getFixityEnv + ; return (con `elemNameEnv` fix_env) } + | otherwise -> return False + +tcConArgs :: ContextKind -- expected kind of arguments + -- always OpenKind for datatypes, but unlifted newtypes + -- might have a specific kind + -> HsConDeclDetails GhcRn + -> TcM [(TcType, HsSrcBang)] +tcConArgs exp_kind (PrefixCon btys) + = mapM (tcConArg exp_kind) btys +tcConArgs exp_kind (InfixCon bty1 bty2) + = do { bty1' <- tcConArg exp_kind bty1 + ; bty2' <- tcConArg exp_kind bty2 + ; return [bty1', bty2'] } +tcConArgs exp_kind (RecCon fields) + = mapM (tcConArg exp_kind) btys + where + -- We need a one-to-one mapping from field_names to btys + combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) + (unLoc fields) + explode (ns,ty) = zip ns (repeat ty) + exploded = concatMap explode combined + (_,btys) = unzip exploded + + +tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes, + -- but might be an unlifted type with UnliftedNewtypes + -> LHsType GhcRn -> TcM (TcType, HsSrcBang) +tcConArg exp_kind bty + = do { traceTc "tcConArg 1" (ppr bty) + ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind + ; traceTc "tcConArg 2" (ppr bty) + ; return (arg_ty, getBangStrictness bty) } + +{- +Note [Infix GADT constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not currently have syntax to declare an infix constructor in GADT syntax, +but it makes a (small) difference to the Show instance. So as a slightly +ad-hoc solution, we regard a GADT data constructor as infix if + a) it is an operator symbol + b) it has two arguments + c) there is a fixity declaration for it +For example: + infix 6 (:--:) + data T a where + (:--:) :: t1 -> t2 -> T Int + + +Note [Checking GADT return types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a delicacy around checking the return types of a datacon. The +central problem is dealing with a declaration like + + data T a where + MkT :: T a -> Q a + +Note that the return type of MkT is totally bogus. When creating the T +tycon, we also need to create the MkT datacon, which must have a "rejigged" +return type. That is, the MkT datacon's type must be transformed to have +a uniform return type with explicit coercions for GADT-like type parameters. +This rejigging is what rejigConRes does. The problem is, though, that checking +that the return type is appropriate is much easier when done over *Type*, +not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully +defined yet. + +So, we want to make rejigConRes lazy and then check the validity of +the return type in checkValidDataCon. To do this we /always/ return a +6-tuple from rejigConRes (so that we can compute the return type from it, which +checkValidDataCon needs), but the first three fields may be bogus if +the return type isn't valid (the last equation for rejigConRes). + +This is better than an earlier solution which reduced the number of +errors reported in one pass. See #7175, and #10836. +-} + +-- Example +-- data instance T (b,c) where +-- TI :: forall e. e -> T (e,e) +-- +-- The representation tycon looks like this: +-- data :R7T b c where +-- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 +-- In this case orig_res_ty = T (e,e) + +rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type -- Template for result type; e.g. + -- data instance T [a] b c ... + -- gives template ([a,b,c], T [a] b c) + -> [TyVar] -- The constructor's inferred type variables + -> [TyVar] -- The constructor's user-written, specified + -- type variables + -> KnotTied Type -- res_ty + -> ([TyVar], -- Universal + [TyVar], -- Existential (distinct OccNames from univs) + [TyVar], -- The constructor's rejigged, user-written, + -- inferred type variables + [TyVar], -- The constructor's rejigged, user-written, + -- specified type variables + [EqSpec], -- Equality predicates + TCvSubst) -- Substitution to apply to argument types + -- We don't check that the TyCon given in the ResTy is + -- the same as the parent tycon, because checkValidDataCon will do it +-- NB: All arguments may potentially be knot-tied +rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty + -- E.g. data T [a] b c where + -- MkT :: forall x y z. T [(x,y)] z z + -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs + -- (NB: unlike the H98 case, the dc_tvs are not all existential) + -- Then we generate + -- Univ tyvars Eq-spec + -- a a~(x,y) + -- b b~z + -- z + -- Existentials are the leftover type vars: [x,y] + -- The user-written type variables are what is listed in the forall: + -- [x, y, z] (all specified). We must rejig these as well. + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. + -- So we return ( [a,b,z], [x,y] + -- , [], [x,y,z] + -- , [a~(x,y),b~z], ) + | Just subst <- tcMatchTy res_tmpl res_ty + = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst + raw_ex_tvs = dc_tvs `minusList` univ_tvs + (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs + + -- After rejigging the existential tyvars, the resulting substitution + -- gives us exactly what we need to rejig the user-written tyvars, + -- since the dcUserTyVarBinders invariant guarantees that the + -- substitution has *all* the tyvars in its domain. + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. + subst_user_tvs = map (getTyVar "rejigConRes" . substTyVar arg_subst) + substed_inferred_tvs = subst_user_tvs dc_inferred_tvs + substed_specified_tvs = subst_user_tvs dc_specified_tvs + + substed_eqs = map (substEqSpec arg_subst) raw_eqs + in + (univ_tvs, substed_ex_tvs, substed_inferred_tvs, substed_specified_tvs, + substed_eqs, arg_subst) + + | otherwise + -- If the return type of the data constructor doesn't match the parent + -- type constructor, or the arity is wrong, the tcMatchTy will fail + -- e.g data T a b where + -- T1 :: Maybe a -- Wrong tycon + -- T2 :: T [a] -- Wrong arity + -- We are detect that later, in checkValidDataCon, but meanwhile + -- we must do *something*, not just crash. So we do something simple + -- albeit bogus, relying on checkValidDataCon to check the + -- bad-result-type error before seeing that the other fields look odd + -- See Note [Checking GADT return types] + = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_inferred_tvs, dc_specified_tvs, + [], emptyTCvSubst) + where + dc_tvs = dc_inferred_tvs ++ dc_specified_tvs + tmpl_tvs = binderVars tmpl_bndrs + +{- Note [mkGADTVars] +~~~~~~~~~~~~~~~~~~~~ +Running example: + +data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where + MkT :: forall (x1 : *) (y :: x1) (z :: *). + T x1 * (Proxy (y :: x1), z) z + +We need the rejigged type to be + + MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2). + forall (y :: x1) (z :: *). + (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z) + => T x1 k2 a b + +You might naively expect that z should become a universal tyvar, +not an existential. (After all, x1 becomes a universal tyvar.) +But z has kind * while b has kind k2, so the return type + T x1 k2 a z +is ill-kinded. Another way to say it is this: the universal +tyvars must have exactly the same kinds as the tyConTyVars. + +So we need an existential tyvar and a heterogeneous equality +constraint. (The b ~ z is a bit redundant with the k2 ~ * that +comes before in that b ~ z implies k2 ~ *. I'm sure we could do +some analysis that could eliminate k2 ~ *. But we don't do this +yet.) + +The data con signature has already been fully kind-checked. +The return type + + T x1 * (Proxy (y :: x1), z) z +becomes + qtkvs = [x1 :: *, y :: x1, z :: *] + res_tmpl = T x1 * (Proxy x1 y, z) z + +We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We +know this match will succeed because of the validity check (actually done +later, but laziness saves us -- see Note [Checking GADT return types]). +Thus, we get + + subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z } + +Now, we need to figure out what the GADT equalities should be. In this case, +we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a +renaming. The others should be GADT equalities. We also need to make +sure that the universally-quantified variables of the datacon match up +with the tyvars of the tycon, as required for Core context well-formedness. +(This last bit is why we have to rejig at all!) + +`choose` walks down the tycon tyvars, figuring out what to do with each one. +It carries two substitutions: + - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables + mentioned in the datacon signature. + - r_sub's domain is *result* tyvars, names written by the programmer in + the datacon signature. The final rejigged type will use these names, but + the subst is still needed because sometimes the printed name of these variables + is different. (See choose_tv_name, below.) + +Before explaining the details of `choose`, let's just look at its operation +on our example: + + choose [] [] {} {} [k1, k2, a, b] + --> -- first branch of `case` statement + choose + univs: [x1 :: *] + eq_spec: [] + t_sub: {k1 |-> x1} + r_sub: {x1 |-> x1} + t_tvs: [k2, a, b] + --> -- second branch of `case` statement + choose + univs: [k2 :: *, x1 :: *] + eq_spec: [k2 ~ *] + t_sub: {k1 |-> x1, k2 |-> k2} + r_sub: {x1 |-> x1} + t_tvs: [a, b] + --> -- second branch of `case` statement + choose + univs: [a :: k2, k2 :: *, x1 :: *] + eq_spec: [ a ~ (Proxy x1 y, z) + , k2 ~ * ] + t_sub: {k1 |-> x1, k2 |-> k2, a |-> a} + r_sub: {x1 |-> x1} + t_tvs: [b] + --> -- second branch of `case` statement + choose + univs: [b :: k2, a :: k2, k2 :: *, x1 :: *] + eq_spec: [ b ~ z + , a ~ (Proxy x1 y, z) + , k2 ~ * ] + t_sub: {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z} + r_sub: {x1 |-> x1} + t_tvs: [] + --> -- end of recursion + ( [x1 :: *, k2 :: *, a :: k2, b :: k2] + , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z] + , {x1 |-> x1} ) + +`choose` looks up each tycon tyvar in the matching (it *must* be matched!). + +* If it finds a bare result tyvar (the first branch of the `case` + statement), it checks to make sure that the result tyvar isn't yet + in the list of univ_tvs. If it is in that list, then we have a + repeated variable in the return type, and we in fact need a GADT + equality. + +* It then checks to make sure that the kind of the result tyvar + matches the kind of the template tyvar. This check is what forces + `z` to be existential, as it should be, explained above. + +* Assuming no repeated variables or kind-changing, we wish to use the + variable name given in the datacon signature (that is, `x1` not + `k1`), not the tycon signature (which may have been made up by + GHC). So, we add a mapping from the tycon tyvar to the result tyvar + to t_sub. + +* If we discover that a mapping in `subst` gives us a non-tyvar (the + second branch of the `case` statement), then we have a GADT equality + to create. We create a fresh equality, but we don't extend any + substitutions. The template variable substitution is meant for use + in universal tyvar kinds, and these shouldn't be affected by any + GADT equalities. + +This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways +of simplifying it: + +1) The first branch of the `case` statement is really an optimization, used +in order to get fewer GADT equalities. It might be possible to make a GADT +equality for *every* univ. tyvar, even if the equality is trivial, and then +either deal with the bigger type or somehow reduce it later. + +2) This algorithm strives to use the names for type variables as specified +by the user in the datacon signature. If we always used the tycon tyvar +names, for example, this would be simplified. This change would almost +certainly degrade error messages a bit, though. +-} + +-- ^ From information about a source datacon definition, extract out +-- what the universal variables and the GADT equalities should be. +-- See Note [mkGADTVars]. +mkGADTVars :: [TyVar] -- ^ The tycon vars + -> [TyVar] -- ^ The datacon vars + -> TCvSubst -- ^ The matching between the template result type + -- and the actual result type + -> ( [TyVar] + , [EqSpec] + , TCvSubst ) -- ^ The univ. variables, the GADT equalities, + -- and a subst to apply to the GADT equalities + -- and existentials. +mkGADTVars tmpl_tvs dc_tvs subst + = choose [] [] empty_subst empty_subst tmpl_tvs + where + in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs) + `unionInScope` getTCvInScope subst + empty_subst = mkEmptyTCvSubst in_scope + + choose :: [TyVar] -- accumulator of univ tvs, reversed + -> [EqSpec] -- accumulator of GADT equalities, reversed + -> TCvSubst -- template substitution + -> TCvSubst -- res. substitution + -> [TyVar] -- template tvs (the univ tvs passed in) + -> ( [TyVar] -- the univ_tvs + , [EqSpec] -- GADT equalities + , TCvSubst ) -- a substitution to fix kinds in ex_tvs + + choose univs eqs _t_sub r_sub [] + = (reverse univs, reverse eqs, r_sub) + choose univs eqs t_sub r_sub (t_tv:t_tvs) + | Just r_ty <- lookupTyVar subst t_tv + = case getTyVar_maybe r_ty of + Just r_tv + | not (r_tv `elem` univs) + , tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv)) + -> -- simple, well-kinded variable substitution. + choose (r_tv:univs) eqs + (extendTvSubst t_sub t_tv r_ty') + (extendTvSubst r_sub r_tv r_ty') + t_tvs + where + r_tv1 = setTyVarName r_tv (choose_tv_name r_tv t_tv) + r_ty' = mkTyVarTy r_tv1 + + -- Not a simple substitution: make an equality predicate + _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs) + (extendTvSubst t_sub t_tv (mkTyVarTy t_tv')) + -- We've updated the kind of t_tv, + -- so add it to t_sub (#14162) + r_sub t_tvs + where + t_tv' = updateTyVarKind (substTy t_sub) t_tv + + | otherwise + = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst) + + -- choose an appropriate name for a univ tyvar. + -- This *must* preserve the Unique of the result tv, so that we + -- can detect repeated variables. It prefers user-specified names + -- over system names. A result variable with a system name can + -- happen with GHC-generated implicit kind variables. + choose_tv_name :: TyVar -> TyVar -> Name + choose_tv_name r_tv t_tv + | isSystemName r_tv_name + = setNameUnique t_tv_name (getUnique r_tv_name) + + | otherwise + = r_tv_name + + where + r_tv_name = getName r_tv + t_tv_name = getName t_tv + +{- +Note [Substitution in template variables kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +data G (a :: Maybe k) where + MkG :: G Nothing + +With explicit kind variables + +data G k (a :: Maybe k) where + MkG :: G k1 (Nothing k1) + +Note how k1 is distinct from k. So, when we match the template +`G k a` against `G k1 (Nothing k1)`, we get a subst +[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two +mappings, we surely don't want to add (k, k1) to the list of +GADT equalities -- that would be overly complex and would create +more untouchable variables than we need. So, when figuring out +which tyvars are GADT-like and which aren't (the fundamental +job of `choose`), we want to treat `k` as *not* GADT-like. +Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1) +instead of (a :: Maybe k). This is the reason for dealing +with a substitution in here. + +However, we do not *always* want to substitute. Consider + +data H (a :: k) where + MkH :: H Int + +With explicit kind variables: + +data H k (a :: k) where + MkH :: H * Int + +Here, we have a kind-indexed GADT. The subst in question is +[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s +kind, because that would give a constructor with the type + +MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a + +The problem here is that a's kind is wrong -- it needs to be k, not *! +So, if the matching for a variable is anything but another bare variable, +we drop the mapping from the substitution before proceeding. This +was not an issue before kind-indexed GADTs because this case could +never happen. + +************************************************************************ +* * + Validity checking +* * +************************************************************************ + +Validity checking is done once the mutually-recursive knot has been +tied, so we can look at things freely. +-} + +checkValidTyCl :: TyCon -> TcM [TyCon] +-- The returned list is either a singleton (if valid) +-- or a list of "fake tycons" (if not); the fake tycons +-- include any implicits, like promoted data constructors +-- See Note [Recover from validity error] +checkValidTyCl tc + = setSrcSpan (getSrcSpan tc) $ + addTyConCtxt tc $ + recoverM recovery_code $ + do { traceTc "Starting validity for tycon" (ppr tc) + ; checkValidTyCon tc + ; traceTc "Done validity for tycon" (ppr tc) + ; return [tc] } + where + recovery_code -- See Note [Recover from validity error] + = do { traceTc "Aborted validity for tycon" (ppr tc) + ; return (concatMap mk_fake_tc $ + ATyCon tc : implicitTyConThings tc) } + + mk_fake_tc (ATyCon tc) + | isClassTyCon tc = [tc] -- Ugh! Note [Recover from validity error] + | otherwise = [makeRecoveryTyCon tc] + mk_fake_tc (AConLike (RealDataCon dc)) + = [makeRecoveryTyCon (promoteDataCon dc)] + mk_fake_tc _ = [] + +{- Note [Recover from validity error] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We recover from a validity error in a type or class, which allows us +to report multiple validity errors. In the failure case we return a +TyCon of the right kind, but with no interesting behaviour +(makeRecoveryTyCon). Why? Suppose we have + type T a = Fun +where Fun is a type family of arity 1. The RHS is invalid, but we +want to go on checking validity of subsequent type declarations. +So we replace T with an abstract TyCon which will do no harm. +See indexed-types/should_fail/BadSock and #10896 + +Some notes: + +* We must make fakes for promoted DataCons too. Consider (#15215) + data T a = MkT ... + data S a = ...T...MkT.... + If there is an error in the definition of 'T' we add a "fake type + constructor" to the type environment, so that we can continue to + typecheck 'S'. But we /were not/ adding a fake anything for 'MkT' + and so there was an internal error when we met 'MkT' in the body of + 'S'. + +* Painfully, we *don't* want to do this for classes. + Consider tcfail041: + class (?x::Int) => C a where ... + instance C Int + The class is invalid because of the superclass constraint. But + we still want it to look like a /class/, else the instance bleats + that the instance is mal-formed because it hasn't got a class in + the head. + + This is really bogus; now we have in scope a Class that is invalid + in some way, with unknown downstream consequences. A better + alternative might be to make a fake class TyCon. A job for another day. +-} + +------------------------- +-- For data types declared with record syntax, we require +-- that each constructor that has a field 'f' +-- (a) has the same result type +-- (b) has the same type for 'f' +-- module alpha conversion of the quantified type variables +-- of the constructor. +-- +-- Note that we allow existentials to match because the +-- fields can never meet. E.g +-- data T where +-- T1 { f1 :: b, f2 :: a, f3 ::Int } :: T +-- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T +-- Here we do not complain about f1,f2 because they are existential + +checkValidTyCon :: TyCon -> TcM () +checkValidTyCon tc + | isPrimTyCon tc -- Happens when Haddock'ing GHC.Prim + = return () + + | isWiredIn tc -- validity-checking wired-in tycons is a waste of + -- time. More importantly, a wired-in tycon might + -- violate assumptions. Example: (~) has a superclass + -- mentioning (~#), which is ill-kinded in source Haskell + = traceTc "Skipping validity check for wired-in" (ppr tc) + + | otherwise + = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc)) + ; if | Just cl <- tyConClass_maybe tc + -> checkValidClass cl + + | Just syn_rhs <- synTyConRhs_maybe tc + -> do { checkValidType syn_ctxt syn_rhs + ; checkTySynRhs syn_ctxt syn_rhs } + + | Just fam_flav <- famTyConFlav_maybe tc + -> case fam_flav of + { ClosedSynFamilyTyCon (Just ax) + -> tcAddClosedTypeFamilyDeclCtxt tc $ + checkValidCoAxiom ax + ; ClosedSynFamilyTyCon Nothing -> return () + ; AbstractClosedSynFamilyTyCon -> + do { hsBoot <- tcIsHsBootOrSig + ; checkTc hsBoot $ + text "You may define an abstract closed type family" $$ + text "only in a .hs-boot file" } + ; DataFamilyTyCon {} -> return () + ; OpenSynFamilyTyCon -> return () + ; BuiltInSynFamTyCon _ -> return () } + + | otherwise -> do + { -- Check the context on the data decl + traceTc "cvtc1" (ppr tc) + ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) + + ; traceTc "cvtc2" (ppr tc) + + ; dflags <- getDynFlags + ; existential_ok <- xoptM LangExt.ExistentialQuantification + ; gadt_ok <- xoptM LangExt.GADTs + ; let ex_ok = existential_ok || gadt_ok + -- Data cons can have existential context + ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons + ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc) + + -- Check that fields with the same name share a type + ; mapM_ check_fields groups }} + where + syn_ctxt = TySynCtxt name + name = tyConName tc + data_cons = tyConDataCons tc + + groups = equivClasses cmp_fld (concatMap get_fields data_cons) + cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2 + get_fields con = dataConFieldLabels con `zip` repeat con + -- dataConFieldLabels may return the empty list, which is fine + + -- See Note [GADT record selectors] in GHC.Tc.TyCl.Utils + -- We must check (a) that the named field has the same + -- type in each constructor + -- (b) that those constructors have the same result type + -- + -- However, the constructors may have differently named type variable + -- and (worse) we don't know how the correspond to each other. E.g. + -- C1 :: forall a b. { f :: a, g :: b } -> T a b + -- C2 :: forall d c. { f :: c, g :: c } -> T c d + -- + -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's + -- result type against other candidates' types BOTH WAYS ROUND. + -- If they magically agrees, take the substitution and + -- apply them to the latter ones, and see if they match perfectly. + check_fields ((label, con1) :| other_fields) + -- These fields all have the same name, but are from + -- different constructors in the data type + = recoverM (return ()) $ mapM_ checkOne other_fields + -- Check that all the fields in the group have the same type + -- NB: this check assumes that all the constructors of a given + -- data type use the same type variables + where + res1 = dataConOrigResTy con1 + fty1 = dataConFieldType con1 lbl + lbl = flLabel label + + checkOne (_, con2) -- Do it both ways to ensure they are structurally identical + = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2 + ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 } + where + res2 = dataConOrigResTy con2 + fty2 = dataConFieldType con2 lbl + +checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM () +-- Checks the partial record field selector, and warns. +-- See Note [Checking partial record field] +checkPartialRecordField all_cons fld + = setSrcSpan loc $ + warnIfFlag Opt_WarnPartialFields + (not is_exhaustive && not (startsWithUnderscore occ_name)) + (sep [text "Use of partial record field selector" <> colon, + nest 2 $ quotes (ppr occ_name)]) + where + sel_name = flSelector fld + loc = getSrcSpan sel_name + occ_name = getOccName sel_name + + (cons_with_field, cons_without_field) = partition has_field all_cons + has_field con = fld `elem` (dataConFieldLabels con) + is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field + + con1 = ASSERT( not (null cons_with_field) ) head cons_with_field + (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1 + eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) + inst_tys = substTyVars eq_subst univ_tvs + +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) } + where + mb_subst1 = tcMatchTy res1 res2 + mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 + +------------------------------- +checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () +checkValidDataCon dflags existential_ok tc con + = setSrcSpan (getSrcSpan con) $ + addErrCtxt (dataConCtxt con) $ + do { -- Check that the return type of the data constructor + -- matches the type constructor; eg reject this: + -- data T a where { MkT :: Bogus a } + -- It's important to do this first: + -- see Note [Checking GADT return types] + -- and c.f. Note [Check role annotations in a second pass] + let tc_tvs = tyConTyVars tc + res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) + orig_res_ty = dataConOrigResTy con + ; traceTc "checkValidDataCon" (vcat + [ ppr con, ppr tc, ppr tc_tvs + , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl) + , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)]) + + + ; checkTc (isJust (tcMatchTy res_ty_tmpl orig_res_ty)) + (badDataConTyCon con res_ty_tmpl) + -- Note that checkTc aborts if it finds an error. This is + -- critical to avoid panicking when we call dataConUserType + -- on an un-rejiggable datacon! + + ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con)) + + -- Check that the result type is a *monotype* + -- e.g. reject this: MkT :: T (forall a. a->a) + -- Reason: it's really the argument of an equality constraint + ; checkValidMonoType orig_res_ty + + -- If we are dealing with a newtype, we allow levity polymorphism + -- regardless of whether or not UnliftedNewtypes is enabled. A + -- later check in checkNewDataCon handles this, producing a + -- better error message than checkForLevPoly would. + ; unless (isNewTyCon tc) + (mapM_ (checkForLevPoly empty) (dataConOrigArgTys con)) + + -- Extra checks for newtype data constructors. Importantly, these + -- checks /must/ come before the call to checkValidType below. This + -- is because checkValidType invokes the constraint solver, and + -- invoking the solver on an ill formed newtype constructor can + -- confuse GHC to the point of panicking. See #17955 for an example. + ; when (isNewTyCon tc) (checkNewDataCon con) + + -- Check all argument types for validity + ; checkValidType ctxt (dataConUserType con) + + -- Check that existentials are allowed if they are used + ; checkTc (existential_ok || isVanillaDataCon con) + (badExistential con) + + -- Check that UNPACK pragmas and bangs work out + -- E.g. reject data T = MkT {-# UNPACK #-} Int -- No "!" + -- data T = MkT {-# UNPACK #-} !a -- Can't unpack + ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..] + + -- Check the dcUserTyVarBinders invariant + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon + -- checked here because we sometimes build invalid DataCons before + -- erroring above here + ; when debugIsOn $ + do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con + user_tvs = dataConUserTyVars con + user_tvbs_invariant + = Set.fromList (filterEqSpec eq_spec univs ++ exs) + == Set.fromList user_tvs + ; MASSERT2( user_tvbs_invariant + , vcat ([ ppr con + , ppr univs + , ppr exs + , ppr eq_spec + , ppr user_tvs ])) } + + ; traceTc "Done validity of data con" $ + vcat [ ppr con + , text "Datacon user type:" <+> ppr (dataConUserType con) + , text "Datacon rep type:" <+> ppr (dataConRepType con) + , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con)) + , case tyConFamInst_maybe (dataConTyCon con) of + Nothing -> text "not family" + Just (f, _) -> ppr (tyConBinders f) ] + } + where + ctxt = ConArgCtxt (dataConName con) + + check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM () + check_bang (HsSrcBang _ _ SrcLazy) _ n + | not (xopt LangExt.StrictData dflags) + = addErrTc + (bad_bang n (text "Lazy annotation (~) without StrictData")) + check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n + | isSrcUnpacked want_unpack, not is_strict + = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'")) + | isSrcUnpacked want_unpack + , case rep_bang of { HsUnpack {} -> False; _ -> True } + -- If not optimising, we don't unpack (rep_bang is never + -- HsUnpack), so don't complain! This happens, e.g., in Haddock. + -- See dataConSrcToImplBang. + , not (gopt Opt_OmitInterfacePragmas dflags) + -- When typechecking an indefinite package in Backpack, we + -- may attempt to UNPACK an abstract type. The test here will + -- conclude that this is unusable, but it might become usable + -- when we actually fill in the abstract type. As such, don't + -- warn in this case (it gives users the wrong idea about whether + -- or not UNPACK on abstract types is supported; it is!) + , unitIsDefinite (thisPackage dflags) + = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma")) + where + is_strict = case strict_mark of + NoSrcStrict -> xopt LangExt.StrictData dflags + bang -> isSrcStrict bang + + check_bang _ _ _ + = return () + + bad_bang n herald + = hang herald 2 (text "on the" <+> speakNth n + <+> text "argument of" <+> quotes (ppr con)) +------------------------------- +checkNewDataCon :: DataCon -> TcM () +-- Further checks for the data constructor of a newtype +checkNewDataCon con + = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) + -- One argument + + ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes + ; let allowedArgType = + unlifted_newtypes || isLiftedType_maybe arg_ty1 == Just True + ; checkTc allowedArgType $ vcat + [ text "A newtype cannot have an unlifted argument type" + , text "Perhaps you intended to use UnliftedNewtypes" + ] + + ; check_con (null eq_spec) $ + text "A newtype constructor must have a return type of form T a1 ... an" + -- Return type is (T a b c) + + ; check_con (null theta) $ + text "A newtype constructor cannot have a context in its type" + + ; check_con (null ex_tvs) $ + text "A newtype constructor cannot have existential type variables" + -- No existentials + + ; checkTc (all ok_bang (dataConSrcBangs con)) + (newtypeStrictError con) + -- No strictness annotations + } + where + (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) + = dataConFullSig con + check_con what msg + = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con)) + + (arg_ty1 : _) = arg_tys + + ok_bang (HsSrcBang _ _ SrcStrict) = False + ok_bang (HsSrcBang _ _ SrcLazy) = False + ok_bang _ = True + +------------------------------- +checkValidClass :: Class -> TcM () +checkValidClass cls + = do { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods + ; multi_param_type_classes <- xoptM LangExt.MultiParamTypeClasses + ; nullary_type_classes <- xoptM LangExt.NullaryTypeClasses + ; fundep_classes <- xoptM LangExt.FunctionalDependencies + ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses + + -- Check that the class is unary, unless multiparameter type classes + -- are enabled; also recognize deprecated nullary type classes + -- 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) + + -- Check the super-classes + ; checkValidTheta (ClassSCCtxt (className cls)) theta + + -- Now check for cyclic superclasses + -- If there are superclass cycles, checkClassCycleErrs bails. + ; unless undecidable_super_classes $ + case checkClassCycles cls of + Just err -> setSrcSpan (getSrcSpan cls) $ + addErrTc err + Nothing -> return () + + -- Check the class operations. + -- But only if there have been no earlier errors + -- See Note [Abort when superclass cycle is detected] + ; whenNoErrs $ + mapM_ (check_op constrained_class_methods) op_stuff + + -- Check the associated type defaults are well-formed and instantiated + ; mapM_ check_at at_stuff } + where + (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls + cls_arity = length (tyConVisibleTyVars (classTyCon cls)) + -- Ignore invisible variables + cls_tv_set = mkVarSet tyvars + + check_op constrained_class_methods (sel_id, dm) + = setSrcSpan (getSrcSpan sel_id) $ + addErrCtxt (classOpCtxt sel_id op_ty) $ do + { traceTc "class op type" (ppr op_ty) + ; checkValidType ctxt op_ty + -- This implements the ambiguity check, among other things + -- Example: tc223 + -- class Error e => Game b mv e | b -> mv e where + -- newBoard :: MonadState b m => m () + -- Here, MonadState has a fundep m->b, so newBoard is fine + + -- a method cannot be levity polymorphic, as we have to store the + -- method in a dictionary + -- example of what this prevents: + -- class BoundedX (a :: TYPE r) where minBound :: a + -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad + ; checkForLevPoly empty tau1 + + ; unless constrained_class_methods $ + mapM_ check_constraint (tail (cls_pred:op_theta)) + + ; check_dm ctxt sel_id cls_pred tau2 dm + } + where + ctxt = FunSigCtxt op_name True -- Report redundant class constraints + op_name = idName sel_id + op_ty = idType sel_id + (_,cls_pred,tau1) = tcSplitMethodTy op_ty + -- See Note [Splitting nested sigma types in class type signatures] + (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1 + + check_constraint :: TcPredType -> TcM () + check_constraint pred -- See Note [Class method constraints] + = when (not (isEmptyVarSet pred_tvs) && + pred_tvs `subVarSet` cls_tv_set) + (addErrTc (badMethPred sel_id pred)) + where + pred_tvs = tyCoVarsOfType pred + + check_at (ATI fam_tc m_dflt_rhs) + = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) + (noClassTyVarErr 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, + -- since there is no possible ambiguity (#10020) + + -- Check that any default declarations for associated types are valid + ; whenIsJust m_dflt_rhs $ \ (rhs, loc) -> + setSrcSpan loc $ + tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $ + checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs } + where + fam_tvs = tyConTyVars fam_tc + + check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM () + -- Check validity of the /top-level/ generic-default type + -- E.g for class C a where + -- default op :: forall b. (a~b) => blah + -- we do not want to do an ambiguity check on a type with + -- a free TyVar 'a' (#11608). See TcType + -- Note [TyVars and TcTyVars during type checking] in GHC.Tc.Utils.TcType + -- Hence the mkDefaultMethodType to close the type. + check_dm ctxt sel_id vanilla_cls_pred vanilla_tau + (Just (dm_name, dm_spec@(GenericDM dm_ty))) + = setSrcSpan (getSrcSpan dm_name) $ do + -- We have carefully set the SrcSpan on the generic + -- default-method Name to be that of the generic + -- default type signature + + -- First, we check that that the method's default type signature + -- aligns with the non-default type signature. + -- See Note [Default method type signatures must align] + let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls + -- Note that the second field of this tuple contains the context + -- of the default type signature, making it apparent that we + -- ignore method contexts completely when validity-checking + -- default type signatures. See the end of + -- Note [Default method type signatures must align] + -- to learn why this is OK. + -- + -- See also + -- Note [Splitting nested sigma types in class type signatures] + -- for an explanation of why we don't use tcSplitSigmaTy here. + (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty + + -- Given this class definition: + -- + -- class C a b where + -- op :: forall p q. (Ord a, D p q) + -- => a -> b -> p -> (a, b) + -- default op :: forall r s. E r + -- => a -> b -> s -> (a, b) + -- + -- We want to match up two types of the form: + -- + -- Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb) + -- Default type sig: C a b => a -> b -> s -> (a, b) + -- + -- Notice that the two type signatures can be quantified over + -- different class type variables! Therefore, it's important that + -- we include the class predicate parts to match up a with aa and + -- b with bb. + vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau + dm_phi_ty = mkPhiTy [cls_pred] dm_tau + + traceTc "check_dm" $ vcat + [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty + , text "dm_phi_ty" <+> ppr dm_phi_ty ] + + -- Actually checking that the types align is done with a call to + -- tcMatchTys. We need to get a match in both directions to rule + -- out degenerate cases like these: + -- + -- class Foo a where + -- foo1 :: a -> b + -- default foo1 :: a -> Int + -- + -- foo2 :: a -> Int + -- default foo2 :: a -> b + unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty] + [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $ + 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") + + -- Now do an ambiguity check on the default type signature. + checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec) + check_dm _ _ _ _ _ = return () + +checkFamFlag :: Name -> TcM () +-- Check that we don't use families without -XTypeFamilies +-- The parser won't even parse them, but I suppose a GHC API +-- client might have a go! +checkFamFlag tc_name + = do { idx_tys <- xoptM LangExt.TypeFamilies + ; checkTc idx_tys err_msg } + where + err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) + 2 (text "Enable TypeFamilies to allow indexed type families") + +checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM () +checkResultSigFlag tc_name (TyVarSig _ tvb) + = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies + ; checkTc ty_fam_deps $ + hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name)) + 2 (text "Enable TypeFamilyDependencies to allow result variable names") } +checkResultSigFlag _ _ = return () -- other cases OK + +{- Note [Class method constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Haskell 2010 is supposed to reject + class C a where + op :: Eq a => a -> a +where the method type constrains only the class variable(s). (The extension +-XConstrainedClassMethods switches off this check.) But regardless +we should not reject + class C a where + op :: (?x::Int) => a -> a +as pointed out in #11793. So the test here rejects the program if + * -XConstrainedClassMethods is off + * the tyvars of the constraint are non-empty + * all the tyvars are class tyvars, none are locally quantified + +Note [Abort when superclass cycle is detected] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must avoid doing the ambiguity check for the methods (in +checkValidClass.check_op) when there are already errors accumulated. +This is because one of the errors may be a superclass cycle, and +superclass cycles cause canonicalization to loop. Here is a +representative example: + + class D a => C a where + meth :: D a => () + class C a => D a + +This fixes #9415, #9739 + +Note [Default method type signatures must align] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC enforces the invariant that a class method's default type signature +must "align" with that of the method's non-default type signature, as per +GHC #12918. For instance, if you have: + + class Foo a where + bar :: forall b. Context => a -> b + +Then a default type signature for bar must be alpha equivalent to +(forall b. a -> b). That is, the types must be the same modulo differences in +contexts. So the following would be acceptable default type signatures: + + default bar :: forall b. Context1 => a -> b + default bar :: forall x. Context2 => a -> x + +But the following are NOT acceptable default type signatures: + + default bar :: forall b. b -> a + default bar :: forall x. x + default bar :: a -> Int + +Note that a is bound by the class declaration for Foo itself, so it is +not allowed to differ in the default type signature. + +The default type signature (default bar :: a -> Int) deserves special mention, +since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To +write this, you need to declare the default type signature like so: + + default bar :: forall b. (b ~ Int). a -> b + +As noted in #12918, there are several reasons to do this: + +1. It would make no sense to have a type that was flat-out incompatible with + the non-default type signature. For instance, if you had: + + class Foo a where + bar :: a -> Int + default bar :: a -> Bool + + Then that would always fail in an instance declaration. So this check + nips such cases in the bud before they have the chance to produce + confusing error messages. + +2. Internally, GHC uses TypeApplications to instantiate the default method in + an instance. See Note [Default methods in instances] in GHC.Tc.TyCl.Instance. + Thus, GHC needs to know exactly what the universally quantified type + variables are, and when instantiated that way, the default method's type + must match the expected type. + +3. Aesthetically, by only allowing the default type signature to differ in its + context, we are making it more explicit the ways in which the default type + signature is less polymorphic than the non-default type signature. + +You might be wondering: why are the contexts allowed to be different, but not +the rest of the type signature? That's because default implementations often +rely on assumptions that the more general, non-default type signatures do not. +For instance, in the Enum class declaration: + + class Enum a where + enum :: [a] + default enum :: (Generic a, GEnum (Rep a)) => [a] + enum = map to genum + + class GEnum f where + genum :: [f a] + +The default implementation for enum only works for types that are instances of +Generic, and for which their generic Rep type is an instance of GEnum. But +clearly enum doesn't _have_ to use this implementation, so naturally, the +context for enum is allowed to be different to accommodate this. As a result, +when we validity-check default type signatures, we ignore contexts completely. + +Note that when checking whether two type signatures match, we must take care to +split as many foralls as it takes to retrieve the tau types we which to check. +See Note [Splitting nested sigma types in class type signatures]. + +Note [Splitting nested sigma types in class type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this type synonym and class definition: + + type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t + + class Each s t a b where + each :: Traversal s t a b + default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b + +It might seem obvious that the tau types in both type signatures for `each` +are the same, but actually getting GHC to conclude this is surprisingly tricky. +That is because in general, the form of a class method's non-default type +signature is: + + forall a. C a => forall d. D d => E a b + +And the general form of a default type signature is: + + forall f. F f => E a f -- The variable `a` comes from the class + +So it you want to get the tau types in each type signature, you might find it +reasonable to call tcSplitSigmaTy twice on the non-default type signature, and +call it once on the default type signature. For most classes and methods, this +will work, but Each is a bit of an exceptional case. The way `each` is written, +it doesn't quantify any additional type variables besides those of the Each +class itself, so the non-default type signature for `each` is actually this: + + forall s t a b. Each s t a b => Traversal s t a b + +Notice that there _appears_ to only be one forall. But there's actually another +forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy +twice, you'll also go under the forall in Traversal! That is, you'll end up +with: + + (a -> f b) -> s -> f t + +A problem arises because you only call tcSplitSigmaTy once on the default type +signature for `each`, which gives you + + Traversal s t a b + +Or, equivalently: + + forall f. Applicative f => (a -> f b) -> s -> f t + +This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will +say that the tau types for `each` are not equal. + +A solution to this problem is to use tcSplitNestedSigmaTys instead of +tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it +sees until it can't go any further, so if you called it on the default type +signature for `each`, it would return (a -> f b) -> s -> f t like we desired. + +Note [Checking partial record field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This check checks the partial record field selector, and warns (#7169). + +For example: + + data T a = A { m1 :: a, m2 :: a } | B { m1 :: a } + +The function 'm2' is partial record field, and will fail when it is applied to +'B'. The warning identifies such partial fields. The check is performed at the +declaration of T, not at the call-sites of m2. + +The warning can be suppressed by prefixing the field-name with an underscore. +For example: + + data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a } + +************************************************************************ +* * + Checking role validity +* * +************************************************************************ +-} + +checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM () +checkValidRoleAnnots role_annots tc + | isTypeSynonymTyCon tc = check_no_roles + | isFamilyTyCon tc = check_no_roles + | isAlgTyCon tc = check_roles + | otherwise = return () + where + -- Role annotations are given only on *explicit* variables, + -- but a tycon stores roles for all variables. + -- So, we drop the implicit roles (which are all Nominal, anyway). + name = tyConName tc + roles = tyConRoles tc + (vis_roles, vis_vars) = unzip $ mapMaybe pick_vis $ + zip roles (tyConBinders tc) + role_annot_decl_maybe = lookupRoleAnnot role_annots name + + pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar) + pick_vis (role, tvb) + | isVisibleTyConBinder tvb = Just (role, binderVar tvb) + | otherwise = Nothing + + check_roles + = whenIsJust role_annot_decl_maybe $ + \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> + addRoleAnnotCtxt name $ + setSrcSpan loc $ do + { role_annots_ok <- xoptM LangExt.RoleAnnotations + ; checkTc role_annots_ok $ needXRoleAnnotations tc + ; checkTc (vis_vars `equalLength` the_role_annots) + (wrongNumberOfRoles 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 + -- IncoherentInstances to have them. See #8773, #14292 + ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances + ; checkTc ( incoherent_roles_ok + || (not $ isClassTyCon tc) + || (all (== Nominal) vis_roles)) + incoherentRoles + + ; lint <- goptM Opt_DoCoreLinting + ; when lint $ checkValidRoles tc } + + check_no_roles + = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl + +checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM () +checkRoleAnnot _ (L _ Nothing) _ = return () +checkRoleAnnot tv (L _ (Just r1)) r2 + = when (r1 /= r2) $ + addErrTc $ badRoleAnnot (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 +checkValidRoles :: TyCon -> TcM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +checkValidRoles tc + | isAlgTyCon tc + -- tyConDataCons returns an empty list for data families + = mapM_ check_dc_roles (tyConDataCons tc) + | Just rhs <- synTyConRhs_maybe tc + = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs + | otherwise + = return () + where + check_dc_roles datacon + = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc)) + ; mapM_ (check_ty_roles role_env Representational) $ + eqSpecPreds eq_spec ++ theta ++ arg_tys } + -- See Note [Role-checking data constructor arguments] in GHC.Tc.TyCl.Utils + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) + = dataConFullSig datacon + univ_roles = zipVarEnv univ_tvs (tyConRoles tc) + -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs + ex_roles = mkVarEnv (map (, Nominal) ex_tvs) + role_env = univ_roles `plusVarEnv` ex_roles + + check_ty_roles env role ty + | Just ty' <- coreView ty -- #14101 + = check_ty_roles env role ty' + + 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" + + check_ty_roles env Representational (TyConApp tc tys) + = let roles' = tyConRoles tc in + zipWithM_ (maybe_check_ty_roles env) roles' tys + + check_ty_roles env Nominal (TyConApp _ tys) + = mapM_ (check_ty_roles env Nominal) tys + + check_ty_roles _ Phantom ty@(TyConApp {}) + = pprPanic "check_ty_roles" (ppr ty) + + check_ty_roles env role (AppTy ty1 ty2) + = check_ty_roles env role ty1 + >> check_ty_roles env Nominal ty2 + + check_ty_roles env role (FunTy _ ty1 ty2) + = check_ty_roles env role ty1 + >> check_ty_roles env role ty2 + + check_ty_roles env role (ForAllTy (Bndr tv _) ty) + = check_ty_roles env Nominal (tyVarKind tv) + >> check_ty_roles (extendVarEnv env tv Nominal) role ty + + check_ty_roles _ _ (LitTy {}) = return () + + check_ty_roles env role (CastTy t _) + = check_ty_roles env role t + + check_ty_roles _ role (CoercionTy co) + = unless (role == Phantom) $ + report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role + + maybe_check_ty_roles env role ty + = when (role == Nominal || role == Representational) $ + check_ty_roles env role ty + + report_error doc + = addErrTc $ vcat [text "Internal error in role inference:", + doc, + text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] + +{- +************************************************************************ +* * + Error messages +* * +************************************************************************ +-} + +tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc +tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl, + text "declaration for", quotes (ppr (tcdName decl))] + +addVDQNote :: TcTyCon -> TcM a -> TcM a +-- See Note [Inferring visible dependent quantification] +-- Only types without a signature (CUSK or SAK) here +addVDQNote tycon thing_inside + | ASSERT2( isTcTyCon tycon, ppr tycon ) + ASSERT2( not (tcTyConIsPoly tycon), ppr tycon $$ ppr tc_kind ) + has_vdq + = addLandmarkErrCtxt vdq_warning thing_inside + | otherwise + = thing_inside + where + -- Check whether a tycon has visible dependent quantification. + -- This will *always* be a TcTyCon. Furthermore, it will *always* + -- be an ungeneralised TcTyCon, straight out of kcInferDeclHeader. + -- Thus, all the TyConBinders will be anonymous. Thus, the + -- free variables of the tycon's kind will be the same as the free + -- variables from all the binders. + has_vdq = any is_vdq_tcb (tyConBinders tycon) + tc_kind = tyConKind tycon + kind_fvs = tyCoVarsOfType tc_kind + + is_vdq_tcb tcb = (binderVar tcb `elemVarSet` kind_fvs) && + isVisibleTyConBinder tcb + + vdq_warning = vcat + [ text "NB: Type" <+> quotes (ppr tycon) <+> + text "was inferred to use visible dependent quantification." + , text "Most types with visible dependent quantification are" + , text "polymorphically recursive and need a standalone kind" + , text "signature. Perhaps supply one, with StandaloneKindSignatures." + ] + +tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a +tcAddDeclCtxt decl thing_inside + = addErrCtxt (tcMkDeclCtxt decl) thing_inside + +tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a +tcAddTyFamInstCtxt decl + = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl) + +tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc +tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn = + HsIB { hsib_body = eqn }}) + = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance") + (unLoc (feqn_tycon eqn)) + +tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a +tcAddDataFamInstCtxt decl + = addErrCtxt (tcMkDataFamInstCtxt decl) + +tcMkFamInstCtxt :: SDoc -> Name -> SDoc +tcMkFamInstCtxt flavour tycon + = hsep [ text "In the" <+> flavour <+> text "declaration for" + , quotes (ppr tycon) ] + +tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a +tcAddFamInstCtxt flavour tycon thing_inside + = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside + +tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a +tcAddClosedTypeFamilyDeclCtxt tc + = addErrCtxt ctxt + where + ctxt = text "In the equations for closed type family" <+> + quotes (ppr tc) + +resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc +resultTypeMisMatch field_name con1 con2 + = 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 -> SDoc +fieldTypeMisMatch field_name con1 con2 + = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, + text "give different types for field", quotes (ppr field_name)] + +dataConCtxtName :: [Located Name] -> SDoc +dataConCtxtName [con] + = text "In the definition of data constructor" <+> quotes (ppr con) +dataConCtxtName con + = text "In the definition of data constructors" <+> interpp'SP con + +dataConCtxt :: Outputable a => a -> SDoc +dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con) + +classOpCtxt :: Var -> Type -> SDoc +classOpCtxt sel_id tau = sep [text "When checking the class method:", + nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] + +classArityErr :: Int -> Class -> SDoc +classArityErr n cls + | n == 0 = mkErr "No" "no-parameter" + | otherwise = mkErr "Too many" "multi-parameter" + where + mkErr howMany allowWhat = + vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls), + parens (text ("Enable MultiParamTypeClasses to allow " + ++ allowWhat ++ " classes"))] + +classFunDepsErr :: Class -> SDoc +classFunDepsErr cls + = vcat [text "Fundeps in class" <+> quotes (ppr cls), + parens (text "Enable FunctionalDependencies to allow fundeps")] + +badMethPred :: Id -> TcPredType -> SDoc +badMethPred sel_id pred + = 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 -> SDoc +noClassTyVarErr clas fam_tc + = 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 -> SDoc +badDataConTyCon data_con res_ty_tmpl + | ASSERT( all isTyVar tvs ) + tcIsForAllTy actual_res_ty + = nested_foralls_contexts_suggestion + | isJust (tcSplitPredFunTy_maybe actual_res_ty) + = nested_foralls_contexts_suggestion + | otherwise + = 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 + + -- This suggestion is useful for suggesting how to correct code like what + -- was reported in #12087: + -- + -- data F a where + -- MkF :: Ord a => Eq a => a -> F a + -- + -- Although nested foralls or contexts are allowed in function type + -- signatures, it is much more difficult to engineer GADT constructor type + -- signatures to allow something similar, so we error in the latter case. + -- Nevertheless, we can at least suggest how a user might reshuffle their + -- exotic GADT constructor type signature so that GHC will accept. + nested_foralls_contexts_suggestion = + text "GADT constructor type signature cannot contain nested" + <+> quotes forAllLit <> text "s or contexts" + $+$ hang (text "Suggestion: instead use this type signature:") + 2 (ppr (dataConName data_con) <+> dcolon <+> ppr suggested_ty) + + -- To construct a type that GHC would accept (suggested_ty), we: + -- + -- 1) Find the existentially quantified type variables and the class + -- predicates from the datacon. (NB: We don't need the universally + -- quantified type variables, since rejigConRes won't substitute them in + -- the result type if it fails, as in this scenario.) + -- 2) Split apart the return type (which is headed by a forall or a + -- context) using tcSplitNestedSigmaTys, collecting the type variables + -- and class predicates we find, as well as the rho type lurking + -- underneath the nested foralls and contexts. + -- 3) Smash together the type variables and class predicates from 1) and + -- 2), and prepend them to the rho type from 2). + (tvs, theta, rho) = tcSplitNestedSigmaTys (dataConUserType data_con) + suggested_ty = mkSpecSigmaTy tvs theta rho + +badGadtDecl :: Name -> SDoc +badGadtDecl tc_name + = 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 -> SDoc +badExistential con + = 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 (dataConUserType con) + , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ]) + +badStupidTheta :: Name -> SDoc +badStupidTheta tc_name + = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) + +newtypeConError :: Name -> Int -> SDoc +newtypeConError tycon n + = sep [text "A newtype must have exactly one constructor,", + nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] + +newtypeStrictError :: DataCon -> SDoc +newtypeStrictError con + = sep [text "A newtype constructor cannot have a strictness annotation,", + nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"] + +newtypeFieldErr :: DataCon -> Int -> SDoc +newtypeFieldErr con_name n_flds + = sep [text "The constructor of a newtype must have exactly one field", + nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds] + +badSigTyDecl :: Name -> SDoc +badSigTyDecl tc_name + = vcat [ text "Illegal kind signature" <+> + quotes (ppr tc_name) + , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] + +emptyConDeclsErr :: Name -> SDoc +emptyConDeclsErr tycon + = sep [quotes (ppr tycon) <+> text "has no constructors", + nest 2 $ text "(EmptyDataDecls permits this)"] + +wrongKindOfFamily :: TyCon -> SDoc +wrongKindOfFamily family + = 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 -> SDoc +wrongNumberOfParmsErr max_args + = text "Number of parameters must match family declaration; expected" + <+> ppr max_args + +badRoleAnnot :: Name -> Role -> Role -> SDoc +badRoleAnnot var annot inferred + = 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 -> SDoc +wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) + = 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 _)) + = setErrCtxt [] $ + setSrcSpan loc $ + addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ + text "they are allowed only for datatypes and classes.") + +needXRoleAnnotations :: TyCon -> SDoc +needXRoleAnnotations tc + = text "Illegal role annotation for" <+> ppr tc <> char ';' $$ + text "did you intend to use RoleAnnotations?" + +incoherentRoles :: SDoc +incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+> + text "for class parameters can lead to incoherence.") $$ + (text "Use IncoherentInstances to allow this; bad role found") + +addTyConCtxt :: TyCon -> TcM a -> TcM a +addTyConCtxt tc = addTyConFlavCtxt name flav + where + name = getName tc + flav = tyConFlavour tc + +addRoleAnnotCtxt :: Name -> TcM a -> TcM a +addRoleAnnotCtxt name + = addErrCtxt $ + text "while checking a role annotation for" <+> quotes (ppr name) diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -0,0 +1,418 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Tc.TyCl.Build ( + buildDataCon, + buildPatSyn, + TcMethInfo, MethInfo, buildClass, + mkNewTyConRhs, + newImplicitBinder, newTyConRepName + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Iface.Env +import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) +import GHC.Builtin.Types( isCTupleTyConName ) +import GHC.Builtin.Types.Prim ( voidPrimTy ) +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Id.Make +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Types.Id +import GHC.Tc.Utils.TcType + +import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) +import GHC.Driver.Session +import GHC.Tc.Utils.Monad +import GHC.Types.Unique.Supply +import GHC.Utils.Misc +import GHC.Utils.Outputable + + +mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs +-- ^ Monadic because it makes a Name for the coercion TyCon +-- We pass the Name of the parent TyCon, as well as the TyCon itself, +-- because the latter is part of a knot, whereas the former is not. +mkNewTyConRhs tycon_name tycon con + = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc + ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs + ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax) + ; return (NewTyCon { data_con = con, + nt_rhs = rhs_ty, + nt_etad_rhs = (etad_tvs, etad_rhs), + nt_co = nt_ax, + nt_lev_poly = isKindLevPoly res_kind } ) } + -- Coreview looks through newtypes with a Nothing + -- for nt_co, or uses explicit coercions otherwise + where + tvs = tyConTyVars tycon + roles = tyConRoles tycon + res_kind = tyConResKind tycon + con_arg_ty = case dataConRepArgTys con of + [arg_ty] -> arg_ty + tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys) + rhs_ty = substTyWith (dataConUnivTyVars con) + (mkTyVarTys tvs) con_arg_ty + -- Instantiate the newtype's RHS with the + -- type variables from the tycon + -- NB: a newtype DataCon has a type that must look like + -- forall tvs. -> T tvs + -- Note that we *can't* use dataConInstOrigArgTys here because + -- the newtype arising from class Foo a => Bar a where {} + -- has a single argument (Foo a) that is a *type class*, so + -- dataConInstOrigArgTys returns []. + + etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can + etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty + etad_rhs :: Type -- See Note [Tricky iface loop] in GHC.Iface.Load + (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty + + eta_reduce :: [TyVar] -- Reversed + -> [Role] -- also reversed + -> Type -- Rhs type + -> ([TyVar], [Role], Type) -- Eta-reduced version + -- (tyvars in normal order) + eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty, + Just tv <- getTyVar_maybe arg, + tv == a, + not (a `elemVarSet` tyCoVarsOfType fun) + = eta_reduce as rs fun + eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty) + +------------------------------------------------------ +buildDataCon :: FamInstEnvs + -> Name + -> Bool -- Declared infix + -> TyConRepName + -> [HsSrcBang] + -> Maybe [HsImplBang] + -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make + -> [FieldLabel] -- Field labels + -> [TyVar] -- Universals + -> [TyCoVar] -- Existentials + -> [TyVarBinder] -- User-written 'TyVarBinder's + -> [EqSpec] -- Equality spec + -> KnotTied ThetaType -- Does not include the "stupid theta" + -- or the GADT equalities + -> [KnotTied Type] -- Arguments + -> KnotTied Type -- Result types + -> KnotTied TyCon -- Rep tycon + -> NameEnv ConTag -- Maps the Name of each DataCon to its + -- ConTag + -> TcRnIf m n DataCon +-- A wrapper for DataCon.mkDataCon that +-- a) makes the worker Id +-- b) makes the wrapper Id if necessary, including +-- allocating its unique (hence monadic) +buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs + field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty + rep_tycon tag_map + = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc + ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc + -- This last one takes the name of the data constructor in the source + -- code, which (for Haskell source anyway) will be in the DataName name + -- space, and puts it into the VarName name space + + ; traceIf (text "buildDataCon 1" <+> ppr src_name) + ; us <- newUniqueSupply + ; dflags <- getDynFlags + ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs + tag = lookupNameEnv_NF tag_map src_name + -- See Note [Constructor tag allocation], fixes #14657 + data_con = mkDataCon src_name declared_infix prom_info + src_bangs field_lbls + univ_tvs ex_tvs user_tvbs eq_spec ctxt + arg_tys res_ty NoRRI rep_tycon tag + stupid_ctxt dc_wrk dc_rep + dc_wrk = mkDataConWorkId work_name data_con + dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name + impl_bangs data_con) + + ; traceIf (text "buildDataCon 2" <+> ppr src_name) + ; return data_con } + + +-- The stupid context for a data constructor should be limited to +-- the type variables mentioned in the arg_tys +-- ToDo: Or functionally dependent on? +-- This whole stupid theta thing is, well, stupid. +mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType] +mkDataConStupidTheta tycon arg_tys univ_tvs + | null stupid_theta = [] -- The common case + | otherwise = filter in_arg_tys stupid_theta + where + tc_subst = zipTvSubst (tyConTyVars tycon) + (mkTyVarTys univ_tvs) + stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) + -- Start by instantiating the master copy of the + -- stupid theta, taken from the TyCon + + arg_tyvars = tyCoVarsOfTypes arg_tys + in_arg_tys pred = not $ isEmptyVarSet $ + tyCoVarsOfType pred `intersectVarSet` arg_tyvars + + +------------------------------------------------------ +buildPatSyn :: Name -> Bool + -> (Id,Bool) -> Maybe (Id, Bool) + -> ([TyVarBinder], ThetaType) -- ^ Univ and req + -> ([TyVarBinder], ThetaType) -- ^ Ex and prov + -> [Type] -- ^ Argument types + -> Type -- ^ Result type + -> [FieldLabel] -- ^ Field labels for + -- a record pattern synonym + -> PatSyn +buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder + (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys + pat_ty field_labels + = -- The assertion checks that the matcher is + -- compatible with the pattern synonym + ASSERT2((and [ univ_tvs `equalLength` univ_tvs1 + , ex_tvs `equalLength` ex_tvs1 + , pat_ty `eqType` substTy subst pat_ty1 + , prov_theta `eqTypes` substTys subst prov_theta1 + , req_theta `eqTypes` substTys subst req_theta1 + , compareArgTys arg_tys (substTys subst arg_tys1) + ]) + , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1 + , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1 + , ppr pat_ty <+> twiddle <+> ppr pat_ty1 + , ppr prov_theta <+> twiddle <+> ppr prov_theta1 + , ppr req_theta <+> twiddle <+> ppr req_theta1 + , ppr arg_tys <+> twiddle <+> ppr arg_tys1])) + mkPatSyn src_name declared_infix + (univ_tvs, req_theta) (ex_tvs, prov_theta) + arg_tys pat_ty + matcher builder field_labels + where + ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id + ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau + (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma + (arg_tys1, _) = (tcSplitFunTys cont_tau) + twiddle = char '~' + subst = zipTvSubst (univ_tvs1 ++ ex_tvs1) + (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs))) + + -- For a nullary pattern synonym we add a single void argument to the + -- matcher to preserve laziness in the case of unlifted types. + -- See #12746 + compareArgTys :: [Type] -> [Type] -> Bool + compareArgTys [] [x] = x `eqType` voidPrimTy + compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys + + +------------------------------------------------------ +type TcMethInfo = MethInfo -- this variant needs zonking +type MethInfo -- A temporary intermediate, to communicate + -- between tcClassSigs and buildClass. + = ( Name -- Name of the class op + , Type -- Type of the class op + , Maybe (DefMethSpec (SrcSpan, Type))) + -- Nothing => no default method + -- + -- Just VanillaDM => There is an ordinary + -- polymorphic default method + -- + -- Just (GenericDM (loc, ty)) => There is a generic default metho + -- Here is its type, and the location + -- of the type signature + -- We need that location /only/ to attach it to the + -- generic default method's Name; and we need /that/ + -- only to give the right location of an ambiguity error + -- for the generic default method, spat out by checkValidClass + +buildClass :: Name -- Name of the class/tycon (they have the same Name) + -> [TyConBinder] -- Of the tycon + -> [Role] + -> [FunDep TyVar] -- Functional dependencies + -- Super classes, associated types, method info, minimal complete def. + -- This is Nothing if the class is abstract. + -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef) + -> TcRnIf m n Class + +buildClass tycon_name binders roles fds Nothing + = fixM $ \ rec_clas -> -- Only name generation inside loop + do { traceIf (text "buildClass") + + ; tc_rep_name <- newTyConRepName tycon_name + ; let univ_tvs = binderVars binders + tycon = mkClassTyCon tycon_name binders roles + AbstractTyCon rec_clas tc_rep_name + result = mkAbstractClass tycon_name univ_tvs fds tycon + ; traceIf (text "buildClass" <+> ppr tycon) + ; return result } + +buildClass tycon_name binders roles fds + (Just (sc_theta, at_items, sig_stuff, mindef)) + = fixM $ \ rec_clas -> -- Only name generation inside loop + do { traceIf (text "buildClass") + + ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc + ; tc_rep_name <- newTyConRepName tycon_name + + ; op_items <- mapM (mk_op_item rec_clas) sig_stuff + -- Build the selector id and default method id + + -- Make selectors for the superclasses + ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc) + (takeList sc_theta [fIRST_TAG..]) + ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas + | sc_name <- sc_sel_names] + -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we + -- can construct names for the selectors. Thus + -- class (C a, C b) => D a b where ... + -- gives superclass selectors + -- D_sc1, D_sc2 + -- (We used to call them D_C, but now we can have two different + -- superclasses both called C!) + + ; let use_newtype = isSingleton arg_tys + -- Use a newtype if the data constructor + -- (a) has exactly one value field + -- i.e. exactly one operation or superclass taken together + -- (b) that value is of lifted type (which they always are, because + -- we box equality superclasses) + -- See note [Class newtypes and equality predicates] + + -- We treat the dictionary superclasses as ordinary arguments. + -- That means that in the case of + -- class C a => D a + -- we don't get a newtype with no arguments! + args = sc_sel_names ++ op_names + op_tys = [ty | (_,ty,_) <- sig_stuff] + op_names = [op | (op,_,_) <- sig_stuff] + arg_tys = sc_theta ++ op_tys + rec_tycon = classTyCon rec_clas + univ_bndrs = tyConTyVarBinders binders + univ_tvs = binderVars univ_bndrs + + ; rep_nm <- newTyConRepName datacon_name + ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs") + datacon_name + False -- Not declared infix + rep_nm + (map (const no_bang) args) + (Just (map (const HsLazy) args)) + [{- No fields -}] + univ_tvs + [{- no existentials -}] + univ_bndrs + [{- No GADT equalities -}] + [{- No theta -}] + arg_tys + (mkTyConApp rec_tycon (mkTyVarTys univ_tvs)) + rec_tycon + (mkTyConTagMap rec_tycon) + + ; rhs <- case () of + _ | use_newtype + -> mkNewTyConRhs tycon_name rec_tycon dict_con + | isCTupleTyConName tycon_name + -> return (TupleTyCon { data_con = dict_con + , tup_sort = ConstraintTuple }) + | otherwise + -> return (mkDataTyConRhs [dict_con]) + + ; let { tycon = mkClassTyCon tycon_name binders roles + rhs rec_clas tc_rep_name + -- A class can be recursive, and in the case of newtypes + -- this matters. For example + -- class C a where { op :: C b => a -> b -> Int } + -- Because C has only one operation, it is represented by + -- a newtype, and it should be a *recursive* newtype. + -- [If we don't make it a recursive newtype, we'll expand the + -- newtype like a synonym, but that will lead to an infinite + -- type] + + ; result = mkClass tycon_name univ_tvs fds + sc_theta sc_sel_ids at_items + op_items mindef tycon + } + ; traceIf (text "buildClass" <+> ppr tycon) + ; return result } + where + no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict + + mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem + mk_op_item rec_clas (op_name, _, dm_spec) + = do { dm_info <- mk_dm_info op_name dm_spec + ; return (mkDictSelId op_name rec_clas, dm_info) } + + mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type)) + -> TcRnIf n m (Maybe (Name, DefMethSpec Type)) + mk_dm_info _ Nothing + = return Nothing + mk_dm_info op_name (Just VanillaDM) + = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc + ; return (Just (dm_name, VanillaDM)) } + mk_dm_info op_name (Just (GenericDM (loc, dm_ty))) + = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc + ; return (Just (dm_name, GenericDM dm_ty)) } + +{- +Note [Class newtypes and equality predicates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class (a ~ F b) => C a b where + op :: a -> b + +We cannot represent this by a newtype, even though it's not +existential, because there are two value fields (the equality +predicate and op. See #2238 + +Moreover, + class (a ~ F b) => C a b where {} +Here we can't use a newtype either, even though there is only +one field, because equality predicates are unboxed, and classes +are boxed. +-} + +newImplicitBinder :: Name -- Base name + -> (OccName -> OccName) -- Occurrence name modifier + -> TcRnIf m n Name -- Implicit name +-- Called in GHC.Tc.TyCl.Build to allocate the implicit binders of type/class decls +-- For source type/class decls, this is the first occurrence +-- For iface ones, GHC.Iface.Load has already allocated a suitable name in the cache +newImplicitBinder base_name mk_sys_occ + = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name) + +newImplicitBinderLoc :: Name -- Base name + -> (OccName -> OccName) -- Occurrence name modifier + -> SrcSpan + -> TcRnIf m n Name -- Implicit name +-- Just the same, but lets you specify the SrcSpan +newImplicitBinderLoc base_name mk_sys_occ loc + | Just mod <- nameModule_maybe base_name + = newGlobalBinder mod occ loc + | otherwise -- When typechecking a [d| decl bracket |], + -- TH generates types, classes etc with Internal names, + -- so we follow suit for the implicit binders + = do { uniq <- newUnique + ; return (mkInternalName uniq occ loc) } + where + occ = mk_sys_occ (nameOccName base_name) + +-- | Make the 'TyConRepName' for this 'TyCon' +newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName +newTyConRepName tc_name + | Just mod <- nameModule_maybe tc_name + , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name) + = newGlobalBinder mod occ noSrcSpan + | otherwise + = newImplicitBinder tc_name mkTyConRepOcc diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -0,0 +1,554 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking class declarations +module GHC.Tc.TyCl.Class + ( tcClassSigs + , tcClassDecl2 + , findMethodBind + , instantiateMethod + , tcClassMinimalDef + , HsSigFun + , mkHsSigFun + , badMethodErr + , instDeclCtxt1 + , instDeclCtxt2 + , instDeclCtxt3 + , tcATDefault + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Sig +import GHC.Tc.Types.Evidence ( idHsWrapper ) +import GHC.Tc.Gen.Bind +import GHC.Tc.Utils.Unify +import GHC.Tc.Gen.HsType +import GHC.Tc.Utils.TcMType +import GHC.Core.Type ( piResultTys ) +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Monad +import GHC.Driver.Phases (HscSource(..)) +import GHC.Tc.TyCl.Build( TcMethInfo ) +import GHC.Core.Class +import GHC.Core.Coercion ( pprCoAxiom ) +import GHC.Driver.Session +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Core.TyCon +import GHC.Data.Maybe +import GHC.Types.Basic +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.BooleanFormula +import GHC.Utils.Misc + +import Control.Monad +import Data.List ( mapAccumL, partition ) + +{- +Dictionary handling +~~~~~~~~~~~~~~~~~~~ +Every class implicitly declares a new data type, corresponding to dictionaries +of that class. So, for example: + + class (D a) => C a where + op1 :: a -> a + op2 :: forall b. Ord b => a -> b -> b + +would implicitly declare + + data CDict a = CDict (D a) + (a -> a) + (forall b. Ord b => a -> b -> b) + +(We could use a record decl, but that means changing more of the existing apparatus. +One step at a time!) + +For classes with just one superclass+method, we use a newtype decl instead: + + class C a where + op :: forallb. a -> b -> b + +generates + + newtype CDict a = CDict (forall b. a -> b -> b) + +Now DictTy in Type is just a form of type synomym: + DictTy c t = TyConTy CDict `AppTy` t + +Death to "ExpandingDicts". + + +************************************************************************ +* * + Type-checking the class op signatures +* * +************************************************************************ +-} + +illegalHsigDefaultMethod :: Name -> SDoc +illegalHsigDefaultMethod n = + text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file" + +tcClassSigs :: Name -- Name of the class + -> [LSig GhcRn] + -> LHsBinds GhcRn + -> TcM [TcMethInfo] -- Exactly one for each method +tcClassSigs clas sigs def_methods + = do { traceTc "tcClassSigs 1" (ppr clas) + + ; gen_dm_prs <- concatMapM (addLocM tc_gen_sig) gen_sigs + ; let gen_dm_env :: NameEnv (SrcSpan, Type) + gen_dm_env = mkNameEnv gen_dm_prs + + ; op_info <- concatMapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs + + ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ] + ; sequence_ [ failWithTc (badMethodErr clas n) + | n <- dm_bind_names, not (n `elemNameSet` op_names) ] + -- Value binding for non class-method (ie no TypeSig) + + ; tcg_env <- getGblEnv + ; if tcg_src tcg_env == HsigFile + then + -- Error if we have value bindings + -- (Generic signatures without value bindings indicate + -- that a default of this form is expected to be + -- provided.) + when (not (null def_methods)) $ + failWithTc (illegalHsigDefaultMethod clas) + else + -- Error for each generic signature without value binding + sequence_ [ failWithTc (badGenericMethod clas n) + | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] + + ; traceTc "tcClassSigs 2" (ppr clas) + ; return op_info } + where + vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs] + gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs] + dm_bind_names :: [Name] -- These ones have a value binding in the class decl + dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] + + skol_info = TyConSkol ClassFlavour clas + + tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn) + -> TcM [TcMethInfo] + tc_sig gen_dm_env (op_names, op_hs_ty) + = do { traceTc "ClsSig 1" (ppr op_names) + ; op_ty <- tcClassSigType skol_info op_names op_hs_ty + -- Class tyvars already in scope + + ; traceTc "ClsSig 2" (ppr op_names) + ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] } + where + f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty) + | nm `elem` dm_bind_names = Just VanillaDM + | otherwise = Nothing + + tc_gen_sig (op_names, gen_hs_ty) + = do { gen_op_ty <- tcClassSigType skol_info op_names gen_hs_ty + ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] } + +{- +************************************************************************ +* * + Class Declarations +* * +************************************************************************ +-} + +tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration + -> TcM (LHsBinds GhcTcId) + +tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, + tcdMeths = default_binds})) + = recoverM (return emptyLHsBinds) $ + setSrcSpan (getLoc class_name) $ + do { clas <- tcLookupLocatedClass class_name + + -- We make a separate binding for each default method. + -- At one time I used a single AbsBinds for all of them, thus + -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... } + -- But that desugars into + -- ds = \d -> (..., ..., ...) + -- dm1 = \d -> case ds d of (a,b,c) -> a + -- And since ds is big, it doesn't get inlined, so we don't get good + -- default methods. Better to make separate AbsBinds for each + ; let (tyvars, _, _, op_items) = classBigSig clas + prag_fn = mkPragEnv sigs default_binds + sig_fn = mkHsSigFun sigs + clas_tyvars = snd (tcSuperSkolTyVars tyvars) + pred = mkClassPred clas (mkTyVarTys clas_tyvars) + ; this_dict <- newEvVar pred + + ; let tc_item = tcDefMeth clas clas_tyvars this_dict + default_binds sig_fn prag_fn + ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ + mapM tc_item op_items + + ; return (unionManyBags dm_binds) } + +tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) + +tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn + -> HsSigFun -> TcPragEnv -> ClassOpItem + -> TcM (LHsBinds GhcTcId) +-- Generate code for default methods +-- This is incompatible with Hugs, which expects a polymorphic +-- default method for every class op, regardless of whether or not +-- the programmer supplied an explicit default decl for the class. +-- (If necessary we can fix that, but we don't have a convenient Id to hand.) + +tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing) + = do { -- No default method + mapM_ (addLocM (badDmPrag sel_id)) + (lookupPragEnv prag_fn (idName sel_id)) + ; return emptyBag } + +tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn + (sel_id, Just (dm_name, dm_spec)) + | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn + = do { -- First look up the default method; it should be there! + -- It can be the ordinary default method + -- or the generic-default method. E.g of the latter + -- class C a where + -- op :: a -> a -> Bool + -- default op :: Eq a => a -> a -> Bool + -- op x y = x==y + -- The default method we generate is + -- $gm :: (C a, Eq a) => a -> a -> Bool + -- $gm x y = x==y + + global_dm_id <- tcLookupId dm_name + ; global_dm_id <- addInlinePrags global_dm_id prags + ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc + -- Base the local_dm_name on the selector name, because + -- type errors from tcInstanceMethodBody come from here + + ; spec_prags <- discardConstraints $ + tcSpecPrags global_dm_id prags + ; warnTc NoReason + (not (null spec_prags)) + (text "Ignoring SPECIALISE pragmas on default method" + <+> quotes (ppr sel_name)) + + ; let hs_ty = hs_sig_fn sel_name + `orElse` pprPanic "tc_dm" (ppr sel_name) + -- We need the HsType so that we can bring the right + -- type variables into scope + -- + -- Eg. class C a where + -- op :: forall b. Eq b => a -> [b] -> a + -- gen_op :: a -> a + -- generic gen_op :: D a => a -> a + -- The "local_dm_ty" is precisely the type in the above + -- type signatures, ie with no "forall a. C a =>" prefix + + local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars) + + lm_bind = dm_bind { fun_id = L bind_loc local_dm_name } + -- Substitute the local_meth_name for the binder + -- NB: the binding is always a FunBind + + warn_redundant = case dm_spec of + GenericDM {} -> True + VanillaDM -> False + -- For GenericDM, warn if the user specifies a signature + -- with redundant constraints; but not for VanillaDM, where + -- the default method may well be 'error' or something + + ctxt = FunSigCtxt sel_name warn_redundant + + ; let local_dm_id = mkLocalId local_dm_name local_dm_ty + local_dm_sig = CompleteSig { sig_bndr = local_dm_id + , sig_ctxt = ctxt + , sig_loc = getLoc (hsSigType hs_ty) } + + ; (ev_binds, (tc_bind, _)) + <- checkConstraints skol_info tyvars [this_dict] $ + tcPolyCheck no_prag_fn local_dm_sig + (L bind_loc lm_bind) + + ; let export = ABE { abe_ext = noExtField + , abe_poly = global_dm_id + , abe_mono = local_dm_id + , abe_wrap = idHsWrapper + , abe_prags = IsDefaultMethod } + full_bind = AbsBinds { abs_ext = noExtField + , abs_tvs = tyvars + , abs_ev_vars = [this_dict] + , abs_exports = [export] + , abs_ev_binds = [ev_binds] + , abs_binds = tc_bind + , abs_sig = True } + + ; return (unitBag (L bind_loc full_bind)) } + + | otherwise = pprPanic "tcDefMeth" (ppr sel_id) + where + skol_info = TyConSkol ClassFlavour (getName clas) + sel_name = idName sel_id + no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; + -- they are all for meth_id + +--------------- +tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef +tcClassMinimalDef _clas sigs op_info + = case findMinimalDef sigs of + Nothing -> return defMindef + Just mindef -> do + -- Warn if the given mindef does not imply the default one + -- That is, the given mindef should at least ensure that the + -- class ops without default methods are required, since we + -- have no way to fill them in otherwise + tcg_env <- getGblEnv + -- However, only do this test when it's not an hsig file, + -- since you can't write a default implementation. + when (tcg_src tcg_env /= HsigFile) $ + whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ + (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf)) + return mindef + where + -- By default require all methods without a default implementation + defMindef :: ClassMinimalDef + defMindef = mkAnd [ noLoc (mkVar name) + | (name, _, Nothing) <- op_info ] + +instantiateMethod :: Class -> TcId -> [TcType] -> TcType +-- Take a class operation, say +-- op :: forall ab. C a => forall c. Ix c => (b,c) -> a +-- Instantiate it at [ty1,ty2] +-- Return the "local method type": +-- forall c. Ix x => (ty2,c) -> ty1 +instantiateMethod clas sel_id inst_tys + = ASSERT( ok_first_pred ) local_meth_ty + where + rho_ty = piResultTys (idType sel_id) inst_tys + (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty + `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) + + ok_first_pred = case getClassPredTys_maybe first_pred of + Just (clas1, _tys) -> clas == clas1 + Nothing -> False + -- The first predicate should be of form (C a b) + -- where C is the class in question + + +--------------------------- +type HsSigFun = Name -> Maybe (LHsSigType GhcRn) + +mkHsSigFun :: [LSig GhcRn] -> HsSigFun +mkHsSigFun sigs = lookupNameEnv env + where + env = mkHsSigEnv get_classop_sig sigs + + get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn) + get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty) + get_classop_sig _ = Nothing + +--------------------------- +findMethodBind :: Name -- Selector + -> LHsBinds GhcRn -- A group of bindings + -> TcPragEnv + -> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn]) + -- Returns the binding, the binding + -- site of the method binder, and any inline or + -- specialisation pragmas +findMethodBind sel_name binds prag_fn + = foldl' mplus Nothing (mapBag f binds) + where + prags = lookupPragEnv prag_fn sel_name + + f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) + | op_name == sel_name + = Just (bind, bndr_loc, prags) + f _other = Nothing + +--------------------------- +findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef +findMinimalDef = firstJusts . map toMinimalDef + where + toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef + toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf) + toMinimalDef _ = Nothing + +{- +Note [Polymorphic methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class Foo a where + op :: forall b. Ord b => a -> b -> b -> b + instance Foo c => Foo [c] where + op = e + +When typechecking the binding 'op = e', we'll have a meth_id for op +whose type is + op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b + +So tcPolyBinds must be capable of dealing with nested polytypes; +and so it is. See GHC.Tc.Gen.Bind.tcMonoBinds (with type-sig case). + +Note [Silly default-method bind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we pass the default method binding to the type checker, it must +look like op2 = e +not $dmop2 = e +otherwise the "$dm" stuff comes out error messages. But we want the +"$dm" to come out in the interface file. So we typecheck the former, +and wrap it in a let, thus + $dmop2 = let op2 = e in op2 +This makes the error messages right. + + +************************************************************************ +* * + Error messages +* * +************************************************************************ +-} + +badMethodErr :: Outputable a => a -> Name -> SDoc +badMethodErr clas op + = hsep [text "Class", quotes (ppr clas), + text "does not have a method", quotes (ppr op)] + +badGenericMethod :: Outputable a => a -> Name -> SDoc +badGenericMethod clas op + = hsep [text "Class", quotes (ppr clas), + text "has a generic-default signature without a binding", quotes (ppr op)] + +{- +badGenericInstanceType :: LHsBinds Name -> SDoc +badGenericInstanceType binds + = vcat [text "Illegal type pattern in the generic bindings", + nest 2 (ppr binds)] + +missingGenericInstances :: [Name] -> SDoc +missingGenericInstances missing + = text "Missing type patterns for" <+> pprQuotedList missing + +dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc +dupGenericInsts tc_inst_infos + = vcat [text "More than one type pattern for a single generic type constructor:", + nest 2 (vcat (map ppr_inst_ty tc_inst_infos)), + text "All the type patterns for a generic type constructor must be identical" + ] + where + ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) +-} +badDmPrag :: TcId -> Sig GhcRn -> TcM () +badDmPrag sel_id prag + = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method") + <+> quotes (ppr sel_id) + <+> text "lacks an accompanying binding") + +warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc +warningMinimalDefIncomplete mindef + = vcat [ text "The MINIMAL pragma does not require:" + , nest 2 (pprBooleanFormulaNice mindef) + , text "but there is no default implementation." ] + +instDeclCtxt1 :: LHsSigType GhcRn -> SDoc +instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + +instDeclCtxt2 :: Type -> SDoc +instDeclCtxt2 dfun_ty + = instDeclCtxt3 cls tys + where + (_,_,cls,tys) = tcSplitDFunTy dfun_ty + +instDeclCtxt3 :: Class -> [Type] -> SDoc +instDeclCtxt3 cls cls_tys + = inst_decl_ctxt (ppr (mkClassPred cls cls_tys)) + +inst_decl_ctxt :: SDoc -> SDoc +inst_decl_ctxt doc = hang (text "In the instance declaration for") + 2 (quotes doc) + +tcATDefault :: SrcSpan + -> TCvSubst + -> NameSet + -> ClassATItem + -> TcM [FamInst] +-- ^ Construct default instances for any associated types that +-- aren't given a user definition +-- Returns [] or singleton +tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) + -- User supplied instances ==> everything is OK + | tyConName fam_tc `elemNameSet` defined_ats + = return [] + + -- No user instance, have defaults ==> instantiate them + -- Example: class C a where { type F a b :: *; type F a b = () } + -- instance C [x] + -- Then we want to generate the decl: type F [x] b = () + | Just (rhs_ty, _loc) <- defs + = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst + (tyConTyVars fam_tc) + rhs' = substTyUnchecked subst' rhs_ty + tcv' = tyCoVarsOfTypesList pat_tys' + (tv', cv') = partition isTyVar tcv' + tvs' = scopedSort tv' + cvs' = scopedSort cv' + ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys' + ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs' + fam_tc pat_tys' rhs' + -- NB: no validity check. We check validity of default instances + -- in the class definition. Because type instance arguments cannot + -- be type family applications and cannot be polytypes, the + -- validity check is redundant. + + ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty + , pprCoAxiom axiom ]) + ; fam_inst <- newFamInst SynFamilyInst axiom + ; return [fam_inst] } + + -- No defaults ==> generate a warning + | otherwise -- defs = Nothing + = do { warnMissingAT (tyConName fam_tc) + ; return [] } + where + subst_tv subst tc_tv + | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv + = (subst, ty) + | otherwise + = (extendTvSubst subst tc_tv ty', ty') + where + ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv) + +warnMissingAT :: Name -> TcM () +warnMissingAT name + = do { warn <- woptM Opt_WarnMissingMethods + ; traceTc "warn" (ppr name <+> ppr warn) + ; hsc_src <- fmap tcg_src getGblEnv + -- Warn only if -Wmissing-methods AND not a signature + ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile) + (text "No explicit" <+> text "associated type" + <+> text "or default declaration for" + <+> quotes (ppr name)) } diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -0,0 +1,2230 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking instance declarations +module GHC.Tc.TyCl.Instance + ( tcInstDecls1 + , tcInstDeclsDeriv + , tcInstDecls2 + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Tc.Gen.Bind +import GHC.Tc.TyCl +import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv ) +import GHC.Tc.TyCl.Class ( tcClassDecl2, tcATDefault, + HsSigFun, mkHsSigFun, badMethodErr, + findMethodBind, instantiateMethod ) +import GHC.Tc.Gen.Sig +import GHC.Tc.Utils.Monad +import GHC.Tc.Validity +import GHC.Tc.Utils.Zonk +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.TyCl.Build +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated ) +import GHC.Core.InstEnv +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Tc.Deriv +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.HsType +import GHC.Tc.Utils.Unify +import GHC.Core ( Expr(..), mkApps, mkVarApps, mkLams ) +import GHC.Core.Make ( nO_METHOD_BINDING_ERROR_ID ) +import GHC.Core.Unfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding ) +import GHC.Core.Type +import GHC.Tc.Types.Evidence +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.Class +import GHC.Types.Var as Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Data.Bag +import GHC.Types.Basic +import GHC.Driver.Session +import GHC.Utils.Error +import GHC.Data.FastString +import GHC.Types.Id +import GHC.Data.List.SetOps +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Utils.Misc +import GHC.Data.BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.Tuple +import GHC.Data.Maybe +import Data.List( mapAccumL ) + + +{- +Typechecking instance declarations is done in two passes. The first +pass, made by @tcInstDecls1@, collects information to be used in the +second pass. + +This pre-processed info includes the as-yet-unprocessed bindings +inside the instance declaration. These are type-checked in the second +pass, when the class-instance envs and GVE contain all the info from +all the instance and value decls. Indeed that's the reason we need +two passes over the instance decls. + + +Note [How instance declarations are translated] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is how we translate instance declarations into Core + +Running example: + class C a where + op1, op2 :: Ix b => a -> b -> b + op2 = + + instance C a => C [a] + {-# INLINE [2] op1 #-} + op1 = +===> + -- Method selectors + op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b + op1 = ... + op2 = ... + + -- Default methods get the 'self' dictionary as argument + -- so they can call other methods at the same type + -- Default methods get the same type as their method selector + $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b + $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). + -- NB: type variables 'a' and 'b' are *both* in scope in + -- Note [Tricky type variable scoping] + + -- A top-level definition for each instance method + -- Here op1_i, op2_i are the "instance method Ids" + -- The INLINE pragma comes from the user pragma + {-# INLINE [2] op1_i #-} -- From the instance decl bindings + op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b + op1_i = /\a. \(d:C a). + let this :: C [a] + this = df_i a d + -- Note [Subtle interaction of recursion and overlap] + + local_op1 :: forall b. Ix b => [a] -> b -> b + local_op1 = + -- Source code; run the type checker on this + -- NB: Type variable 'a' (but not 'b') is in scope in + -- Note [Tricky type variable scoping] + + in local_op1 a d + + op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) + + -- The dictionary function itself + {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions + df_i :: forall a. C a -> C [a] + df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d) + -- But see Note [Default methods in instances] + -- We can't apply the type checker to the default-method call + + -- Use a RULE to short-circuit applications of the class ops + {-# RULE "op1@C[a]" forall a, d:C a. + op1 [a] (df_i d) = op1_i a d #-} + +Note [Instances and loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Note that df_i may be mutually recursive with both op1_i and op2_i. + It's crucial that df_i is not chosen as the loop breaker, even + though op1_i has a (user-specified) INLINE pragma. + +* Instead the idea is to inline df_i into op1_i, which may then select + methods from the MkC record, and thereby break the recursion with + df_i, leaving a *self*-recursive op1_i. (If op1_i doesn't call op at + the same type, it won't mention df_i, so there won't be recursion in + the first place.) + +* If op1_i is marked INLINE by the user there's a danger that we won't + inline df_i in it, and that in turn means that (since it'll be a + loop-breaker because df_i isn't), op1_i will ironically never be + inlined. But this is OK: the recursion breaking happens by way of + a RULE (the magic ClassOp rule above), and RULES work inside InlineRule + unfoldings. See Note [RULEs enabled in InitialPhase] in GHC.Core.Opt.Simplify.Utils + +Note [ClassOp/DFun selection] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One thing we see a lot is stuff like + op2 (df d1 d2) +where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both* +'op2' and 'df' to get + case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of + MkD _ op2 _ _ _ -> op2 +And that will reduce to ($cop2 d1 d2) which is what we wanted. + +But it's tricky to make this work in practice, because it requires us to +inline both 'op2' and 'df'. But neither is keen to inline without having +seen the other's result; and it's very easy to get code bloat (from the +big intermediate) if you inline a bit too much. + +Instead we use a cunning trick. + * We arrange that 'df' and 'op2' NEVER inline. + + * We arrange that 'df' is ALWAYS defined in the sylised form + df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ... + + * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..]) + that lists its methods. + + * We make GHC.Core.Unfold.exprIsConApp_maybe spot a DFunUnfolding and return + a suitable constructor application -- inlining df "on the fly" as it + were. + + * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that + extracts the right piece iff its argument satisfies + exprIsConApp_maybe. This is done in GHC.Types.Id.Make.mkDictSelId + + * We make 'df' CONLIKE, so that shared uses still match; eg + let d = df d1 d2 + in ...(op2 d)...(op1 d)... + +Note [Single-method classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the class has just one method (or, more accurately, just one element +of {superclasses + methods}), then we use a different strategy. + + class C a where op :: a -> a + instance C a => C [a] where op = + +We translate the class decl into a newtype, which just gives a +top-level axiom. The "constructor" MkC expands to a cast, as does the +class-op selector. + + axiom Co:C a :: C a ~ (a->a) + + op :: forall a. C a -> (a -> a) + op a d = d |> (Co:C a) + + MkC :: forall a. (a->a) -> C a + MkC = /\a.\op. op |> (sym Co:C a) + +The clever RULE stuff doesn't work now, because ($df a d) isn't +a constructor application, so exprIsConApp_maybe won't return +Just . + +Instead, we simply rely on the fact that casts are cheap: + + $df :: forall a. C a => C [a] + {-# INLINE df #-} -- NB: INLINE this + $df = /\a. \d. MkC [a] ($cop_list a d) + = $cop_list |> forall a. C a -> (sym (Co:C [a])) + + $cop_list :: forall a. C a => [a] -> [a] + $cop_list = + +So if we see + (op ($df a d)) +we'll inline 'op' and '$df', since both are simply casts, and +good things happen. + +Why do we use this different strategy? Because otherwise we +end up with non-inlined dictionaries that look like + $df = $cop |> blah +which adds an extra indirection to every use, which seems stupid. See +#4138 for an example (although the regression reported there +wasn't due to the indirection). + +There is an awkward wrinkle though: we want to be very +careful when we have + instance C a => C [a] where + {-# INLINE op #-} + op = ... +then we'll get an INLINE pragma on $cop_list but it's important that +$cop_list only inlines when it's applied to *two* arguments (the +dictionary and the list argument). So we must not eta-expand $df +above. We ensure that this doesn't happen by putting an INLINE +pragma on the dfun itself; after all, it ends up being just a cast. + +There is one more dark corner to the INLINE story, even more deeply +buried. Consider this (#3772): + + class DeepSeq a => C a where + gen :: Int -> a + + instance C a => C [a] where + gen n = ... + + class DeepSeq a where + deepSeq :: a -> b -> b + + instance DeepSeq a => DeepSeq [a] where + {-# INLINE deepSeq #-} + deepSeq xs b = foldr deepSeq b xs + +That gives rise to these defns: + + $cdeepSeq :: DeepSeq a -> [a] -> b -> b + -- User INLINE( 3 args )! + $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ... + + $fDeepSeq[] :: DeepSeq a -> DeepSeq [a] + -- DFun (with auto INLINE pragma) + $fDeepSeq[] a d = $cdeepSeq a d |> blah + + $cp1 a d :: C a => DeepSep [a] + -- We don't want to eta-expand this, lest + -- $cdeepSeq gets inlined in it! + $cp1 a d = $fDeepSep[] a (scsel a d) + + $fC[] :: C a => C [a] + -- Ordinary DFun + $fC[] a d = MkC ($cp1 a d) ($cgen a d) + +Here $cp1 is the code that generates the superclass for C [a]. The +issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[] +and then $cdeepSeq will inline there, which is definitely wrong. Like +on the dfun, we solve this by adding an INLINE pragma to $cp1. + +Note [Subtle interaction of recursion and overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + class C a where { op1,op2 :: a -> a } + instance C a => C [a] where + op1 x = op2 x ++ op2 x + op2 x = ... + instance C [Int] where + ... + +When type-checking the C [a] instance, we need a C [a] dictionary (for +the call of op2). If we look up in the instance environment, we find +an overlap. And in *general* the right thing is to complain (see Note +[Overlapping instances] in GHC.Core.InstEnv). But in *this* case it's wrong to +complain, because we just want to delegate to the op2 of this same +instance. + +Why is this justified? Because we generate a (C [a]) constraint in +a context in which 'a' cannot be instantiated to anything that matches +other overlapping instances, or else we would not be executing this +version of op1 in the first place. + +It might even be a bit disguised: + + nullFail :: C [a] => [a] -> [a] + nullFail x = op2 x ++ op2 x + + instance C a => C [a] where + op1 x = nullFail x + +Precisely this is used in package 'regex-base', module Context.hs. +See the overlapping instances for RegexContext, and the fact that they +call 'nullFail' just like the example above. The DoCon package also +does the same thing; it shows up in module Fraction.hs. + +Conclusion: when typechecking the methods in a C [a] instance, we want to +treat the 'a' as an *existential* type variable, in the sense described +by Note [Binding when looking up instances]. That is why isOverlappableTyVar +responds True to an InstSkol, which is the kind of skolem we use in +tcInstDecl2. + + +Note [Tricky type variable scoping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In our example + class C a where + op1, op2 :: Ix b => a -> b -> b + op2 = + + instance C a => C [a] + {-# INLINE [2] op1 #-} + op1 = + +note that 'a' and 'b' are *both* in scope in , but only 'a' is +in scope in . In particular, we must make sure that 'b' is in +scope when typechecking . This is achieved by subFunTys, +which brings appropriate tyvars into scope. This happens for both + and for , but that doesn't matter: the *renamer* will have +complained if 'b' is mentioned in . + + + +************************************************************************ +* * +\subsection{Extracting instance decls} +* * +************************************************************************ + +Gather up the instance declarations from their various sources +-} + +tcInstDecls1 -- Deal with both source-code and imported instance decls + :: [LInstDecl GhcRn] -- Source code instance decls + -> TcM (TcGblEnv, -- The full inst env + [InstInfo GhcRn], -- Source-code instance decls to process; + -- contains all dfuns for this module + [DerivInfo]) -- From data family instances + +tcInstDecls1 inst_decls + = do { -- Do class and family instance declarations + ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls + + ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff + fam_insts = concat fam_insts_s + local_infos = concat local_infos_s + + ; gbl_env <- addClsInsts local_infos $ + addFamInsts fam_insts $ + getGblEnv + + ; return ( gbl_env + , local_infos + , concat datafam_deriv_infos ) } + +-- | Use DerivInfo for data family instances (produced by tcInstDecls1), +-- datatype declarations (TyClDecl), and standalone deriving declarations +-- (DerivDecl) to check and process all derived class instances. +tcInstDeclsDeriv + :: [DerivInfo] + -> [LDerivDecl GhcRn] + -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn) +tcInstDeclsDeriv deriv_infos derivds + = do th_stage <- getStage -- See Note [Deriving inside TH brackets] + if isBrackStage th_stage + then do { gbl_env <- getGblEnv + ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) } + else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds + ; return (tcg_env, bagToList info_bag, valbinds) } + +addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a +addClsInsts infos thing_inside + = tcExtendLocalInstEnv (map iSpec infos) thing_inside + +addFamInsts :: [FamInst] -> TcM a -> TcM a +-- Extend (a) the family instance envt +-- (b) the type envt with stuff from data type decls +addFamInsts fam_insts thing_inside + = tcExtendLocalFamInstEnv fam_insts $ + tcExtendGlobalEnv axioms $ + do { traceTc "addFamInsts" (pprFamInsts fam_insts) + ; gbl_env <- addTyConsToGblEnv data_rep_tycons + -- Does not add its axiom; that comes + -- from adding the 'axioms' above + ; setGblEnv gbl_env thing_inside } + where + axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts + data_rep_tycons = famInstsRepTyCons fam_insts + -- The representation tycons for 'data instances' declarations + +{- +Note [Deriving inside TH brackets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a declaration bracket + [d| data T = A | B deriving( Show ) |] + +there is really no point in generating the derived code for deriving( +Show) and then type-checking it. This will happen at the call site +anyway, and the type check should never fail! Moreover (#6005) +the scoping of the generated code inside the bracket does not seem to +work out. + +The easy solution is simply not to generate the derived instances at +all. (A less brutal solution would be to generate them with no +bindings.) This will become moot when we shift to the new TH plan, so +the brutal solution will do. +-} + +tcLocalInstDecl :: LInstDecl GhcRn + -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) + -- A source-file instance declaration + -- Type-check all the stuff before the "where" + -- + -- We check for respectable instance type, and context +tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl })) + = do { fam_inst <- tcTyFamInstDecl NotAssociated (L loc decl) + ; return ([], [fam_inst], []) } + +tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl })) + = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated emptyVarEnv (L loc decl) + ; return ([], [fam_inst], maybeToList m_deriv_info) } + +tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) + = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl) + ; return (insts, fam_insts, deriv_infos) } + +tcClsInstDecl :: LClsInstDecl GhcRn + -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) +-- The returned DerivInfos are for any associated data families +tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds + , cid_sigs = uprags, cid_tyfam_insts = ats + , cid_overlap_mode = overlap_mode + , cid_datafam_insts = adts })) + = setSrcSpan loc $ + addErrCtxt (instDeclCtxt1 hs_ty) $ + do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty + ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty + -- NB: tcHsClsInstType does checkValidInstance + + ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars + ; let tv_skol_prs = [ (tyVarName tv, skol_tv) + | (tv, skol_tv) <- tyvars `zip` skol_tvs ] + -- Map from the skolemized Names to the original Names. + -- See Note [Associated data family instances and di_scoped_tvs]. + tv_skol_env = mkVarEnv $ map swap tv_skol_prs + n_inferred = countWhile ((== Inferred) . binderArgFlag) $ + fst $ splitForAllVarBndrs dfun_ty + visible_skol_tvs = drop n_inferred skol_tvs + + ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs) + + -- Next, process any associated types. + ; (datafam_stuff, tyfam_insts) + <- tcExtendNameTyVarEnv tv_skol_prs $ + do { let mini_env = mkVarEnv (classTyVars clas `zip` substTys subst inst_tys) + mini_subst = mkTvSubst (mkInScopeSet (mkVarSet skol_tvs)) mini_env + mb_info = InClsInst { ai_class = clas + , ai_tyvars = visible_skol_tvs + , ai_inst_env = mini_env } + ; df_stuff <- mapAndRecoverM (tcDataFamInstDecl mb_info tv_skol_env) adts + ; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info) ats + + -- Check for missing associated types and build them + -- from their defaults (if available) + ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats) + (classATItems clas) + + ; return (df_stuff, tf_insts1 ++ concat tf_insts2) } + + + -- Finally, construct the Core representation of the instance. + -- (This no longer includes the associated types.) + ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType hs_ty)) + -- Dfun location is that of instance *header* + + ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name + tyvars theta clas inst_tys + + ; let inst_binds = InstBindings + { ib_binds = binds + , ib_tyvars = map Var.varName tyvars -- Scope over bindings + , ib_pragmas = uprags + , ib_extensions = [] + , ib_derived = False } + inst_info = InstInfo { iSpec = ispec, iBinds = inst_binds } + + (datafam_insts, m_deriv_infos) = unzip datafam_stuff + deriv_infos = catMaybes m_deriv_infos + all_insts = tyfam_insts ++ datafam_insts + + -- In hs-boot files there should be no bindings + ; is_boot <- tcIsHsBootOrSig + ; let no_binds = isEmptyLHsBinds binds && null uprags + ; failIfTc (is_boot && not no_binds) badBootDeclErr + + ; return ( [inst_info], all_insts, deriv_infos ) } + where + defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) + `unionNameSet` + mkNameSet (map (unLoc . feqn_tycon + . hsib_body + . dfid_eqn + . unLoc) adts) + +{- +************************************************************************ +* * + Type family instances +* * +************************************************************************ + +Family instances are somewhat of a hybrid. They are processed together with +class instance heads, but can contain data constructors and hence they share a +lot of kinding and type checking code with ordinary algebraic data types (and +GADTs). +-} + +tcTyFamInstDecl :: AssocInstInfo + -> LTyFamInstDecl GhcRn -> TcM FamInst + -- "type instance" + -- See Note [Associated type instances] +tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) + = setSrcSpan loc $ + tcAddTyFamInstCtxt decl $ + do { let fam_lname = feqn_tycon (hsib_body eqn) + ; fam_tc <- tcLookupLocatedTyCon fam_lname + ; tcFamInstDeclChecks mb_clsinfo fam_tc + + -- (0) Check it's an open type family + ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc) + + -- (1) do the work of verifying the synonym group + ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo + (L (getLoc fam_lname) eqn) + + + -- (2) check for validity + ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch + ; checkValidCoAxBranch fam_tc co_ax_branch + + -- (3) construct coercion axiom + ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch] + ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch + ; newFamInst SynFamilyInst axiom } + + +--------------------- +tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM () +-- Used for both type and data families +tcFamInstDeclChecks mb_clsinfo 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 $ badFamInstDecl fam_tc + ; checkTc (not is_boot) $ badBootFamInstDeclErr + + -- Check that it is a family TyCon, and that + -- oplevel type instances are not for associated types. + ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) + + ; when (isNotAssociated mb_clsinfo && -- Not in a class decl + isTyConAssoc fam_tc) -- but an associated type + (addErr $ assocInClassErr fam_tc) + } + +{- Note [Associated type instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow this: + class C a where + type T x a + instance C Int where + type T (S y) Int = y + type T Z Int = Char + +Note that + a) The variable 'x' is not bound by the class decl + b) 'x' is instantiated to a non-type-variable in the instance + c) There are several type instance decls for T in the instance + +All this is fine. Of course, you can't give any *more* instances +for (T ty Int) elsewhere, because it's an *associated* type. + + +************************************************************************ +* * + Data family instances +* * +************************************************************************ + +For some reason data family instances are a lot more complicated +than type family instances +-} + +tcDataFamInstDecl :: + AssocInstInfo + -> TyVarEnv Name -- If this is an associated data family instance, maps the + -- parent class's skolemized type variables to their + -- original Names. If this is a non-associated instance, + -- this will be empty. + -- See Note [Associated data family instances and di_scoped_tvs]. + -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo) + -- "newtype instance" and "data instance" +tcDataFamInstDecl mb_clsinfo tv_skol_env + (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = imp_vars + , hsib_body = + FamEqn { feqn_bndrs = mb_bndrs + , feqn_pats = hs_pats + , feqn_tycon = lfam_name@(L _ fam_name) + , feqn_fixity = fixity + , feqn_rhs = HsDataDefn { dd_ND = new_or_data + , dd_cType = cType + , dd_ctxt = hs_ctxt + , dd_cons = hs_cons + , dd_kindSig = m_ksig + , dd_derivs = derivs } }}})) + = setSrcSpan loc $ + tcAddDataFamInstCtxt decl $ + do { fam_tc <- tcLookupLocatedTyCon lfam_name + + ; tcFamInstDeclChecks mb_clsinfo fam_tc + + -- Check that the family declaration is for the right kind + ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons + -- Do /not/ check that the number of patterns = tyConArity fam_tc + -- See [Arity of data families] in GHC.Core.FamInstEnv + ; (qtvs, pats, res_kind, stupid_theta) + <- tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs + fixity hs_ctxt hs_pats m_ksig hs_cons + new_or_data + + -- Eta-reduce the axiom if possible + -- Quite tricky: see Note [Implementing eta reduction for data families] + ; let (eta_pats, eta_tcbs) = eta_reduce fam_tc pats + eta_tvs = map binderVar eta_tcbs + post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs + + full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs + (tyCoVarsOfType (mkSpecForAllTys eta_tvs res_kind)) + ++ eta_tcbs + -- Put the eta-removed tyvars at the end + -- Remember, qtvs is in arbitrary order, except kind vars are + -- first, so there is no reason to suppose that the eta_tvs + -- (obtained from the pats) are at the end (#11148) + + -- Eta-expand the representation tycon until it has result + -- kind `TYPE r`, for some `r`. If UnliftedNewtypes is not enabled, we + -- go one step further and ensure that it has kind `TYPE 'LiftedRep`. + -- + -- See also Note [Arity of data families] in GHC.Core.FamInstEnv + -- NB: we can do this after eta-reducing the axiom, because if + -- we did it before the "extra" tvs from etaExpandAlgTyCon + -- would always be eta-reduced + -- + -- See also Note [Datatype return kinds] in GHC.Tc.TyCl + ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind + ; checkDataKindSig (DataInstanceSort new_or_data) final_res_kind + ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs + all_pats = pats `chkAppend` extra_pats + orig_res_ty = mkTyConApp fam_tc all_pats + ty_binders = full_tcbs `chkAppend` extra_tcbs + + ; traceTc "tcDataFamInstDecl" $ + vcat [ text "Fam tycon:" <+> ppr fam_tc + , text "Pats:" <+> ppr pats + , text "visibliities:" <+> ppr (tcbVisibilities fam_tc pats) + , text "all_pats:" <+> ppr all_pats + , text "ty_binders" <+> ppr ty_binders + , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc) + , text "eta_pats" <+> ppr eta_pats + , text "eta_tcbs" <+> ppr eta_tcbs ] + + ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) -> + do { data_cons <- tcExtendTyVarEnv qtvs $ + -- For H98 decls, the tyvars scope + -- over the data constructors + tcConDecls rec_rep_tc new_or_data ty_binders final_res_kind + orig_res_ty hs_cons + + ; rep_tc_name <- newFamInstTyConName lfam_name pats + ; axiom_name <- newFamInstAxiomName lfam_name [pats] + ; tc_rhs <- case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) + + ; let axiom = mkSingleCoAxiom Representational axiom_name + post_eta_qtvs eta_tvs [] fam_tc eta_pats + (mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs)) + parent = DataFamInstTyCon axiom fam_tc all_pats + + -- NB: Use the full ty_binders from the pats. See bullet toward + -- the end of Note [Data type families] in GHC.Core.TyCon + rep_tc = mkAlgTyCon rep_tc_name + ty_binders final_res_kind + (map (const Nominal) ty_binders) + (fmap unLoc cType) stupid_theta + tc_rhs parent + gadt_syntax + -- We always assume that indexed types are recursive. Why? + -- (1) Due to their open nature, we can never be sure that a + -- further instance might not introduce a new recursive + -- dependency. (2) They are always valid loop breakers as + -- they involve a coercion. + ; return (rep_tc, axiom) } + + -- Remember to check validity; no recursion to worry about here + -- Check that left-hand sides are ok (mono-types, no type families, + -- consistent instantiations, etc) + ; let ax_branch = coAxiomSingleBranch axiom + ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch + ; checkValidCoAxBranch fam_tc ax_branch + ; checkValidTyCon rep_tc + + ; let scoped_tvs = map mk_deriv_info_scoped_tv_pr (tyConTyVars rep_tc) + m_deriv_info = case derivs of + L _ [] -> Nothing + L _ preds -> + Just $ DerivInfo { di_rep_tc = rep_tc + , di_scoped_tvs = scoped_tvs + , di_clauses = preds + , di_ctxt = tcMkDataFamInstCtxt decl } + + ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom + ; return (fam_inst, m_deriv_info) } + where + eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder]) + -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + -- Splits the incoming patterns into two: the [TyVar] + -- are the patterns that can be eta-reduced away. + -- e.g. T [a] Int a d c ==> (T [a] Int a, [d,c]) + -- + -- NB: quadratic algorithm, but types are small here + eta_reduce fam_tc pats + = go (reverse (zip3 pats fvs_s vis_s)) [] + where + vis_s :: [TyConBndrVis] + vis_s = tcbVisibilities fam_tc pats + + fvs_s :: [TyCoVarSet] -- 1-1 correspondence with pats + -- Each elt is the free vars of all /earlier/ pats + (_, fvs_s) = mapAccumL add_fvs emptyVarSet pats + add_fvs fvs pat = (fvs `unionVarSet` tyCoVarsOfType pat, fvs) + + go ((pat, fvs_to_the_left, tcb_vis):pats) etad_tvs + | Just tv <- getTyVar_maybe pat + , not (tv `elemVarSet` fvs_to_the_left) + = go pats (Bndr tv tcb_vis : etad_tvs) + go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs) + + -- Create a Name-TyVar mapping to bring into scope when typechecking any + -- deriving clauses this data family instance may have. + -- See Note [Associated data family instances and di_scoped_tvs]. + mk_deriv_info_scoped_tv_pr :: TyVar -> (Name, TyVar) + mk_deriv_info_scoped_tv_pr tv = + let n = lookupWithDefaultVarEnv tv_skol_env (tyVarName tv) tv + in (n, tv) + +{- +Note [Associated data family instances and di_scoped_tvs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some care is required to implement `deriving` correctly for associated data +family instances. Consider this example from #18055: + + class C a where + data D a + + class X a b + + instance C (Maybe a) where + data D (Maybe a) deriving (X a) + +When typechecking the `X a` in `deriving (X a)`, we must ensure that the `a` +from the instance header is brought into scope. This is the role of +di_scoped_tvs, which maps from the original, renamed `a` to the skolemized, +typechecked `a`. When typechecking the `deriving` clause, this mapping will be +consulted when looking up the `a` in `X a`. + +A naïve attempt at creating the di_scoped_tvs is to simply reuse the +tyConTyVars of the representation TyCon for `data D (Maybe a)`. This is only +half correct, however. We do want the typechecked `a`'s Name in the /range/ +of the mapping, but we do not want it in the /domain/ of the mapping. +To ensure that the original `a`'s Name ends up in the domain, we consult a +TyVarEnv (passed as an argument to tcDataFamInstDecl) that maps from the +typechecked `a`'s Name to the original `a`'s Name. In the even that +tcDataFamInstDecl is processing a non-associated data family instance, this +TyVarEnv will simply be empty, and there is nothing to worry about. +-} + +----------------------- +tcDataFamInstHeader + :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn] + -> LexicalFixity -> LHsContext GhcRn + -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn] + -> NewOrData + -> TcM ([TyVar], [Type], Kind, ThetaType) +-- The "header" of a data family instance is the part other than +-- the data constructors themselves +-- e.g. data instance D [a] :: * -> * where ... +-- Here the "header" is the bit before the "where" +tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity + hs_ctxt hs_pats m_ksig hs_cons new_or_data + = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, lhs_applied_kind))) + <- pushTcLevelM_ $ + solveEqualities $ + bindImplicitTKBndrs_Q_Skol imp_vars $ + bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ + do { stupid_theta <- tcHsContext hs_ctxt + ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats + + -- Ensure that the instance is consistent + -- with its parent class + ; addConsistencyConstraints mb_clsinfo lhs_ty + + -- Add constraints from the result signature + ; res_kind <- tc_kind_sig m_ksig + + -- Add constraints from the data constructors + ; kcConDecls new_or_data res_kind hs_cons + + -- See Note [Datatype return kinds] in GHC.Tc.TyCl, point (7). + ; (lhs_extra_args, lhs_applied_kind) + <- tcInstInvisibleTyBinders (invisibleTyBndrCount lhs_kind) + lhs_kind + ; let lhs_applied_ty = lhs_ty `mkTcAppTys` lhs_extra_args + hs_lhs = nlHsTyConApp fixity (getName fam_tc) hs_pats + ; _ <- unifyKind (Just (unLoc hs_lhs)) lhs_applied_kind res_kind + + ; return ( stupid_theta + , lhs_applied_ty + , lhs_applied_kind ) } + + -- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts] + -- This code (and the stuff immediately above) is very similar + -- to that in tcTyFamInstEqnGuts. Maybe we should abstract the + -- common code; but for the moment I concluded that it's + -- clearer to duplicate it. Still, if you fix a bug here, + -- check there too! + ; let scoped_tvs = imp_tvs ++ exp_tvs + ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) + ; qtvs <- quantifyTyVars dvs + + -- Zonk the patterns etc into the Type world + ; (ze, qtvs) <- zonkTyBndrs qtvs + ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty + ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta + ; lhs_applied_kind <- zonkTcTypeToTypeX ze lhs_applied_kind + + -- Check that type patterns match the class instance head + -- The call to splitTyConApp_maybe here is just an inlining of + -- the body of unravelFamInstPats. + ; pats <- case splitTyConApp_maybe lhs_ty of + Just (_, pats) -> pure pats + Nothing -> pprPanic "tcDataFamInstHeader" (ppr lhs_ty) + ; return (qtvs, pats, lhs_applied_kind, stupid_theta) } + where + fam_name = tyConName fam_tc + data_ctxt = DataKindCtxt fam_name + exp_bndrs = mb_bndrs `orElse` [] + + -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl, wrinkle (2). + tc_kind_sig Nothing + = do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes + ; if unlifted_newtypes && new_or_data == NewType + then newOpenTypeKind + else pure liftedTypeKind + } + + -- See Note [Result kind signature for a data family instance] + tc_kind_sig (Just hs_kind) + = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind + ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind + ; lvl <- getTcLevel + ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs + -- Perhaps surprisingly, we don't need the skolemised tvs themselves + ; let final_kind = substTy subst inner_kind + ; checkDataKindSig (DataInstanceSort new_or_data) $ + snd $ tcSplitPiTys final_kind + -- See Note [Datatype return kinds], end of point (4) + ; return final_kind } + +{- Note [Result kind signature for a data family instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The expected type might have a forall at the type. Normally, we +can't skolemise in kinds because we don't have type-level lambda. +But here, we're at the top-level of an instance declaration, so +we actually have a place to put the regeneralised variables. +Thus: skolemise away. cf. Inst.deeplySkolemise and GHC.Tc.Utils.Unify.tcSkolemise +Examples in indexed-types/should_compile/T12369 + +Note [Implementing eta reduction for data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data D :: * -> * -> * -> * -> * + + data instance D [(a,b)] p q :: * -> * where + D1 :: blah1 + D2 :: blah2 + +Then we'll generate a representation data type + data Drep a b p q z where + D1 :: blah1 + D2 :: blah2 + +and an axiom to connect them + axiom AxDrep forall a b p q z. D [(a,b]] p q z = Drep a b p q z + +except that we'll eta-reduce the axiom to + axiom AxDrep forall a b. D [(a,b]] = Drep a b + +This is described at some length in Note [Eta reduction for data families] +in GHC.Core.Coercion.Axiom. There are several fiddly subtleties lurking here, +however, so this Note aims to describe these subtleties: + +* The representation tycon Drep is parameterised over the free + variables of the pattern, in no particular order. So there is no + guarantee that 'p' and 'q' will come last in Drep's parameters, and + in the right order. So, if the /patterns/ of the family insatance + are eta-reducible, we re-order Drep's parameters to put the + eta-reduced type variables last. + +* Although we eta-reduce the axiom, we eta-/expand/ the representation + tycon Drep. The kind of D says it takes four arguments, but the + data instance header only supplies three. But the AlgTyCon for Drep + itself must have enough TyConBinders so that its result kind is Type. + So, with etaExpandAlgTyCon we make up some extra TyConBinders. + See point (3) in Note [Datatype return kinds] in GHC.Tc.TyCl. + +* The result kind in the instance might be a polykind, like this: + data family DP a :: forall k. k -> * + data instance DP [b] :: forall k1 k2. (k1,k2) -> * + + So in type-checking the LHS (DP Int) we need to check that it is + more polymorphic than the signature. To do that we must skolemise + the signature and instantiate the call of DP. So we end up with + data instance DP [b] @(k1,k2) (z :: (k1,k2)) where + + Note that we must parameterise the representation tycon DPrep over + 'k1' and 'k2', as well as 'b'. + + The skolemise bit is done in tc_kind_sig, while the instantiate bit + is done by tcFamTyPats. + +* Very fiddly point. When we eta-reduce to + axiom AxDrep forall a b. D [(a,b]] = Drep a b + + we want the kind of (D [(a,b)]) to be the same as the kind of + (Drep a b). This ensures that applying the axiom doesn't change the + kind. Why is that hard? Because the kind of (Drep a b) depends on + the TyConBndrVis on Drep's arguments. In particular do we have + (forall (k::*). blah) or (* -> blah)? + + We must match whatever D does! In #15817 we had + data family X a :: forall k. * -> * -- Note: a forall that is not used + data instance X Int b = MkX + + So the data instance is really + data istance X Int @k b = MkX + + The axiom will look like + axiom X Int = Xrep + + and it's important that XRep :: forall k * -> *, following X. + + To achieve this we get the TyConBndrVis flags from tcbVisibilities, + and use those flags for any eta-reduced arguments. Sigh. + +* The final turn of the knife is that tcbVisibilities is itself + tricky to sort out. Consider + data family D k :: k + Then consider D (forall k2. k2 -> k2) Type Type + The visibility flags on an application of D may affected by the arguments + themselves. Heavy sigh. But not truly hard; that's what tcbVisibilities + does. + +-} + + +{- ********************************************************************* +* * + Class instance declarations, pass 2 +* * +********************************************************************* -} + +tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] + -> TcM (LHsBinds GhcTc) +-- (a) From each class declaration, +-- generate any default-method bindings +-- (b) From each instance decl +-- generate the dfun binding + +tcInstDecls2 tycl_decls inst_decls + = do { -- (a) Default methods from class decls + let class_decls = filter (isClassDecl . unLoc) tycl_decls + ; dm_binds_s <- mapM tcClassDecl2 class_decls + ; let dm_binds = unionManyBags dm_binds_s + + -- (b) instance declarations + ; let dm_ids = collectHsBindsBinders dm_binds + -- Add the default method Ids (again) + -- (they were arready added in GHC.Tc.TyCl.Utils.tcAddImplicits) + -- See Note [Default methods in the type environment] + ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $ + mapM tcInstDecl2 inst_decls + + -- Done + ; return (dm_binds `unionBags` unionManyBags inst_binds_s) } + +{- Note [Default methods in the type environment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The default method Ids are already in the type environment (see Note +[Default method Ids and Template Haskell] in TcTyDcls), BUT they +don't have their InlinePragmas yet. Usually that would not matter, +because the simplifier propagates information from binding site to +use. But, unusually, when compiling instance decls we *copy* the +INLINE pragma from the default method to the method for that +particular operation (see Note [INLINE and default methods] below). + +So right here in tcInstDecls2 we must re-extend the type envt with +the default method Ids replete with their INLINE pragmas. Urk. +-} + +tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc) + -- Returns a binding for the dfun +tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) + = recoverM (return emptyLHsBinds) $ + setSrcSpan loc $ + addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ + do { -- Instantiate the instance decl with skolem constants + ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id + ; dfun_ev_vars <- newEvVars dfun_theta + -- We instantiate the dfun_id with superSkolems. + -- See Note [Subtle interaction of recursion and overlap] + -- and Note [Binding when looking up instances] + + ; let (clas, inst_tys) = tcSplitDFunHead inst_head + (class_tyvars, sc_theta, _, op_items) = classBigSig clas + sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta + + ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta']) + + -- Deal with 'SPECIALISE instance' pragmas + -- See Note [SPECIALISE instance pragmas] + ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds + + -- Typecheck superclasses and methods + -- See Note [Typechecking plan for instance declarations] + ; dfun_ev_binds_var <- newTcEvBinds + ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var + ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics)) + <- pushTcLevelM $ + do { (sc_ids, sc_binds, sc_implics) + <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars + inst_tys dfun_ev_binds + sc_theta' + + -- Typecheck the methods + ; (meth_ids, meth_binds, meth_implics) + <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars + inst_tys dfun_ev_binds spec_inst_info + op_items ibinds + + ; return ( sc_ids ++ meth_ids + , sc_binds `unionBags` meth_binds + , sc_implics `unionBags` meth_implics ) } + + ; imp <- newImplication + ; emitImplication $ + imp { ic_tclvl = tclvl + , ic_skols = inst_tyvars + , ic_given = dfun_ev_vars + , ic_wanted = mkImplicWC sc_meth_implics + , ic_binds = dfun_ev_binds_var + , ic_info = InstSkol } + + -- Create the result bindings + ; self_dict <- newDict clas inst_tys + ; let class_tc = classTyCon clas + [dict_constr] = tyConDataCons class_tc + dict_bind = mkVarBind self_dict (L loc con_app_args) + + -- We don't produce a binding for the dict_constr; instead we + -- rely on the simplifier to unfold this saturated application + -- We do this rather than generate an HsCon directly, because + -- it means that the special cases (e.g. dictionary with only one + -- member) are dealt with by the common MkId.mkDataConWrapId + -- code rather than needing to be repeated here. + -- con_app_tys = MkD ty1 ty2 + -- con_app_scs = MkD ty1 ty2 sc1 sc2 + -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 + con_app_tys = mkHsWrap (mkWpTyApps inst_tys) + (HsConLikeOut noExtField (RealDataCon dict_constr)) + -- NB: We *can* have covars in inst_tys, in the case of + -- promoted GADT constructors. + + con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids + + app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc + app_to_meth fun meth_id = HsApp noExtField (L loc fun) + (L loc (wrapId arg_wrapper meth_id)) + + inst_tv_tys = mkTyVarTys inst_tyvars + arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys + + is_newtype = isNewTyCon class_tc + dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids + dfun_spec_prags + | is_newtype = SpecPrags [] + | otherwise = SpecPrags spec_inst_prags + -- Newtype dfuns just inline unconditionally, + -- so don't attempt to specialise them + + export = ABE { abe_ext = noExtField + , abe_wrap = idHsWrapper + , abe_poly = dfun_id_w_prags + , abe_mono = self_dict + , abe_prags = dfun_spec_prags } + -- NB: see Note [SPECIALISE instance pragmas] + main_bind = AbsBinds { abs_ext = noExtField + , abs_tvs = inst_tyvars + , abs_ev_vars = dfun_ev_vars + , abs_exports = [export] + , abs_ev_binds = [] + , abs_binds = unitBag dict_bind + , abs_sig = True } + + ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds) + } + where + dfun_id = instanceDFunId ispec + loc = getSrcSpan dfun_id + +addDFunPrags :: DFunId -> [Id] -> DFunId +-- DFuns need a special Unfolding and InlinePrag +-- See Note [ClassOp/DFun selection] +-- and Note [Single-method classes] +-- It's easiest to create those unfoldings right here, where +-- have all the pieces in hand, even though we are messing with +-- Core at this point, which the typechecker doesn't usually do +-- However we take care to build the unfolding using the TyVars from +-- the DFunId rather than from the skolem pieces that the typechecker +-- is messing with. +addDFunPrags dfun_id sc_meth_ids + | is_newtype + = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 con_app + `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } + | otherwise + = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args + `setInlinePragma` dfunInlinePragma + where + con_app = mkLams dfun_bndrs $ + mkApps (Var (dataConWrapId dict_con)) dict_args + -- mkApps is OK because of the checkForLevPoly call in checkValidClass + -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad + dict_args = map Type inst_tys ++ + [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] + + (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id) + ev_ids = mkTemplateLocalsNum 1 dfun_theta + dfun_bndrs = dfun_tvs ++ ev_ids + clas_tc = classTyCon clas + [dict_con] = tyConDataCons clas_tc + is_newtype = isNewTyCon clas_tc + +wrapId :: HsWrapper -> Id -> HsExpr GhcTc +wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLoc id)) + +{- Note [Typechecking plan for instance declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For instance declarations we generate the following bindings and implication +constraints. Example: + + instance Ord a => Ord [a] where compare = + +generates this: + + Bindings: + -- Method bindings + $ccompare :: forall a. Ord a => a -> a -> Ordering + $ccompare = /\a \(d:Ord a). let in ... + + -- Superclass bindings + $cp1Ord :: forall a. Ord a => Eq [a] + $cp1Ord = /\a \(d:Ord a). let + in dfEqList (dw :: Eq a) + + Constraints: + forall a. Ord a => + -- Method constraint + (forall. (empty) => ) + -- Superclass constraint + /\ (forall. (empty) => dw :: Eq a) + +Notice that + + * Per-meth/sc implication. There is one inner implication per + superclass or method, with no skolem variables or givens. The only + reason for this one is to gather the evidence bindings privately + for this superclass or method. This implication is generated + by checkInstConstraints. + + * Overall instance implication. There is an overall enclosing + implication for the whole instance declaration, with the expected + skolems and givens. We need this to get the correct "redundant + constraint" warnings, gathering all the uses from all the methods + and superclasses. See GHC.Tc.Solver Note [Tracking redundant + constraints] + + * The given constraints in the outer implication may generate + evidence, notably by superclass selection. Since the method and + superclass bindings are top-level, we want that evidence copied + into *every* method or superclass definition. (Some of it will + be usused in some, but dead-code elimination will drop it.) + + We achieve this by putting the evidence variable for the overall + instance implication into the AbsBinds for each method/superclass. + Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses. + (And that in turn is why the abs_ev_binds field of AbBinds is a + [TcEvBinds] rather than simply TcEvBinds. + + This is a bit of a hack, but works very nicely in practice. + + * Note that if a method has a locally-polymorphic binding, there will + be yet another implication for that, generated by tcPolyCheck + in tcMethodBody. E.g. + class C a where + foo :: forall b. Ord b => blah + + +************************************************************************ +* * + Type-checking superclasses +* * +************************************************************************ +-} + +tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] + -> TcEvBinds + -> TcThetaType + -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication) +-- Make a new top-level function binding for each superclass, +-- something like +-- $Ordp1 :: forall a. Ord a => Eq [a] +-- $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d) +-- +-- See Note [Recursive superclasses] for why this is so hard! +-- In effect, we build a special-purpose solver for the first step +-- of solving each superclass constraint +tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta + = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..]) + ; return (ids, listToBag binds, listToBag implics) } + where + loc = getSrcSpan dfun_id + size = sizeTypes inst_tys + tc_super (sc_pred, n) + = do { (sc_implic, ev_binds_var, sc_ev_tm) + <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred + + ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) + ; sc_ev_id <- newEvVar sc_pred + ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm + ; let sc_top_ty = mkInvForAllTys tyvars $ + mkPhiTy (map idType dfun_evs) sc_pred + sc_top_id = mkLocalId sc_top_name sc_top_ty + export = ABE { abe_ext = noExtField + , abe_wrap = idHsWrapper + , abe_poly = sc_top_id + , abe_mono = sc_ev_id + , abe_prags = noSpecPrags } + local_ev_binds = TcEvBinds ev_binds_var + bind = AbsBinds { abs_ext = noExtField + , abs_tvs = tyvars + , abs_ev_vars = dfun_evs + , abs_exports = [export] + , abs_ev_binds = [dfun_ev_binds, local_ev_binds] + , abs_binds = emptyBag + , abs_sig = False } + ; return (sc_top_id, L loc bind, sc_implic) } + +------------------- +checkInstConstraints :: TcM result + -> TcM (Implication, EvBindsVar, result) +-- See Note [Typechecking plan for instance declarations] +checkInstConstraints thing_inside + = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $ + thing_inside + + ; ev_binds_var <- newTcEvBinds + ; implic <- newImplication + ; let implic' = implic { ic_tclvl = tclvl + , ic_wanted = wanted + , ic_binds = ev_binds_var + , ic_info = InstSkol } + + ; return (implic', ev_binds_var, result) } + +{- +Note [Recursive superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #3731, #4809, #5751, #5913, #6117, #6161, which all +describe somewhat more complicated situations, but ones +encountered in practice. + +See also tests tcrun020, tcrun021, tcrun033, and #11427. + +----- THE PROBLEM -------- +The problem is that it is all too easy to create a class whose +superclass is bottom when it should not be. + +Consider the following (extreme) situation: + class C a => D a where ... + instance D [a] => D [a] where ... (dfunD) + instance C [a] => C [a] where ... (dfunC) +Although this looks wrong (assume D [a] to prove D [a]), it is only a +more extreme case of what happens with recursive dictionaries, and it +can, just about, make sense because the methods do some work before +recursing. + +To implement the dfunD we must generate code for the superclass C [a], +which we had better not get by superclass selection from the supplied +argument: + dfunD :: forall a. D [a] -> D [a] + dfunD = \d::D [a] -> MkD (scsel d) .. + +Otherwise if we later encounter a situation where +we have a [Wanted] dw::D [a] we might solve it thus: + dw := dfunD dw +Which is all fine except that now ** the superclass C is bottom **! + +The instance we want is: + dfunD :: forall a. D [a] -> D [a] + dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ... + +----- THE SOLUTION -------- +The basic solution is simple: be very careful about using superclass +selection to generate a superclass witness in a dictionary function +definition. More precisely: + + Superclass Invariant: in every class dictionary, + every superclass dictionary field + is non-bottom + +To achieve the Superclass Invariant, in a dfun definition we can +generate a guaranteed-non-bottom superclass witness from: + (sc1) one of the dictionary arguments itself (all non-bottom) + (sc2) an immediate superclass of a smaller dictionary + (sc3) a call of a dfun (always returns a dictionary constructor) + +The tricky case is (sc2). We proceed by induction on the size of +the (type of) the dictionary, defined by GHC.Tc.Validity.sizeTypes. +Let's suppose we are building a dictionary of size 3, and +suppose the Superclass Invariant holds of smaller dictionaries. +Then if we have a smaller dictionary, its immediate superclasses +will be non-bottom by induction. + +What does "we have a smaller dictionary" mean? It might be +one of the arguments of the instance, or one of its superclasses. +Here is an example, taken from CmmExpr: + class Ord r => UserOfRegs r a where ... +(i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where +(i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where + +For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a), +since it is smaller than the thing we are building (UserOfRegs r (Maybe a). + +But for (i2) that isn't the case, so we must add an explicit, and +perhaps surprising, (Ord r) argument to the instance declaration. + +Here's another example from #6161: + + class Super a => Duper a where ... + class Duper (Fam a) => Foo a where ... +(i3) instance Foo a => Duper (Fam a) where ... +(i4) instance Foo Float where ... + +It would be horribly wrong to define + dfDuperFam :: Foo a -> Duper (Fam a) -- from (i3) + dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ... + + dfFooFloat :: Foo Float -- from (i4) + dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ... + +Now the Super superclass of Duper is definitely bottom! + +This won't happen because when processing (i3) we can use the +superclasses of (Foo a), which is smaller, namely Duper (Fam a). But +that is *not* smaller than the target so we can't take *its* +superclasses. As a result the program is rightly rejected, unless you +add (Super (Fam a)) to the context of (i3). + +Note [Solving superclass constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How do we ensure that every superclass witness is generated by +one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses]. +Answer: + + * Superclass "wanted" constraints have CtOrigin of (ScOrigin size) + where 'size' is the size of the instance declaration. e.g. + class C a => D a where... + instance blah => D [a] where ... + The wanted superclass constraint for C [a] has origin + ScOrigin size, where size = size( D [a] ). + + * (sc1) When we rewrite such a wanted constraint, it retains its + origin. But if we apply an instance declaration, we can set the + origin to (ScOrigin infinity), thus lifting any restrictions by + making prohibitedSuperClassSolve return False. + + * (sc2) ScOrigin wanted constraints can't be solved from a + superclass selection, except at a smaller type. This test is + implemented by GHC.Tc.Solver.Interact.prohibitedSuperClassSolve + + * The "given" constraints of an instance decl have CtOrigin + GivenOrigin InstSkol. + + * When we make a superclass selection from InstSkol we use + a SkolemInfo of (InstSC size), where 'size' is the size of + the constraint whose superclass we are taking. A similarly + when taking the superclass of an InstSC. This is implemented + in GHC.Tc.Solver.Canonical.newSCWorkFromFlavored + +Note [Silent superclass arguments] (historical interest only) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB1: this note describes our *old* solution to the + recursive-superclass problem. I'm keeping the Note + for now, just as institutional memory. + However, the code for silent superclass arguments + was removed in late Dec 2014 + +NB2: the silent-superclass solution introduced new problems + of its own, in the form of instance overlap. Tests + SilentParametersOverlapping, T5051, and T7862 are examples + +NB3: the silent-superclass solution also generated tons of + extra dictionaries. For example, in monad-transformer + code, when constructing a Monad dictionary you had to pass + an Applicative dictionary; and to construct that you need + a Functor dictionary. Yet these extra dictionaries were + often never used. Test T3064 compiled *far* faster after + silent superclasses were eliminated. + +Our solution to this problem "silent superclass arguments". We pass +to each dfun some ``silent superclass arguments’’, which are the +immediate superclasses of the dictionary we are trying to +construct. In our example: + dfun :: forall a. C [a] -> D [a] -> D [a] + dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ... +Notice the extra (dc :: C [a]) argument compared to the previous version. + +This gives us: + + ----------------------------------------------------------- + DFun Superclass Invariant + ~~~~~~~~~~~~~~~~~~~~~~~~ + In the body of a DFun, every superclass argument to the + returned dictionary is + either * one of the arguments of the DFun, + or * constant, bound at top level + ----------------------------------------------------------- + +This net effect is that it is safe to treat a dfun application as +wrapping a dictionary constructor around its arguments (in particular, +a dfun never picks superclasses from the arguments under the +dictionary constructor). No superclass is hidden inside a dfun +application. + +The extra arguments required to satisfy the DFun Superclass Invariant +always come first, and are called the "silent" arguments. You can +find out how many silent arguments there are using Id.dfunNSilent; +and then you can just drop that number of arguments to see the ones +that were in the original instance declaration. + +DFun types are built (only) by MkId.mkDictFunId, so that is where we +decide what silent arguments are to be added. +-} + +{- +************************************************************************ +* * + Type-checking an instance method +* * +************************************************************************ + +tcMethod +- Make the method bindings, as a [(NonRec, HsBinds)], one per method +- Remembering to use fresh Name (the instance method Name) as the binder +- Bring the instance method Ids into scope, for the benefit of tcInstSig +- Use sig_fn mapping instance method Name -> instance tyvars +- Ditto prag_fn +- Use tcValBinds to do the checking +-} + +tcMethods :: DFunId -> Class + -> [TcTyVar] -> [EvVar] + -> [TcType] + -> TcEvBinds + -> ([Located TcSpecPrag], TcPragEnv) + -> [ClassOpItem] + -> InstBindings GhcRn + -> TcM ([Id], LHsBinds GhcTc, Bag Implication) + -- The returned inst_meth_ids all have types starting + -- forall tvs. theta => ... +tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds (spec_inst_prags, prag_fn) op_items + (InstBindings { ib_binds = binds + , ib_tyvars = lexical_tvs + , ib_pragmas = sigs + , ib_extensions = exts + , ib_derived = is_derived }) + = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $ + -- The lexical_tvs scope over the 'where' part + do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) + ; checkMinimalDefinition + ; checkMethBindMembership + ; (ids, binds, mb_implics) <- set_exts exts $ + unset_warnings_deriving $ + mapAndUnzip3M tc_item op_items + ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) } + where + set_exts :: [LangExt.Extension] -> TcM a -> TcM a + set_exts es thing = foldr setXOptM thing es + + -- See Note [Avoid -Winaccessible-code when deriving] + unset_warnings_deriving :: TcM a -> TcM a + unset_warnings_deriving + | is_derived = unsetWOptM Opt_WarnInaccessibleCode + | otherwise = id + + hs_sig_fn = mkHsSigFun sigs + inst_loc = getSrcSpan dfun_id + + ---------------------- + tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication) + tc_item (sel_id, dm_info) + | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn + = tcMethodBody clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds is_derived hs_sig_fn + spec_inst_prags prags + sel_id user_bind bndr_loc + | otherwise + = do { traceTc "tc_def" (ppr sel_id) + ; tc_default sel_id dm_info } + + ---------------------- + tc_default :: Id -> DefMethInfo + -> TcM (TcId, LHsBind GhcTc, Maybe Implication) + + tc_default sel_id (Just (dm_name, _)) + = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name + ; tcMethodBody 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) + ; (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) + ; return (meth_id, meth_bind, Nothing) } + where + error_rhs dflags = L inst_loc $ HsApp noExtField error_fun (error_msg dflags) + error_fun = L inst_loc $ + wrapId (mkWpTyApps + [ getRuntimeRep meth_tau, meth_tau]) + nO_METHOD_BINDING_ERROR_ID + error_msg dflags = L inst_loc (HsLit noExtField (HsStringPrim NoSourceText + (unsafeMkByteString (error_string dflags)))) + meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys) + error_string dflags = showSDoc dflags + (hcat [ppr inst_loc, vbar, ppr sel_id ]) + lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars + + ---------------------- + -- Check if one of the minimal complete definitions is satisfied + checkMinimalDefinition + = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $ + warnUnsatisfiedMinimalDefinition + + methodExists meth = isJust (findMethodBind meth binds prag_fn) + + ---------------------- + -- Check if any method bindings do not correspond to the class. + -- See Note [Mismatched class methods and associated type families]. + checkMethBindMembership + = mapM_ (addErrTc . badMethodErr clas) mismatched_meths + where + bind_nms = map unLoc $ collectMethodBinders binds + cls_meth_nms = map (idName . fst) op_items + mismatched_meths = bind_nms `minusList` cls_meth_nms + +{- +Note [Mismatched class methods and associated type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's entirely possible for someone to put methods or associated type family +instances inside of a class in which it doesn't belong. For instance, we'd +want to fail if someone wrote this: + + instance Eq () where + type Rep () = Maybe + compare = undefined + +Since neither the type family `Rep` nor the method `compare` belong to the +class `Eq`. Normally, this is caught in the renamer when resolving RdrNames, +since that would discover that the parent class `Eq` is incorrect. + +However, there is a scenario in which the renamer could fail to catch this: +if the instance was generated through Template Haskell, as in #12387. In that +case, Template Haskell will provide fully resolved names (e.g., +`GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going +on. For this reason, we also put an extra validity check for this in the +typechecker as a last resort. + +Note [Avoid -Winaccessible-code when deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-Winaccessible-code can be particularly noisy when deriving instances for +GADTs. Consider the following example (adapted from #8128): + + data T a where + MkT1 :: Int -> T Int + MkT2 :: T Bool + MkT3 :: T Bool + deriving instance Eq (T a) + deriving instance Ord (T a) + +In the derived Ord instance, GHC will generate the following code: + + instance Ord (T a) where + compare x y + = case x of + MkT2 + -> case y of + MkT1 {} -> GT + MkT2 -> EQ + _ -> LT + ... + +However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2 +differ, so if -Winaccessible-code is enabled, then deriving this instance will +result in unwelcome warnings. + +One conceivable approach to fixing this issue would be to change `deriving Ord` +such that it becomes smarter about not generating unreachable cases. This, +however, would be a highly nontrivial refactor, as we'd have to propagate +through typing information everywhere in the algorithm that generates Ord +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: + +1. In tcMethods (which typechecks method bindings), disable + -Winaccessible-code. +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! +-} + +------------------------ +tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType] + -> TcEvBinds -> Bool + -> HsSigFun + -> [LTcSpecPrag] -> [LSig GhcRn] + -> Id -> LHsBind GhcRn -> SrcSpan + -> TcM (TcId, LHsBind GhcTc, Maybe Implication) +tcMethodBody clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds is_derived + sig_fn spec_inst_prags prags + sel_id (L bind_loc meth_bind) bndr_loc + = add_meth_ctxt $ + do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc) + ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $ + mkMethIds clas tyvars dfun_ev_vars + inst_tys sel_id + + ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) } + -- Substitute the local_meth_name for the binder + -- NB: the binding is always a FunBind + + -- taking instance signature into account might change the type of + -- the local_meth_id + ; (meth_implic, ev_binds_var, tc_bind) + <- checkInstConstraints $ + tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind) + + ; global_meth_id <- addInlinePrags global_meth_id prags + ; spec_prags <- tcSpecPrags global_meth_id prags + + ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags + export = ABE { abe_ext = noExtField + , abe_poly = global_meth_id + , abe_mono = local_meth_id + , abe_wrap = idHsWrapper + , abe_prags = specs } + + local_ev_binds = TcEvBinds ev_binds_var + full_bind = AbsBinds { abs_ext = noExtField + , abs_tvs = tyvars + , abs_ev_vars = dfun_ev_vars + , abs_exports = [export] + , abs_ev_binds = [dfun_ev_binds, local_ev_binds] + , abs_binds = tc_bind + , abs_sig = True } + + ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) } + where + -- For instance decls that come from deriving clauses + -- we want to print out the full source code if there's an error + -- because otherwise the user won't see the code at all + add_meth_ctxt thing + | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing + | otherwise = thing + +tcMethodBodyHelp :: HsSigFun -> Id -> TcId + -> LHsBind GhcRn -> TcM (LHsBinds GhcTcId) +tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind + | Just hs_sig_ty <- hs_sig_fn sel_name + -- There is a signature in the instance + -- See Note [Instance method signatures] + = do { (sig_ty, hs_wrap) + <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $ + do { inst_sigs <- xoptM LangExt.InstanceSigs + ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty) + ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty + ; let local_meth_ty = idType local_meth_id + ctxt = FunSigCtxt sel_name False + -- False <=> do not report redundant constraints when + -- checking instance-sig <= class-meth-sig + -- The instance-sig is the focus here; the class-meth-sig + -- is fixed (#18036) + ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $ + tcSubType_NC ctxt sig_ty local_meth_ty + ; return (sig_ty, hs_wrap) } + + ; inner_meth_name <- newName (nameOccName sel_name) + ; let ctxt = FunSigCtxt sel_name True + -- True <=> check for redundant constraints in the + -- user-specified instance signature + inner_meth_id = mkLocalId inner_meth_name sig_ty + inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id + , sig_ctxt = ctxt + , sig_loc = getLoc (hsSigType hs_sig_ty) } + + + ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind + + ; let export = ABE { abe_ext = noExtField + , abe_poly = local_meth_id + , abe_mono = inner_id + , abe_wrap = hs_wrap + , abe_prags = noSpecPrags } + + ; return (unitBag $ L (getLoc meth_bind) $ + AbsBinds { abs_ext = noExtField, abs_tvs = [], abs_ev_vars = [] + , abs_exports = [export] + , abs_binds = tc_bind, abs_ev_binds = [] + , abs_sig = True }) } + + | otherwise -- No instance signature + = do { let ctxt = FunSigCtxt sel_name False + -- False <=> don't report redundant constraints + -- The signature is not under the users control! + tc_sig = completeSigFromId ctxt local_meth_id + -- Absent a type sig, there are no new scoped type variables here + -- Only the ones from the instance decl itself, which are already + -- in scope. Example: + -- class C a where { op :: forall b. Eq b => ... } + -- instance C [c] where { op = } + -- In , 'c' is scope but 'b' is not! + + ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind + ; return tc_bind } + + where + sel_name = idName sel_id + no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; + -- they are all for meth_id + + +------------------------ +mkMethIds :: Class -> [TcTyVar] -> [EvVar] + -> [TcType] -> Id -> TcM (TcId, TcId) + -- returns (poly_id, local_id), but ignoring any instance signature + -- See Note [Instance method signatures] +mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id + = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ) + ; local_meth_name <- newName sel_occ + -- Base the local_meth_name on the selector name, because + -- type errors from tcMethodBody come from here + ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty + local_meth_id = mkLocalId local_meth_name local_meth_ty + + ; return (poly_meth_id, local_meth_id) } + where + sel_name = idName sel_id + sel_occ = nameOccName sel_name + local_meth_ty = instantiateMethod clas sel_id inst_tys + poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty + theta = map idType dfun_ev_vars + +methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) +methSigCtxt sel_name sig_ty meth_ty env0 + = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty + ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty + ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name)) + 2 (vcat [ text "is more general than its signature in the class" + , text "Instance sig:" <+> ppr sig_ty + , text " Class sig:" <+> ppr meth_ty ]) + ; return (env2, msg) } + +misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc +misplacedInstSig name hs_ty + = vcat [ hang (text "Illegal type signature in instance declaration:") + 2 (hang (pprPrefixName name) + 2 (dcolon <+> ppr hs_ty)) + , text "(Use InstanceSigs to allow this)" ] + +{- Note [Instance method signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -XInstanceSigs we allow the user to supply a signature for the +method in an instance declaration. Here is an artificial example: + + data T a = MkT a + instance Ord a => Ord (T a) where + (>) :: forall b. b -> b -> Bool + (>) = error "You can't compare Ts" + +The instance signature can be *more* polymorphic than the instantiated +class method (in this case: Age -> Age -> Bool), but it cannot be less +polymorphic. Moreover, if a signature is given, the implementation +code should match the signature, and type variables bound in the +singature should scope over the method body. + +We achieve this by building a TcSigInfo for the method, whether or not +there is an instance method signature, and using that to typecheck +the declaration (in tcMethodBody). That means, conveniently, +that the type variables bound in the signature will scope over the body. + +What about the check that the instance method signature is more +polymorphic than the instantiated class method type? We just do a +tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like +this (for the example above + + AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a] + , abs_exports + = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool + , gr_lcl :: T a -> T a -> Bool } + , abs_binds + = AbsBind { abs_tvs = [], abs_ev_vars = [] + , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool + , gr_inner :: forall b. b -> b -> Bool } + , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = [] + , ..etc.. } + } } + +Wow! Three nested AbsBinds! + * The outer one abstracts over the tyvars and dicts for the instance + * The middle one is only present if there is an instance signature, + and does the impedance matching for that signature + * The inner one is for the method binding itself against either the + signature from the class, or the instance signature. +-} + +---------------------- +mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags + -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id + -- There are two sources: + -- * spec_prags_for_me: {-# SPECIALISE op :: #-} + -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: #-} + -- These ones have the dfun inside, but [perhaps surprisingly] + -- the correct wrapper. + -- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind +mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me + = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst) + where + spec_prags_from_inst + | isInlinePragma (idInlinePragma meth_id) + = [] -- Do not inherit SPECIALISE from the instance if the + -- method is marked INLINE, because then it'll be inlined + -- and the specialisation would do nothing. (Indeed it'll provoke + -- a warning from the desugarer + | otherwise + = [ L inst_loc (SpecPrag meth_id wrap inl) + | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] + + +mkDefMethBind :: Class -> [Type] -> Id -> Name + -> TcM (LHsBind GhcRn, [LSig GhcRn]) +-- The is a default method (vanailla or generic) defined in the class +-- So make a binding op = $dmop @t1 @t2 +-- where $dmop is the name of the default method in the class, +-- and t1,t2 are the instance types. +-- See Note [Default methods in instances] for why we use +-- visible type application here +mkDefMethBind clas inst_tys sel_id dm_name + = do { dflags <- getDynFlags + ; dm_id <- tcLookupId dm_name + ; let inline_prag = idInlinePragma dm_id + inline_prags | isAnyInlinePragma inline_prag + = [noLoc (InlineSig noExtField fn inline_prag)] + | otherwise + = [] + -- Copy the inline pragma (if any) from the default method + -- to this version. Note [INLINE and default methods] + + fn = noLoc (idName sel_id) + visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys + , tyConBinderArgFlag tcb /= Inferred ] + rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys + bind = noLoc $ mkTopFunBind Generated fn $ + [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] + + ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" + FormatHaskell + (vcat [ppr clas <+> ppr inst_tys, + nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) + + ; return (bind, inline_prags) } + where + mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn + mk_vta fun ty = noLoc (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy + $ noLoc $ XHsType $ NHsCoreTy ty)) + -- NB: use visible type application + -- See Note [Default methods in instances] + +---------------------- +derivBindCtxt :: Id -> Class -> [Type ] -> SDoc +derivBindCtxt sel_id clas tys + = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id) + , nest 2 (text "in a derived instance for" + <+> quotes (pprClassPred clas tys) <> colon) + , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ] + +warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () +warnUnsatisfiedMinimalDefinition mindef + = do { warn <- woptM Opt_WarnMissingMethods + ; warnTc (Reason Opt_WarnMissingMethods) warn message + } + where + message = vcat [text "No explicit implementation for" + ,nest 2 $ pprBooleanFormulaNice mindef + ] + +{- +Note [Export helper functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We arrange to export the "helper functions" of an instance declaration, +so that they are not subject to preInlineUnconditionally, even if their +RHS is trivial. Reason: they are mentioned in the DFunUnfolding of +the dict fun as Ids, not as CoreExprs, so we can't substitute a +non-variable for them. + +We could change this by making DFunUnfoldings have CoreExprs, but it +seems a bit simpler this way. + +Note [Default methods in instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + + class Baz v x where + foo :: x -> x + foo y = + + instance Baz Int Int + +From the class decl we get + + $dmfoo :: forall v x. Baz v x => x -> x + $dmfoo y = + +Notice that the type is ambiguous. So we use Visible Type Application +to disambiguate: + + $dBazIntInt = MkBaz fooIntInt + fooIntInt = $dmfoo @Int @Int + +Lacking VTA we'd get ambiguity errors involving the default method. This applies +equally to vanilla default methods (#1061) and generic default methods +(#12220). + +Historical note: before we had VTA we had to generate +post-type-checked code, which took a lot more code, and didn't work for +generic default methods. + +Note [INLINE and default methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Default methods need special case. They are supposed to behave rather like +macros. For example + + class Foo a where + op1, op2 :: Bool -> a -> a + + {-# INLINE op1 #-} + op1 b x = op2 (not b) x + + instance Foo Int where + -- op1 via default method + op2 b x = + +The instance declaration should behave + + just as if 'op1' had been defined with the + code, and INLINE pragma, from its original + definition. + +That is, just as if you'd written + + instance Foo Int where + op2 b x = + + {-# INLINE op1 #-} + op1 b x = op2 (not b) x + +So for the above example we generate: + + {-# INLINE $dmop1 #-} + -- $dmop1 has an InlineCompulsory unfolding + $dmop1 d b x = op2 d (not b) x + + $fFooInt = MkD $cop1 $cop2 + + {-# INLINE $cop1 #-} + $cop1 = $dmop1 $fFooInt + + $cop2 = + +Note carefully: + +* We *copy* any INLINE pragma from the default method $dmop1 to the + instance $cop1. Otherwise we'll just inline the former in the + latter and stop, which isn't what the user expected + +* Regardless of its pragma, we give the default method an + unfolding with an InlineCompulsory source. That means + that it'll be inlined at every use site, notably in + each instance declaration, such as $cop1. This inlining + must happen even though + a) $dmop1 is not saturated in $cop1 + b) $cop1 itself has an INLINE pragma + + It's vital that $dmop1 *is* inlined in this way, to allow the mutual + recursion between $fooInt and $cop1 to be broken + +* To communicate the need for an InlineCompulsory to the desugarer + (which makes the Unfoldings), we use the IsDefaultMethod constructor + in TcSpecPrags. + + +************************************************************************ +* * + Specialise instance pragmas +* * +************************************************************************ + +Note [SPECIALISE instance pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + instance (Ix a, Ix b) => Ix (a,b) where + {-# SPECIALISE instance Ix (Int,Int) #-} + range (x,y) = ... + +We make a specialised version of the dictionary function, AND +specialised versions of each *method*. Thus we should generate +something like this: + + $dfIxPair :: (Ix a, Ix b) => Ix (a,b) + {-# DFUN [$crangePair, ...] #-} + {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-} + $dfIxPair da db = Ix ($crangePair da db) (...other methods...) + + $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] + {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} + $crange da db = + +The SPECIALISE pragmas are acted upon by the desugarer, which generate + + dii :: Ix Int + dii = ... + + $s$dfIxPair :: Ix ((Int,Int),(Int,Int)) + {-# DFUN [$crangePair di di, ...] #-} + $s$dfIxPair = Ix ($crangePair di di) (...) + + {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-} + + $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)] + $c$crangePair = ...specialised RHS of $crangePair... + + {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-} + +Note that + + * The specialised dictionary $s$dfIxPair is very much needed, in case we + call a function that takes a dictionary, but in a context where the + specialised dictionary can be used. See #7797. + + * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because + it still has a DFunUnfolding. See Note [ClassOp/DFun selection] + + * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways: + --> {ClassOp rule for range} $crangePair Int Int d1 d2 + --> {SPEC rule for $crangePair} $s$crangePair + or thus: + --> {SPEC rule for $dfIxPair} range $s$dfIxPair + --> {ClassOpRule for range} $s$crangePair + It doesn't matter which way. + + * We want to specialise the RHS of both $dfIxPair and $crangePair, + but the SAME HsWrapper will do for both! We can call tcSpecPrag + just once, and pass the result (in spec_inst_info) to tcMethods. +-} + +tcSpecInstPrags :: DFunId -> InstBindings GhcRn + -> TcM ([Located TcSpecPrag], TcPragEnv) +tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) + = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ + filter isSpecInstLSig uprags + -- The filter removes the pragmas for methods + ; return (spec_inst_prags, mkPragEnv uprags binds) } + +------------------------------ +tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag +tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty) + = addErrCtxt (spec_ctxt prag) $ + do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty + ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty + ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } + where + spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) + +tcSpecInst _ _ = panic "tcSpecInst" + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +instDeclCtxt1 :: LHsSigType GhcRn -> SDoc +instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + +instDeclCtxt2 :: Type -> SDoc +instDeclCtxt2 dfun_ty + = inst_decl_ctxt (ppr (mkClassPred cls tys)) + where + (_,_,cls,tys) = tcSplitDFunTy dfun_ty + +inst_decl_ctxt :: SDoc -> SDoc +inst_decl_ctxt doc = hang (text "In the instance declaration for") + 2 (quotes doc) + +badBootFamInstDeclErr :: SDoc +badBootFamInstDeclErr + = text "Illegal family instance in hs-boot file" + +notFamily :: TyCon -> SDoc +notFamily tycon + = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) + , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] + +assocInClassErr :: TyCon -> SDoc +assocInClassErr name + = text "Associated type" <+> quotes (ppr name) <+> + text "must be inside a class instance" + +badFamInstDecl :: TyCon -> SDoc +badFamInstDecl tc_name + = vcat [ text "Illegal family instance for" <+> + quotes (ppr tc_name) + , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ] + +notOpenFamily :: TyCon -> SDoc +notOpenFamily tc + = text "Illegal instance for closed family" <+> quotes (ppr tc) diff --git a/compiler/GHC/Tc/TyCl/Instance.hs-boot b/compiler/GHC/Tc/TyCl/Instance.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/TyCl/Instance.hs-boot @@ -0,0 +1,16 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Tc.TyCl.Instance ( tcInstDecls1 ) where + +import GHC.Hs +import GHC.Tc.Types +import GHC.Tc.Utils.Env( InstInfo ) +import GHC.Tc.Deriv + +-- We need this because of the mutual recursion +-- between GHC.Tc.TyCl and GHC.Tc.TyCl.Instance +tcInstDecls1 :: [LInstDecl GhcRn] + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -0,0 +1,1145 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking pattern synonym declarations +module GHC.Tc.TyCl.PatSyn + ( tcPatSynDecl + , tcPatSynBuilderBind + , tcPatSynBuilderOcc + , nonBidirectionalErr + ) +where + +import GHC.Prelude + +import GHC.Hs +import GHC.Tc.Gen.Pat +import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Gen.Sig( emptyPragEnv, completeSigFromId ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Zonk +import GHC.Builtin.Types.Prim +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Core.PatSyn +import GHC.Types.Name.Set +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Var +import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSet ) +import GHC.Types.Id +import GHC.Types.Id.Info( RecSelParent(..), setLevityInfoWithType ) +import GHC.Tc.Gen.Bind +import GHC.Types.Basic +import GHC.Tc.Solver +import GHC.Tc.Utils.Unify +import GHC.Core.Predicate +import GHC.Builtin.Types +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin +import GHC.Tc.TyCl.Build +import GHC.Types.Var.Set +import GHC.Types.Id.Make +import GHC.Tc.TyCl.Utils +import GHC.Core.ConLike +import GHC.Types.FieldLabel +import GHC.Data.Bag +import GHC.Utils.Misc +import GHC.Utils.Error +import Data.Maybe( mapMaybe ) +import Control.Monad ( zipWithM ) +import Data.List( partition ) + +#include "HsVersions.h" + +{- +************************************************************************ +* * + Type checking a pattern synonym +* * +************************************************************************ +-} + +tcPatSynDecl :: PatSynBind GhcRn GhcRn + -> Maybe TcSigInfo + -> TcM (LHsBinds GhcTc, TcGblEnv) +tcPatSynDecl psb mb_sig + = recoverM (recoverPSB psb) $ + case mb_sig of + Nothing -> tcInferPatSynDecl psb + Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi + _ -> panic "tcPatSynDecl" + +recoverPSB :: PatSynBind GhcRn GhcRn + -> TcM (LHsBinds GhcTc, TcGblEnv) +-- See Note [Pattern synonym error recovery] +recoverPSB (PSB { psb_id = L _ name + , psb_args = details }) + = do { matcher_name <- newImplicitBinder name mkMatcherOcc + ; let placeholder = AConLike $ PatSynCon $ + mk_placeholder matcher_name + ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv + ; return (emptyBag, gbl_env) } + where + (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details + mk_placeholder matcher_name + = mkPatSyn name is_infix + ([mkTyVarBinder Specified alphaTyVar], []) ([], []) + [] -- Arg tys + alphaTy + (matcher_id, True) Nothing + [] -- Field labels + where + -- The matcher_id is used only by the desugarer, so actually + -- and error-thunk would probably do just as well here. + matcher_id = mkLocalId matcher_name $ + mkSpecForAllTys [alphaTyVar] alphaTy + +{- Note [Pattern synonym error recovery] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If type inference for a pattern synonym fails, we can't continue with +the rest of tc_patsyn_finish, because we may get knock-on errors, or +even a crash. E.g. from + pattern What = True :: Maybe +we get a kind error; and we must stop right away (#15289). + +We stop if there are /any/ unsolved constraints, not just insoluble +ones; because pattern synonyms are top-level things, we will never +solve them later if we can't solve them now. And if we were to carry +on, tc_patsyn_finish does zonkTcTypeToType, which defaults any +unsolved unificatdion variables to Any, which confuses the error +reporting no end (#15685). + +So we use simplifyTop to completely solve the constraint, report +any errors, throw an exception. + +Even in the event of such an error we can recover and carry on, just +as we do for value bindings, provided we plug in placeholder for the +pattern synonym: see recoverPSB. The goal of the placeholder is not +to cause a raft of follow-on errors. I've used the simplest thing for +now, but we might need to elaborate it a bit later. (e.g. I've given +it zero args, which may cause knock-on errors if it is used in a +pattern.) But it'll do for now. + +-} + +tcInferPatSynDecl :: PatSynBind GhcRn GhcRn + -> TcM (LHsBinds GhcTc, TcGblEnv) +tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details + , psb_def = lpat, psb_dir = dir }) + = addPatSynCtxt lname $ + do { traceTc "tcInferPatSynDecl {" $ ppr name + + ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details + ; (tclvl, wanted, ((lpat', args), pat_ty)) + <- pushLevelAndCaptureConstraints $ + tcInferPat PatSyn lpat $ + mapM tcLookupId arg_names + + ; let (ex_tvs, prov_dicts) = tcCollectEx lpat' + + named_taus = (name, pat_ty) : map mk_named_tau args + mk_named_tau arg + = (getName arg, mkSpecForAllTys ex_tvs (varType arg)) + -- The mkSpecForAllTys is important (#14552), albeit + -- slightly artificial (there is no variable with this funny type). + -- We do not want to quantify over variable (alpha::k) + -- that mention the existentially-bound type variables + -- ex_tvs in its kind k. + -- See Note [Type variables whose kind is captured] + + ; (univ_tvs, req_dicts, ev_binds, residual, _) + <- simplifyInfer tclvl NoRestrictions [] named_taus wanted + ; top_ev_binds <- checkNoErrs (simplifyTop residual) + ; addTopEvBinds top_ev_binds $ + + do { prov_dicts <- mapM zonkId prov_dicts + ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts + -- Filtering: see Note [Remove redundant provided dicts] + (prov_theta, prov_evs) + = unzip (mapMaybe mkProvEvidence filtered_prov_dicts) + req_theta = map evVarPred req_dicts + + -- 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) ] + ; mapM_ dependentArgErr bad_args + + ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) + ; tc_patsyn_finish lname dir is_infix lpat' + (mkTyVarBinders Inferred univ_tvs + , req_theta, ev_binds, req_dicts) + (mkTyVarBinders Inferred ex_tvs + , mkTyVarTys ex_tvs, prov_theta, prov_evs) + (map nlHsVar args, map idType args) + pat_ty rec_fields } } + +mkProvEvidence :: EvId -> Maybe (PredType, EvTerm) +-- See Note [Equality evidence in pattern synonyms] +mkProvEvidence ev_id + | EqPred r ty1 ty2 <- classifyPredType pred + , let k1 = tcTypeKind ty1 + k2 = tcTypeKind ty2 + is_homo = k1 `tcEqType` k2 + homo_tys = [k1, ty1, ty2] + hetero_tys = [k1, k2, ty1, ty2] + = case r of + ReprEq | is_homo + -> Just ( mkClassPred coercibleClass homo_tys + , evDataConApp coercibleDataCon homo_tys eq_con_args ) + | otherwise -> Nothing + NomEq | is_homo + -> Just ( mkClassPred eqClass homo_tys + , evDataConApp eqDataCon homo_tys eq_con_args ) + | otherwise + -> Just ( mkClassPred heqClass hetero_tys + , evDataConApp heqDataCon hetero_tys eq_con_args ) + + | otherwise + = Just (pred, EvExpr (evId ev_id)) + where + pred = evVarPred ev_id + eq_con_args = [evId ev_id] + +dependentArgErr :: (Id, DTyCoVarSet) -> TcM () +-- See Note [Coercions that escape] +dependentArgErr (arg, bad_cos) + = addErrTc $ + 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 + +{- Note [Type variables whose kind is captured] +~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data AST a = Sym [a] + class Prj s where { prj :: [a] -> Maybe (s a) } + pattern P x <= Sym (prj -> Just x) + +Here we get a matcher with this type + $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r + +No problem. But note that 's' is not fixed by the type of the +pattern (AST a), nor is it existentially bound. It's really only +fixed by the type of the continuation. + +#14552 showed that this can go wrong if the kind of 's' mentions +existentially bound variables. We obviously can't make a type like + $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r) + -> r -> r +But neither is 's' itself existentially bound, so the forall (s::k->*) +can't go in the inner forall either. (What would the matcher apply +the continuation to?) + +Solution: do not quantiify over any unification variable whose kind +mentions the existentials. We can conveniently do that by making the +"taus" passed to simplifyInfer look like + forall ex_tvs. arg_ty + +After that, Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType takes +over and errors. + +Note [Remove redundant provided dicts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall that + HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2) + => a1 :~~: a2 +(NB: technically the (k1~k2) existential dictionary is not necessary, +but it's there at the moment.) + +Now consider (#14394): + pattern Foo = HRefl +in a non-poly-kinded module. We don't want to get + pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b +with that redundant (* ~ *). We'd like to remove it; hence the call to +mkMinimalWithSCs. + +Similarly consider + data S a where { MkS :: Ord a => a -> S a } + pattern Bam x y <- (MkS (x::a), MkS (y::a))) + +The pattern (Bam x y) binds two (Ord a) dictionaries, but we only +need one. Again mkMimimalWithSCs removes the redundant one. + +Note [Equality evidence in pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data X a where + MkX :: Eq a => [a] -> X (Maybe a) + pattern P x = MkG x + +Then there is a danger that GHC will infer + P :: forall a. () => + forall b. (a ~# Maybe b, Eq b) => [b] -> X a + +The 'builder' for P, which is called in user-code, will then +have type + $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a + +and that is bad because (a ~# Maybe b) is not a predicate type +(see Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep +and is not implicitly instantiated. + +So in mkProvEvidence we lift (a ~# b) to (a ~ b). Tiresome, and +marginally less efficient, if the builder/martcher are not inlined. + +See also Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType + +Note [Coercions that escape] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#14507 showed an example where the inferred type of the matcher +for the pattern synonym was something like + $mSO :: forall (r :: TYPE rep) kk (a :: k). + TypeRep k a + -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r) + -> (Void# -> r) + -> r + +What is that co_a2sv :: Bool ~# *?? It was bound (via a superclass +selection) by the pattern being matched; and indeed it is implicit in +the context (Bool ~ k). You could imagine trying to extract it like +this: + $mSO :: forall (r :: TYPE rep) kk (a :: k). + TypeRep k a + -> ( co :: ((Bool :: *) ~ (k :: *)) => + let co_a2sv = sc_sel co + in TypeRep Bool (a |> co_a2sv) -> r) + -> (Void# -> r) + -> r + +But we simply don't allow that in types. Maybe one day but not now. + +How to detect this situation? We just look for free coercion variables +in the types of any of the arguments to the matcher. The error message +is not very helpful, but at least we don't get a Lint error. +-} + +tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn + -> TcPatSynInfo + -> TcM (LHsBinds GhcTc, TcGblEnv) +tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details + , psb_def = lpat, psb_dir = dir } + TPSI{ patsig_implicit_bndrs = implicit_tvs + , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta + , patsig_ex_bndrs = explicit_ex_tvs, patsig_req = req_theta + , patsig_body_ty = sig_body_ty } + = addPatSynCtxt lname $ + do { let decl_arity = length arg_names + (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details + + ; traceTc "tcCheckPatSynDecl" $ + vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta + , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ] + + ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of + Right stuff -> return stuff + Left missing -> wrongNumberOfParmsErr name decl_arity missing + + -- Complain about: pattern P :: () => forall x. x -> P x + -- The existential 'x' should not appear in the result type + -- Can't check this until we know P's arity + ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs + ; checkTc (null bad_tvs) $ + 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) + + -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.Gen.Sig + ; let univ_fvs = closeOverKinds $ + (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs) + (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs + univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs + ex_bndrs = extra_ex ++ mkTyVarBinders Specified explicit_ex_tvs + univ_tvs = binderVars univ_bndrs + ex_tvs = binderVars ex_bndrs + + -- Right! Let's check the pattern against the signature + -- See Note [Checking against a pattern signature] + ; req_dicts <- newEvVars req_theta + ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <- + ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys ) + pushLevelAndCaptureConstraints $ + tcExtendTyVarEnv univ_tvs $ + tcCheckPat PatSyn lpat pat_ty $ + do { let in_scope = mkInScopeSet (mkVarSet univ_tvs) + empty_subst = mkEmptyTCvSubst in_scope + ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs + -- newMetaTyVarX: see the "Existential type variables" + -- part of Note [Checking against a pattern signature] + ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs]) + ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs']) + ; let prov_theta' = substTheta subst prov_theta + -- Add univ_tvs to the in_scope set to + -- satisfy the substitution invariant. There's no need to + -- add 'ex_tvs' as they are already in the domain of the + -- substitution. + -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. + ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta' + ; args' <- zipWithM (tc_arg subst) arg_names arg_tys + ; return (ex_tvs', prov_dicts, args') } + + ; let skol_info = SigSkol (PatSynCtxt name) pat_ty [] + -- The type here is a bit bogus, but we do not print + -- the type for PatSynCtxt, so it doesn't matter + -- See Note [Skolem info for pattern synonyms] in Origin + ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted + + -- Solve the constraints now, because we are about to make a PatSyn, + -- which should not contain unification variables and the like (#10997) + ; simplifyTopImplic implics + + -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct + -- Otherwise we may get a type error when typechecking the builder, + -- when that should be impossible + + ; traceTc "tcCheckPatSynDecl }" $ ppr name + ; tc_patsyn_finish lname dir is_infix lpat' + (univ_bndrs, req_theta, ev_binds, req_dicts) + (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts) + (args', arg_tys) + pat_ty rec_fields } + where + tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId) + tc_arg subst arg_name arg_ty + = do { -- Look up the variable actually bound by lpat + -- and check that it has the expected type + arg_id <- tcLookupId arg_name + ; wrap <- tcSubType_NC GenSigCtxt + (idType arg_id) + (substTyUnchecked subst arg_ty) + -- Why do we need tcSubType here? + -- See Note [Pattern synonyms and higher rank types] + ; return (mkLHsWrap wrap $ nlHsVar arg_id) } + +{- [Pattern synonyms and higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT (forall a. a->a) + + pattern P :: (Int -> Int) -> T + pattern P x <- MkT x + +This should work. But in the matcher we must match against MkT, and then +instantiate its argument 'x', to get a function of type (Int -> Int). +Equality is not enough! #13752 was an example. + + +Note [The pattern-synonym signature splitting rule] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a pattern signature, we must split + the kind-generalised variables, and + the implicitly-bound variables +into universal and existential. The rule is this +(see discussion on #11224): + + The universal tyvars are the ones mentioned in + - univ_tvs: the user-specified (forall'd) universals + - req_theta + - res_ty + The existential tyvars are all the rest + +For example + + pattern P :: () => b -> T a + pattern P x = ... + +Here 'a' is universal, and 'b' is existential. But there is a wrinkle: +how do we split the arg_tys from req_ty? Consider + + pattern Q :: () => b -> S c -> T a + pattern Q x = ... + +This is an odd example because Q has only one syntactic argument, and +so presumably is defined by a view pattern matching a function. But +it can happen (#11977, #12108). + +We don't know Q's arity from the pattern signature, so we have to wait +until we see the pattern declaration itself before deciding res_ty is, +and hence which variables are existential and which are universal. + +And that in turn is why TcPatSynInfo has a separate field, +patsig_implicit_bndrs, to capture the implicitly bound type variables, +because we don't yet know how to split them up. + +It's a slight compromise, because it means we don't really know the +pattern synonym's real signature until we see its declaration. So, +for example, in hs-boot file, we may need to think what to do... +(eg don't have any implicitly-bound variables). + + +Note [Checking against a pattern signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When checking the actual supplied pattern against the pattern synonym +signature, we need to be quite careful. + +----- Provided constraints +Example + + data T a where + MkT :: Ord a => a -> T a + + pattern P :: () => Eq a => a -> [T a] + pattern P x = [MkT x] + +We must check that the (Eq a) that P claims to bind (and to +make available to matches against P), is derivable from the +actual pattern. For example: + f (P (x::a)) = ...here (Eq a) should be available... +And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs. + +----- Existential type variables +Unusually, we instantiate the existential tyvars of the pattern with +*meta* type variables. For example + + data S where + MkS :: Eq a => [a] -> S + + pattern P :: () => Eq x => x -> S + pattern P x <- MkS x + +The pattern synonym conceals from its client the fact that MkS has a +list inside it. The client just thinks it's a type 'x'. So we must +unify x := [a] during type checking, and then use the instantiating type +[a] (called ex_tys) when building the matcher. In this case we'll get + + $mP :: S -> (forall x. Ex x => x -> r) -> r -> r + $mP x k = case x of + MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a] + dl = $dfunEqList d + in k [a] dl ys + +All this applies when type-checking the /matching/ side of +a pattern synonym. What about the /building/ side? + +* For Unidirectional, there is no builder + +* For ExplicitBidirectional, the builder is completely separate + code, typechecked in tcPatSynBuilderBind + +* For ImplicitBidirectional, the builder is still typechecked in + tcPatSynBuilderBind, by converting the pattern to an expression and + typechecking it. + + At one point, for ImplicitBidirectional I used TyVarTvs (instead of + TauTvs) in tcCheckPatSynDecl. But (a) strengthening the check here + is redundant since tcPatSynBuilderBind does the job, (b) it was + still incomplete (TyVarTvs can unify with each other), and (c) it + didn't even work (#13441 was accepted with + ExplicitBidirectional, but rejected if expressed in + ImplicitBidirectional form. Conclusion: trying to be too clever is + a bad idea. +-} + +collectPatSynArgInfo :: HsPatSynDetails (Located Name) + -> ([Name], [Name], Bool) +collectPatSynArgInfo details = + case details of + PrefixCon names -> (map unLoc names, [], False) + InfixCon name1 name2 -> (map unLoc [name1, name2], [], True) + RecCon names -> (vars, sels, False) + where + (vars, sels) = unzip (map splitRecordPatSyn names) + where + splitRecordPatSyn :: RecordPatSynField (Located Name) + -> (Name, Name) + splitRecordPatSyn (RecordPatSynField + { recordPatSynPatVar = L _ patVar + , recordPatSynSelectorId = L _ selId }) + = (patVar, selId) + +addPatSynCtxt :: Located Name -> TcM a -> TcM a +addPatSynCtxt (L loc name) thing_inside + = setSrcSpan loc $ + addErrCtxt (text "In the declaration for pattern synonym" + <+> quotes (ppr name)) $ + thing_inside + +wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a +wrongNumberOfParmsErr name decl_arity missing + = failWithTc $ + hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has") + <+> speakNOf decl_arity (text "argument")) + 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") + +------------------------- +-- Shared by both tcInferPatSyn and tcCheckPatSyn +tc_patsyn_finish :: Located Name -- ^ PatSyn Name + -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) + -> Bool -- ^ Whether infix + -> LPat GhcTc -- ^ Pattern of the PatSyn + -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar]) + -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm]) + -> ([LHsExpr GhcTcId], [TcType]) -- ^ Pattern arguments and + -- types + -> TcType -- ^ Pattern type + -> [Name] -- ^ Selector names + -- ^ Whether fields, empty if not record PatSyn + -> TcM (LHsBinds GhcTc, TcGblEnv) +tc_patsyn_finish lname dir is_infix lpat' + (univ_tvs, req_theta, req_ev_binds, req_dicts) + (ex_tvs, ex_tys, prov_theta, prov_dicts) + (args, arg_tys) + pat_ty field_labels + = do { -- Zonk everything. We are about to build a final PatSyn + -- so there had better be no unification variables in there + + (ze, univ_tvs') <- zonkTyVarBinders 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 + + ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs' + (env2, ex_tvs) = tidyTyCoVarBinders 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' + + ; traceTc "tc_patsyn_finish {" $ + ppr (unLoc lname) $$ ppr (unLoc lpat') $$ + ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$ + ppr (ex_tvs, prov_theta, prov_dicts) $$ + ppr args $$ + ppr arg_tys $$ + ppr pat_ty + + -- Make the 'matcher' + ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' + (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts) + (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts) + (args, arg_tys) + pat_ty + + -- Make the 'builder' + ; builder_id <- mkPatSynBuilderId dir lname + univ_tvs req_theta + ex_tvs prov_theta + arg_tys pat_ty + + -- TODO: Make this have the proper information + ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name) + , flIsOverloaded = False + , flSelector = name } + field_labels' = map mkFieldLabel field_labels + + + -- Make the PatSyn itself + ; let patSyn = mkPatSyn (unLoc lname) is_infix + (univ_tvs, req_theta) + (ex_tvs, prov_theta) + arg_tys + pat_ty + matcher_id builder_id + field_labels' + + -- Selectors + ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn) + tything = AConLike (PatSynCon patSyn) + ; tcg_env <- tcExtendGlobalEnv [tything] $ + tcRecSelBinds rn_rec_sel_binds + + ; traceTc "tc_patsyn_finish }" empty + ; return (matcher_bind, tcg_env) } + +{- +************************************************************************ +* * + Constructing the "matcher" Id and its binding +* * +************************************************************************ +-} + +tcPatSynMatcher :: Located Name + -> LPat GhcTc + -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) + -> ([TcTyVar], [TcType], ThetaType, [EvTerm]) + -> ([LHsExpr GhcTcId], [TcType]) + -> TcType + -> TcM ((Id, Bool), LHsBinds GhcTc) +-- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn +tcPatSynMatcher (L loc name) lpat + (univ_tvs, req_theta, req_ev_binds, req_dicts) + (ex_tvs, ex_tys, prov_theta, prov_dicts) + (args, arg_tys) pat_ty + = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc + ; tv_name <- newNameAt (mkTyVarOcc "r") loc + ; let rr_tv = mkTyVar rr_name runtimeRepTy + rr = mkTyVarTy rr_tv + res_tv = mkTyVar tv_name (tYPE rr) + res_ty = mkTyVarTy res_tv + is_unlifted = null args && null prov_dicts + (cont_args, cont_arg_tys) + | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy]) + | otherwise = (args, arg_tys) + cont_ty = mkInfSigmaTy ex_tvs prov_theta $ + mkVisFunTys cont_arg_tys res_ty + + fail_ty = mkVisFunTy voidPrimTy res_ty + + ; matcher_name <- newImplicitBinder name mkMatcherOcc + ; scrutinee <- newSysLocalId (fsLit "scrut") pat_ty + ; cont <- newSysLocalId (fsLit "cont") cont_ty + ; fail <- newSysLocalId (fsLit "fail") fail_ty + + ; let matcher_tau = mkVisFunTys [pat_ty, cont_ty, fail_ty] res_ty + matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau + matcher_id = mkExportedVanillaId matcher_name matcher_sigma + -- See Note [Exported LocalIds] in GHC.Types.Id + + inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys + cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args + + fail' = nlHsApps fail [nlHsVar voidPrimId] + + args = map nlVarPat [scrutinee, cont, fail] + lwpat = noLoc $ WildPat pat_ty + cases = if isIrrefutableHsPat lpat + then [mkHsCaseAlt lpat cont'] + else [mkHsCaseAlt lpat cont', + mkHsCaseAlt lwpat fail'] + body = mkLHsWrap (mkWpLet req_ev_binds) $ + L (getLoc lpat) $ + HsCase noExtField (nlHsVar scrutinee) $ + MG{ mg_alts = L (getLoc lpat) cases + , mg_ext = MatchGroupTc [pat_ty] res_ty + , mg_origin = Generated + } + body' = noLoc $ + HsLam noExtField $ + MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr + args body] + , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty + , mg_origin = Generated + } + match = mkMatch (mkPrefixFunRhs (L loc name)) [] + (mkHsLams (rr_tv:res_tv:univ_tvs) + req_dicts body') + (noLoc (EmptyLocalBinds noExtField)) + mg :: MatchGroup GhcTc (LHsExpr GhcTc) + mg = MG{ mg_alts = L (getLoc match) [match] + , mg_ext = MatchGroupTc [] res_ty + , mg_origin = Generated + } + + ; let bind = FunBind{ fun_id = L loc matcher_id + , fun_matches = mg + , fun_ext = idHsWrapper + , fun_tick = [] } + matcher_bind = unitBag (noLoc bind) + + ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) + ; traceTc "tcPatSynMatcher" (ppr matcher_bind) + + ; return ((matcher_id, is_unlifted), matcher_bind) } + +mkPatSynRecSelBinds :: PatSyn + -> [FieldLabel] -- ^ Visible field labels + -> [(Id, LHsBind GhcRn)] +mkPatSynRecSelBinds ps fields + = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl + | fld_lbl <- fields ] + +isUnidirectional :: HsPatSynDir a -> Bool +isUnidirectional Unidirectional = True +isUnidirectional ImplicitBidirectional = False +isUnidirectional ExplicitBidirectional{} = False + +{- +************************************************************************ +* * + Constructing the "builder" Id +* * +************************************************************************ +-} + +mkPatSynBuilderId :: HsPatSynDir a -> Located Name + -> [TyVarBinder] -> ThetaType + -> [TyVarBinder] -> ThetaType + -> [Type] -> Type + -> TcM (Maybe (Id, Bool)) +mkPatSynBuilderId dir (L _ name) + univ_bndrs req_theta ex_bndrs prov_theta + arg_tys pat_ty + | isUnidirectional dir + = return Nothing + | otherwise + = do { builder_name <- newImplicitBinder name mkBuilderOcc + ; let theta = req_theta ++ prov_theta + need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta + builder_sigma = add_void need_dummy_arg $ + mkForAllTys univ_bndrs $ + mkForAllTys ex_bndrs $ + mkPhiTy theta $ + mkVisFunTys arg_tys $ + pat_ty + builder_id = mkExportedVanillaId builder_name builder_sigma + -- See Note [Exported LocalIds] in GHC.Types.Id + + builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id + + ; return (Just (builder_id', need_dummy_arg)) } + where + +tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn + -> TcM (LHsBinds GhcTc) +-- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn +tcPatSynBuilderBind (PSB { psb_id = L loc name + , psb_def = lpat + , psb_dir = dir + , psb_args = details }) + | isUnidirectional dir + = return emptyBag + + | Left why <- mb_match_group -- Can't invert the pattern + = setSrcSpan (getLoc lpat) $ failWithTc $ + vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" + <+> quotes (ppr name) <> colon) + 2 why + , text "RHS pattern:" <+> ppr lpat ] + + | Right match_group <- mb_match_group -- Bidirectional + = do { patsyn <- tcLookupPatSyn name + ; case patSynBuilder patsyn of { + Nothing -> return emptyBag ; + -- This case happens if we found a type error in the + -- pattern synonym, recovered, and put a placeholder + -- with patSynBuilder=Nothing in the environment + + Just (builder_id, need_dummy_arg) -> -- Normal case + do { -- Bidirectional, so patSynBuilder returns Just + let match_group' | need_dummy_arg = add_dummy_arg match_group + | otherwise = match_group + + bind = FunBind { fun_id = L loc (idName builder_id) + , fun_matches = match_group' + , fun_ext = emptyNameSet + , fun_tick = [] } + + sig = completeSigFromId (PatSynCtxt name) builder_id + + ; traceTc "tcPatSynBuilderBind {" $ + ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id) + ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind) + ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds + ; return builder_binds } } } + +#if __GLASGOW_HASKELL__ <= 810 + | otherwise = panic "tcPatSynBuilderBind" -- Both cases dealt with +#endif + where + mb_match_group + = case dir of + ExplicitBidirectional explicit_mg -> Right explicit_mg + ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat) + Unidirectional -> panic "tcPatSynBuilderBind" + + mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) + mk_mg body = mkMatchGroup Generated [builder_match] + where + builder_args = [L loc (VarPat noExtField (L loc n)) + | L loc n <- args] + builder_match = mkMatch (mkPrefixFunRhs (L loc name)) + builder_args body + (noLoc (EmptyLocalBinds noExtField)) + + args = case details of + PrefixCon args -> args + InfixCon arg1 arg2 -> [arg1, arg2] + RecCon args -> map recordPatSynPatVar args + + add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn) + -> MatchGroup GhcRn (LHsExpr GhcRn) + add_dummy_arg mg@(MG { mg_alts = + (L l [L loc match@(Match { m_pats = pats })]) }) + = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] } + add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ + pprMatches other_mg + +tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType) +-- monadic only for failure +tcPatSynBuilderOcc ps + | Just (builder_id, add_void_arg) <- builder + , let builder_expr = HsConLikeOut noExtField (PatSynCon ps) + builder_ty = idType builder_id + = return $ + if add_void_arg + then ( builder_expr -- still just return builder_expr; the void# arg is added + -- by dsConLike in the desugarer + , tcFunResultTy builder_ty ) + else (builder_expr, builder_ty) + + | otherwise -- Unidirectional + = nonBidirectionalErr name + where + name = patSynName ps + builder = patSynBuilder ps + +add_void :: Bool -> Type -> Type +add_void need_dummy_arg ty + | need_dummy_arg = mkVisFunTy voidPrimTy ty + | otherwise = ty + +tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn + -> Either MsgDoc (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 +-- input uses constructors from HsPat and the output uses constructors +-- from HsExpr. +-- +-- 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 + where + lhsVars = mkNameSet (map unLoc args) + + -- Make a prefix con for prefix and infix patterns for simplicity + mkPrefixConExpr :: Located Name -> [LPat GhcRn] + -> Either MsgDoc (HsExpr GhcRn) + mkPrefixConExpr lcon@(L loc _) pats + = do { exprs <- mapM go pats + ; return (foldl' (\x y -> HsApp noExtField (L loc x) y) + (HsVar noExtField lcon) exprs) } + + mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) + -> Either MsgDoc (HsExpr GhcRn) + mkRecordConExpr con fields + = do { exprFields <- mapM go fields + ; return (RecordCon noExtField con exprFields) } + + go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) + go (L loc p) = L loc <$> go1 p + + go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn) + go1 (ConPat NoExtField con info) + = case info of + PrefixCon ps -> mkPrefixConExpr con ps + InfixCon l r -> mkPrefixConExpr con [l,r] + RecCon fields -> mkRecordConExpr con fields + + go1 (SigPat _ pat _) = go1 (unLoc pat) + -- See Note [Type signatures and the builder expression] + + go1 (VarPat _ (L l var)) + | 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") + go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat + go1 p@(ListPat reb pats) + | Nothing <- reb = do { exprs <- mapM go pats + ; return $ ExplicitList noExtField Nothing exprs } + | otherwise = notInvertibleListPat p + go1 (TuplePat _ pats box) = do { exprs <- mapM go pats + ; return $ ExplicitTuple noExtField + (map (noLoc . (Present noExtField)) exprs) + box } + go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) + ; return $ ExplicitSum noExtField alt arity + (noLoc expr) + } + go1 (LitPat _ lit) = return $ HsLit noExtField lit + go1 (NPat _ (L _ n) mb_neg _) + | Just (SyntaxExprRn neg) <- mb_neg + = return $ unLoc $ foldl' nlHsApp (noLoc neg) + [noLoc (HsOverLit noExtField n)] + | otherwise = return $ HsOverLit noExtField n + go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) + = go1 pat + go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" + + -- The following patterns are not invertible. + go1 p@(BangPat {}) = notInvertible p -- #14112 + go1 p@(LazyPat {}) = notInvertible p + go1 p@(WildPat {}) = notInvertible p + go1 p@(AsPat {}) = notInvertible p + go1 p@(ViewPat {}) = notInvertible p + go1 p@(NPlusKPat {}) = notInvertible p + go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p + go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p + go1 p@(SplicePat _ (HsQuasiQuote {})) = 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) + + -- We should really be able to invert list patterns, even when + -- rebindable syntax is on, but doing so involves a bit of + -- refactoring; see #14380. Until then we reject with a + -- helpful error message. + notInvertibleListPat p + = Left (vcat [ not_invertible_msg p + , text "Reason: rebindable syntax is on." + , text "This is fixable: add use-case to #14380" ]) + +{- Note [Builder for a bidirectional pattern synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a bidirectional pattern synonym we need to produce an /expression/ +that matches the supplied /pattern/, given values for the arguments +of the pattern synonym. For example + pattern F x y = (Just x, [y]) +The 'builder' for F looks like + $builderF x y = (Just x, [y]) + +We can't always do this: + * Some patterns aren't invertible; e.g. view patterns + pattern F x = (reverse -> x:_) + + * The RHS pattern might bind more variables than the pattern + synonym, so again we can't invert it + pattern F x = (x,y) + + * Ditto wildcards + pattern F x = (x,_) + + +Note [Redundant constraints for builder] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The builder can have redundant constraints, which are awkward to eliminate. +Consider + pattern P = Just 34 +To match against this pattern we need (Eq a, Num a). But to build +(Just 34) we need only (Num a). Fortunately instTcSigFromId sets +sig_warn_redundant to False. + +************************************************************************ +* * + Helper functions +* * +************************************************************************ + +Note [As-patterns in pattern synonym definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rationale for rejecting as-patterns in pattern synonym definitions +is that an as-pattern would introduce nonindependent pattern synonym +arguments, e.g. given a pattern synonym like: + + pattern K x y = x@(Just y) + +one could write a nonsensical function like + + f (K Nothing x) = ... + +or + g (K (Just True) False) = ... + +Note [Type signatures and the builder expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + pattern L x = Left x :: Either [a] [b] + +In tc{Infer/Check}PatSynDecl we will check that the pattern has the +specified type. We check the pattern *as a pattern*, so the type +signature is a pattern signature, and so brings 'a' and 'b' into +scope. But we don't have a way to bind 'a, b' in the LHS, as we do +'x', say. Nevertheless, the signature may be useful to constrain +the type. + +When making the binding for the *builder*, though, we don't want + $buildL x = Left x :: Either [a] [b] +because that wil either mean (forall a b. Either [a] [b]), or we'll +get a complaint that 'a' and 'b' are out of scope. (Actually the +latter; #9867.) No, the job of the signature is done, so when +converting the pattern to an expression (for the builder RHS) we +simply discard the signature. + +Note [Record PatSyn Desugaring] +------------------------------- +It is important that prov_theta comes before req_theta as this ordering is used +when desugaring record pattern synonym updates. + +Any change to this ordering should make sure to change GHC.HsToCore.Expr if you +want to avoid difficult to decipher core lint errors! + -} + + +nonBidirectionalErr :: Outputable name => name -> TcM a +nonBidirectionalErr name = failWithTc $ + text "non-bidirectional pattern synonym" + <+> quotes (ppr name) <+> text "used in an expression" + +-- Walk the whole pattern and for all ConPatOuts, collect the +-- existentially-bound type variables and evidence binding variables. +-- +-- These are used in computing the type of a pattern synonym and also +-- in generating matcher functions, since success continuations need +-- to be passed these pattern-bound evidences. +tcCollectEx + :: LPat GhcTc + -> ( [TyVar] -- Existentially-bound type variables + -- in correctly-scoped order; e.g. [ k:*, x:k ] + , [EvVar] ) -- and evidence variables + +tcCollectEx pat = go pat + where + go :: LPat GhcTc -> ([TyVar], [EvVar]) + go = go1 . unLoc + + go1 :: Pat GhcTc -> ([TyVar], [EvVar]) + go1 (LazyPat _ p) = go p + go1 (AsPat _ _ p) = go p + go1 (ParPat _ p) = go p + go1 (BangPat _ p) = go p + go1 (ListPat _ ps) = mergeMany . map go $ ps + go1 (TuplePat _ ps _) = mergeMany . map go $ ps + go1 (SumPat _ p _ _) = go p + go1 (ViewPat _ _ p) = go p + go1 con@ConPat{ pat_con_ext = con' } + = merge (cpt_tvs con', cpt_dicts con') $ + goConDetails $ pat_args con + go1 (SigPat _ p _) = go p + go1 (XPat (CoPat _ p _)) = go1 p + go1 (NPlusKPat _ n k _ geq subtract) + = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract + go1 _ = empty + + goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar]) + goConDetails (PrefixCon ps) = mergeMany . map go $ ps + goConDetails (InfixCon p1 p2) = go p1 `merge` go p2 + goConDetails (RecCon HsRecFields{ rec_flds = flds }) + = mergeMany . map goRecFd $ flds + + goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar]) + goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p + + merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) + mergeMany = foldr merge empty + empty = ([], []) diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot @@ -0,0 +1,16 @@ +module GHC.Tc.TyCl.PatSyn where + +import GHC.Hs ( PatSynBind, LHsBinds ) +import GHC.Tc.Types ( TcM, TcSigInfo ) +import GHC.Tc.Utils.Monad ( TcGblEnv) +import GHC.Utils.Outputable ( Outputable ) +import GHC.Hs.Extension ( GhcRn, GhcTc ) +import Data.Maybe ( Maybe ) + +tcPatSynDecl :: PatSynBind GhcRn GhcRn + -> Maybe TcSigInfo + -> TcM (LHsBinds GhcTc, TcGblEnv) + +tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) + +nonBidirectionalErr :: Outputable name => name -> TcM a diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -0,0 +1,1098 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Analysis functions over data types. Specifically, detecting recursive types. +-- +-- This stuff is only used for source-code decls; it's recorded in interface +-- files for imported data types. +module GHC.Tc.TyCl.Utils( + RolesInfo, + inferRoles, + checkSynCycles, + checkClassCycles, + + -- * Implicits + addTyConsToGblEnv, mkDefaultMethodType, + + -- * Record selectors + tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Bind( tcValBinds ) +import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) ) +import GHC.Tc.Utils.TcType +import GHC.Core.Predicate +import GHC.Builtin.Types( unitTy ) +import GHC.Core.Make( rEC_SEL_ERROR_ID ) +import GHC.Hs +import GHC.Core.Class +import GHC.Core.Type +import GHC.Driver.Types +import GHC.Core.TyCon +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set hiding (unitFV) +import GHC.Types.Name.Reader ( mkVarUnqual ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Core.Coercion ( ltRole ) +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Unique ( mkBuiltinUnique ) +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Utils.FV as FV +import GHC.Unit.Module +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad + +{- +************************************************************************ +* * + Cycles in type synonym declarations +* * +************************************************************************ +-} + +synonymTyConsOfType :: Type -> [TyCon] +-- Does not look through type synonyms at all +-- Return a list of synonym tycons +-- Keep this synchronized with 'expandTypeSynonyms' +synonymTyConsOfType ty + = nameEnvElts (go ty) + where + go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim + go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys + go (LitTy _) = emptyNameEnv + go (TyVarTy _) = emptyNameEnv + go (AppTy a b) = go a `plusNameEnv` go b + go (FunTy _ a b) = go a `plusNameEnv` go b + go (ForAllTy _ ty) = go ty + go (CastTy ty co) = go ty `plusNameEnv` go_co co + go (CoercionTy co) = go_co co + + -- Note [TyCon cycles through coercions?!] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Although, in principle, it's possible for a type synonym loop + -- could go through a coercion (since a coercion can refer to + -- a TyCon or Type), it doesn't seem possible to actually construct + -- a Haskell program which tickles this case. Here is an example + -- program which causes a coercion: + -- + -- type family Star where + -- Star = Type + -- + -- data T :: Star -> Type + -- data S :: forall (a :: Type). T a -> Type + -- + -- Here, the application 'T a' must first coerce a :: Type to a :: Star, + -- witnessed by the type family. But if we now try to make Type refer + -- to a type synonym which in turn refers to Star, we'll run into + -- trouble: we're trying to define and use the type constructor + -- in the same recursive group. Possibly this restriction will be + -- lifted in the future but for now, this code is "just for completeness + -- sake". + go_mco MRefl = emptyNameEnv + go_mco (MCo co) = go_co co + + go_co (Refl ty) = go ty + go_co (GRefl _ ty mco) = go ty `plusNameEnv` go_mco mco + go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs + go_co (AppCo co co') = go_co co `plusNameEnv` go_co co' + go_co (ForAllCo _ co co') = go_co co `plusNameEnv` go_co co' + go_co (FunCo _ co co') = go_co co `plusNameEnv` go_co co' + go_co (CoVarCo _) = emptyNameEnv + go_co (HoleCo {}) = emptyNameEnv + go_co (AxiomInstCo _ _ cs) = go_co_s cs + go_co (UnivCo p _ ty ty') = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty' + go_co (SymCo co) = go_co co + go_co (TransCo co co') = go_co co `plusNameEnv` go_co co' + go_co (NthCo _ _ co) = go_co co + go_co (LRCo _ co) = go_co co + go_co (InstCo co co') = go_co co `plusNameEnv` go_co co' + go_co (KindCo co) = go_co co + go_co (SubCo co) = go_co co + go_co (AxiomRuleCo _ cs) = go_co_s cs + + go_prov (PhantomProv co) = go_co co + go_prov (ProofIrrelProv co) = go_co co + go_prov (PluginProv _) = emptyNameEnv + + go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc + | otherwise = emptyNameEnv + go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys + go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos + +-- | A monad for type synonym cycle checking, which keeps +-- 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) } + deriving (Functor) + +type SynCycleState = NameSet + +instance Applicative SynCycleM where + pure x = SynCycleM $ \state -> Right (x, state) + (<*>) = ap + +instance Monad SynCycleM where + m >>= f = SynCycleM $ \state -> + case runSynCycleM m state of + Right (x, state') -> + runSynCycleM (f x) state' + Left err -> Left err + +failSynCycleM :: SrcSpan -> SDoc -> SynCycleM () +failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err) + +-- | Test if a 'Name' is acyclic, short-circuiting if we've +-- seen it already. +checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM () +checkNameIsAcyclic n m = SynCycleM $ \s -> + if n `elemNameSet` s + then Right ((), s) -- short circuit + else case runSynCycleM m s of + Right ((), s') -> Right ((), extendNameSet s' n) + Left err -> Left err + +-- | Checks if any of the passed in 'TyCon's have cycles. +-- Takes the 'Unit' of the home package (as we can avoid +-- checking those TyCons: cycles never go through foreign packages) and +-- the corresponding @LTyClDecl Name@ for each 'TyCon', so we +-- can give better error messages. +checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () +checkSynCycles this_uid tcs tyclds = do + case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of + Left (loc, err) -> setSrcSpan loc $ failWithTc err + Right _ -> return () + where + -- Try our best to print the LTyClDecl for locally defined things + lcl_decls = mkNameEnv (zip (map tyConName tcs) tyclds) + + -- Short circuit if we've already seen this Name and concluded + -- it was acyclic. + go :: NameSet -> [TyCon] -> TyCon -> SynCycleM () + go so_far seen_tcs tc = + checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc + + -- Expand type synonyms, complaining if you find the same + -- type synonym a second time. + go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM () + go' so_far seen_tcs tc + | n `elemNameSet` so_far + = failSynCycleM (getSrcSpan (head seen_tcs)) $ + sep [ text "Cycle in type synonym declarations:" + , nest 2 (vcat (map ppr_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. + -- + -- This won't hold once we get recursive packages with Backpack, + -- but for now it's fine. + | not (isHoleModule mod || + moduleUnit mod == this_uid || + isInteractiveModule mod) + = return () + | Just ty <- synTyConRhs_maybe tc = + go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty + | otherwise = return () + where + n = tyConName tc + mod = nameModule n + ppr_decl tc = + case lookupNameEnv lcl_decls n of + Just (L loc decl) -> ppr loc <> colon <+> ppr decl + Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n + <+> text "from external module" + where + n = tyConName tc + + go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM () + go_ty so_far seen_tcs ty = + mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty) + +{- Note [Superclass cycle check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The superclass cycle check for C decides if we can statically +guarantee that expanding C's superclass cycles transitively is +guaranteed to terminate. This is a Haskell98 requirement, +but one that we lift with -XUndecidableSuperClasses. + +The worry is that a superclass cycle could make the type checker loop. +More precisely, with a constraint (Given or Wanted) + C ty1 .. tyn +one approach is to instantiate all of C's superclasses, transitively. +We can only do so if that set is finite. + +This potential loop occurs only through superclasses. This, for +example, is fine + class C a where + op :: C b => a -> b -> b +even though C's full definition uses C. + +Making the check static also makes it conservative. Eg + type family F a + class F a => C a +Here an instance of (F a) might mention C: + type instance F [a] = C a +and now we'd have a loop. + +The static check works like this, starting with C + * Look at C's superclass predicates + * If any is a type-function application, + or is headed by a type variable, fail + * If any has C at the head, fail + * If any has a type class D at the head, + make the same test with D + +A tricky point is: what if there is a type variable at the head? +Consider this: + class f (C f) => C f + class c => Id c +and now expand superclasses for constraint (C Id): + C Id + --> Id (C Id) + --> C Id + --> .... +Each step expands superclasses one layer, and clearly does not terminate. +-} + +checkClassCycles :: Class -> Maybe SDoc +-- Nothing <=> ok +-- Just err <=> possible cycle error +checkClassCycles cls + = do { (definite_cycle, err) <- go (unitNameSet (getName 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]) } + 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 + -- + -- NB: this code duplicates TcType.transSuperClasses, but + -- with more error message generation clobber + -- Make sure the two stay in sync. + go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc) + go so_far cls tys = firstJusts $ + map (go_pred so_far) $ + immSuperClasses cls tys + + go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc) + -- Nothing <=> ok + -- Just (True, err) <=> definite cycle + -- Just (False, err) <=> possible cycle + go_pred so_far pred -- NB: tcSplitTyConApp looks through synonyms + | 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))) + | otherwise + = Nothing + + go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc) + 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 cls <- tyConClass_maybe tc + = go_cls so_far cls tys + | otherwise -- Equality predicate, for example + = Nothing + + go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc) + go_cls so_far cls tys + | cls_nm `elemNameSet` so_far + = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls)) + | isCTupleClass cls + = go so_far cls tys + | otherwise + = do { (b,err) <- go (so_far `extendNameSet` cls_nm) cls tys + ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls) + $$ err) } + where + cls_nm = getName cls + +{- +************************************************************************ +* * + Role inference +* * +************************************************************************ + +Note [Role inference] +~~~~~~~~~~~~~~~~~~~~~ +The role inference algorithm datatype definitions to infer the roles on the +parameters. Although these roles are stored in the tycons, we can perform this +algorithm on the built tycons, as long as we don't peek at an as-yet-unknown +roles field! Ah, the magic of laziness. + +First, we choose appropriate initial roles. For families and classes, roles +(including initial roles) are N. For datatypes, we start with the role in the +role annotation (if any), or otherwise use Phantom. This is done in +initialRoleEnv1. + +The function irGroup then propagates role information until it reaches a +fixpoint, preferring N over (R or P) and R over P. To aid in this, we have a +monad RoleM, which is a combination reader and state monad. In its state are +the current RoleEnv, which gets updated by role propagation, and an update +bit, which we use to know whether or not we've reached the fixpoint. The +environment of RoleM contains the tycon whose parameters we are inferring, and +a VarEnv from parameters to their positions, so we can update the RoleEnv. +Between tycons, this reader information is missing; it is added by +addRoleInferenceInfo. + +There are two kinds of tycons to consider: algebraic ones (excluding classes) +and type synonyms. (Remember, families don't participate -- all their parameters +are N.) An algebraic tycon processes each of its datacons, in turn. Note that +a datacon's universally quantified parameters might be different from the parent +tycon's parameters, so we use the datacon's univ parameters in the mapping from +vars to positions. Note also that we don't want to infer roles for existentials +(they're all at N, too), so we put them in the set of local variables. As an +optimisation, we skip any tycons whose roles are already all Nominal, as there +nowhere else for them to go. For synonyms, we just analyse their right-hand sides. + +irType walks through a type, looking for uses of a variable of interest and +propagating role information. Because anything used under a phantom position +is at phantom and anything used under a nominal position is at nominal, the +irType function can assume that anything it sees is at representational. (The +other possibilities are pruned when they're encountered.) + +The rest of the code is just plumbing. + +How do we know that this algorithm is correct? It should meet the following +specification: + +Let Z be a role context -- a mapping from variables to roles. The following +rules define the property (Z |- t : r), where t is a type and r is a role: + +Z(a) = r' r' <= r +------------------------- RCVar +Z |- a : r + +---------- RCConst +Z |- T : r -- T is a type constructor + +Z |- t1 : r +Z |- t2 : N +-------------- RCApp +Z |- t1 t2 : r + +forall i<=n. (r_i is R or N) implies Z |- t_i : r_i +roles(T) = r_1 .. r_n +---------------------------------------------------- RCDApp +Z |- T t_1 .. t_n : R + +Z, a:N |- t : r +---------------------- RCAll +Z |- forall a:k.t : r + + +We also have the following rules: + +For all datacon_i in type T, where a_1 .. a_n are universally quantified +and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p, +then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R, +then roles(T) = r_1 .. r_n + +roles(->) = R, R +roles(~#) = N, N + +With -dcore-lint on, the output of this algorithm is checked in checkValidRoles, +called from checkValidTycon. + +Note [Role-checking data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a where + MkT :: Eq b => F a -> (a->a) -> T (G a) + +Then we want to check the roles at which 'a' is used +in MkT's type. We want to work on the user-written type, +so we need to take into account + * the arguments: (F a) and (a->a) + * the context: C a b + * the result type: (G a) -- this is in the eq_spec + + +Note [Coercions in role inference] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is (t |> co1) representationally equal to (t |> co2)? Of course they are! Changing +the kind of a type is totally irrelevant to the representation of that type. So, +we want to totally ignore coercions when doing role inference. This includes omitting +any type variables that appear in nominal positions but only within coercions. +-} + +type RolesInfo = Name -> [Role] + +type RoleEnv = NameEnv [Role] -- from tycon names to roles + +-- This, and any of the functions it calls, must *not* look at the roles +-- field of a tycon we are inferring roles about! +-- See Note [Role inference] +inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role] +inferRoles hsc_src annots tycons + = let role_env = initialRoleEnv hsc_src annots tycons + role_env' = irGroup role_env tycons in + \name -> case lookupNameEnv role_env' name of + Just roles -> roles + Nothing -> pprPanic "inferRoles" (ppr name) + +initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv +initialRoleEnv hsc_src annots = extendNameEnvList emptyNameEnv . + map (initialRoleEnv1 hsc_src annots) + +initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role]) +initialRoleEnv1 hsc_src annots_env tc + | isFamilyTyCon tc = (name, map (const Nominal) bndrs) + | isAlgTyCon tc = (name, default_roles) + | isTypeSynonymTyCon tc = (name, default_roles) + | otherwise = pprPanic "initialRoleEnv1" (ppr tc) + where name = tyConName tc + bndrs = tyConBinders tc + argflags = map tyConBinderArgFlag bndrs + num_exps = count isVisibleArgFlag argflags + + -- if the number of annotations in the role annotation decl + -- is wrong, just ignore it. We check this in the validity check. + role_annots + = case lookupRoleAnnot annots_env name of + Just (L _ (RoleAnnotDecl _ _ annots)) + | annots `lengthIs` num_exps -> map unLoc annots + _ -> replicate num_exps Nothing + default_roles = build_default_roles argflags role_annots + + build_default_roles (argf : argfs) (m_annot : ras) + | isVisibleArgFlag argf + = (m_annot `orElse` default_role) : build_default_roles argfs ras + build_default_roles (_argf : argfs) ras + = Nominal : build_default_roles argfs ras + build_default_roles [] [] = [] + build_default_roles _ _ = pprPanic "initialRoleEnv1 (2)" + (vcat [ppr tc, ppr role_annots]) + + default_role + | isClassTyCon tc = Nominal + -- Note [Default roles for abstract TyCons in hs-boot/hsig] + | HsBootFile <- hsc_src + , isAbstractTyCon tc = Representational + | HsigFile <- hsc_src + , isAbstractTyCon tc = Nominal + | otherwise = Phantom + +-- Note [Default roles for abstract TyCons in hs-boot/hsig] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- What should the default role for an abstract TyCon be? +-- +-- Originally, we inferred phantom role for abstract TyCons +-- in hs-boot files, because the type variables were never used. +-- +-- This was silly, because the role of the abstract TyCon +-- was required to match the implementation, and the roles of +-- data types are almost never phantom. Thus, in ticket #9204, +-- the default was changed so be representational (the most common case). If +-- the implementing data type was actually nominal, you'd get an easy +-- to understand error, and add the role annotation yourself. +-- +-- Then Backpack was added, and with it we added role *subtyping* +-- the matching judgment: if an abstract TyCon has a nominal +-- parameter, it's OK to implement it with a representational +-- parameter. But now, the representational default is not a good +-- one, because you should *only* request representational if +-- you're planning to do coercions. To be maximally flexible +-- with what data types you will accept, you want the default +-- for hsig files is nominal. We don't allow role subtyping +-- with hs-boot files (it's good practice to give an exactly +-- accurate role here, because any types that use the abstract +-- type will propagate the role information.) + +irGroup :: RoleEnv -> [TyCon] -> RoleEnv +irGroup env tcs + = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in + if update + then irGroup env' tcs + else env' + +irTyCon :: TyCon -> RoleM () +irTyCon tc + | isAlgTyCon tc + = do { old_roles <- lookupRoles tc + ; unless (all (== Nominal) old_roles) $ -- also catches data families, + -- which don't want or need role inference + irTcTyVars tc $ + do { mapM_ (irType emptyVarSet) (tyConStupidTheta tc) -- See #8958 + ; whenIsJust (tyConClass_maybe tc) irClass + ; mapM_ irDataCon (visibleDataCons $ algTyConRhs tc) }} + + | Just ty <- synTyConRhs_maybe tc + = irTcTyVars tc $ + irType emptyVarSet ty + + | otherwise + = return () + +-- any type variable used in an associated type must be Nominal +irClass :: Class -> RoleM () +irClass cls + = mapM_ ir_at (classATs cls) + where + cls_tvs = classTyVars cls + cls_tv_set = mkVarSet cls_tvs + + ir_at at_tc + = mapM_ (updateRole Nominal) nvars + where nvars = filter (`elemVarSet` cls_tv_set) $ tyConTyVars at_tc + +-- See Note [Role inference] +irDataCon :: DataCon -> RoleM () +irDataCon datacon + = setRoleInferenceVars univ_tvs $ + irExTyVars ex_tvs $ \ ex_var_set -> + mapM_ (irType ex_var_set) + (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ arg_tys) + -- See Note [Role-checking data constructor arguments] + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) + = dataConFullSig datacon + +irType :: VarSet -> Type -> RoleM () +irType = go + where + go lcls ty | Just ty' <- coreView ty -- #14101 + = go lcls ty' + go lcls (TyVarTy tv) = unless (tv `elemVarSet` lcls) $ + updateRole Representational tv + go lcls (AppTy t1 t2) = go lcls t1 >> markNominal lcls t2 + go lcls (TyConApp tc tys) = do { roles <- lookupRolesX tc + ; zipWithM_ (go_app lcls) roles tys } + go lcls (ForAllTy tvb ty) = do { let tv = binderVar tvb + lcls' = extendVarSet lcls tv + ; markNominal lcls (tyVarKind tv) + ; go lcls' ty } + go lcls (FunTy _ arg res) = go lcls arg >> go lcls res + go _ (LitTy {}) = return () + -- See Note [Coercions in role inference] + go lcls (CastTy ty _) = go lcls ty + go _ (CoercionTy _) = return () + + go_app _ Phantom _ = return () -- nothing to do here + go_app lcls Nominal ty = markNominal lcls ty -- all vars below here are N + go_app lcls Representational ty = go lcls ty + +irTcTyVars :: TyCon -> RoleM a -> RoleM a +irTcTyVars tc thing + = setRoleInferenceTc (tyConName tc) $ go (tyConTyVars tc) + where + go [] = thing + go (tv:tvs) = do { markNominal emptyVarSet (tyVarKind tv) + ; addRoleInferenceVar tv $ go tvs } + +irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a +irExTyVars orig_tvs thing = go emptyVarSet orig_tvs + where + go lcls [] = thing lcls + go lcls (tv:tvs) = do { markNominal lcls (tyVarKind tv) + ; go (extendVarSet lcls tv) tvs } + +markNominal :: TyVarSet -- local variables + -> Type -> RoleM () +markNominal lcls ty = let nvars = fvVarList (FV.delFVs lcls $ get_ty_vars ty) in + mapM_ (updateRole Nominal) nvars + where + -- get_ty_vars gets all the tyvars (no covars!) from a type *without* + -- recurring into coercions. Recall: coercions are totally ignored during + -- role inference. See [Coercions in role inference] + get_ty_vars :: Type -> FV + get_ty_vars (TyVarTy tv) = unitFV tv + get_ty_vars (AppTy t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 + get_ty_vars (FunTy _ t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 + get_ty_vars (TyConApp _ tys) = mapUnionFV get_ty_vars tys + get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty) + get_ty_vars (LitTy {}) = emptyFV + get_ty_vars (CastTy ty _) = get_ty_vars ty + get_ty_vars (CoercionTy _) = emptyFV + +-- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps +lookupRolesX :: TyCon -> RoleM [Role] +lookupRolesX tc + = do { roles <- lookupRoles tc + ; return $ roles ++ repeat Nominal } + +-- gets the roles either from the environment or the tycon +lookupRoles :: TyCon -> RoleM [Role] +lookupRoles tc + = do { env <- getRoleEnv + ; case lookupNameEnv env (tyConName tc) of + Just roles -> return roles + Nothing -> return $ tyConRoles tc } + +-- tries to update a role; won't ever update a role "downwards" +updateRole :: Role -> TyVar -> RoleM () +updateRole role tv + = do { var_ns <- getVarNs + ; name <- getTyConName + ; case lookupVarEnv var_ns tv of + Nothing -> pprPanic "updateRole" (ppr name $$ ppr tv $$ ppr var_ns) + Just n -> updateRoleEnv name n role } + +-- the state in the RoleM monad +data RoleInferenceState = RIS { role_env :: RoleEnv + , update :: Bool } + +-- the environment in the RoleM monad +type VarPositions = VarEnv Int + +-- See [Role inference] +newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon + -> VarPositions + -> Int -- size of VarPositions + -> RoleInferenceState + -> (a, RoleInferenceState) } + deriving (Functor) + +instance Applicative RoleM where + pure x = RM $ \_ _ _ state -> (x, state) + (<*>) = ap + +instance Monad RoleM where + a >>= f = RM $ \m_info vps nvps state -> + let (a', state') = unRM a m_info vps nvps state in + unRM (f a') m_info vps nvps state' + +runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool) +runRoleM env thing = (env', update) + where RIS { role_env = env', update = update } + = snd $ unRM thing Nothing emptyVarEnv 0 state + state = RIS { role_env = env + , update = False } + +setRoleInferenceTc :: Name -> RoleM a -> RoleM a +setRoleInferenceTc name thing = RM $ \m_name vps nvps state -> + ASSERT( isNothing m_name ) + ASSERT( isEmptyVarEnv vps ) + ASSERT( nvps == 0 ) + unRM thing (Just name) vps nvps state + +addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a +addRoleInferenceVar tv thing + = RM $ \m_name vps nvps state -> + ASSERT( isJust m_name ) + unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state + +setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a +setRoleInferenceVars tvs thing + = RM $ \m_name _vps _nvps state -> + ASSERT( isJust m_name ) + unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars") + state + +getRoleEnv :: RoleM RoleEnv +getRoleEnv = RM $ \_ _ _ state@(RIS { role_env = env }) -> (env, state) + +getVarNs :: RoleM VarPositions +getVarNs = RM $ \_ vps _ state -> (vps, state) + +getTyConName :: RoleM Name +getTyConName = RM $ \m_name _ _ state -> + case m_name of + Nothing -> panic "getTyConName" + Just name -> (name, state) + +updateRoleEnv :: Name -> Int -> Role -> RoleM () +updateRoleEnv name n role + = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((), + case lookupNameEnv role_env name of + Nothing -> pprPanic "updateRoleEnv" (ppr name) + Just roles -> let (before, old_role : after) = splitAt n roles in + if role `ltRole` old_role + then let roles' = before ++ role : after + role_env' = extendNameEnv role_env name roles' in + RIS { role_env = role_env', update = True } + else state ) + + +{- ********************************************************************* +* * + Building implicits +* * +********************************************************************* -} + +addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv +-- Given a [TyCon], add to the TcGblEnv +-- * extend the TypeEnv with the tycons +-- * extend the TypeEnv with their implicitTyThings +-- * extend the TypeEnv with any default method Ids +-- * add bindings for record selectors +addTyConsToGblEnv tyclss + = tcExtendTyConEnv tyclss $ + tcExtendGlobalEnvImplicit implicit_things $ + tcExtendGlobalValEnv def_meth_ids $ + do { traceTc "tcAddTyCons" $ vcat + [ text "tycons" <+> ppr tyclss + , text "implicits" <+> ppr implicit_things ] + ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss) + ; return gbl_env } + where + implicit_things = concatMap implicitTyConThings tyclss + def_meth_ids = mkDefaultMethodIds tyclss + +mkDefaultMethodIds :: [TyCon] -> [Id] +-- We want to put the default-method Ids (both vanilla and generic) +-- into the type environment so that they are found when we typecheck +-- the filled-in default methods of each instance declaration +-- See Note [Default method Ids and Template Haskell] +mkDefaultMethodIds tycons + = [ mkExportedVanillaId dm_name (mkDefaultMethodType cls sel_id dm_spec) + | tc <- tycons + , Just cls <- [tyConClass_maybe tc] + , (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ] + +mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type +-- Returns the top-level type of the default method +mkDefaultMethodType _ sel_id VanillaDM = idType sel_id +mkDefaultMethodType cls _ (GenericDM dm_ty) = mkSigmaTy tv_bndrs [pred] dm_ty + where + pred = mkClassPred cls (mkTyVarTys (binderVars cls_bndrs)) + cls_bndrs = tyConBinders (classTyCon cls) + tv_bndrs = tyConTyVarBinders cls_bndrs + -- NB: the Class doesn't have TyConBinders; we reach into its + -- TyCon to get those. We /do/ need the TyConBinders because + -- we need the correct visibility: these default methods are + -- used in code generated by the fill-in for missing + -- methods in instances (GHC.Tc.TyCl.Instance.mkDefMethBind), and + -- then typechecked. So we need the right visibility info + -- (#13998) + +{- +************************************************************************ +* * + Building record selectors +* * +************************************************************************ +-} + +{- +Note [Default method Ids and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#4169): + class Numeric a where + fromIntegerNum :: a + fromIntegerNum = ... + + ast :: Q [Dec] + ast = [d| instance Numeric Int |] + +When we typecheck 'ast' we have done the first pass over the class decl +(in tcTyClDecls), but we have not yet typechecked the default-method +declarations (because they can mention value declarations). So we +must bring the default method Ids into scope first (so they can be seen +when typechecking the [d| .. |] quote, and typecheck them later. +-} + +{- +************************************************************************ +* * + Building record selectors +* * +************************************************************************ +-} + +tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv +tcRecSelBinds sel_bind_prs + = tcExtendGlobalValEnv [sel_id | (L _ (IdSig _ sel_id)) <- sigs] $ + do { (rec_sel_binds, tcg_env) <- discardWarnings $ + -- See Note [Impredicative record selectors] + setXOptM LangExt.ImpredicativeTypes $ + tcValBinds TopLevel binds sigs getGblEnv + ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } + where + sigs = [ L loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs + , let loc = getSrcSpan sel_id ] + binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] + +mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)] +-- NB We produce *un-typechecked* bindings, rather like 'deriving' +-- This makes life easier, because the later type checking will add +-- all necessary type abstractions and applications +mkRecSelBinds tycons + = map mkRecSelBind [ (tc,fld) | tc <- tycons + , fld <- tyConFieldLabels tc ] + +mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn) +mkRecSelBind (tycon, fl) + = mkOneRecordSelector all_cons (RecSelData tycon) fl + where + all_cons = map RealDataCon (tyConDataCons tycon) + +mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel + -> (Id, LHsBind GhcRn) +mkOneRecordSelector all_cons idDetails fl + = (sel_id, L loc sel_bind) + where + loc = getSrcSpan sel_name + lbl = flLabel fl + sel_name = flSelector fl + + sel_id = mkExportedLocalId rec_details sel_name sel_ty + rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty } + + -- Find a representative constructor, con1 + cons_w_field = conLikesWithFields all_cons [lbl] + con1 = ASSERT( not (null cons_w_field) ) head cons_w_field + + -- Selector type; Note [Polymorphic selectors] + field_ty = conLikeFieldType con1 lbl + data_tvbs = filter (\tvb -> binderVar tvb `elemVarSet` data_tv_set) $ + conLikeUserTyVarBinders con1 + data_tv_set= tyCoVarsOfTypes inst_tys + is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set) + sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] + | otherwise = mkForAllTys data_tvbs $ + mkPhiTy (conLikeStupidTheta con1) $ -- Urgh! + -- req_theta is empty for normal DataCon + mkPhiTy req_theta $ + mkVisFunTy data_ty $ + field_ty + + -- 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 + where + alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname) + [] unit_rhs] + | otherwise = map mk_match cons_w_field ++ deflt + mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) + [L loc (mk_sel_pat con)] + (L loc (HsVar noExtField (L loc field_var))) + mk_sel_pat con = ConPat NoExtField (L loc (getName con)) (RecCon rec_fields) + rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } + rec_field = noLoc (HsRecField + { hsRecFieldLbl + = L loc (FieldOcc sel_name + (L loc $ mkVarUnqual lbl)) + , hsRecFieldArg + = L loc (VarPat noExtField (L loc field_var)) + , hsRecPun = False }) + sel_lname = L loc sel_name + field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc + + -- Add catch-all default case unless the case is exhaustive + -- We do this explicitly so that we get a nice error message that + -- mentions this particular record selector + deflt | all dealt_with all_cons = [] + | otherwise = [mkSimpleMatch CaseAlt + [L loc (WildPat noExtField)] + (mkHsApp (L loc (HsVar noExtField + (L loc (getName rEC_SEL_ERROR_ID)))) + (L loc (HsLit noExtField msg_lit)))] + + -- Do not add a default case unless there are unmatched + -- constructors. We must take account of GADTs, else we + -- get overlap warning messages from the pattern-match checker + -- NB: we need to pass type args for the *representation* TyCon + -- to dataConCannotMatch, hence the calculation of inst_tys + -- This matters in data families + -- data instance T Int a where + -- A :: { fld :: Int } -> T Int Bool + -- B :: { fld :: Int } -> T Int Char + dealt_with :: ConLike -> Bool + dealt_with (PatSynCon _) = False -- We can't predict overlap + dealt_with con@(RealDataCon dc) = + con `elem` cons_w_field || dataConCannotMatch inst_tys dc + + (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1 + + eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) + -- inst_tys corresponds to one of the following: + -- + -- * The arguments to the user-written return type (for GADT constructors). + -- In this scenario, eq_subst provides a mapping from the universally + -- quantified type variables to the argument types. Note that eq_subst + -- does not need to be applied to any other part of the DataCon + -- (see Note [The dcEqSpec domain invariant] in GHC.Core.DataCon). + -- * The universally quantified type variables + -- (for Haskell98-style constructors and pattern synonyms). In these + -- scenarios, eq_subst is an empty substitution. + inst_tys = substTyVars eq_subst univ_tvs + + unit_rhs = mkLHsTupleExpr [] + msg_lit = HsStringPrim NoSourceText (bytesFS lbl) + +{- +Note [Polymorphic selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We take care to build the type of a polymorphic selector in the right +order, so that visible type application works according to the specification in +the GHC User's Guide (see the "Field selectors and TypeApplications" section). +We won't bother rehashing the entire specification in this Note, but the tricky +part is dealing with GADT constructor fields. Here is an appropriately tricky +example to illustrate the challenges: + + {-# LANGUAGE PolyKinds #-} + data T a b where + MkT :: forall b a x. + { field1 :: forall c. (Num a, Show c) => (Either a c, Proxy b) + , field2 :: x + } + -> T a b + +Our goal is to obtain the following type for `field1`: + + field1 :: forall {k} (b :: k) a. + T a b -> forall c. (Num a, Show c) => (Either a c, Proxy b) + +(`field2` is naughty, per Note [Naughty record selectors], so we cannot turn +it into a top-level field selector.) + +Some potential gotchas, inspired by #18023: + +1. Since the user wrote `forall b a x.` in the type of `MkT`, we want the `b` + to appear before the `a` when quantified in the type of `field1`. +2. On the other hand, we *don't* want to quantify `x` in the type of `field1`. + This is because `x` does not appear in the GADT return type, so it is not + needed in the selector type. +3. Because of PolyKinds, the kind of `b` is generalized to `k`. Moreover, since + this `k` is not written in the source code, it is inferred (i.e., not + available for explicit type applications) and thus written as {k} in the type + of `field1`. + +In order to address these gotchas, we start by looking at the +conLikeUserTyVarBinders, which gives the order and specificity of each binder. +This effectively solves (1) and (3). To solve (2), we filter the binders to +leave only those that are needed for the selector type. + +Note [Naughty record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "naughty" field is one for which we can't define a record +selector, because an existential type variable would escape. For example: + data T = forall a. MkT { x,y::a } +We obviously can't define + x (MkT v _) = v +Nevertheless we *do* put a RecSelId into the type environment +so that if the user tries to use 'x' as a selector we can bleat +helpfully, rather than saying unhelpfully that 'x' is not in scope. +Hence the sel_naughty flag, to identify record selectors that don't really exist. + +In general, a field is "naughty" if its type mentions a type variable that +isn't in the result type of the constructor. Note that this *allows* +GADT record selectors (Note [GADT record selectors]) whose types may look +like sel :: T [a] -> a + +For naughty selectors we make a dummy binding + sel = () +so that the later type-check will add them to the environment, and they'll be +exported. The function is never called, because the typechecker spots the +sel_naughty field. + +Note [GADT record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For GADTs, we require that all constructors with a common field 'f' have the same +result type (modulo alpha conversion). [Checked in GHC.Tc.TyCl.checkValidTyCon] +E.g. + data T where + T1 { f :: Maybe a } :: T [a] + T2 { f :: Maybe a, y :: b } :: T [a] + T3 :: T Int + +and now the selector takes that result type as its argument: + f :: forall a. T [a] -> Maybe a + +Details: the "real" types of T1,T2 are: + T1 :: forall r a. (r~[a]) => a -> T r + T2 :: forall r a b. (r~[a]) => a -> b -> T r + +So the selector loooks like this: + f :: forall a. T [a] -> Maybe a + f (a:*) (t:T [a]) + = case t of + T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g)) + T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g)) + T3 -> error "T3 does not have field f" + +Note the forall'd tyvars of the selector are just the free tyvars +of the result type; there may be other tyvars in the constructor's +type (e.g. 'b' in T2). + +Note the need for casts in the result! + +Note [Selector running example] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's OK to combine GADTs and type families. Here's a running example: + + data instance T [a] where + T1 { fld :: b } :: T [Maybe b] + +The representation type looks like this + data :R7T a where + T1 { fld :: b } :: :R7T (Maybe b) + +and there's coercion from the family type to the representation type + :CoR7T a :: T [a] ~ :R7T a + +The selector we want for fld looks like this: + + fld :: forall b. T [Maybe b] -> b + fld = /\b. \(d::T [Maybe b]). + case d `cast` :CoR7T (Maybe b) of + T1 (x::b) -> x + +The scrutinee of the case has type :R7T (Maybe b), which can be +gotten by applying the eq_spec to the univ_tvs of the data con. + +Note [Impredicative record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are situations where generating code for record selectors requires the +use of ImpredicativeTypes. Here is one example (adapted from #18005): + + type S = (forall b. b -> b) -> Int + data T = MkT {unT :: S} + | Dummy + +We want to generate HsBinds for unT that look something like this: + + unT :: S + unT (MkT x) = x + unT _ = recSelError "unT"# + +Note that the type of recSelError is `forall r (a :: TYPE r). Addr# -> a`. +Therefore, when used in the right-hand side of `unT`, GHC attempts to +instantiate `a` with `(forall b. b -> b) -> Int`, which is impredicative. +To make sure that GHC is OK with this, we enable ImpredicativeTypes interally +when typechecking these HsBinds so that the user does not have to. + +Although ImpredicativeTypes is somewhat fragile and unpredictable in GHC right +now, it will become robust when Quick Look impredicativity is implemented. In +the meantime, using ImpredicativeTypes to instantiate the `a` type variable in +recSelError's type does actually work, so its use here is benign. +-} diff --git a/compiler/GHC/Tc/Types/EvTerm.hs b/compiler/GHC/Tc/Types/EvTerm.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Types/EvTerm.hs @@ -0,0 +1,71 @@ + +-- (those who have too heavy dependencies for GHC.Tc.Types.Evidence) +module GHC.Tc.Types.EvTerm + ( evDelayedError, evCallStack ) +where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Core.Type +import GHC.Core +import GHC.Core.Make +import GHC.Types.Literal ( Literal(..) ) +import GHC.Tc.Types.Evidence +import GHC.Driver.Types +import GHC.Driver.Session +import GHC.Types.Name +import GHC.Unit +import GHC.Core.Utils +import GHC.Builtin.Names +import GHC.Types.SrcLoc + +-- Used with Opt_DeferTypeErrors +-- See Note [Deferring coercion errors to runtime] +-- in GHC.Tc.Solver +evDelayedError :: Type -> FastString -> EvTerm +evDelayedError ty msg + = EvExpr $ + Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg] + where + errorId = tYPE_ERROR_ID + litMsg = Lit (LitString (bytesFS msg)) + +-- Dictionary for CallStack implicit parameters +evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) => + EvCallStack -> m EvExpr +-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence +evCallStack cs = do + df <- getDynFlags + let platform = targetPlatform df + m <- getModule + srcLocDataCon <- lookupDataCon srcLocDataConName + let mkSrcLoc l = mkCoreConApps srcLocDataCon <$> + sequence [ mkStringExprFS (unitFS $ moduleUnit m) + , mkStringExprFS (moduleNameFS $ moduleName m) + , mkStringExprFS (srcSpanFile l) + , return $ mkIntExprInt platform (srcSpanStartLine l) + , return $ mkIntExprInt platform (srcSpanStartCol l) + , return $ mkIntExprInt platform (srcSpanEndLine l) + , return $ mkIntExprInt platform (srcSpanEndCol l) + ] + + emptyCS <- Var <$> lookupId emptyCallStackName + + pushCSVar <- lookupId pushCallStackName + let pushCS name loc rest = + mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest] + + let mkPush name loc tm = do + nameExpr <- mkStringExprFS name + locExpr <- mkSrcLoc loc + -- at this point tm :: IP sym CallStack + -- but we need the actual CallStack to pass to pushCS, + -- so we use unwrapIP to strip the dictionary wrapper + -- See Note [Overview of implicit CallStacks] + let ip_co = unwrapIP (exprType tm) + return (pushCS nameExpr locExpr (Cast tm ip_co)) + + case cs of + EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm + EvCsEmpty -> return emptyCS diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -0,0 +1,1008 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Utils.Backpack ( + findExtraSigImports', + findExtraSigImports, + implicitRequirements', + implicitRequirements, + checkUnit, + tcRnCheckUnit, + tcRnMergeSignatures, + mergeSignatures, + tcRnInstantiateSignature, + instantiateSignature, +) where + +import GHC.Prelude + +import GHC.Types.Basic (defaultFixity, TypeOrKind(..)) +import GHC.Unit.State +import GHC.Tc.Gen.Export +import GHC.Driver.Session +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Tc.Utils.Monad +import GHC.Tc.TyCl.Utils +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Tc.Utils.Instantiate +import GHC.IfaceToCore +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Solver +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Iface.Load +import GHC.Rename.Names +import GHC.Utils.Error +import GHC.Types.Id +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.SrcLoc +import GHC.Driver.Types +import GHC.Utils.Outputable +import GHC.Core.Type +import GHC.Data.FastString +import GHC.Rename.Fixity ( lookupFixityRn ) +import GHC.Data.Maybe +import GHC.Tc.Utils.Env +import GHC.Types.Var +import GHC.Iface.Syntax +import GHC.Builtin.Names +import qualified Data.Map as Map + +import GHC.Driver.Finder +import GHC.Types.Unique.DSet +import GHC.Types.Name.Shape +import GHC.Tc.Errors +import GHC.Tc.Utils.Unify +import GHC.Iface.Rename +import GHC.Utils.Misc + +import Control.Monad +import Data.List (find) + +import {-# SOURCE #-} GHC.Tc.Module + +#include "HsVersions.h" + +fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc +fixityMisMatch real_thing real_fixity sig_fixity = + 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) + +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 + 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) + +-- | Given a 'ModDetails' of an instantiated signature (note that the +-- 'ModDetails' must be knot-tied consistently with the actual implementation) +-- and a 'GlobalRdrEnv' constructed from the implementor of this interface, +-- verify that the actual implementation actually matches the original +-- interface. +-- +-- Note that it is already assumed that the implementation *exports* +-- 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 + ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, + md_types = sig_type_env, md_exports = sig_exports } = do + traceTc "checkHsigIface" $ vcat + [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ] + mapM_ check_export (map availName sig_exports) + unless (null sig_fam_insts) $ + panic ("GHC.Tc.Module.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 + tcg_env <- getGblEnv + setGblEnv tcg_env { tcg_inst_env = emptyInstEnv, + tcg_fam_inst_env = emptyFamInstEnv, + tcg_insts = [], + tcg_fam_insts = [] } $ do + mapM_ check_inst sig_insts + failIfErrsM + where + -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig + -- in package p that defines T; and we implement with himpl:H. Then the + -- Name is p[himpl:H]:H.T, NOT himplH:H.T. That's OK but we just + -- have to look up the right name. + sig_type_occ_env = mkOccEnv + . map (\t -> (nameOccName (getName t), t)) + $ nameEnvElts sig_type_env + dfun_names = map getName sig_insts + check_export name + -- Skip instances, we'll check them later + -- TODO: Actually this should never happen, because DFuns are + -- never exported... + | name `elem` dfun_names = return () + -- See if we can find the type directly in the hsig ModDetails + -- TODO: need to special case wired in names + | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do + -- NB: We use tcLookupImported_maybe because we want to EXCLUDE + -- tcg_env (TODO: but maybe this isn't relevant anymore). + r <- tcLookupImported_maybe name + case r of + Failed err -> addErr 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 { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) = + when (name /= name') $ do + -- See Note [Error reporting bad reexport] + -- TODO: Actually this error swizzle doesn't work + let p (L _ ie) = name `elem` ieNames ie + loc = case tcg_rn_exports tcg_env of + Just es | Just e <- find p (map fst es) + -- TODO: maybe we can be a little more + -- precise here and use the Located + -- info for the *specific* name we matched. + -> getLoc e + _ -> nameSrcSpan name + addErrAt loc + (badReexportedBootThing False name name') + -- This should actually never happen, but whatever... + | otherwise = + addErrAt (nameSrcSpan name) + (missingBootThing False name "exported by") + +-- Note [Error reporting bad reexport] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- NB: You want to be a bit careful about what location you report on reexports. +-- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the +-- correct source location. However, if it was *reexported*, obviously the name +-- is not going to have the right location. In this case, we need to grovel in +-- tcg_rn_exports to figure out where the reexport came from. + + + +-- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't +-- assume that the implementing file actually implemented the instances (they +-- may be reexported from elsewhere). Where should we look for the instances? +-- We do the same as we would otherwise: consult the EPS. This isn't perfect +-- (we might conclude the module exports an instance when it doesn't, see +-- #9422), but we will never refuse to compile something. +check_inst :: ClsInst -> TcM () +check_inst sig_inst = do + -- TODO: This could be very well generalized to support instance + -- declarations in boot files. + tcg_env <- getGblEnv + -- 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 ty = idType (instanceDFunId sig_inst) + skol_info = InstSkol + -- Based off of tcSplitDFunTy + (tvs, theta, pred) = + case tcSplitForAllTys ty of { (tvs, rho) -> + case splitFunTys rho of { (theta, pred) -> + (tvs, theta, pred) }} + origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst + (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize + (tclvl,cts) <- pushTcLevelM $ do + wanted <- newWanted origin + (Just TypeLevel) + (substTy skol_subst pred) + givens <- forM theta $ \given -> do + loc <- getCtLocM origin (Just TypeLevel) + let given_pred = substTy skol_subst given + new_ev <- newEvVar given_pred + return CtGiven { ctev_pred = given_pred + -- Doesn't matter, make something up + , ctev_evar = new_ev + , ctev_loc = loc + } + return $ wanted : givens + unsolved <- simplifyWantedsTcM cts + + (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved + reportAllUnsolved (mkImplicWC implic) + +-- | Return this list of requirement interfaces that need to be merged +-- to form @mod_name@, or @[]@ if this is not a requirement. +requirementMerges :: PackageState -> ModuleName -> [InstantiatedModule] +requirementMerges pkgstate mod_name = + fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate)) + where + -- update IndefUnitId ppr info as they may have changed since the + -- time the IndefUnitId was created + fixupModule (Module iud name) = Module iud' name + where + iud' = iud { instUnitInstanceOf = cid' } + cid = instUnitInstanceOf iud + cid' = updateIndefUnitId pkgstate cid + +-- | For a module @modname@ of type 'HscSource', determine the list +-- of extra "imports" of other requirements which should be considered part of +-- the import of the requirement, because it transitively depends on those +-- requirements by imports of modules from other packages. The situation +-- is something like this: +-- +-- unit p where +-- signature A +-- signature B +-- import A +-- +-- unit q where +-- dependency p[A=,B=] +-- signature A +-- signature B +-- +-- Although q's B does not directly import A, we still have to make sure we +-- process A first, because the merging process will cause B to indirectly +-- import A. This function finds the TRANSITIVE closure of all such imports +-- we need to make. +findExtraSigImports' :: HscEnv + -> HscSource + -> ModuleName + -> IO (UniqDSet ModuleName) +findExtraSigImports' hsc_env HsigFile modname = + fmap unionManyUniqDSets (forM reqs $ \(Module iuid mod_name) -> + (initIfaceLoad hsc_env + . withException + $ moduleFreeHolesPrecise (text "findExtraSigImports") + (mkModule (VirtUnit iuid) mod_name))) + where + pkgstate = pkgState (hsc_dflags hsc_env) + reqs = requirementMerges pkgstate modname + +findExtraSigImports' _ _ _ = return emptyUniqDSet + +-- | 'findExtraSigImports', but in a convenient form for "GHC.Driver.Make" and +-- "GHC.Tc.Module". +findExtraSigImports :: HscEnv -> HscSource -> ModuleName + -> IO [(Maybe FastString, Located ModuleName)] +findExtraSigImports hsc_env hsc_src modname = do + extra_requirements <- findExtraSigImports' hsc_env hsc_src modname + return [ (Nothing, noLoc mod_name) + | mod_name <- uniqDSetToList extra_requirements ] + +-- A version of 'implicitRequirements'' which is more friendly +-- for "GHC.Driver.Make" and "GHC.Tc.Module". +implicitRequirements :: HscEnv + -> [(Maybe FastString, Located ModuleName)] + -> IO [(Maybe FastString, Located ModuleName)] +implicitRequirements hsc_env normal_imports + = do mns <- implicitRequirements' hsc_env normal_imports + return [ (Nothing, noLoc mn) | mn <- mns ] + +-- Given a list of 'import M' statements in a module, figure out +-- any extra implicit requirement imports they may have. For +-- example, if they 'import M' and M resolves to p[A=], then +-- they actually also import the local requirement B. +implicitRequirements' :: HscEnv + -> [(Maybe FastString, Located ModuleName)] + -> IO [ModuleName] +implicitRequirements' hsc_env normal_imports + = fmap concat $ + forM normal_imports $ \(mb_pkg, L _ imp) -> do + found <- findImportedModule hsc_env imp mb_pkg + case found of + Found _ mod | thisPackage dflags /= moduleUnit mod -> + return (uniqDSetToList (moduleFreeHoles mod)) + _ -> return [] + where dflags = hsc_dflags hsc_env + +-- | Given a 'Unit', make sure it is well typed. This is because +-- unit IDs come from Cabal, which does not know if things are well-typed or +-- not; a component may have been filled with implementations for the holes +-- that don't actually fulfill the requirements. +checkUnit :: Unit -> TcM () +checkUnit HoleUnit = return () +checkUnit (RealUnit _) = return () -- if it's already compiled, must be well-typed +checkUnit (VirtUnit indef) = do + let insts = instUnitInsts indef + forM_ insts $ \(mod_name, mod) -> + -- NB: direct hole instantiations are well-typed by construction + -- (because we FORCE things to be merged in), so don't check them + when (not (isHoleModule mod)) $ do + checkUnit (moduleUnit mod) + _ <- mod `checkImplements` Module indef mod_name + return () + +-- | Top-level driver for signature instantiation (run when compiling +-- an @hsig@ file.) +tcRnCheckUnit :: + HscEnv -> Unit -> + IO (Messages, Maybe ()) +tcRnCheckUnit hsc_env uid = + withTiming dflags + (text "Check unit id" <+> ppr uid) + (const ()) $ + initTc hsc_env + HsigFile -- bogus + False + mAIN -- bogus + (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus + $ checkUnit uid + where + dflags = hsc_dflags hsc_env + loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid) + +-- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear... + +-- | Top-level driver for signature merging (run after typechecking +-- an @hsig@ file). +tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface + -> IO (Messages, Maybe TcGblEnv) +tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = + withTiming dflags + (text "Signature merging" <+> brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env HsigFile False this_mod real_loc $ + mergeSignatures hpm orig_tcg_env iface + where + dflags = hsc_dflags hsc_env + this_mod = mi_module iface + real_loc = tcg_top_loc orig_tcg_env + +thinModIface :: [AvailInfo] -> ModIface -> ModIface +thinModIface avails iface = + iface { + mi_exports = avails, + -- mi_fixities = ..., + -- mi_warns = ..., + -- mi_anns = ..., + -- TODO: The use of nameOccName here is a bit dodgy, because + -- perhaps there might be two IfaceTopBndr that are the same + -- OccName but different Name. Requires better understanding + -- of invariants here. + mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls + -- mi_insts = ..., + -- mi_fam_insts = ..., + } + where + 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 + | a <- avails + , n <- availNames a ] + exported_decls = filter_decls exported_occs + + non_exported_occs = mkOccSet [ occName n + | (_, d) <- exported_decls + , n <- ifaceDeclNeverExportedRefs d ] + non_exported_decls = filter_decls non_exported_occs + + dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True + dfun_pred _ = False + dfun_decls = filter (dfun_pred . snd) (mi_decls iface) + +-- | The list of 'Name's of *non-exported* 'IfaceDecl's which this +-- 'IfaceDecl' may refer to. A non-exported 'IfaceDecl' should be kept +-- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps) +-- refers to it; we can't decide to keep it by looking at the exports +-- of a module after thinning. Keep this synchronized with +-- 'rnIfaceDecl'. +ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name] +ifaceDeclNeverExportedRefs d@IfaceFamily{} = + case ifFamFlav d of + IfaceClosedSynFamilyTyCon (Just (n, _)) + -> [n] + _ -> [] +ifaceDeclNeverExportedRefs _ = [] + + +-- Note [Blank hsigs for all requirements] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- One invariant that a client of GHC must uphold is that there +-- must be an hsig file for every requirement (according to +-- @-this-unit-id@); this ensures that for every interface +-- file (hi), there is a source file (hsig), which helps grease +-- the wheels of recompilation avoidance which assumes that +-- source files always exist. + +{- +inheritedSigPvpWarning :: WarningTxt +inheritedSigPvpWarning = + WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))] + where + msg = "Inherited requirements from non-signature libraries (libraries " ++ + "with modules) should not be used, as this mode of use is not " ++ + "compatible with PVP-style version bounds. Instead, copy the " ++ + "declaration to the local hsig file or move the signature to a " ++ + "library of its own and add that library as a dependency." +-} + +-- Note [Handling never-exported TyThings under Backpack] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will +-- never be mentioned in the export list of a module (mi_avails). +-- Unlike implicit TyThings (Note [Implicit TyThings]), non-exported +-- TyThings DO have a standalone IfaceDecl declaration in their +-- interface file. +-- +-- Originally, Backpack was designed under the assumption that anything +-- you could declare in a module could also be exported; thus, merging +-- the export lists of two signatures is just merging the declarations +-- of two signatures writ small. Of course, in GHC Haskell, there are a +-- few important things which are not explicitly exported but still can +-- be used: in particular, dictionary functions for instances, Typeable +-- TyCon bindings, and coercion axioms for type families also count. +-- +-- When handling these non-exported things, there two primary things +-- we need to watch out for: +-- +-- * Signature matching/merging is done by comparing each +-- of the exported entities of a signature and a module. These exported +-- entities may refer to non-exported TyThings which must be tested for +-- consistency. For example, an instance (ClsInst) will refer to a +-- non-exported DFunId. In this case, 'checkBootDeclM' directly compares the +-- embedded 'DFunId' in 'is_dfun'. +-- +-- For this to work at all, we must ensure that pointers in 'is_dfun' refer +-- to DISTINCT 'DFunId's, even though the 'Name's (may) be the same. +-- Unfortunately, this is the OPPOSITE of how we treat most other references +-- to 'Name's, so this case needs to be handled specially. +-- +-- The details are in the documentation for 'typecheckIfacesForMerging'. +-- and the Note [Resolving never-exported Names] in GHC.IfaceToCore. +-- +-- * When we rename modules and signatures, we use the export lists to +-- decide how the declarations should be renamed. However, this +-- means we don't get any guidance for how to rename non-exported +-- entities. Fortunately, we only need to rename these entities +-- *consistently*, so that 'typecheckIfacesForMerging' can wire them +-- up as needed. +-- +-- The details are in Note [rnIfaceNeverExported] in 'GHC.Iface.Rename'. +-- +-- The root cause for all of these complications is the fact that these +-- logically "implicit" entities are defined indirectly in an interface +-- file. #13151 gives a proposal to make these *truly* implicit. + +merge_msg :: ModuleName -> [InstantiatedModule] -> SDoc +merge_msg mod_name [] = + text "while checking the local signature" <+> ppr mod_name <+> + text "for consistency" +merge_msg mod_name reqs = + hang (text "while merging the signatures from" <> colon) + 2 (vcat [ bullet <+> ppr req | req <- reqs ] $$ + bullet <+> text "...and the local signature for" <+> ppr mod_name) + +-- | Given a local 'ModIface', merge all inherited requirements +-- 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 + (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }), + hpm_src_files = src_files }) + orig_tcg_env lcl_iface0 = setSrcSpan loc $ do + -- The lcl_iface0 is the ModIface for the local hsig + -- file, which is guaranteed to exist, see + -- Note [Blank hsigs for all requirements] + hsc_env <- getTopEnv + dflags <- getDynFlags + + -- Copy over some things from the original TcGblEnv that + -- we want to preserve + updGblEnv (\env -> env { + -- Renamed imports/declarations are often used + -- by programs that use the GHC API, e.g., Haddock. + -- These won't get filled by the merging process (since + -- we don't actually rename the parsed module again) so + -- we need to take them directly from the previous + -- typechecking. + -- + -- NB: the export declarations aren't in their final + -- form yet. We'll fill those in when we reprocess + -- the export declarations. + tcg_rn_imports = tcg_rn_imports orig_tcg_env, + tcg_rn_decls = tcg_rn_decls orig_tcg_env, + -- Annotations + tcg_ann_env = tcg_ann_env orig_tcg_env, + -- Documentation header + tcg_doc_hdr = tcg_doc_hdr orig_tcg_env + -- tcg_dus? + -- tcg_th_used = tcg_th_used orig_tcg_env, + -- tcg_th_splice_used = tcg_th_splice_used orig_tcg_env + }) $ do + tcg_env <- getGblEnv + + let outer_mod = tcg_mod tcg_env + inner_mod = tcg_semantic_mod tcg_env + mod_name = moduleName (tcg_mod tcg_env) + pkgstate = pkgState dflags + + -- STEP 1: Figure out all of the external signature interfaces + -- we are going to merge in. + let reqs = requirementMerges pkgstate mod_name + + addErrCtxt (merge_msg mod_name reqs) $ do + + -- STEP 2: Read in the RAW forms of all of these interfaces + ireq_ifaces0 <- forM reqs $ \(Module iuid mod_name) -> + let m = mkModule (VirtUnit iuid) mod_name + im = fst (getModuleInstantiation m) + in fmap fst + . withException + $ findAndReadIface (text "mergeSignatures") im m False + + -- STEP 3: Get the unrenamed exports of all these interfaces, + -- thin it according to the export list, and do shaping on them. + let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as + -- This function gets run on every inherited interface, and + -- it's responsible for: + -- + -- 1. Merging the exports of the interface into @nsubst@, + -- 2. Adding these exports to the "OK to import" set (@oks@) + -- if they came from a package with no exposed modules + -- (this means we won't report a PVP error in this case), and + -- 3. Thinning the interface according to an explicit export + -- list. + -- + gen_subst (nsubst,oks,ifaces) (imod@(Module iuid _), ireq_iface) = do + let insts = instUnitInsts iuid + isFromSignaturePackage = + let inst_uid = instUnitInstanceOf iuid + pkg = getInstalledPackageDetails pkgstate (indefUnit inst_uid) + in null (unitExposedModules pkg) + -- 3(a). Rename the exports according to how the dependency + -- was instantiated. The resulting export list will be accurate + -- except for exports *from the signature itself* (which may + -- be subsequently updated by exports from other signatures in + -- the merge. + as1 <- tcRnModExports insts ireq_iface + -- 3(b). Thin the interface if it comes from a signature package. + (thinned_iface, as2) <- case mb_exports of + Just (L loc _) + -- Check if the package containing this signature is + -- a signature package (i.e., does not expose any + -- modules.) If so, we can thin it. + | isFromSignaturePackage + -> setSrcSpan loc $ do + -- Suppress missing errors; they might be used to refer + -- to entities from other signatures we are merging in. + -- If an identifier truly doesn't exist in any of the + -- signatures that are merged in, we will discover this + -- when we run exports_from_avail on the final merged + -- export list. + (mb_r, msgs) <- tryTc $ do + -- Suppose that we have written in a signature: + -- signature A ( module A ) where {- empty -} + -- If I am also inheriting a signature from a + -- signature package, does 'module A' scope over + -- all of its exports? + -- + -- There are two possible interpretations: + -- + -- 1. For non self-reexports, a module reexport + -- is interpreted only in terms of the local + -- signature module, and not any of the inherited + -- ones. The reason for this is because after + -- typechecking, module exports are completely + -- erased from the interface of a file, so we + -- have no way of "interpreting" a module reexport. + -- Thus, it's only useful for the local signature + -- module (where we have a useful GlobalRdrEnv.) + -- + -- 2. On the other hand, a common idiom when + -- you want to "export everything, plus a reexport" + -- in modules is to say module A ( module A, reex ). + -- This applies to signature modules too; and in + -- particular, you probably still want the entities + -- from the inherited signatures to be preserved + -- too. + -- + -- We think it's worth making a special case for + -- self reexports to make use case (2) work. To + -- do this, we take the exports of the inherited + -- signature @as1@, and bundle them into a + -- GlobalRdrEnv where we treat them as having come + -- from the import @import A@. Thus, we will + -- pick them up if they are referenced explicitly + -- (@foo@) or even if we do a module reexport + -- (@module A@). + let ispec = ImpSpec ImpDeclSpec{ + -- NB: This needs to be mod name + -- of the local signature, not + -- the (original) module name of + -- the inherited signature, + -- because we need module + -- LocalSig (from the local + -- export list) to match it! + is_mod = mod_name, + is_as = mod_name, + is_qual = False, + is_dloc = loc + } ImpAll + rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1) + setGblEnv tcg_env { + tcg_rdr_env = rdr_env + } $ exports_from_avail mb_exports rdr_env + -- NB: tcg_imports is also empty! + emptyImportAvails + (tcg_semantic_mod tcg_env) + case mb_r of + Just (_, as2) -> return (thinModIface as2 ireq_iface, as2) + Nothing -> addMessages msgs >> failM + -- We can't think 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.) + -- (NB: This code is actually dead right now.) + let oks' | isFromSignaturePackage + = extendOccSetList oks (exportOccs as2) + | otherwise + = oks + -- 3(d). Extend the name substitution (performing shaping) + mb_r <- extend_ns nsubst as2 + case mb_r of + Left err -> failWithTc 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)) + -- Process each interface, getting the thinned interfaces as well as + -- the final, full set of exports @nsubst@ and the exports which are + -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.) + (nsubst, ok_to_use, rev_thinned_ifaces) + <- 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) + _warn_occs = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports) + warns = NoWarnings + {- + -- 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. + -- Not supported in current warning framework + warns | null warn_occs = NoWarnings + | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs + -} + setGblEnv tcg_env { + -- The top-level GlobalRdrEnv is quite interesting. It consists + -- of two components: + -- 1. First, we reuse the GlobalRdrEnv of the local signature. + -- This is very useful, because it means that if we have + -- to print a message involving some entity that the local + -- signature imported, we'll qualify it accordingly. + -- 2. Second, we need to add all of the declarations we are + -- going to merge in (as they need to be in scope for the + -- final test of the export list.) + tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env, + -- Inherit imports from the local signature, so that module + -- reexports are picked up correctly + tcg_imports = tcg_imports orig_tcg_env, + tcg_exports = exports, + tcg_dus = usesOnly (availsToNameSetWithSelectors 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 + (tcg_imports tcg_env) (tcg_semantic_mod tcg_env) + + {- -- NB: This is commented out, because warns above is disabled. + -- If you tried to explicitly export an identifier that has a warning + -- attached to it, that's probably a mistake. Warn about it. + case mb_lies of + Nothing -> return () + Just lies -> + forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) -> + setSrcSpan loc $ + unless (nameOccName n `elemOccSet` ok_to_use) $ + addWarn NoReason $ vcat [ + text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.", + parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.") + ] + -} + + failIfErrsM + + -- Save the exports + setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do + tcg_env <- getGblEnv + + -- STEP 4: Rename the interfaces + ext_ifaces <- forM thinned_ifaces $ \((Module iuid _), ireq_iface) -> + tcRnModIface (instUnitInsts iuid) (Just nsubst) ireq_iface + lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0 + let ifaces = lcl_iface : ext_ifaces + + -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env + let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) + | (occ, f) <- concatMap mi_fixities ifaces + , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ] + + -- STEP 5: Typecheck the interfaces + let type_env_var = tcg_type_env_var tcg_env + + -- typecheckIfacesForMerging does two things: + -- 1. It merges the all of the ifaces together, and typechecks the + -- result to type_env. + -- 2. It typechecks each iface individually, but with their 'Name's + -- resolving to the merged type_env from (1). + -- See typecheckIfacesForMerging for more details. + (type_env, detailss) <- initIfaceTcRn $ + typecheckIfacesForMerging inner_mod ifaces type_env_var + let infos = zip ifaces detailss + + -- Test for cycles + checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) [] + + -- NB on type_env: it contains NO dfuns. DFuns are recorded inside + -- detailss, and given a Name that doesn't correspond to anything real. See + -- also Note [Signature merging DFuns] + + -- Add the merged type_env to TcGblEnv, so that it gets serialized + -- out when we finally write out the interface. + -- + -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly, + -- rather than use tcExtendGlobalEnv (the normal method to add newly + -- defined types to TcGblEnv?) tcExtendGlobalEnv adds these + -- TyThings to 'tcg_type_env_var', which is consulted when + -- we read in interfaces to tie the knot. But *these TyThings themselves + -- come from interface*, so that would result in deadlock. Don't + -- update it! + setGblEnv tcg_env { + tcg_tcs = typeEnvTyCons type_env, + tcg_patsyns = typeEnvPatSyns type_env, + tcg_type_env = type_env, + tcg_fix_env = fix_env + } $ do + tcg_env <- getGblEnv + + -- STEP 6: Check for compatibility/merge things + tcg_env <- (\x -> foldM x tcg_env infos) + $ \tcg_env (iface, details) -> do + + let check_export name + | Just sig_thing <- lookupTypeEnv (md_types details) name + = case lookupTypeEnv type_env (getName sig_thing) of + Just thing -> checkHsigDeclM iface sig_thing thing + Nothing -> panic "mergeSignatures: check_export" + -- Oops! We're looking for this export but it's + -- not actually in the type environment of the signature's + -- ModDetails. + -- + -- NB: This case happens because the we're iterating + -- over the union of all exports, so some interfaces + -- won't have everything. Note that md_exports is nonsense + -- (it's the same as exports); maybe we should fix this + -- eventually. + | otherwise + = return () + mapM_ check_export (map availName exports) + + -- Note [Signature merging instances] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Merge instances into the global environment. The algorithm here is + -- dumb and simple: if an instance has exactly the same DFun type + -- (tested by 'memberInstEnv') as an existing instance, we drop it; + -- otherwise, we add it even, even if this would cause overlap. + -- + -- Why don't we deduplicate instances with identical heads? There's no + -- good choice if they have premises: + -- + -- instance K1 a => K (T a) + -- instance K2 a => K (T a) + -- + -- Why not eagerly error in this case? The overlapping head does not + -- necessarily mean that the instances are unimplementable: in fact, + -- they may be implemented without overlap (if, for example, the + -- implementing module has 'instance K (T a)'; both are implemented in + -- this case.) The implements test just checks that the wanteds are + -- derivable assuming the givens. + -- + -- Still, overlapping instances with hypotheses like above are going + -- to be a bad deal, because instance resolution when we're typechecking + -- against the merged signature is going to have a bad time when + -- there are overlapping heads like this: we never backtrack, so it + -- may be difficult to see that a wanted is derivable. For now, + -- we hope that we get lucky / the overlapping instances never + -- get used, but it is not a very good situation to be in. + -- + let merge_inst (insts, inst_env) inst + | memberInstEnv inst_env inst -- test DFun Type equality + = (insts, inst_env) + | otherwise + -- NB: is_dfun_name inst is still nonsense here, + -- see Note [Signature merging DFuns] + = (inst:insts, extendInstEnv inst_env inst) + (insts, inst_env) = foldl' merge_inst + (tcg_insts tcg_env, tcg_inst_env tcg_env) + (md_insts details) + -- This is a HACK to prevent calculateAvails from including imp_mod + -- in the listing. We don't want it because a module is NOT + -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 + iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } } + avails = plusImportAvails (tcg_imports tcg_env) $ + calculateAvails dflags iface' False False ImportedBySystem + return tcg_env { + tcg_inst_env = inst_env, + tcg_insts = insts, + tcg_imports = avails, + tcg_merged = + if outer_mod == mi_module iface + -- Don't add ourselves! + then tcg_merged tcg_env + else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env + } + + -- Note [Signature merging DFuns] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Once we know all of instances which will be defined by this merged + -- signature, we go through each of the DFuns and rename them with a fresh, + -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing + -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'. + -- + -- We can't do this fixup earlier, because we need a way to identify each + -- source DFun (from each of the signatures we are merging in) so that + -- when we have a ClsInst, we can pull up the correct DFun to check if + -- the types match. + -- + -- See also Note [rnIfaceNeverExported] in GHC.Iface.Rename + dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do + 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) + } + + addDependentFiles src_files + + return tcg_env + +-- | Top-level driver for signature instantiation (run when compiling +-- an @hsig@ file.) +tcRnInstantiateSignature :: + HscEnv -> Module -> RealSrcSpan -> + IO (Messages, Maybe TcGblEnv) +tcRnInstantiateSignature hsc_env this_mod real_loc = + withTiming dflags + (text "Signature instantiation"<+>brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature + where + dflags = hsc_dflags hsc_env + +exportOccs :: [AvailInfo] -> [OccName] +exportOccs = concatMap (map occName . availNames) + +impl_msg :: Module -> InstantiatedModule -> SDoc +impl_msg impl_mod (Module req_uid req_mod_name) = + text "while checking that" <+> ppr impl_mod <+> + text "implements signature" <+> ppr req_mod_name <+> + text "in" <+> ppr req_uid + +-- | 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 impl_mod req_mod@(Module uid mod_name) = + addErrCtxt (impl_msg impl_mod req_mod) $ do + let insts = instUnitInsts uid + + -- STEP 1: Load the implementing interface, and make a RdrEnv + -- for its exports. Also, add its 'ImportAvails' to 'tcg_imports', + -- so that we treat all orphan instances it provides as visible + -- when we verify that all instances are checked (see #12945), and so that + -- when we eventually write out the interface we record appropriate + -- dependency information. + impl_iface <- initIfaceTcRn $ + loadSysInterface (text "checkImplements 1") impl_mod + let impl_gr = mkGlobalRdrEnv + (gresFromAvails Nothing (mi_exports impl_iface)) + nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface) + + -- Load all the orphans, so the subsequent 'checkHsigIface' sees + -- all the instances it needs to + loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)") + (dep_orphs (mi_deps impl_iface)) + + dflags <- getDynFlags + let avails = calculateAvails dflags + impl_iface False{- safe -} False{- boot -} ImportedBySystem + fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) + | (occ, f) <- mi_fixities impl_iface + , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ] + updGblEnv (\tcg_env -> tcg_env { + -- Setting tcg_rdr_env to treat all exported entities from + -- the implementing module as in scope improves error messages, + -- as it reduces the amount of qualification we need. Unfortunately, + -- we still end up qualifying references to external modules + -- (see bkpfail07 for an example); we'd need to record more + -- information in ModIface to solve this. + tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr, + tcg_imports = tcg_imports tcg_env `plusImportAvails` avails, + -- This is here so that when we call 'lookupFixityRn' for something + -- directly implemented by the module, we grab the right thing + tcg_fix_env = fix_env + }) $ do + + -- STEP 2: Load the *unrenamed, uninstantiated* interface for + -- the ORIGINAL signature. We are going to eventually rename it, + -- but we must proceed slowly, because it is NOT known if the + -- instantiation is correct. + let sig_mod = mkModule (VirtUnit uid) mod_name + isig_mod = fst (getModuleInstantiation sig_mod) + mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod False + isig_iface <- case mb_isig_iface of + Succeeded (iface, _) -> return iface + Failed err -> failWithTc $ + hang (text "Could not find hi interface for signature" <+> + quotes (ppr isig_mod) <> colon) 4 err + + -- 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 $ quotes (ppr occ) + <+> text "is exported by the hsig file, but not" + <+> text "exported by the implementing module" + <+> quotes (ppr impl_mod) + _ -> return () + failIfErrsM + + -- STEP 4: Now that the export is complete, rename the interface... + sig_iface <- tcRnModIface insts (Just nsubst) isig_iface + + -- STEP 5: ...and typecheck it. (Note that in both cases, the nsubst + -- lets us determine how top-level identifiers should be handled.) + sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface + + -- STEP 6: Check that it's sufficient + tcg_env <- getGblEnv + checkHsigIface tcg_env impl_gr sig_iface sig_details + + -- STEP 7: Return the updated 'TcGblEnv' with the signature exports, + -- so we write them out. + return tcg_env { + tcg_exports = mi_exports sig_iface + } + +-- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite +-- library to use the actual implementations of the relevant entities, +-- checking that the implementation matches the signature. +instantiateSignature :: TcRn TcGblEnv +instantiateSignature = do + tcg_env <- getGblEnv + dflags <- getDynFlags + let outer_mod = tcg_mod tcg_env + inner_mod = tcg_semantic_mod tcg_env + -- TODO: setup the local RdrEnv so the error messages look a little better. + -- But this information isn't stored anywhere. Should we RETYPECHECK + -- the local one just to get the information? Hmm... + MASSERT( moduleUnit outer_mod == thisPackage dflags ) + inner_mod `checkImplements` + Module + (mkInstantiatedUnit (thisComponentId dflags) + (thisUnitIdInsts dflags)) + (moduleName outer_mod) diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -0,0 +1,1103 @@ +-- (c) The University of Glasgow 2006 +{-# LANGUAGE CPP, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an + -- orphan +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Utils.Env( + TyThing(..), TcTyThing(..), TcId, + + -- Instance environment, and InstInfo type + InstInfo(..), iDFunId, pprInstInfoDetails, + simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, + InstBindings(..), + + -- Global environment + tcExtendGlobalEnv, tcExtendTyConEnv, + tcExtendGlobalEnvImplicit, setGlobalTypeEnv, + tcExtendGlobalValEnv, + tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly, + tcLookupTyCon, tcLookupClass, + tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, + tcLookupLocatedGlobalId, tcLookupLocatedTyCon, + tcLookupLocatedClass, tcLookupAxiom, + lookupGlobal, ioLookupDataCon, + addTypecheckedBinds, + + -- Local environment + tcExtendKindEnv, tcExtendKindEnvList, + tcExtendTyVarEnv, tcExtendNameTyVarEnv, + tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds, + tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, + tcExtendBinderStack, tcExtendLocalTypeEnv, + isTypeClosedLetBndr, + + tcLookup, tcLookupLocated, tcLookupLocalIds, + tcLookupId, tcLookupIdMaybe, tcLookupTyVar, + tcLookupTcTyCon, + tcLookupLcl_maybe, + getInLocalScope, + wrongThingErr, pprBinders, + + tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders, + getTypeSigNames, + tcExtendRecEnv, -- For knot-tying + + -- Tidying + tcInitTidyEnv, tcInitOpenTidyEnv, + + -- Instances + tcLookupInstance, tcGetInstEnvs, + + -- Rules + tcExtendRules, + + -- Defaults + tcGetDefaultTys, + + -- Template Haskell stuff + checkWellStaged, tcMetaTy, thLevel, + topIdLvl, isBrackStage, + + -- New Ids + newDFunName, newFamInstTyConName, + newFamInstAxiomName, + mkStableIdFromString, mkStableIdFromName, + mkWrapperName + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Iface.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Iface.Load +import GHC.Builtin.Names +import GHC.Builtin.Types +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Name.Reader +import GHC.Core.InstEnv +import GHC.Core.DataCon ( DataCon ) +import GHC.Core.PatSyn ( PatSyn ) +import GHC.Core.ConLike +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Coercion.Axiom +import GHC.Core.Class +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Var.Env +import GHC.Driver.Types +import GHC.Driver.Session +import GHC.Types.SrcLoc +import GHC.Types.Basic hiding( SuccessFlag(..) ) +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Utils.Encoding +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Data.List.SetOps +import GHC.Utils.Error +import GHC.Data.Maybe( MaybeErr(..), orElse ) +import qualified GHC.LanguageExtensions as LangExt +import GHC.Utils.Misc ( HasDebugCallStack ) + +import Data.IORef +import Data.List (intercalate) +import Control.Monad + +{- ********************************************************************* +* * + An IO interface to looking up globals +* * +********************************************************************* -} + +lookupGlobal :: HscEnv -> Name -> IO TyThing +-- A variant of lookupGlobal_maybe for the clients which are not +-- interested in recovering from lookup failure and accept panic. +lookupGlobal hsc_env name + = do { + mb_thing <- lookupGlobal_maybe hsc_env name + ; case mb_thing of + Succeeded thing -> return thing + Failed msg -> pprPanic "lookupGlobal" msg + } + +lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) +-- This may look up an Id that one one has previously looked up. +-- If so, we are going to read its interface file, and add its bindings +-- to the ExternalPackageTable. +lookupGlobal_maybe hsc_env name + = do { -- Try local envt + let mod = icInteractiveModule (hsc_IC hsc_env) + dflags = hsc_dflags hsc_env + tcg_semantic_mod = canonicalizeModuleIfHome dflags 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 + } + +lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) +-- Returns (Failed err) if we can't find the interface file for the thing +lookupImported_maybe hsc_env name + = do { mb_thing <- lookupTypeHscEnv hsc_env name + ; case mb_thing of + Just thing -> return (Succeeded thing) + Nothing -> importDecl_maybe hsc_env name + } + +importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) +importDecl_maybe hsc_env name + | Just thing <- wiredInNameTyThing_maybe name + = do { when (needWiredInHomeIface thing) + (initIfaceLoad hsc_env (loadWiredInHomeIface name)) + -- See Note [Loading instances for wired-in things] + ; return (Succeeded thing) } + | 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 MsgDoc 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 + -- Do not add the code for record-selector bindings + -- when compiling hs-boot files + | otherwise = tcg_env { tcg_binds = foldr unionBags + (tcg_binds tcg_env) + binds } + +{- +************************************************************************ +* * +* tcLookupGlobal * +* * +************************************************************************ + +Using the Located versions (eg. tcLookupLocatedGlobal) is preferred, +unless you know that the SrcSpan in the monad is already set to the +span of the Name. +-} + + +tcLookupLocatedGlobal :: Located Name -> TcM TyThing +-- c.f. GHC.IfaceToCore.tcIfaceGlobal +tcLookupLocatedGlobal name + = addLocM tcLookupGlobal name + +tcLookupGlobal :: Name -> TcM TyThing +-- The Name is almost always an ExternalName, but not always +-- In GHCi, we may make command-line bindings (ghci> let x = True) +-- that bind a GlobalId, but with an InternalName +tcLookupGlobal name + = do { -- Try local envt + env <- getGblEnv + ; case lookupNameEnv (tcg_type_env env) name of { + Just thing -> return thing ; + Nothing -> + + -- Should it have been in the local envt? + -- (NB: use semantic mod here, since names never use + -- identity module, see Note [Identity versus semantic module].) + if nameIsLocalOrFrom (tcg_semantic_mod env) name + then notFound name -- Internal names can happen in GHCi + else + + -- Try home package table and external package table + do { mb_thing <- tcLookupImported_maybe name + ; case mb_thing of + Succeeded thing -> return thing + Failed msg -> failWithTc msg + }}} + +-- Look up only in this module's global env't. Don't look in imports, etc. +-- Panic if it's not there. +tcLookupGlobalOnly :: Name -> TcM TyThing +tcLookupGlobalOnly name + = do { env <- getGblEnv + ; return $ case lookupNameEnv (tcg_type_env env) name of + Just thing -> thing + Nothing -> pprPanic "tcLookupGlobalOnly" (ppr name) } + +tcLookupDataCon :: Name -> TcM DataCon +tcLookupDataCon name = do + thing <- tcLookupGlobal name + case thing of + AConLike (RealDataCon con) -> return con + _ -> wrongThingErr "data constructor" (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 + +tcLookupConLike :: Name -> TcM ConLike +tcLookupConLike name = do + thing <- tcLookupGlobal name + case thing of + AConLike cl -> return cl + _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name + +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 + +tcLookupTyCon :: Name -> TcM TyCon +tcLookupTyCon name = do + thing <- tcLookupGlobal name + case thing of + ATyCon tc -> return tc + _ -> wrongThingErr "type constructor" (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 + +tcLookupLocatedGlobalId :: Located Name -> TcM Id +tcLookupLocatedGlobalId = addLocM tcLookupId + +tcLookupLocatedClass :: Located Name -> TcM Class +tcLookupLocatedClass = addLocM tcLookupClass + +tcLookupLocatedTyCon :: Located Name -> TcM TyCon +tcLookupLocatedTyCon = addLocM tcLookupTyCon + +-- Find the instance that exactly matches a type class application. The class arguments must be precisely +-- the same as in the instance declaration (modulo renaming & casts). +-- +tcLookupInstance :: Class -> [Type] -> TcM ClsInst +tcLookupInstance cls tys + = do { instEnv <- tcGetInstEnvs + ; case lookupUniqueInstEnv instEnv cls tys of + Left err -> failWithTc $ text "Couldn't match instance:" <+> err + Right (inst, tys) + | uniqueTyVars tys -> return inst + | otherwise -> failWithTc errNotExact + } + where + errNotExact = text "Not an exact match (i.e., some variables get instantiated)" + + uniqueTyVars tys = all isTyVarTy tys + && hasNoDups (map (getTyVar "tcLookupInstance") tys) + +tcGetInstEnvs :: TcM InstEnvs +-- Gets both the external-package inst-env +-- and the home-pkg inst env (includes module being compiled) +tcGetInstEnvs = do { eps <- getEps + ; env <- getGblEnv + ; return (InstEnvs { ie_global = eps_inst_env eps + , ie_local = tcg_inst_env env + , ie_visible = tcVisibleOrphanMods env }) } + +instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where + lookupThing = tcLookupGlobal + +{- +************************************************************************ +* * + Extending the global environment +* * +************************************************************************ +-} + +setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv +-- Use this to update the global type env +-- It updates both * the normal tcg_type_env field +-- * the tcg_type_env_var field seen by interface files +setGlobalTypeEnv tcg_env new_type_env + = do { -- Sync the type-envt variable seen by interface files + writeMutVar (tcg_type_env_var tcg_env) new_type_env + ; return (tcg_env { tcg_type_env = new_type_env }) } + + +tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r + -- Just extend the global environment with some TyThings + -- Do not extend tcg_tcs, tcg_patsyns etc +tcExtendGlobalEnvImplicit things thing_inside + = do { tcg_env <- getGblEnv + ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things + ; tcg_env' <- setGlobalTypeEnv tcg_env ge' + ; setGblEnv tcg_env' thing_inside } + +tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r + -- Given a mixture of Ids, TyCons, Classes, all defined in the + -- module being compiled, extend the global environment +tcExtendGlobalEnv things thing_inside + = do { env <- getGblEnv + ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env, + tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env } + ; setGblEnv env' $ + tcExtendGlobalEnvImplicit things thing_inside + } + +tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r + -- Given a mixture of Ids, TyCons, Classes, all defined in the + -- module being compiled, extend the global environment +tcExtendTyConEnv tycons thing_inside + = do { env <- getGblEnv + ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env } + ; setGblEnv env' $ + tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside + } + +tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a + -- Same deal as tcExtendGlobalEnv, but for Ids +tcExtendGlobalValEnv ids thing_inside + = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside + +tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r +-- Extend the global environments for the type/class knot tying game +-- Just like tcExtendGlobalEnv, except the argument is a list of pairs +tcExtendRecEnv gbl_stuff thing_inside + = do { tcg_env <- getGblEnv + ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff + tcg_env' = tcg_env { tcg_type_env = ge' } + -- No need for setGlobalTypeEnv (which side-effects the + -- tcg_type_env_var); tcExtendRecEnv is used just + -- when kind-check a group of type/class decls. It would + -- in any case be wrong for an interface-file decl to end up + -- with a TcTyCon in it! + ; setGblEnv tcg_env' thing_inside } + +{- +************************************************************************ +* * +\subsection{The local environment} +* * +************************************************************************ +-} + +tcLookupLocated :: Located Name -> TcM TcTyThing +tcLookupLocated = addLocM tcLookup + +tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) +tcLookupLcl_maybe name + = do { local_env <- getLclTypeEnv + ; return (lookupNameEnv local_env name) } + +tcLookup :: Name -> TcM TcTyThing +tcLookup name = do + local_env <- getLclTypeEnv + case lookupNameEnv local_env name of + Just thing -> return thing + Nothing -> AGlobal <$> tcLookupGlobal name + +tcLookupTyVar :: Name -> TcM TcTyVar +tcLookupTyVar name + = do { thing <- tcLookup name + ; case thing of + ATyVar _ tv -> return tv + _ -> pprPanic "tcLookupTyVar" (ppr name) } + +tcLookupId :: Name -> TcM Id +-- Used when we aren't interested in the binding level, nor refinement. +-- The "no refinement" part means that we return the un-refined Id regardless +-- +-- The Id is never a DataCon. (Why does that matter? see GHC.Tc.Gen.Expr.tcId) +tcLookupId name = do + thing <- tcLookupIdMaybe name + case thing of + Just id -> return id + _ -> pprPanic "tcLookupId" (ppr name) + +tcLookupIdMaybe :: Name -> TcM (Maybe Id) +tcLookupIdMaybe name + = do { thing <- tcLookup name + ; case thing of + ATcId { tct_id = id} -> return $ Just id + AGlobal (AnId id) -> return $ Just id + _ -> return Nothing } + +tcLookupLocalIds :: [Name] -> TcM [TcId] +-- We expect the variables to all be bound, and all at +-- the same level as the lookup. Only used in one place... +tcLookupLocalIds ns + = do { env <- getLclEnv + ; return (map (lookup (tcl_env env)) ns) } + where + lookup lenv name + = case lookupNameEnv lenv name of + Just (ATcId { tct_id = id }) -> id + _ -> pprPanic "tcLookupLocalIds" (ppr name) + +-- inferInitialKind has made a suitably-shaped kind for the type or class +-- Look it up in the local environment. This is used only for tycons +-- that we're currently type-checking, so we're sure to find a TcTyCon. +tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon +tcLookupTcTyCon name = do + thing <- tcLookup name + case thing of + ATcTyCon tc -> return tc + _ -> pprPanic "tcLookupTcTyCon" (ppr name) + +getInLocalScope :: TcM (Name -> Bool) +getInLocalScope = do { lcl_env <- getLclTypeEnv + ; return (`elemNameEnv` lcl_env) } + +tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r +-- Used only during kind checking, for TcThings that are +-- ATcTyCon or APromotionErr +-- 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 } + where + upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things } + +tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r +-- A variant of tcExtendKindEvnList +tcExtendKindEnv extra_env thing_inside + = do { traceTc "tcExtendKindEnv" (ppr extra_env) + ; updLclEnv upd_env thing_inside } + where + upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env } + +----------------------- +-- Scoped type and kind variables +tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r +tcExtendTyVarEnv tvs thing_inside + = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside + +tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r +tcExtendNameTyVarEnv binds thing_inside + -- this should be used only for explicitly mentioned scoped variables. + -- thus, no coercion variables + = do { tc_extend_local_env NotTopLevel + [(name, ATyVar name tv) | (name, tv) <- binds] $ + tcExtendBinderStack tv_binds $ + thing_inside } + where + tv_binds :: [TcBinder] + tv_binds = [TcTvBndr name tv | (name,tv) <- binds] + +isTypeClosedLetBndr :: Id -> Bool +-- See Note [Bindings with closed types] in GHC.Tc.Types +isTypeClosedLetBndr = noFreeVarsOfType . idType + +tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a +-- Used for binding the recursive uses of Ids in a binding +-- both top-level value bindings and nested let/where-bindings +-- Does not extend the TcBinderStack +tcExtendRecIds pairs thing_inside + = tc_extend_local_env NotTopLevel + [ (name, ATcId { tct_id = let_id + , tct_info = NonClosedLet emptyNameSet False }) + | (name, let_id) <- pairs ] $ + thing_inside + +tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a +-- Used for binding the Ids that have a complete user type signature +-- Does not extend the TcBinderStack +tcExtendSigIds top_lvl sig_ids thing_inside + = tc_extend_local_env top_lvl + [ (idName id, ATcId { tct_id = id + , tct_info = info }) + | id <- sig_ids + , let closed = isTypeClosedLetBndr id + info = NonClosedLet emptyNameSet closed ] + thing_inside + + +tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed + -> [TcId] -> TcM a -> TcM a +-- Used for both top-level value bindings and nested let/where-bindings +-- Adds to the TcBinderStack too +tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed) + ids thing_inside + = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $ + tc_extend_local_env top_lvl + [ (idName id, ATcId { tct_id = id + , tct_info = mk_tct_info id }) + | id <- ids ] + thing_inside + where + mk_tct_info id + | type_closed && isEmptyNameSet rhs_fvs = ClosedLet + | otherwise = NonClosedLet rhs_fvs type_closed + where + name = idName id + rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet + type_closed = isTypeClosedLetBndr id && + (fv_type_closed || hasCompleteSig sig_fn name) + +tcExtendIdEnv :: [TcId] -> TcM a -> TcM a +-- For lambda-bound and case-bound Ids +-- Extends the TcBinderStack as well +tcExtendIdEnv ids thing_inside + = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside + +tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a +-- Exactly like tcExtendIdEnv2, but for a single (name,id) pair +tcExtendIdEnv1 name id thing_inside + = tcExtendIdEnv2 [(name,id)] thing_inside + +tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a +tcExtendIdEnv2 names_w_ids thing_inside + = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel + | (_,mono_id) <- names_w_ids ] $ + tc_extend_local_env NotTopLevel + [ (name, ATcId { tct_id = id + , tct_info = NotLetBound }) + | (name,id) <- names_w_ids] + thing_inside + +tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a +tc_extend_local_env top_lvl extra_env thing_inside +-- Precondition: the argument list extra_env has TcTyThings +-- that ATcId or ATyVar, but nothing else +-- +-- Invariant: the ATcIds are fully zonked. Reasons: +-- (a) The kinds of the forall'd type variables are defaulted +-- (see Kind.defaultKind, done in skolemiseQuantifiedTyVar) +-- (b) There are no via-Indirect occurrences of the bound variables +-- in the types, because instantiation does not look through such things +-- (c) The call to tyCoVarsOfTypes is ok without looking through refs + +-- The second argument of type TyVarSet is a set of type variables +-- 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) + ; env0 <- getLclEnv + ; let env1 = tcExtendLocalTypeEnv env0 extra_env + ; stage <- getStage + ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1 + ; setLclEnv env2 thing_inside } + where + extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv + -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously + -- Reason for extending LocalRdrEnv: after running a TH splice we need + -- to do renaming. + extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env + , tcl_th_bndrs = th_bndrs }) + = env { tcl_rdr = extendLocalRdrEnvList rdr_env + [ n | (n, _) <- pairs, isInternalName n ] + -- The LocalRdrEnv contains only non-top-level names + -- (GlobalRdrEnv handles the top level) + , tcl_th_bndrs = extendNameEnvList th_bndrs -- We only track Ids in tcl_th_bndrs + [(n, thlvl) | (n, ATcId {}) <- pairs] } + +tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv +tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things + = lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things } + +{- ********************************************************************* +* * + The TcBinderStack +* * +********************************************************************* -} + +tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a +tcExtendBinderStack bndrs thing_inside + = do { traceTc "tcExtendBinderStack" (ppr bndrs) + ; updLclEnv (\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 <- zonkTcTyVarToTyVar 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 +* * +********************************************************************* -} + +tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a +-- See Note [AFamDataCon: not promoting data family constructors] +tcAddDataFamConPlaceholders inst_decls thing_inside + = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE) + | lid <- inst_decls, con <- get_cons lid ] + thing_inside + -- Note [AFamDataCon: not promoting data family constructors] + where + -- get_cons extracts the *constructor* bindings of the declaration + get_cons :: LInstDecl GhcRn -> [Name] + get_cons (L _ (TyFamInstD {})) = [] + get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid + get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } })) + = concatMap (get_fi_cons . unLoc) fids + + get_fi_cons :: DataFamInstDecl GhcRn -> [Name] + get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}}) + = map unLoc $ concatMap (getConNames . unLoc) cons + + +tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a +-- See Note [Don't promote pattern synonyms] +tcAddPatSynPlaceholders pat_syns thing_inside + = tcExtendKindEnvList [ (name, APromotionErr PatSynPE) + | PSB{ psb_id = L _ name } <- pat_syns ] + thing_inside + +getTypeSigNames :: [LSig GhcRn] -> NameSet +-- Get the names that have a user type sig +getTypeSigNames sigs + = foldr get_type_sig emptyNameSet sigs + where + get_type_sig :: LSig GhcRn -> NameSet -> NameSet + get_type_sig sig ns = + case sig of + L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names) + L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names) + _ -> ns + + +{- Note [AFamDataCon: not promoting data family constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a + data instance T Int = MkT + data Proxy (a :: k) + data S = MkS (Proxy 'MkT) + +Is it ok to use the promoted data family instance constructor 'MkT' in +the data declaration for S (where both declarations live in the same module)? +No, we don't allow this. It *might* make sense, but at least it would mean that +we'd have to interleave typechecking instances and data types, whereas at +present we do data types *then* instances. + +So to check for this we put in the TcLclEnv a binding for all the family +constructors, bound to AFamDataCon, so that if we trip over 'MkT' when +type checking 'S' we'll produce a decent error message. + +#12088 describes this limitation. Of course, when MkT and S live in +different modules then all is well. + +Note [Don't promote pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never promote pattern synonyms. + +Consider this (#11265): + pattern A = True + instance Eq A +We want a civilised error message from the occurrence of 'A' +in the instance, yet 'A' really has not yet been type checked. + +Similarly (#9161) + {-# LANGUAGE PatternSynonyms, DataKinds #-} + pattern A = () + b :: A + b = undefined +Here, the type signature for b mentions A. But A is a pattern +synonym, which is typechecked as part of a group of bindings (for very +good reasons; a view pattern in the RHS may mention a value binding). +It is entirely reasonable to reject this, but to do so we need A to be +in the kind environment when kind-checking the signature for B. + +Hence tcAddPatSynPlaceholers adds a binding + A -> APromotionErr PatSynPE +to the environment. Then GHC.Tc.Gen.HsType.tcTyVar will find A in the kind +environment, and will give a 'wrongThingErr' as a result. But the +lookup of A won't fail. + + +************************************************************************ +* * +\subsection{Rules} +* * +************************************************************************ +-} + +tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a + -- Just pop the new rules into the EPS and envt resp + -- All the rules come from an interface file, not source + -- Nevertheless, some may be for this module, if we read + -- its interface instead of its source code +tcExtendRules lcl_rules thing_inside + = do { env <- getGblEnv + ; let + env' = env { tcg_rules = lcl_rules ++ tcg_rules env } + ; setGblEnv env' thing_inside } + +{- +************************************************************************ +* * + Meta level +* * +************************************************************************ +-} + +checkWellStaged :: SDoc -- What the stage check is for + -> ThLevel -- Binding level (increases inside brackets) + -> ThLevel -- Use stage + -> TcM () -- Fail if badly staged, adding an error +checkWellStaged pp_thing bind_lvl use_lvl + | use_lvl >= bind_lvl -- OK! Used later than bound + = return () -- E.g. \x -> [| $(f x) |] + + | bind_lvl == outerLevel -- GHC restriction on top level splices + = stageRestrictionError pp_thing + + | otherwise -- Badly staged + = failWithTc $ -- E.g. \x -> $(f x) + 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 $ + 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"])] + +topIdLvl :: Id -> ThLevel +-- Globals may either be imported, or may be from an earlier "chunk" +-- (separated by declaration splices) of this module. The former +-- *can* be used inside a top-level splice, but the latter cannot. +-- Hence we give the former impLevel, but the latter topLevel +-- E.g. this is bad: +-- x = [| foo |] +-- $( f x ) +-- By the time we are processing the $(f x), the binding for "x" +-- will be in the global env, not the local one. +topIdLvl id | isLocalId id = outerLevel + | otherwise = impLevel + +tcMetaTy :: Name -> TcM Type +-- Given the name of a Template Haskell data type, +-- return the type +-- E.g. given the name "Expr" return the type "Expr" +tcMetaTy tc_name = do + t <- tcLookupTyCon tc_name + return (mkTyConTy t) + +isBrackStage :: ThStage -> Bool +isBrackStage (Brack {}) = True +isBrackStage _other = False + +{- +************************************************************************ +* * + getDefaultTys +* * +************************************************************************ +-} + +tcGetDefaultTys :: TcM ([Type], -- Default types + (Bool, -- True <=> Use overloaded strings + Bool)) -- True <=> Use extended defaulting rules +tcGetDefaultTys + = do { dflags <- getDynFlags + ; let ovl_strings = xopt LangExt.OverloadedStrings dflags + extended_defaults = xopt LangExt.ExtendedDefaultRules dflags + -- See also #1974 + flags = (ovl_strings, extended_defaults) + + ; mb_defaults <- getDeclaredDefaultTys + ; case mb_defaults of { + Just tys -> return (tys, flags) ; + -- User-supplied defaults + Nothing -> do + + -- No use-supplied default + -- Use [Integer, Double], plus modifications + { integer_ty <- tcMetaTy integerTyConName + ; list_ty <- tcMetaTy listTyConName + ; checkWiredInTyCon doubleTyCon + ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty] + -- Note [Extended defaults] + ++ [integer_ty, doubleTy] + ++ opt_deflt ovl_strings [stringTy] + ; return (deflt_tys, flags) } } } + where + opt_deflt True xs = xs + opt_deflt False _ = [] + +{- +Note [Extended defaults] +~~~~~~~~~~~~~~~~~~~~~ +In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we +try when defaulting. This has very little real impact, except in the following case. +Consider: + Text.Printf.printf "hello" +This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't +want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to +default the 'a' to (), rather than to Integer (which is what would otherwise happen; +and then GHCi doesn't attempt to print the (). So in interactive mode, we add +() to the list of defaulting types. See #1200. + +Additionally, the list type [] is added as a default specialization for +Traversable and Foldable. As such the default default list now has types of +varying kinds, e.g. ([] :: * -> *) and (Integer :: *). + +************************************************************************ +* * +\subsection{The InstInfo type} +* * +************************************************************************ + +The InstInfo type summarises the information in an instance declaration + + instance c => k (t tvs) where b + +It is used just for *local* instance decls (not ones from interface files). +But local instance decls includes + - derived ones + - generic ones +as well as explicit user written ones. +-} + +data InstInfo a + = InstInfo + { iSpec :: ClsInst -- Includes the dfun id + , iBinds :: InstBindings a + } + +iDFunId :: InstInfo a -> DFunId +iDFunId info = instanceDFunId (iSpec info) + +data InstBindings a + = InstBindings + { ib_tyvars :: [Name] -- Names of the tyvars from the instance head + -- that are lexically in scope in the bindings + -- Must correspond 1-1 with the forall'd tyvars + -- of the dfun Id. When typechecking, we are + -- going to extend the typechecker's envt with + -- ib_tyvars -> dfun_forall_tyvars + + , ib_binds :: LHsBinds a -- Bindings for the instance methods + + , ib_pragmas :: [LSig a] -- User pragmas recorded for generating + -- specialised instances + + , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should + -- be enabled when type-checking + -- this instance; needed for + -- GeneralizedNewtypeDeriving + + , ib_derived :: Bool + -- True <=> This code was generated by GHC from a deriving clause + -- or standalone deriving declaration + -- Used only to improve error messages + } + +instance (OutputableBndrId a) + => Outputable (InstInfo (GhcPass a)) where + ppr = pprInstInfoDetails + +pprInstInfoDetails :: (OutputableBndrId a) + => InstInfo (GhcPass a) -> SDoc +pprInstInfoDetails info + = hang (pprInstanceHdr (iSpec info) <+> text "where") + 2 (details (iBinds info)) + where + details (InstBindings { ib_pragmas = p, ib_binds = b }) = + pprDeclList (pprLHsBindsForUser b p) + +simpleInstInfoClsTy :: InstInfo a -> (Class, Type) +simpleInstInfoClsTy info = case instanceHead (iSpec info) of + (_, cls, [ty]) -> (cls, ty) + _ -> panic "simpleInstInfoClsTy" + +simpleInstInfoTy :: InstInfo a -> Type +simpleInstInfoTy info = snd (simpleInstInfoClsTy info) + +simpleInstInfoTyCon :: InstInfo a -> TyCon + -- Gets the type constructor for a simple instance declaration, + -- i.e. one of the form instance (...) => C (T a b c) where ... +simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) + +-- | Make a name for the dict fun for an instance decl. It's an *external* +-- name, like other top-level names, and hence must be made with +-- newGlobalBinder. +newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name +newDFunName clas tys loc + = do { is_boot <- tcIsHsBootOrSig + ; mod <- getModule + ; let info_string = occNameString (getOccName clas) ++ + concatMap (occNameString.getDFunTyKey) tys + ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) + ; newGlobalBinder mod dfun_occ loc } + +newFamInstTyConName :: Located Name -> [Type] -> TcM Name +newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys] + +newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name +newFamInstAxiomName (L loc name) branches + = mk_fam_inst_name mkInstTyCoOcc loc name branches + +mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name +mk_fam_inst_name adaptOcc loc tc_name tyss + = do { mod <- getModule + ; let info_string = occNameString (getOccName tc_name) ++ + intercalate "|" ty_strings + ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string) + ; newGlobalBinder mod (adaptOcc occ) loc } + where + ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss + +{- +Stable names used for foreign exports and annotations. +For stable names, the name must be unique (see #1533). If the +same thing has several stable Ids based on it, the +top-level bindings generated must not have the same name. +Hence we create an External name (doesn't change), and we +append a Unique to the string right here. +-} + +mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId +mkStableIdFromString str sig_ty loc occ_wrapper = do + uniq <- newUnique + mod <- getModule + name <- mkWrapperName "stable" str + let occ = mkVarOccFS name :: OccName + gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name + id = mkExportedVanillaId gnm sig_ty :: Id + return id + +mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId +mkStableIdFromName nm = mkStableIdFromString (getOccString nm) + +mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m) + => String -> String -> m FastString +mkWrapperName what nameBase + = do dflags <- getDynFlags + thisMod <- getModule + let -- Note [Generating fresh names for ccall wrapper] + wrapperRef = nextWrapperNum dflags + pkg = unitString (moduleUnit thisMod) + mod = moduleNameString (moduleName thisMod) + wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env -> + let num = lookupWithDefaultModuleEnv mod_env 0 thisMod + mod_env' = extendModuleEnv mod_env thisMod (num+1) + in (mod_env', num) + let components = [what, show wrapperNum, pkg, mod, nameBase] + return $ mkFastString $ zEncodeString $ intercalate ":" components + +{- +Note [Generating fresh names for FFI wrappers] + +We used to use a unique, rather than nextWrapperNum, to distinguish +between FFI wrapper functions. However, the wrapper names that we +generate are external names. This means that if a call to them ends up +in an unfolding, then we can't alpha-rename them, and thus if the +unique randomly changes from one compile to another then we get a +spurious ABI change (#4012). + +The wrapper counter has to be per-module, not global, so that the number we end +up using is not dependent on the modules compiled before the current one. +-} + +{- +************************************************************************ +* * +\subsection{Errors} +* * +************************************************************************ +-} + +pprBinders :: [Name] -> SDoc +-- Used in error messages +-- Use quotes for a single one; they look a bit "busy" for several +pprBinders [bndr] = quotes (ppr bndr) +pprBinders bndrs = pprWithCommas ppr bndrs + +notFound :: Name -> TcM TyThing +notFound name + = do { lcl_env <- getLclEnv + ; let stage = tcl_th_ctxt 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)) + _ -> failWithTc $ + 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)] + -- 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; + -- so let's just not print it! Getting a loop here is + -- very unhelpful, because it hides one compiler bug with another + } + +wrongThingErr :: String -> TcTyThing -> Name -> TcM a +-- It's important that this only calls pprTcTyThingCategory, which in +-- turn does not look at the details of the TcTyThing. +-- See Note [Placeholder PatSyn kinds] in GHC.Tc.Gen.Bind +wrongThingErr expected thing name + = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> + text "used as a" <+> text expected) + +{- Note [Out of scope might be a staging error] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + x = 3 + data T = MkT $(foo x) + +where 'foo' is imported from somewhere. + +This is really a staging error, because we can't run code involving 'x'. +But in fact the type checker processes types first, so 'x' won't even be +in the type envt when we look for it in $(foo x). So inside splices we +report something missing from the type env as a staging error. +See #5752 and #5795. +-} diff --git a/compiler/GHC/Tc/Utils/Env.hs-boot b/compiler/GHC/Tc/Utils/Env.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Utils/Env.hs-boot @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -0,0 +1,851 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, MultiWayIf, TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | The @Inst@ type: dictionaries or method instances +module GHC.Tc.Utils.Instantiate ( + deeplySkolemise, + topInstantiate, topInstantiateInferred, deeplyInstantiate, + instCall, instDFunType, instStupidTheta, instTyVarsWith, + newWanted, newWanteds, + + tcInstInvisibleTyBinders, tcInstInvisibleTyBinder, + + newOverloadedLit, mkOverLit, + + newClsInst, + tcGetInsts, tcGetInstEnvs, getOverlapFlag, + tcExtendLocalInstEnv, + instCallConstraints, newMethodFromName, + tcSyntaxName, + + -- Simple functions over evidence variables + tyCoVarsOfWC, + tyCoVarsOfCt, tyCoVarsOfCts, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckExpr, tcSyntaxOp ) +import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType, unifyKind ) + +import GHC.Types.Basic ( IntegralLit(..), SourceText(..) ) +import GHC.Data.FastString +import GHC.Hs +import GHC.Tc.Utils.Zonk +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Evidence +import GHC.Core.InstEnv +import GHC.Builtin.Types ( heqDataCon, eqDataCon ) +import GHC.Core ( isOrphan ) +import GHC.Tc.Instance.FunDeps +import GHC.Tc.Utils.TcMType +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr ( debugPprType ) +import GHC.Tc.Utils.TcType +import GHC.Driver.Types +import GHC.Core.Class( Class ) +import GHC.Types.Id.Make( mkDictFunId ) +import GHC.Core( Expr(..) ) -- For the Coercion constructor +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Var ( EvVar, tyVarName, VarBndr(..) ) +import GHC.Core.DataCon +import GHC.Types.Var.Env +import GHC.Builtin.Names +import GHC.Types.SrcLoc as SrcLoc +import GHC.Driver.Session +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Types.Basic ( TypeOrKind(..) ) +import qualified GHC.LanguageExtensions as LangExt + +import Data.List ( sortBy ) +import Control.Monad( unless ) +import Data.Function ( on ) + +{- +************************************************************************ +* * + Creating and emittind constraints +* * +************************************************************************ +-} + +newMethodFromName + :: CtOrigin -- ^ why do we need this? + -> Name -- ^ name of the method + -> [TcRhoType] -- ^ types with which to instantiate the class + -> TcM (HsExpr GhcTcId) +-- ^ Used when 'Name' is the wired-in name for a wired-in class method, +-- so the caller knows its type for sure, which should be of form +-- +-- > forall a. C a => +-- +-- 'newMethodFromName' is supposed to instantiate just the outer +-- type variable and constraint + +newMethodFromName origin name ty_args + = do { id <- tcLookupId name + -- Use tcLookupId not tcLookupGlobalId; the method is almost + -- always a class op, but with -XRebindableSyntax GHC is + -- meant to find whatever thing is in scope, and that may + -- be an ordinary function. + + ; let ty = piResultTys (idType id) ty_args + (theta, _caller_knows_this) = tcSplitPhiTy ty + ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) + instCall origin ty_args theta + + ; return (mkHsWrap wrap (HsVar noExtField (noLoc id))) } + +{- +************************************************************************ +* * + Deep instantiation and skolemisation +* * +************************************************************************ + +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 +-} + +deeplySkolemise :: TcSigmaType + -> TcM ( HsWrapper + , [(Name,TyVar)] -- All skolemised variables + , [EvVar] -- All "given"s + , TcRhoType ) + +deeplySkolemise ty + = go init_subst ty + where + init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) + + go subst ty + | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty + = do { let arg_tys' = substTys subst arg_tys + ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys' + ; (subst', tvs1) <- tcInstSkolTyVarsX 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 ( mkWpLams ids1 + <.> mkWpTyLams tvs1 + <.> mkWpLams ev_vars1 + <.> wrap + <.> mkWpEvVarApps ids1 + , tv_prs1 ++ tvs_prs2 + , ev_vars1 ++ ev_vars2 + , mkVisFunTys arg_tys' rho ) } + + | otherwise + = return (idHsWrapper, [], [], substTy subst ty) + -- substTy is a quick no-op on an empty substitution + +-- | Instantiate all outer type variables +-- and any context. Never looks through arrows. +topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) +-- if topInstantiate ty = (wrap, rho) +-- and e :: ty +-- then wrap e :: rho (that is, wrap :: ty "->" rho) +topInstantiate = top_instantiate True + +-- | Instantiate all outer 'Inferred' binders +-- and any context. Never looks through arrows or specified type variables. +-- Used for visible type application. +topInstantiateInferred :: CtOrigin -> TcSigmaType + -> TcM (HsWrapper, TcSigmaType) +-- if topInstantiate ty = (wrap, rho) +-- and e :: ty +-- then wrap e :: rho +topInstantiateInferred = top_instantiate False + +top_instantiate :: Bool -- True <=> instantiate *all* variables + -- False <=> instantiate only the inferred ones + -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) +top_instantiate inst_all orig ty + | not (null binders && null theta) + = do { let (inst_bndrs, leave_bndrs) = span should_inst binders + (inst_theta, leave_theta) + | null leave_bndrs = (theta, []) + | otherwise = ([], theta) + in_scope = mkInScopeSet (tyCoVarsOfType ty) + empty_subst = mkEmptyTCvSubst in_scope + inst_tvs = binderVars inst_bndrs + ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs + ; let inst_theta' = substTheta subst inst_theta + sigma' = substTy subst (mkForAllTys leave_bndrs $ + mkPhiTy leave_theta rho) + inst_tv_tys' = mkTyVarTys inst_tvs' + + ; wrap1 <- instCall orig inst_tv_tys' inst_theta' + ; traceTc "Instantiating" + (vcat [ text "all tyvars?" <+> ppr inst_all + , text "origin" <+> pprCtOrigin orig + , text "type" <+> debugPprType ty + , text "theta" <+> ppr theta + , text "leave_bndrs" <+> ppr leave_bndrs + , text "with" <+> vcat (map debugPprType inst_tv_tys') + , text "theta:" <+> ppr inst_theta' ]) + + ; (wrap2, rho2) <- + if null leave_bndrs + + -- account for types like forall a. Num a => forall b. Ord b => ... + then top_instantiate inst_all orig sigma' + + -- but don't loop if there were any un-inst'able tyvars + else return (idHsWrapper, sigma') + + ; return (wrap2 <.> wrap1, rho2) } + + | otherwise = return (idHsWrapper, ty) + where + (binders, phi) = tcSplitForAllVarBndrs ty + (theta, rho) = tcSplitPhiTy phi + + should_inst bndr + | inst_all = True + | otherwise = binderArgFlag bndr == Inferred + +deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) +-- Int -> forall a. a -> a ==> (\x:Int. [] x alpha) :: Int -> alpha +-- In general if +-- if deeplyInstantiate ty = (wrap, rho) +-- and e :: ty +-- then wrap e :: rho +-- That is, wrap :: ty ~> rho +-- +-- If you don't need the HsWrapper returned from this function, consider +-- using tcSplitNestedSigmaTys in GHC.Tc.Utils.TcType, which is a pure alternative that +-- only computes the returned TcRhoType. + +deeplyInstantiate orig ty = + deeply_instantiate orig + (mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))) + ty + +deeply_instantiate :: CtOrigin + -> TCvSubst + -> TcSigmaType -> TcM (HsWrapper, TcRhoType) +-- Internal function to deeply instantiate that builds on an existing subst. +-- It extends the input substitution and applies the final substitution to +-- the types on return. See #12549. + +deeply_instantiate orig subst ty + | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty + = do { (subst', tvs') <- newMetaTyVarsX subst tvs + ; let arg_tys' = substTys subst' arg_tys + theta' = substTheta subst' theta + ; ids1 <- newSysLocalIds (fsLit "di") arg_tys' + ; wrap1 <- instCall orig (mkTyVarTys tvs') theta' + ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig + , text "type" <+> ppr ty + , text "with" <+> ppr tvs' + , text "args:" <+> ppr ids1 + , text "theta:" <+> ppr theta' + , text "subst:" <+> ppr subst']) + ; (wrap2, rho2) <- deeply_instantiate orig subst' rho + ; return (mkWpLams ids1 + <.> wrap2 + <.> wrap1 + <.> mkWpEvVarApps ids1, + mkVisFunTys arg_tys' rho2) } + + | otherwise + = do { let ty' = substTy subst ty + ; traceTc "deeply_instantiate final subst" + (vcat [ text "origin:" <+> pprCtOrigin orig + , text "type:" <+> ppr ty + , text "new type:" <+> ppr ty' + , text "subst:" <+> ppr subst ]) + ; return (idHsWrapper, ty') } + + +instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst +-- Use this when you want to instantiate (forall a b c. ty) with +-- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might +-- not yet match (perhaps because there are unsolved constraints; #14154) +-- If they don't match, emit a kind-equality to promise that they will +-- eventually do so, and thus make a kind-homongeneous substitution. +instTyVarsWith orig tvs tys + = go emptyTCvSubst tvs tys + where + go subst [] [] + = return subst + go subst (tv:tvs) (ty:tys) + | tv_kind `tcEqType` ty_kind + = go (extendTvSubstAndInScope subst tv ty) tvs tys + | otherwise + = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind + ; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys } + where + tv_kind = substTy subst (tyVarKind tv) + ty_kind = tcTypeKind ty + + go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys) + + +{- +************************************************************************ +* * + Instantiating a call +* * +************************************************************************ + +Note [Handling boxed equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The solver deals entirely in terms of unboxed (primitive) equality. +There should never be a boxed Wanted equality. Ever. But, what if +we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality +is boxed, so naive treatment here would emit a boxed Wanted equality. + +So we simply check for this case and make the right boxing of evidence. + +-} + +---------------- +instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper +-- Instantiate the constraints of a call +-- (instCall o tys theta) +-- (a) Makes fresh dictionaries as necessary for the constraints (theta) +-- (b) Throws these dictionaries into the LIE +-- (c) Returns an HsWrapper ([.] tys dicts) + +instCall orig tys theta + = do { dict_app <- instCallConstraints orig theta + ; return (dict_app <.> mkWpTyApps tys) } + +---------------- +instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper +-- Instantiates the TcTheta, puts all constraints thereby generated +-- into the LIE, and returns a HsWrapper to enclose the call site. + +instCallConstraints orig preds + | null preds + = return idHsWrapper + | otherwise + = do { evs <- mapM go preds + ; traceTc "instCallConstraints" (ppr evs) + ; return (mkWpEvApps evs) } + where + go :: TcPredType -> TcM EvTerm + go pred + | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1 + = do { co <- unifyType Nothing ty1 ty2 + ; return (evCoercion co) } + + -- Try short-cut #2 + | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred + , tc `hasKey` heqTyConKey + = do { co <- unifyType Nothing ty1 ty2 + ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) } + + | otherwise + = emitWanted orig pred + +instDFunType :: DFunId -> [DFunInstType] + -> TcM ( [TcType] -- instantiated argument types + , TcThetaType ) -- instantiated constraint +-- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv +instDFunType dfun_id dfun_inst_tys + = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys + ; return (inst_tys, substTheta subst dfun_theta) } + where + dfun_ty = idType dfun_id + (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty + empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty)) + -- With quantified constraints, the + -- type of a dfun may not be closed + + go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType]) + go subst [] [] = return (subst, []) + go subst (tv:tvs) (Just ty : mb_tys) + = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty) + tvs + mb_tys + ; return (subst', ty : tys) } + go subst (tv:tvs) (Nothing : mb_tys) + = do { (subst', tv') <- newMetaTyVarX subst tv + ; (subst'', tys) <- go subst' tvs mb_tys + ; return (subst'', mkTyVarTy tv' : tys) } + go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys) + +---------------- +instStupidTheta :: CtOrigin -> TcThetaType -> TcM () +-- Similar to instCall, but only emit the constraints in the LIE +-- Used exclusively for the 'stupid theta' of a data constructor +instStupidTheta orig theta + = do { _co <- instCallConstraints orig theta -- Discard the coercion + ; return () } + + +{- ********************************************************************* +* * + Instantiating Kinds +* * +********************************************************************* -} + +-- | Instantiates up to n invisible binders +-- Returns the instantiating types, and body kind +tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind) + +tcInstInvisibleTyBinders 0 kind + = return ([], kind) +tcInstInvisibleTyBinders n ty + = go n empty_subst ty + where + empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) + + go n subst kind + | n > 0 + , Just (bndr, body) <- tcSplitPiTy_maybe kind + , isInvisibleBinder bndr + = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr + ; (args, inner_ty) <- go (n-1) subst' body + ; return (arg:args, inner_ty) } + | otherwise + = return ([], substTy subst kind) + +-- | Used only in *types* +tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType) +tcInstInvisibleTyBinder subst (Named (Bndr tv _)) + = do { (subst', tv') <- newMetaTyVarX subst tv + ; return (subst', mkTyVarTy tv') } + +tcInstInvisibleTyBinder subst (Anon af ty) + | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty) + -- Equality is the *only* constraint currently handled in types. + -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep + = ASSERT( af == InvisArg ) + do { co <- unifyKind Nothing k1 k2 + ; arg' <- mk co + ; return (subst, arg') } + + | 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 -> TcM Type + -- given a coercion proving t1 ~# t2, produce the + -- right instantiation for the TyBinder 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 (\co -> mkHEqBoxTy co k1 k2, k1, k2) + + -- Lifted homogeneous equality (~) + | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty + , tc `hasKey` eqTyConKey + = Just (\co -> mkEqBoxTy co k1 k2, k1, k2) + + | otherwise + = Nothing + +-- | This takes @a ~# b@ and returns @a ~~ b@. +mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type +-- monadic just for convenience with mkEqBoxTy +mkHEqBoxTy co ty1 ty2 + = return $ + mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co] + where k1 = tcTypeKind ty1 + k2 = tcTypeKind ty2 + +-- | This takes @a ~# b@ and returns @a ~ b@. +mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type +mkEqBoxTy co ty1 ty2 + = return $ + mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co] + where k = tcTypeKind ty1 + +{- +************************************************************************ +* * + Literals +* * +************************************************************************ + +-} + +{- +In newOverloadedLit we convert directly to an Int or Integer if we +know that's what we want. This may save some time, by not +temporarily generating overloaded literals, but it won't catch all +cases (the rest are caught in lookupInst). + +-} + +newOverloadedLit :: HsOverLit GhcRn + -> ExpRhoType + -> TcM (HsOverLit GhcTcId) +newOverloadedLit + lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty + | not rebindable + -- all built-in overloaded lits are tau-types, so we can just + -- tauify the ExpType + = do { res_ty <- expTypeToType res_ty + ; dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; case shortCutLit platform val res_ty of + -- Do not generate a LitInst for rebindable syntax. + -- Reason: If we do, tcSimplify will call lookupInst, which + -- will call tcSyntaxName, which does unification, + -- which tcSimplify doesn't like + Just expr -> return (lit { ol_witness = expr + , ol_ext = OverLitTc False res_ty }) + Nothing -> newNonTrivialOverloadedLit orig lit + (mkCheckExpType res_ty) } + + | otherwise + = newNonTrivialOverloadedLit orig lit res_ty + where + orig = LiteralOrigin lit + +-- Does not handle things that 'shortCutLit' can handle. See also +-- newOverloadedLit in GHC.Tc.Utils.Unify +newNonTrivialOverloadedLit :: CtOrigin + -> HsOverLit GhcRn + -> ExpRhoType + -> TcM (HsOverLit GhcTcId) +newNonTrivialOverloadedLit orig + lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name) + , ol_ext = rebindable }) res_ty + = do { hs_lit <- mkOverLit val + ; let lit_ty = hsLitType hs_lit + ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name) + [synKnownType lit_ty] res_ty $ + \_ -> return () + ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit] + ; res_ty <- readExpType res_ty + ; return (lit { ol_witness = witness + , ol_ext = OverLitTc rebindable res_ty }) } +newNonTrivialOverloadedLit _ lit _ + = pprPanic "newNonTrivialOverloadedLit" (ppr lit) + +------------ +mkOverLit ::OverLitVal -> TcM (HsLit GhcTc) +mkOverLit (HsIntegral i) + = do { integer_ty <- tcMetaTy integerTyConName + ; return (HsInteger (il_text i) + (il_value i) integer_ty) } + +mkOverLit (HsFractional r) + = do { rat_ty <- tcMetaTy rationalTyConName + ; return (HsRat noExtField r rat_ty) } + +mkOverLit (HsIsString src s) = return (HsString src s) + +{- +************************************************************************ +* * + Re-mappable syntax + + Used only for arrow syntax -- find a way to nuke this +* * +************************************************************************ + +Suppose we are doing the -XRebindableSyntax thing, and we encounter +a do-expression. We have to find (>>) in the current environment, which is +done by the rename. Then we have to check that it has the same type as +Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had +this: + + (>>) :: HB m n mn => m a -> n b -> mn b + +So the idea is to generate a local binding for (>>), thus: + + let then72 :: forall a b. m a -> m b -> m b + then72 = ...something involving the user's (>>)... + in + ...the do-expression... + +Now the do-expression can proceed using then72, which has exactly +the expected type. + +In fact tcSyntaxName just generates the RHS for then72, because we only +want an actual binding in the do-expression case. For literals, we can +just use the expression inline. +-} + +tcSyntaxName :: CtOrigin + -> TcType -- ^ Type to instantiate it at + -> (Name, HsExpr GhcRn) -- ^ (Standard name, user name) + -> TcM (Name, HsExpr GhcTcId) + -- ^ (Standard name, suitable expression) +-- USED ONLY FOR CmdTop (sigh) *** +-- See Note [CmdSyntaxTable] in GHC.Hs.Expr + +tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm)) + | std_nm == user_nm + = do rhs <- newMethodFromName orig std_nm [ty] + return (std_nm, rhs) + +tcSyntaxName orig ty (std_nm, user_nm_expr) = do + std_id <- tcLookupId std_nm + let + -- C.f. newMethodAtLoc + ([tv], _, tau) = tcSplitSigmaTy (idType std_id) + sigma1 = substTyWith [tv] [ty] tau + -- Actually, the "tau-type" might be a sigma-type in the + -- case of locally-polymorphic methods. + + addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do + + -- Check that the user-supplied thing has the + -- same type as the standard one. + -- Tiresome jiggling because tcCheckSigma takes a located expression + span <- getSrcSpanM + expr <- tcCheckExpr (L span user_nm_expr) sigma1 + return (std_nm, unLoc expr) + +syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv + -> TcRn (TidyEnv, SDoc) +syntaxNameCtxt name orig ty tidy_env + = do { inst_loc <- getCtLocM orig (Just TypeLevel) + ; let msg = vcat [ text "When checking that" <+> quotes (ppr name) + <+> text "(needed by a syntactic construct)" + , nest 2 (text "has the required type:" + <+> ppr (tidyType tidy_env ty)) + , nest 2 (pprCtLoc inst_loc) ] + ; return (tidy_env, msg) } + +{- +************************************************************************ +* * + Instances +* * +************************************************************************ +-} + +getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag +-- Construct the OverlapFlag from the global module flags, +-- but if the overlap_mode argument is (Just m), +-- set the OverlapMode to 'm' +getOverlapFlag overlap_mode + = do { dflags <- getDynFlags + ; let overlap_ok = xopt LangExt.OverlappingInstances dflags + incoherent_ok = xopt LangExt.IncoherentInstances 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 + ; return final_oflag } + +tcGetInsts :: TcM [ClsInst] +-- Gets the local class instances. +tcGetInsts = fmap tcg_insts getGblEnv + +newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType + -> Class -> [Type] -> TcM ClsInst +newClsInst overlap_mode dfun_name tvs theta clas tys + = do { (subst, tvs') <- freshenTyVarBndrs tvs + -- Be sure to freshen those type variables, + -- so they are sure not to appear in any lookup + ; let tys' = substTys subst tys + + dfun = mkDictFunId dfun_name tvs theta clas tys + -- The dfun uses the original 'tvs' because + -- (a) they don't need to be fresh + -- (b) they may be mentioned in the ib_binds field of + -- an InstInfo, and in GHC.Tc.Utils.Env.pprInstInfoDetails it's + -- helpful to use the same names + + ; oflag <- getOverlapFlag overlap_mode + ; let inst = mkLocalInstance dfun oflag tvs' clas tys' + ; warnIfFlag Opt_WarnOrphans + (isOrphan (is_orphan inst)) + (instOrphWarn inst) + ; return inst } + +instOrphWarn :: ClsInst -> SDoc +instOrphWarn inst + = hang (text "Orphan instance:") 2 (pprInstanceHdr inst) + $$ text "To avoid this" + $$ nest 4 (vcat possibilities) + where + possibilities = + text "move the instance declaration to the module of the class or of the type, or" : + text "wrap the type with a newtype and declare the instance on the new type." : + [] + +tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a + -- Add new locally-defined instances +tcExtendLocalInstEnv dfuns thing_inside + = do { traceDFuns dfuns + ; env <- getGblEnv + ; (inst_env', cls_insts') <- foldlM addLocalInst + (tcg_inst_env env, tcg_insts env) + dfuns + ; let env' = env { tcg_insts = cls_insts' + , tcg_inst_env = inst_env' } + ; setGblEnv env' thing_inside } + +addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst]) +-- Check that the proposed new instance is OK, +-- and then add it to the home inst env +-- If overwrite_inst, then we can overwrite a direct match +addLocalInst (home_ie, my_insts) ispec + = do { + -- Load imported instances, so that we report + -- duplicates correctly + + -- 'matches' are existing instance declarations that are less + -- specific than the new one + -- 'dups' are those 'matches' that are equal to the new one + ; isGHCi <- getIsGHCi + ; eps <- getEps + ; tcg_env <- getGblEnv + + -- In GHCi, we *override* any identical instances + -- that are also defined in the interactive context + -- See Note [Override identical instances in GHCi] + ; let home_ie' + | isGHCi = deleteFromInstEnv home_ie ispec + | otherwise = home_ie + + global_ie = eps_inst_env eps + inst_envs = InstEnvs { ie_global = global_ie + , ie_local = home_ie' + , ie_visible = tcVisibleOrphanMods tcg_env } + + -- Check for inconsistent functional dependencies + ; let inconsistent_ispecs = checkFunDeps inst_envs ispec + ; unless (null inconsistent_ispecs) $ + funDepErr ispec inconsistent_ispecs + + -- Check for duplicate instance decls. + ; let (_tvs, cls, tys) = instanceHead ispec + (matches, _, _) = lookupInstEnv False inst_envs cls tys + dups = filter (identicalClsInstHead ispec) (map fst matches) + ; unless (null dups) $ + dupInstErr ispec (head dups) + + ; return (extendInstEnv home_ie' ispec, ispec : my_insts) } + +{- +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 +the file (this is because the signatures go in the EPS and we +can't filter them out easily.) This is also why we cannot +place the instance in the hi file: it would show up as a duplicate, +and we don't have instance reexports anyway. + +However, you might find them useful when typechecking against +a signature: the instance is a way of indicating to GHC that +some instance exists, in case downstream code uses it. + +Implementing this is a little tricky. Consider the following +situation (sigof03): + + module A where + instance C T where ... + + module ASig where + instance C T + +When compiling ASig, A.hi is loaded, which brings its instances +into the EPS. When we process the instance declaration in ASig, +we should ignore it for the purpose of doing a duplicate check, +since it's not actually a duplicate. But don't skip the check +entirely, we still want this to fail (tcfail221): + + module ASig where + instance C T + instance C T + +Note that in some situations, the interface containing the type +class instances may not have been loaded yet at all. The usual +situation when A imports another module which provides the +instances (sigof02m): + + module A(module B) where + import B + +See also Note [Signature lazy interface loading]. We can't +rely on this, however, since sometimes we'll have spurious +type class instances in the EPS, see #9422 (sigof02dm) + +************************************************************************ +* * + Errors and tracing +* * +************************************************************************ +-} + +traceDFuns :: [ClsInst] -> TcRn () +traceDFuns ispecs + = traceTc "Adding instances:" (vcat (map pp ispecs)) + where + pp ispec = hang (ppr (instanceDFunId ispec) <+> colon) + 2 (ppr ispec) + -- Print the dfun name itself too + +funDepErr :: ClsInst -> [ClsInst] -> TcRn () +funDepErr ispec ispecs + = addClsInstsErr (text "Functional dependencies conflict between instance declarations:") + (ispec : ispecs) + +dupInstErr :: ClsInst -> ClsInst -> TcRn () +dupInstErr ispec dup_ispec + = addClsInstsErr (text "Duplicate instance declarations:") + [ispec, dup_ispec] + +addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () +addClsInstsErr herald ispecs + = setSrcSpan (getSrcSpan (head sorted)) $ + addErr (hang herald 2 (pprInstances sorted)) + where + sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs + -- The sortBy just arranges that instances are displayed in order + -- of source location, which reduced wobbling in error messages, + -- and is better for users diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -0,0 +1,1997 @@ +{- +(c) The University of Glasgow 2006 + +-} + +{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE ViewPatterns #-} + + +-- | Functions for working with the typechecker environment (setters, +-- getters...). +module GHC.Tc.Utils.Monad( + -- * Initialisation + initTc, initTcWithGbl, initTcInteractive, initTcRnIf, + + -- * Simple accessors + discardResult, + getTopEnv, updTopEnv, getGblEnv, updGblEnv, + setGblEnv, getLclEnv, updLclEnv, setLclEnv, + getEnvs, setEnvs, + xoptM, doptM, goptM, woptM, + setXOptM, unsetXOptM, unsetGOptM, unsetWOptM, + whenDOptM, whenGOptM, whenWOptM, + whenXOptM, unlessXOptM, + getGhcMode, + withDoDynamicToo, + getEpsVar, + getEps, + updateEps, updateEps_, + getHpt, getEpsAndHpt, + + -- * Arrow scopes + newArrowScope, escapeArrowScope, + + -- * Unique supply + newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName, + newSysName, newSysLocalId, newSysLocalIds, + + -- * Accessing input/output + newTcRef, readTcRef, writeTcRef, updTcRef, + + -- * Debugging + traceTc, traceRn, traceOptTcRn, dumpOptTcRn, + dumpTcRn, + getPrintUnqualified, + printForUserTcRn, + traceIf, traceHiDiffs, traceOptIf, + debugTc, + + -- * Typechecker global environment + getIsGHCi, getGHCiMonad, getInteractivePrintName, + tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv, + getRdrEnvs, getImports, + getFixityEnv, extendFixityEnv, getRecFieldEnv, + getDeclaredDefaultTys, + addDependentFiles, + + -- * Error management + getSrcSpanM, setSrcSpan, addLocM, + wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_, + getErrsVar, setErrsVar, + addErr, + failWith, failAt, + addErrAt, addErrs, + checkErr, + addMessages, + discardWarnings, + + -- * Shared error message stuff: renamer and typechecker + mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError, + reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, + attemptM, tryTc, + askNoErrs, discardErrs, tryTcDiscardingErrs, + checkNoErrs, whenNoErrs, + ifErrsM, failIfErrsM, + + -- * Context management for the type checker + getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, + addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM, + + -- * Error message generation (type checker) + addErrTc, addErrsTc, + addErrTcM, mkErrTcM, mkErrTc, + failWithTc, failWithTcM, + checkTc, checkTcM, + failIfTc, failIfTcM, + warnIfFlag, warnIf, warnTc, warnTcM, + addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn, + mkErrInfo, + + -- * Type constraints + newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar, + addTcEvBind, addTopEvBinds, + getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, + chooseUniqueOccTc, + getConstraintVar, setConstraintVar, + emitConstraints, emitStaticConstraints, emitSimple, emitSimples, + emitImplication, emitImplications, emitInsoluble, + discardConstraints, captureConstraints, tryCaptureConstraints, + pushLevelAndCaptureConstraints, + pushTcLevelM_, pushTcLevelM, pushTcLevelsM, + getTcLevel, setTcLevel, isTouchableTcM, + getLclTypeEnv, setLclTypeEnv, + traceTcConstraints, + emitNamedWildCardHoleConstraints, emitAnonWildCardHoleConstraint, + + -- * Template Haskell context + recordThUse, recordThSpliceUse, + keepAlive, getStage, getStageAndBindLevel, setStage, + addModFinalizersWithLclEnv, + + -- * Safe Haskell context + recordUnsafeInfer, finalSafeMode, fixSafeInstances, + + -- * Stuff for the renamer's local env + getLocalRdrEnv, setLocalRdrEnv, + + -- * Stuff for interface decls + mkIfLclEnv, + initIfaceTcRn, + initIfaceCheck, + initIfaceLcl, + initIfaceLclWithSubst, + initIfaceLoad, + getIfModule, + failIfM, + forkM_maybe, + forkM, + setImplicitEnvM, + + withException, + + -- * Stuff for cost centres. + ContainsCostCentreState(..), getCCIndexM, + + -- * Types etc. + module GHC.Tc.Types, + module GHC.Data.IOEnv + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Types -- Re-export all +import GHC.Data.IOEnv -- Re-export all +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin + +import GHC.Hs hiding (LIE) +import GHC.Driver.Types +import GHC.Unit +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Core.Type + +import GHC.Tc.Utils.TcType +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Builtin.Names + +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Utils.Error +import GHC.Types.SrcLoc +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Data.Bag +import GHC.Utils.Outputable as Outputable +import GHC.Types.Unique.Supply +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Types.Annotations +import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) ) +import GHC.Data.Maybe +import GHC.Types.CostCentre.State + +import qualified GHC.LanguageExtensions as LangExt + +import Data.IORef +import Control.Monad + +import {-# SOURCE #-} GHC.Tc.Utils.Env ( tcInitTidyEnv ) + +import qualified Data.Map as Map + +{- +************************************************************************ +* * + initTc +* * +************************************************************************ +-} + +-- | Setup the initial typechecking environment +initTc :: HscEnv + -> HscSource + -> Bool -- True <=> retain renamed syntax trees + -> Module + -> RealSrcSpan + -> TcM r + -> IO (Messages, Maybe r) + -- Nothing => error thrown by the thing inside + -- (error messages should have been printed already) + +initTc hsc_env hsc_src keep_rn_syntax mod loc do_this + = do { keep_var <- newIORef emptyNameSet ; + used_gre_var <- newIORef [] ; + th_var <- newIORef False ; + th_splice_var<- newIORef False ; + infer_var <- newIORef (True, emptyBag) ; + dfun_n_var <- newIORef emptyOccSet ; + type_env_var <- case hsc_type_env_var hsc_env of { + Just (_mod, te_var) -> return te_var ; + Nothing -> newIORef emptyNameEnv } ; + + dependent_files_var <- newIORef [] ; + static_wc_var <- newIORef emptyWC ; + cc_st_var <- newIORef newCostCentreState ; + th_topdecls_var <- newIORef [] ; + th_foreign_files_var <- newIORef [] ; + th_topnames_var <- newIORef emptyNameSet ; + th_modfinalizers_var <- newIORef [] ; + th_coreplugins_var <- newIORef [] ; + th_state_var <- newIORef Map.empty ; + th_remote_state_var <- newIORef Nothing ; + let { + dflags = hsc_dflags hsc_env ; + + maybe_rn_syntax :: forall a. a -> Maybe a ; + maybe_rn_syntax empty_val + | dopt Opt_D_dump_rn_ast dflags = Just empty_val + + | gopt Opt_WriteHie dflags = Just empty_val + + -- We want to serialize the documentation in the .hi-files, + -- and need to extract it from the renamed syntax first. + -- See 'GHC.HsToCore.Docs.extractDocs'. + | gopt Opt_Haddock dflags = Just empty_val + + | keep_rn_syntax = Just empty_val + | otherwise = Nothing ; + + gbl_env = TcGblEnv { + tcg_th_topdecls = th_topdecls_var, + tcg_th_foreign_files = th_foreign_files_var, + tcg_th_topnames = th_topnames_var, + tcg_th_modfinalizers = th_modfinalizers_var, + tcg_th_coreplugins = th_coreplugins_var, + tcg_th_state = th_state_var, + tcg_th_remote_state = th_remote_state_var, + + tcg_mod = mod, + tcg_semantic_mod = + canonicalizeModuleIfHome dflags mod, + tcg_src = hsc_src, + tcg_rdr_env = emptyGlobalRdrEnv, + tcg_fix_env = emptyNameEnv, + tcg_field_env = emptyNameEnv, + tcg_default = if moduleUnit mod == primUnitId + then Just [] -- See Note [Default types] + else Nothing, + tcg_type_env = emptyNameEnv, + tcg_type_env_var = type_env_var, + tcg_inst_env = emptyInstEnv, + tcg_fam_inst_env = emptyFamInstEnv, + tcg_ann_env = emptyAnnEnv, + tcg_th_used = th_var, + tcg_th_splice_used = th_splice_var, + tcg_exports = [], + tcg_imports = emptyImportAvails, + tcg_used_gres = used_gre_var, + tcg_dus = emptyDUs, + + tcg_rn_imports = [], + tcg_rn_exports = + if hsc_src == HsigFile + -- Always retain renamed syntax, so that we can give + -- better errors. (TODO: how?) + then Just [] + else maybe_rn_syntax [], + tcg_rn_decls = maybe_rn_syntax emptyRnGroup, + tcg_tr_module = Nothing, + tcg_binds = emptyLHsBinds, + tcg_imp_specs = [], + tcg_sigs = emptyNameSet, + tcg_ev_binds = emptyBag, + tcg_warns = NoWarnings, + tcg_anns = [], + tcg_tcs = [], + tcg_insts = [], + tcg_fam_insts = [], + tcg_rules = [], + tcg_fords = [], + tcg_patsyns = [], + tcg_merged = [], + tcg_dfun_n = dfun_n_var, + tcg_keep = keep_var, + tcg_doc_hdr = Nothing, + tcg_hpc = False, + tcg_main = Nothing, + tcg_self_boot = NoSelfBoot, + tcg_safeInfer = infer_var, + tcg_dependent_files = dependent_files_var, + tcg_tc_plugins = [], + tcg_hf_plugins = [], + tcg_top_loc = loc, + tcg_static_wc = static_wc_var, + tcg_complete_matches = [], + tcg_cc_st = cc_st_var + } ; + } ; + + -- OK, here's the business end! + initTcWithGbl hsc_env gbl_env loc do_this + } + +-- | Run a 'TcM' action in the context of an existing 'GblEnv'. +initTcWithGbl :: HscEnv + -> TcGblEnv + -> RealSrcSpan + -> TcM r + -> IO (Messages, Maybe r) +initTcWithGbl hsc_env gbl_env loc do_this + = do { lie_var <- newIORef emptyWC + ; errs_var <- newIORef (emptyBag, emptyBag) + ; let lcl_env = TcLclEnv { + tcl_errs = errs_var, + tcl_loc = loc, -- Should be over-ridden very soon! + tcl_ctxt = [], + tcl_rdr = emptyLocalRdrEnv, + tcl_th_ctxt = topStage, + tcl_th_bndrs = emptyNameEnv, + tcl_arrow_ctxt = NoArrowCtxt, + tcl_env = emptyNameEnv, + tcl_bndrs = [], + tcl_lie = lie_var, + tcl_tclvl = topTcLevel + } + + ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ + do { r <- tryM do_this + ; case r of + Right res -> return (Just res) + Left _ -> return Nothing } + + -- Check for unsolved constraints + -- If we succeed (maybe_res = Just r), there should be + -- no unsolved constraints. But if we exit via an + -- exception (maybe_res = Nothing), we may have skipped + -- solving, so don't panic then (#13466) + ; lie <- readIORef (tcl_lie lcl_env) + ; when (isJust maybe_res && not (isEmptyWC lie)) $ + pprPanic "initTc: unsolved constraints" (ppr lie) + + -- Collect any error messages + ; msgs <- readIORef (tcl_errs lcl_env) + + ; let { final_res | errorsFound dflags msgs = Nothing + | otherwise = maybe_res } + + ; return (msgs, final_res) + } + where dflags = hsc_dflags hsc_env + +initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a) +-- Initialise the type checker monad for use in GHCi +initTcInteractive hsc_env thing_inside + = initTc hsc_env HsSrcFile False + (icInteractiveModule (hsc_IC hsc_env)) + (realSrcLocSpan interactive_src_loc) + thing_inside + where + interactive_src_loc = mkRealSrcLoc (fsLit "") 1 1 + +{- Note [Default types] +~~~~~~~~~~~~~~~~~~~~~~~ +The Integer type is simply not available in package ghc-prim (it is +declared in integer-gmp). So we set the defaulting types to (Just +[]), meaning there are no default types, rather then Nothing, which +means "use the default default types of Integer, Double". + +If you don't do this, attempted defaulting in package ghc-prim causes +an actual crash (attempting to look up the Integer type). + + +************************************************************************ +* * + Initialisation +* * +************************************************************************ +-} + +initTcRnIf :: Char -- ^ Mask for unique supply + -> HscEnv + -> gbl -> lcl + -> TcRnIf gbl lcl a + -> IO a +initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside + = do { let { env = Env { env_top = hsc_env, + env_um = uniq_mask, + env_gbl = gbl_env, + env_lcl = lcl_env} } + + ; runIOEnv env thing_inside + } + +{- +************************************************************************ +* * + Simple accessors +* * +************************************************************************ +-} + +discardResult :: TcM a -> TcM () +discardResult a = a >> return () + +getTopEnv :: TcRnIf gbl lcl HscEnv +getTopEnv = do { env <- getEnv; return (env_top env) } + +updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updTopEnv upd = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = upd top }) + +getGblEnv :: TcRnIf gbl lcl gbl +getGblEnv = do { Env{..} <- getEnv; return env_gbl } + +updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> + env { env_gbl = upd gbl }) + +setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env }) + +getLclEnv :: TcRnIf gbl lcl lcl +getLclEnv = do { Env{..} <- getEnv; return env_lcl } + +updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> + env { env_lcl = upd lcl }) + +setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a +setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) + +getEnvs :: TcRnIf gbl lcl (gbl, lcl) +getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } + +setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a +setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env }) + +-- Command-line flags + +xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool +xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) } + +doptM :: DumpFlag -> TcRnIf gbl lcl Bool +doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) } + +goptM :: GeneralFlag -> TcRnIf gbl lcl Bool +goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) } + +woptM :: WarningFlag -> TcRnIf gbl lcl Bool +woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) } + +setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setXOptM flag = + updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag}) + +unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetXOptM flag = + updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag}) + +unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetGOptM flag = + updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag}) + +unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetWOptM flag = + updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag}) + +-- | Do it flag is true +whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenDOptM flag thing_inside = do b <- doptM flag + when b thing_inside + +whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenGOptM flag thing_inside = do b <- goptM flag + when b thing_inside + +whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenWOptM flag thing_inside = do b <- woptM flag + when b thing_inside + +whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenXOptM flag thing_inside = do b <- xoptM flag + when b thing_inside + +unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +unlessXOptM flag thing_inside = do b <- xoptM flag + unless b thing_inside + +getGhcMode :: TcRnIf gbl lcl GhcMode +getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } + +withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a +withDoDynamicToo = + updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) -> + top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags }) + +getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) +getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } + +getEps :: TcRnIf gbl lcl ExternalPackageState +getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) } + +-- | Update the external package state. Returns the second result of the +-- modifier function. +-- +-- This is an atomic operation and forces evaluation of the modified EPS in +-- order to avoid space leaks. +updateEps :: (ExternalPackageState -> (ExternalPackageState, a)) + -> TcRnIf gbl lcl a +updateEps upd_fn = do + traceIf (text "updating EPS") + eps_var <- getEpsVar + atomicUpdMutVar' eps_var upd_fn + +-- | Update the external package state. +-- +-- This is an atomic operation and forces evaluation of the modified EPS in +-- order to avoid space leaks. +updateEps_ :: (ExternalPackageState -> ExternalPackageState) + -> TcRnIf gbl lcl () +updateEps_ upd_fn = do + traceIf (text "updating EPS_") + eps_var <- getEpsVar + atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ())) + +getHpt :: TcRnIf gbl lcl HomePackageTable +getHpt = do { env <- getTopEnv; return (hsc_HPT env) } + +getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) +getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) + ; return (eps, hsc_HPT env) } + +-- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing +-- an exception if it is an error. +withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a +withException do_this = do + r <- do_this + dflags <- getDynFlags + case r of + Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) + Succeeded result -> return result + +{- +************************************************************************ +* * + Arrow scopes +* * +************************************************************************ +-} + +newArrowScope :: TcM a -> TcM a +newArrowScope + = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) } + +-- Return to the stored environment (from the enclosing proc) +escapeArrowScope :: TcM a -> TcM a +escapeArrowScope + = updLclEnv $ \ env -> + case tcl_arrow_ctxt env of + NoArrowCtxt -> env + ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt + , tcl_lie = lie + , tcl_rdr = rdr_env } + +{- +************************************************************************ +* * + Unique supply +* * +************************************************************************ +-} + +newUnique :: TcRnIf gbl lcl Unique +newUnique + = do { env <- getEnv + ; let mask = env_um env + ; liftIO $! uniqFromMask mask } + +newUniqueSupply :: TcRnIf gbl lcl UniqSupply +newUniqueSupply + = do { env <- getEnv + ; let mask = env_um env + ; liftIO $! mkSplitUniqSupply mask } + +cloneLocalName :: Name -> TcM Name +-- Make a fresh Internal name with the same OccName and SrcSpan +cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name) + +newName :: OccName -> TcM Name +newName occ = do { loc <- getSrcSpanM + ; newNameAt occ loc } + +newNameAt :: OccName -> SrcSpan -> TcM Name +newNameAt occ span + = do { uniq <- newUnique + ; return (mkInternalName uniq occ span) } + +newSysName :: OccName -> TcRnIf gbl lcl Name +newSysName occ + = do { uniq <- newUnique + ; return (mkSystemName uniq occ) } + +newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId +newSysLocalId fs ty + = do { u <- newUnique + ; return (mkSysLocal fs u ty) } + +newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] +newSysLocalIds fs tys + = do { us <- newUniqueSupply + ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } + +instance MonadUnique (IOEnv (Env gbl lcl)) where + getUniqueM = newUnique + getUniqueSupplyM = newUniqueSupply + +{- +************************************************************************ +* * + 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 $ do { old <- readIORef ref + ; writeIORef ref (fn old) } + +{- +************************************************************************ +* * + Debugging +* * +************************************************************************ +-} + + +-- Typechecker trace +traceTc :: String -> SDoc -> TcRn () +traceTc = + labelledTraceOptTcRn Opt_D_dump_tc_trace + +-- Renamer Trace +traceRn :: String -> SDoc -> TcRn () +traceRn = + labelledTraceOptTcRn Opt_D_dump_rn_trace + +-- | Trace when a certain flag is enabled. This is like `traceOptTcRn` +-- but accepts a string as a label and formats the trace message uniformly. +labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn () +labelledTraceOptTcRn flag herald doc = do + traceOptTcRn flag (formatTraceMsg herald doc) + +formatTraceMsg :: String -> SDoc -> SDoc +formatTraceMsg herald doc = hang (text herald) 2 doc + +-- | Trace if the given 'DumpFlag' is set. +traceOptTcRn :: DumpFlag -> SDoc -> TcRn () +traceOptTcRn flag doc = do + dflags <- getDynFlags + when (dopt flag dflags) $ + dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc + +-- | Dump if the given 'DumpFlag' is set. +dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () +dumpOptTcRn flag title fmt doc = do + dflags <- getDynFlags + when (dopt flag dflags) $ + dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc + +-- | Unconditionally dump some trace output +-- +-- Certain tests (T3017, Roles3, T12763 etc.) expect part of the +-- output generated by `-ddump-types` to be in 'PprUser' style. However, +-- generally we want all other debugging output to use 'PprDump' +-- style. We 'PprUser' style if 'useUserStyle' is True. +-- +dumpTcRn :: Bool -> DumpOptions -> String -> DumpFormat -> SDoc -> TcRn () +dumpTcRn useUserStyle dumpOpt title fmt doc = do + dflags <- getDynFlags + printer <- getPrintUnqualified dflags + real_doc <- wrapDocLoc doc + let sty = if useUserStyle + then mkUserStyle dflags printer AllTheWay + else mkDumpStyle dflags printer + liftIO $ dumpAction dflags sty dumpOpt title fmt real_doc + +-- | Add current location if -dppr-debug +-- (otherwise the full location is usually way too much) +wrapDocLoc :: SDoc -> TcRn SDoc +wrapDocLoc doc = do + dflags <- getDynFlags + if hasPprDebug dflags + then do + loc <- getSrcSpanM + return (mkLocMessage SevOutput loc doc) + else + return doc + +getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified +getPrintUnqualified dflags + = do { rdr_env <- getGlobalRdrEnv + ; return $ mkPrintUnqualified dflags rdr_env } + +-- | Like logInfoTcRn, but for user consumption +printForUserTcRn :: SDoc -> TcRn () +printForUserTcRn doc + = do { dflags <- getDynFlags + ; printer <- getPrintUnqualified dflags + ; liftIO (printOutputForUser dflags printer doc) } + +{- +traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is +available. Alas, they behave inconsistently with the other stuff; +e.g. are unaffected by -dump-to-file. +-} + +traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () +traceIf = traceOptIf Opt_D_dump_if_trace +traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs + + +traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () +traceOptIf flag doc + = whenDOptM flag $ -- No RdrEnv available, so qualify everything + do { dflags <- getDynFlags + ; liftIO (putMsg dflags doc) } + +{- +************************************************************************ +* * + Typechecker global environment +* * +************************************************************************ +-} + +getIsGHCi :: TcRn Bool +getIsGHCi = do { mod <- getModule + ; return (isInteractiveModule mod) } + +getGHCiMonad :: TcRn Name +getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } + +getInteractivePrintName :: TcRn Name +getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) } + +tcIsHsBootOrSig :: TcRn Bool +tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) } + +tcIsHsig :: TcRn Bool +tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) } + +tcSelfBootInfo :: TcRn SelfBootInfo +tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) } + +getGlobalRdrEnv :: TcRn GlobalRdrEnv +getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } + +getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) +getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) } + +getImports :: TcRn ImportAvails +getImports = do { env <- getGblEnv; return (tcg_imports env) } + +getFixityEnv :: TcRn FixityEnv +getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) } + +extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a +extendFixityEnv new_bit + = 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) } + +addDependentFiles :: [FilePath] -> TcRn () +addDependentFiles fs = do + ref <- fmap tcg_dependent_files getGblEnv + dep_files <- readTcRef ref + writeTcRef ref (fs ++ dep_files) + +{- +************************************************************************ +* * + Error management +* * +************************************************************************ +-} + +getSrcSpanM :: TcRn SrcSpan + -- Avoid clash with Name.getSrcLoc +getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) } + +setSrcSpan :: SrcSpan -> TcRn a -> TcRn a +setSrcSpan (RealSrcSpan real_loc _) thing_inside + = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside +-- Don't overwrite useful info with useless: +setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside + +addLocM :: (a -> TcM b) -> Located a -> TcM b +addLocM fn (L loc a) = setSrcSpan loc $ fn a + +wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) +wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a + ; return (L loc b) } + +wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) +wrapLocFstM fn (L loc a) = + setSrcSpan loc $ do + (b,c) <- fn a + return (L loc b, c) + +wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c) +wrapLocSndM fn (L loc a) = + setSrcSpan loc $ do + (b,c) <- fn a + return (b, L loc c) + +wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM () +wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a) + +-- Reporting errors + +getErrsVar :: TcRn (TcRef Messages) +getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } + +setErrsVar :: TcRef Messages -> TcRn a -> TcRn a +setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) + +addErr :: MsgDoc -> TcRn () +addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } + +failWith :: MsgDoc -> TcRn a +failWith msg = addErr msg >> failM + +failAt :: SrcSpan -> MsgDoc -> TcRn a +failAt loc msg = addErrAt loc msg >> failM + +addErrAt :: SrcSpan -> MsgDoc -> TcRn () +-- addErrAt is mainly (exclusively?) used by the renamer, where +-- 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 + ; err_info <- mkErrInfo tidy_env ctxt + ; addLongErrAt loc msg err_info } + +addErrs :: [(SrcSpan,MsgDoc)] -> TcRn () +addErrs msgs = mapM_ add msgs + where + add (loc,msg) = addErrAt loc msg + +checkErr :: Bool -> MsgDoc -> TcRn () +-- Add the error if the bool is False +checkErr ok msg = unless ok (addErr msg) + +addMessages :: Messages -> TcRn () +addMessages msgs1 + = do { errs_var <- getErrsVar ; + msgs0 <- readTcRef errs_var ; + writeTcRef errs_var (unionMessages msgs0 msgs1) } + +discardWarnings :: TcRn a -> TcRn a +-- Ignore warnings inside the thing inside; +-- used to ignore-unused-variable warnings inside derived code +discardWarnings thing_inside + = do { errs_var <- getErrsVar + ; (old_warns, _) <- readTcRef errs_var + + ; result <- thing_inside + + -- Revert warnings to old_warns + ; (_new_warns, new_errs) <- readTcRef errs_var + ; writeTcRef errs_var (old_warns, new_errs) + + ; return result } + +{- +************************************************************************ +* * + Shared error message stuff: renamer and typechecker +* * +************************************************************************ +-} + +mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg +mkLongErrAt loc msg extra + = do { dflags <- getDynFlags ; + printer <- getPrintUnqualified dflags ; + return $ mkLongErrMsg dflags loc printer msg extra } + +mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg +mkErrDocAt loc errDoc + = do { dflags <- getDynFlags ; + printer <- getPrintUnqualified dflags ; + return $ mkErrDoc dflags loc printer errDoc } + +addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError + +reportErrors :: [ErrMsg] -> TcM () +reportErrors = mapM_ reportError + +reportError :: ErrMsg -> TcRn () +reportError err + = do { traceTc "Adding error:" (pprLocErrMsg err) ; + errs_var <- getErrsVar ; + (warns, errs) <- readTcRef errs_var ; + writeTcRef errs_var (warns, errs `snocBag` err) } + +reportWarning :: WarnReason -> ErrMsg -> TcRn () +reportWarning reason err + = do { let warn = makeIntoWarning reason err + -- 'err' was built by mkLongErrMsg or something like that, + -- so it's of error severity. For a warning we downgrade + -- its severity to SevWarning + + ; traceTc "Adding warning:" (pprLocErrMsg warn) + ; errs_var <- getErrsVar + ; (warns, errs) <- readTcRef errs_var + ; writeTcRef errs_var (warns `snocBag` warn, errs) } + + +----------------------- +checkNoErrs :: TcM r -> TcM r +-- (checkNoErrs m) succeeds iff m succeeds and generates no errors +-- If m fails then (checkNoErrsTc m) fails. +-- If m succeeds, it checks whether m generated any errors messages +-- (it might have recovered internally) +-- If so, it fails too. +-- Regardless, any errors generated by m are propagated to the enclosing context. +checkNoErrs main + = do { (res, no_errs) <- askNoErrs main + ; unless no_errs failM + ; return res } + +----------------------- +whenNoErrs :: TcM () -> TcM () +whenNoErrs thing = ifErrsM (return ()) thing + +ifErrsM :: TcRn r -> TcRn r -> TcRn r +-- ifErrsM bale_out normal +-- does 'bale_out' if there are errors in errors collection +-- otherwise does 'normal' +ifErrsM bale_out normal + = do { errs_var <- getErrsVar ; + msgs <- readTcRef errs_var ; + dflags <- getDynFlags ; + if errorsFound dflags msgs then + bale_out + else + normal } + +failIfErrsM :: TcRn () +-- Useful to avoid error cascades +failIfErrsM = ifErrsM failM (return ()) + +{- ********************************************************************* +* * + Context management for the type checker +* * +************************************************************************ +-} + +getErrCtxt :: TcM [ErrCtxt] +getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } + +setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a +setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) + +-- | Add a fixed message to the error context. This message should not +-- do any tidying. +addErrCtxt :: MsgDoc -> TcM a -> TcM a +addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) + +-- | Add a message to the error context. This message may do tidying. +addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a +addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts) + +-- | Add a fixed landmark message to the error context. A landmark +-- message is always sure to be reported, even if there is a lot of +-- context. It also doesn't count toward the maximum number of contexts +-- reported. +addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a +addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) + +-- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations +-- and tidying. +addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a +addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts) + +-- Helper function for the above +updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a +updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> + env { tcl_ctxt = upd ctxt }) + +popErrCtxt :: TcM a -> TcM a +popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) + +getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc +getCtLocM origin t_or_k + = do { env <- getLclEnv + ; return (CtLoc { ctl_origin = origin + , ctl_env = env + , ctl_t_or_k = t_or_k + , ctl_depth = initialSubGoalDepth }) } + +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 + + +{- ********************************************************************* +* * + Error recovery and exceptions +* * +********************************************************************* -} + +tcTryM :: TcRn r -> TcRn (Maybe r) +-- The most basic function: catch the exception +-- Nothing => an exception happened +-- Just r => no exception, result R +-- Errors and constraints are propagated in both cases +-- Never throws an exception +tcTryM thing_inside + = do { either_res <- tryM thing_inside + ; return (case either_res of + Left _ -> Nothing + Right r -> Just r) } + -- In the Left case the exception is always the IOEnv + -- built-in in exception; see IOEnv.failM + +----------------------- +capture_constraints :: TcM r -> TcM (r, WantedConstraints) +-- capture_constraints simply captures and returns the +-- constraints 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 lie_var, and we'd lose the constraints altogether +capture_constraints thing_inside + = do { lie_var <- newTcRef emptyWC + ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $ + thing_inside + ; lie <- readTcRef lie_var + ; return (res, lie) } + +capture_messages :: TcM r -> TcM (r, Messages) +-- capture_messages simply captures and returns the +-- errors arnd 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 +capture_messages thing_inside + = do { msg_var <- newTcRef emptyMessages + ; res <- setErrsVar msg_var thing_inside + ; msgs <- readTcRef msg_var + ; return (res, msgs) } + +----------------------- +-- (askNoErrs m) runs m +-- If m fails, +-- then (askNoErrs m) fails, propagating only +-- insoluble constraints +-- +-- If m succeeds with result r, +-- then (askNoErrs m) succeeds with result (r, b), +-- where b is True iff m generated no errors +-- +-- Regardless of success or failure, +-- propagate any errors/warnings generated by m +askNoErrs :: TcRn a -> TcRn (a, Bool) +askNoErrs thing_inside + = do { ((mb_res, lie), msgs) <- capture_messages $ + capture_constraints $ + tcTryM thing_inside + ; addMessages msgs + + ; case mb_res of + Nothing -> do { emitConstraints (insolublesOnly lie) + ; failM } + + Just res -> do { emitConstraints lie + ; dflags <- getDynFlags + ; let errs_found = errorsFound dflags msgs + || insolubleWC lie + ; return (res, not errs_found) } } + +----------------------- +tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints) +-- (tryCaptureConstraints_maybe m) runs m, +-- and returns the type constraints it generates +-- It never throws an exception; instead if thing_inside fails, +-- it returns Nothing and the /insoluble/ constraints +-- Error messages are propagated +tryCaptureConstraints thing_inside + = do { (mb_res, lie) <- capture_constraints $ + tcTryM thing_inside + + -- See Note [Constraints and errors] + ; let lie_to_keep = case mb_res of + Nothing -> insolublesOnly lie + Just {} -> lie + + ; return (mb_res, lie_to_keep) } + +captureConstraints :: TcM a -> TcM (a, WantedConstraints) +-- (captureConstraints m) runs m, and returns the type constraints it generates +-- If thing_inside fails (throwing an exception), +-- then (captureConstraints thing_inside) fails too +-- propagating the insoluble constraints only +-- Error messages are propagated in either case +captureConstraints thing_inside + = do { (mb_res, lie) <- tryCaptureConstraints thing_inside + + -- See Note [Constraints and errors] + -- If the thing_inside threw an exception, emit the insoluble + -- constraints only (returned by tryCaptureConstraints) + -- so that they are not lost + ; case mb_res of + Nothing -> do { emitConstraints lie; failM } + Just res -> return (res, lie) } + +----------------------- +attemptM :: TcRn r -> TcRn (Maybe r) +-- (attemptM thing_inside) runs thing_inside +-- If thing_inside succeeds, returning r, +-- we return (Just r), and propagate all constraints and errors +-- If thing_inside fail, throwing an exception, +-- we return Nothing, propagating insoluble constraints, +-- and all errors +-- attemptM never throws an exception +attemptM thing_inside + = do { (mb_r, lie) <- tryCaptureConstraints thing_inside + ; emitConstraints lie + + -- Debug trace + ; when (isNothing mb_r) $ + traceTc "attemptM recovering with insoluble constraints" $ + (ppr lie) + + ; return mb_r } + +----------------------- +recoverM :: TcRn r -- Recovery action; do this if the main one fails + -> TcRn r -- Main action: do this first; + -- if it generates errors, propagate them all + -> TcRn r +-- (recoverM recover thing_inside) runs thing_inside +-- If thing_inside fails, propagate its errors and insoluble constraints +-- and run 'recover' +-- If thing_inside succeeds, propagate all its errors and constraints +-- +-- Can fail, if 'recover' fails +recoverM recover thing + = do { mb_res <- attemptM thing ; + case mb_res of + Nothing -> recover + Just res -> return res } + +----------------------- + +-- | Drop elements of the input that fail, so the result +-- list can be shorter than the argument list +mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] +mapAndRecoverM f xs + = do { mb_rs <- mapM (attemptM . f) xs + ; return [r | Just r <- mb_rs] } + +-- | Apply the function to all elements on the input list +-- If all succeed, return the list of results +-- Otherwise fail, propagating all errors +mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b] +mapAndReportM f xs + = do { mb_rs <- mapM (attemptM . f) xs + ; when (any isNothing mb_rs) failM + ; return [r | Just r <- mb_rs] } + +-- | The accumulator is not updated if the action fails +foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b +foldAndRecoverM _ acc [] = return acc +foldAndRecoverM f acc (x:xs) = + do { mb_r <- attemptM (f acc x) + ; case mb_r of + Nothing -> foldAndRecoverM f acc xs + Just acc' -> foldAndRecoverM f acc' xs } + +----------------------- +tryTc :: TcRn a -> TcRn (Maybe a, Messages) +-- (tryTc m) executes m, and returns +-- Just r, if m succeeds (returning r) +-- Nothing, if m fails +-- It also returns all the errors and warnings accumulated by m +-- It always succeeds (never raises an exception) +tryTc thing_inside + = capture_messages (attemptM thing_inside) + +----------------------- +discardErrs :: TcRn a -> TcRn a +-- (discardErrs m) runs m, +-- discarding all error messages and warnings generated by m +-- If m fails, discardErrs fails, and vice versa +discardErrs m + = do { errs_var <- newTcRef emptyMessages + ; setErrsVar errs_var m } + +----------------------- +tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r +-- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside'; +-- if 'main' succeeds with no error messages, it's the answer +-- otherwise discard everything from 'main', including errors, +-- and try 'recover' instead. +tryTcDiscardingErrs recover thing_inside + = do { ((mb_res, lie), msgs) <- capture_messages $ + capture_constraints $ + tcTryM thing_inside + ; dflags <- getDynFlags + ; case mb_res of + Just res | not (errorsFound dflags msgs) + , not (insolubleWC lie) + -> -- 'main' succeeded with no errors + do { addMessages msgs -- msgs might still have warnings + ; emitConstraints lie + ; return res } + + _ -> -- 'main' failed, or produced an error message + recover -- Discard all errors and warnings + -- and unsolved constraints entirely + } + +{- +************************************************************************ +* * + Error message generation (type checker) +* * +************************************************************************ + + The addErrTc functions add an error message, but do not cause failure. + The 'M' variants pass a TidyEnv that has already been used to + tidy up the message; we then use it to tidy the context messages +-} + +addErrTc :: MsgDoc -> TcM () +addErrTc err_msg = do { env0 <- tcInitTidyEnv + ; addErrTcM (env0, err_msg) } + +addErrsTc :: [MsgDoc] -> TcM () +addErrsTc err_msgs = mapM_ addErrTc err_msgs + +addErrTcM :: (TidyEnv, MsgDoc) -> TcM () +addErrTcM (tidy_env, err_msg) + = do { ctxt <- getErrCtxt ; + loc <- getSrcSpanM ; + add_err_tcm tidy_env err_msg loc ctxt } + +-- Return the error message, instead of reporting it straight away +mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg +mkErrTcM (tidy_env, err_msg) + = do { ctxt <- getErrCtxt ; + loc <- getSrcSpanM ; + err_info <- mkErrInfo tidy_env ctxt ; + mkLongErrAt loc err_msg err_info } + +mkErrTc :: MsgDoc -> TcM ErrMsg +mkErrTc msg = do { env0 <- tcInitTidyEnv + ; mkErrTcM (env0, msg) } + +-- The failWith functions add an error message and cause failure + +failWithTc :: MsgDoc -> TcM a -- Add an error message and fail +failWithTc err_msg + = addErrTc err_msg >> failM + +failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail +failWithTcM local_and_msg + = addErrTcM local_and_msg >> failM + +checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true +checkTc True _ = return () +checkTc False err = failWithTc err + +checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () +checkTcM True _ = return () +checkTcM False err = failWithTcM err + +failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false +failIfTc False _ = return () +failIfTc True err = failWithTc err + +failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () + -- Check that the boolean is false +failIfTcM False _ = return () +failIfTcM True err = failWithTcM err + + +-- Warnings have no 'M' variant, nor failure + +-- | Display a warning if a condition is met, +-- and the warning is enabled +warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn () +warnIfFlag warn_flag is_bad msg + = do { warn_on <- woptM warn_flag + ; when (warn_on && is_bad) $ + addWarn (Reason warn_flag) msg } + +-- | Display a warning if a condition is met. +warnIf :: Bool -> MsgDoc -> TcRn () +warnIf is_bad msg + = when is_bad (addWarn NoReason msg) + +-- | Display a warning if a condition is met. +warnTc :: WarnReason -> Bool -> MsgDoc -> TcM () +warnTc reason warn_if_true warn_msg + | warn_if_true = addWarnTc reason warn_msg + | otherwise = return () + +-- | Display a warning if a condition is met. +warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM () +warnTcM reason warn_if_true warn_msg + | warn_if_true = addWarnTcM reason warn_msg + | otherwise = return () + +-- | Display a warning in the current context. +addWarnTc :: WarnReason -> MsgDoc -> TcM () +addWarnTc reason msg + = do { env0 <- tcInitTidyEnv ; + addWarnTcM reason (env0, msg) } + +-- | Display a warning in a given context. +addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM () +addWarnTcM reason (env0, msg) + = do { ctxt <- getErrCtxt ; + err_info <- mkErrInfo env0 ctxt ; + add_warn reason msg err_info } + +-- | Display a warning for the current source location. +addWarn :: WarnReason -> MsgDoc -> TcRn () +addWarn reason msg = add_warn reason msg Outputable.empty + +-- | Display a warning for a given source location. +addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn () +addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty + +-- | Display a warning, with an optional flag, for the current source +-- location. +add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn () +add_warn reason msg extra_info + = do { loc <- getSrcSpanM + ; add_warn_at reason loc msg extra_info } + +-- | Display a warning, with an optional flag, for a given location. +add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +add_warn_at reason loc msg extra_info + = do { dflags <- getDynFlags ; + printer <- getPrintUnqualified dflags ; + let { warn = mkLongWarnMsg dflags loc printer + msg extra_info } ; + reportWarning reason warn } + + +{- +----------------------------------- + Other helper functions +-} + +add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan + -> [ErrCtxt] + -> TcM () +add_err_tcm tidy_env err_msg loc ctxt + = do { err_info <- mkErrInfo tidy_env ctxt ; + addLongErrAt loc err_msg err_info } + +mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc +-- Tidy the error info, trimming excessive contexts +mkErrInfo env ctxts +-- = do +-- dbg <- hasPprDebug <$> getDynFlags +-- if dbg -- In -dppr-debug style the output +-- then return empty -- just becomes too voluminous +-- else go dbg 0 env ctxts + = go False 0 env ctxts + where + go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc + go _ _ _ [] = return empty + go dbg n env ((is_landmark, ctxt) : ctxts) + | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg + = do { (env', msg) <- ctxt env + ; let n' = if is_landmark then n else n+1 + ; rest <- go dbg n' env' ctxts + ; return (msg $$ rest) } + | otherwise + = go dbg n env ctxts + +mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts +mAX_CONTEXTS = 3 + +-- debugTc is useful for monadic debugging code + +debugTc :: TcM () -> TcM () +debugTc thing + | debugIsOn = thing + | otherwise = return () + +{- +************************************************************************ +* * + Type constraints +* * +************************************************************************ +-} + +addTopEvBinds :: Bag EvBind -> TcM a -> TcM a +addTopEvBinds new_ev_binds thing_inside + =updGblEnv upd_env thing_inside + where + upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env + `unionBags` new_ev_binds } + +newTcEvBinds :: TcM EvBindsVar +newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap + ; tcvs_ref <- newTcRef emptyVarSet + ; uniq <- newUnique + ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq) + ; return (EvBindsVar { ebv_binds = binds_ref + , ebv_tcvs = tcvs_ref + , ebv_uniq = uniq }) } + +-- | Creates an EvBindsVar incapable of holding any bindings. It still +-- tracks covar usages (see comments on ebv_tcvs in GHC.Tc.Types.Evidence), thus +-- must be made monadically +newNoTcEvBinds :: TcM EvBindsVar +newNoTcEvBinds + = do { tcvs_ref <- newTcRef emptyVarSet + ; uniq <- newUnique + ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq) + ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref + , ebv_uniq = uniq }) } + +cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar +-- Clone the refs, so that any binding created when +-- solving don't pollute the original +cloneEvBindsVar ebv@(EvBindsVar {}) + = do { binds_ref <- newTcRef emptyEvBindMap + ; tcvs_ref <- newTcRef emptyVarSet + ; return (ebv { ebv_binds = binds_ref + , ebv_tcvs = tcvs_ref }) } +cloneEvBindsVar ebv@(CoEvBindsVar {}) + = do { tcvs_ref <- newTcRef emptyVarSet + ; return (ebv { ebv_tcvs = tcvs_ref }) } + +getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet +getTcEvTyCoVars ev_binds_var + = readTcRef (ebv_tcvs ev_binds_var) + +getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap +getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) + = readTcRef ev_ref +getTcEvBindsMap (CoEvBindsVar {}) + = return emptyEvBindMap + +setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM () +setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds + = writeTcRef ev_ref binds +setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds + | isEmptyEvBindMap ev_binds + = return () + | otherwise + = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds) + +addTcEvBind :: EvBindsVar -> EvBind -> TcM () +-- Add a binding to the TcEvBinds by side effect +addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind + = do { traceTc "addTcEvBind" $ ppr u $$ + ppr ev_bind + ; bnds <- readTcRef ev_ref + ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) } +addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind + = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u) + +chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName +chooseUniqueOccTc fn = + do { env <- getGblEnv + ; let dfun_n_var = tcg_dfun_n env + ; set <- readTcRef dfun_n_var + ; let occ = fn set + ; writeTcRef dfun_n_var (extendOccSet set occ) + ; return occ } + +getConstraintVar :: TcM (TcRef WantedConstraints) +getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) } + +setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a +setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var }) + +emitStaticConstraints :: WantedConstraints -> TcM () +emitStaticConstraints static_lie + = do { gbl_env <- getGblEnv + ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) } + +emitConstraints :: WantedConstraints -> TcM () +emitConstraints ct + | isEmptyWC ct + = return () + | otherwise + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`andWC` ct) } + +emitSimple :: Ct -> TcM () +emitSimple ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addSimples` unitBag ct) } + +emitSimples :: Cts -> TcM () +emitSimples cts + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addSimples` cts) } + +emitImplication :: Implication -> TcM () +emitImplication ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addImplics` unitBag ct) } + +emitImplications :: Bag Implication -> TcM () +emitImplications ct + = unless (isEmptyBag ct) $ + 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) } + +emitInsolubles :: Cts -> TcM () +emitInsolubles cts + | isEmptyBag cts = return () + | otherwise = do { traceTc "emitInsolubles" (ppr cts) + ; lie_var <- getConstraintVar + ; updTcRef lie_var (`addInsols` cts) } + +-- | Throw out any constraints emitted by the thing_inside +discardConstraints :: TcM a -> TcM a +discardConstraints thing_inside = fst <$> captureConstraints thing_inside + +-- | The name says it all. The returned TcLevel is the *inner* TcLevel. +pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) +pushLevelAndCaptureConstraints thing_inside + = do { env <- getLclEnv + ; let tclvl' = pushTcLevel (tcl_tclvl env) + ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl') + ; (res, lie) <- setLclEnv (env { tcl_tclvl = 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 :: TcM a -> TcM (TcLevel, a) +-- See Note [TcLevel assignment] in GHC.Tc.Utils.TcType +pushTcLevelM thing_inside + = do { env <- getLclEnv + ; let tclvl' = pushTcLevel (tcl_tclvl env) + ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) + thing_inside + ; return (tclvl', res) } + +-- Returns pushed TcLevel +pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel) +pushTcLevelsM num_levels thing_inside + = do { env <- getLclEnv + ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env) + ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $ + thing_inside + ; return (res, tclvl') } + +getTcLevel :: TcM TcLevel +getTcLevel = do { env <- getLclEnv + ; return (tcl_tclvl env) } + +setTcLevel :: TcLevel -> TcM a -> TcM a +setTcLevel tclvl thing_inside + = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside + +isTouchableTcM :: TcTyVar -> TcM Bool +isTouchableTcM tv + = do { lvl <- getTcLevel + ; return (isTouchableMetaTyVar lvl tv) } + +getLclTypeEnv :: TcM TcTypeEnv +getLclTypeEnv = do { env <- getLclEnv; return (tcl_env 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 } + +traceTcConstraints :: String -> TcM () +traceTcConstraints msg + = do { lie_var <- getConstraintVar + ; lie <- readTcRef lie_var + ; traceOptTcRn Opt_D_dump_tc_trace $ + hang (text (msg ++ ": LIE:")) 2 (ppr lie) + } + +emitAnonWildCardHoleConstraint :: TcTyVar -> TcM () +emitAnonWildCardHoleConstraint tv + = do { ct_loc <- getCtLocM HoleOrigin Nothing + ; emitInsolubles $ unitBag $ + CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv + , ctev_loc = ct_loc } + , cc_occ = mkTyVarOcc "_" + , cc_hole = TypeHole } } + +emitNamedWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM () +emitNamedWildCardHoleConstraints wcs + = do { ct_loc <- getCtLocM HoleOrigin Nothing + ; emitInsolubles $ listToBag $ + map (do_one ct_loc) wcs } + where + do_one :: CtLoc -> (Name, TcTyVar) -> Ct + do_one ct_loc (name, tv) + = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv + , ctev_loc = ct_loc' } + , cc_occ = occName name + , cc_hole = TypeHole } + where + real_span = case nameSrcSpan name of + RealSrcSpan span _ -> span + UnhelpfulSpan str -> pprPanic "emitNamedWildCardHoleConstraints" + (ppr name <+> quotes (ftext str)) + -- Wildcards are defined locally, and so have RealSrcSpans + ct_loc' = setCtLocSpan ct_loc real_span + +{- Note [Constraints and errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#12124): + + foo :: Maybe Int + foo = return (case Left 3 of + Left -> 1 -- Hard error here! + _ -> 0) + +The call to 'return' will generate a (Monad m) wanted constraint; but +then there'll be "hard error" (i.e. an exception in the TcM monad), from +the unsaturated Left constructor pattern. + +We'll recover in tcPolyBinds, using recoverM. But then the final +tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly +un-filled-in, and will emit a misleading error message. + +The underlying problem is that an exception interrupts the constraint +gathering process. Bottom line: if we have an exception, it's best +simply to discard any gathered constraints. Hence in 'attemptM' we +capture the constraints in a fresh variable, and only emit them into +the surrounding context if we exit normally. If an exception is +raised, simply discard the collected constraints... we have a hard +error to report. So this capture-the-emit dance isn't as stupid as it +looks :-). + +However suppose we throw an exception inside an invocation of +captureConstraints, and discard all the constraints. Some of those +constraints might be "variable out of scope" Hole constraints, and that +might have been the actual original cause of the exception! For +example (#12529): + f = p @ Int +Here 'p' is out of scope, so we get an insoluble Hole constraint. But +the visible type application fails in the monad (throws an exception). +We must not discard the out-of-scope error. + +So we /retain the insoluble constraints/ if there is an exception. +Hence: + - insolublesOnly in tryCaptureConstraints + - emitConstraints in the Left case of captureConstraints + +However note that freshly-generated constraints like (Int ~ Bool), or +((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as +insoluble. The constraint solver does that. So they'll be discarded. +That's probably ok; but see th/5358 as a not-so-good example: + t1 :: Int + t1 x = x -- Manifestly wrong + + foo = $(...raises exception...) +We report the exception, but not the bug in t1. Oh well. Possible +solution: make GHC.Tc.Utils.Unify.uType spot manifestly-insoluble constraints. + + +************************************************************************ +* * + Template Haskell context +* * +************************************************************************ +-} + +recordThUse :: TcM () +recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } + +recordThSpliceUse :: TcM () +recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True } + +keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set +keepAlive name + = do { env <- getGblEnv + ; traceRn "keep alive" (ppr name) + ; updTcRef (tcg_keep env) (`extendNameSet` name) } + +getStage :: TcM ThStage +getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) } + +getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage)) +getStageAndBindLevel name + = do { env <- getLclEnv; + ; case lookupNameEnv (tcl_th_bndrs env) name of + Nothing -> return Nothing + Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) } + +setStage :: ThStage -> TcM a -> TcRn a +setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) + +-- | Adds the given modFinalizers to the global environment and set them to use +-- the current local environment. +addModFinalizersWithLclEnv :: ThModFinalizers -> TcM () +addModFinalizersWithLclEnv mod_finalizers + = do lcl_env <- getLclEnv + th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + updTcRef th_modfinalizers_var $ \fins -> + (lcl_env, mod_finalizers) : fins + +{- +************************************************************************ +* * + Safe Haskell context +* * +************************************************************************ +-} + +-- | Mark that safe inference has failed +-- See Note [Safe Haskell Overlapping Instances Implementation] +-- although this is used for more than just that failure case. +recordUnsafeInfer :: WarningMessages -> TcM () +recordUnsafeInfer warns = + getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns) + +-- | Figure out the final correct safe haskell mode +finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode +finalSafeMode dflags tcg_env = do + safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env) + return $ case safeHaskell dflags of + Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred + | otherwise -> Sf_None + s -> s + +-- | Switch instances to safe instances if we're in Safe mode. +fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst] +fixSafeInstances sfMode | sfMode /= Sf_Safe && sfMode /= Sf_SafeInferred = id +fixSafeInstances _ = map fixSafe + where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True } + in inst { is_flag = new_flag } + +{- +************************************************************************ +* * + Stuff for the renamer's local env +* * +************************************************************************ +-} + +getLocalRdrEnv :: RnM LocalRdrEnv +getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) } + +setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a +setLocalRdrEnv rdr_env thing_inside + = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside + +{- +************************************************************************ +* * + Stuff for interface decls +* * +************************************************************************ +-} + +mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv +mkIfLclEnv mod loc boot + = IfLclEnv { if_mod = mod, + if_loc = loc, + if_boot = boot, + if_nsubst = Nothing, + if_implicits_env = Nothing, + if_tv_env = emptyFsEnv, + if_id_env = emptyFsEnv } + +-- | Run an 'IfG' (top-level interface monad) computation inside an existing +-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv' +-- based on 'TcGblEnv'. +initIfaceTcRn :: IfG a -> TcRn a +initIfaceTcRn thing_inside + = do { tcg_env <- getGblEnv + ; dflags <- getDynFlags + ; let !mod = tcg_semantic_mod tcg_env + -- When we are instantiating a signature, we DEFINITELY + -- do not want to knot tie. + is_instantiate = unitIsDefinite (thisPackage dflags) && + not (null (thisUnitIdInsts dflags)) + ; let { if_env = IfGblEnv { + if_doc = text "initIfaceTcRn", + if_rec_types = + if is_instantiate + then Nothing + else Just (mod, get_type_env) + } + ; get_type_env = readTcRef (tcg_type_env_var tcg_env) } + ; setEnvs (if_env, ()) thing_inside } + +-- Used when sucking in a ModIface into a ModDetails to put in +-- the HPT. Notably, unlike initIfaceCheck, this does NOT use +-- hsc_type_env_var (since we're not actually going to typecheck, +-- so this variable will never get updated!) +initIfaceLoad :: HscEnv -> IfG a -> IO a +initIfaceLoad hsc_env do_this + = do let gbl_env = IfGblEnv { + if_doc = text "initIfaceLoad", + if_rec_types = Nothing + } + initTcRnIf 'i' hsc_env gbl_env () do_this + +initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a +-- Used when checking the up-to-date-ness of the old Iface +-- Initialise the environment with no useful info at all +initIfaceCheck doc hsc_env do_this + = do let rec_types = case hsc_type_env_var hsc_env of + Just (mod,var) -> Just (mod, readTcRef var) + Nothing -> Nothing + gbl_env = IfGblEnv { + if_doc = text "initIfaceCheck" <+> doc, + if_rec_types = rec_types + } + initTcRnIf 'i' hsc_env gbl_env () do_this + +initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a +initIfaceLcl mod loc_doc hi_boot_file thing_inside + = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside + +-- | Initialize interface typechecking, but with a 'NameShape' +-- to apply when typechecking top-level 'OccName's (see +-- 'lookupIfaceTop') +initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a +initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside + = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside + +getIfModule :: IfL Module +getIfModule = do { env <- getLclEnv; return (if_mod env) } + +-------------------- +failIfM :: MsgDoc -> IfL a +-- The Iface monad doesn't have a place to accumulate errors, so we +-- just fall over fast if one happens; it "shouldn't happen". +-- We use IfL here so that we can get context info out of the local env +failIfM msg + = do { env <- getLclEnv + ; let full_msg = (if_loc env <> colon) $$ nest 2 msg + ; dflags <- getDynFlags + ; liftIO (putLogMsg dflags NoReason SevFatal + noSrcSpan (defaultErrStyle dflags) full_msg) + ; failM } + +-------------------- +forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) +-- Run thing_inside in an interleaved thread. +-- It shares everything with the parent thread, so this is DANGEROUS. +-- +-- It returns Nothing if the computation fails +-- +-- It's used for lazily type-checking interface +-- signatures, which is pretty benign + +forkM_maybe doc thing_inside + = do { -- see Note [Masking exceptions in forkM_maybe] + ; unsafeInterleaveM $ uninterruptibleMaskM_ $ + do { traceIf (text "Starting fork {" <+> doc) + ; mb_res <- tryM $ + updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ + thing_inside + ; case mb_res of + Right r -> do { traceIf (text "} ending fork" <+> doc) + ; return (Just r) } + Left exn -> do { + + -- Bleat about errors in the forked thread, if -ddump-if-trace is on + -- Otherwise we silently discard errors. Errors can legitimately + -- happen when compiling interface signatures (see tcInterfaceSigs) + whenDOptM Opt_D_dump_if_trace $ do + dflags <- getDynFlags + let msg = hang (text "forkM failed:" <+> doc) + 2 (text (show exn)) + liftIO $ putLogMsg dflags + NoReason + SevFatal + noSrcSpan + (defaultErrStyle dflags) + msg + + ; traceIf (text "} ending fork (badly)" <+> doc) + ; return Nothing } + }} + +forkM :: SDoc -> IfL a -> IfL a +forkM doc thing_inside + = do { mb_res <- forkM_maybe doc thing_inside + ; return (case mb_res of + Nothing -> pgmError "Cannot continue after interface file error" + -- pprPanic "forkM" doc + Just r -> r) } + +setImplicitEnvM :: TypeEnv -> IfL a -> IfL a +setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl + { if_implicits_env = Just tenv }) m + +{- +Note [Masking exceptions in forkM_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When using GHC-as-API it must be possible to interrupt snippets of code +executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible +by throwing an asynchronous interrupt to the GHC thread. However, there is a +subtle problem: runStmt first typechecks the code before running it, and the +exception might interrupt the type checker rather than the code. Moreover, the +typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and +more importantly might be inside an exception handler inside that +unsafeInterleaveIO. If that is the case, the exception handler will rethrow the +asynchronous exception as a synchronous exception, and the exception will end +up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed +discussion). We don't currently know a general solution to this problem, but +we can use uninterruptibleMask_ to avoid the situation. +-} + +-- | Environments which track 'CostCentreState' +class ContainsCostCentreState e where + extractCostCentreState :: e -> TcRef CostCentreState + +instance ContainsCostCentreState TcGblEnv where + extractCostCentreState = tcg_cc_st + +instance ContainsCostCentreState DsGblEnv where + extractCostCentreState = ds_cc_st + +-- | Get the next cost centre index associated with a given name. +getCCIndexM :: (ContainsCostCentreState gbl) + => FastString -> TcRnIf gbl lcl CostCentreIndex +getCCIndexM nm = do + env <- getGblEnv + let cc_st_ref = extractCostCentreState env + cc_st <- readTcRef cc_st_ref + let (idx, cc_st') = getCCIndex nm cc_st + writeTcRef cc_st_ref cc_st' + return idx diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -0,0 +1,2412 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, TupleSections, MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Monadic type operations +-- +-- This module contains monadic operations over types that contain mutable type +-- variables. +module GHC.Tc.Utils.TcMType ( + TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet, + + -------------------------------- + -- Creating new mutable type variables + newFlexiTyVar, + newNamedFlexiTyVar, + newFlexiTyVarTy, -- Kind -> TcM TcType + newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] + newOpenFlexiTyVarTy, newOpenTypeKind, + newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel, + cloneMetaTyVar, + newFmvTyVar, newFskTyVar, + + readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, + newMetaDetails, isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, + + -------------------------------- + -- Expected types + ExpType(..), ExpSigmaType, ExpRhoType, + mkCheckExpType, + newInferExpType, + readExpType, readExpType_maybe, + expTypeToType, checkingExpType_maybe, checkingExpType, + tauifyExpType, inferResultToType, + + -------------------------------- + -- Creating new evidence variables + newEvVar, newEvVars, newDict, + newWanted, newWanteds, newHoleCt, cloneWanted, cloneWC, + emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, + emitDerivedEqs, + newTcEvBinds, newNoTcEvBinds, addTcEvBind, + + newCoercionHole, fillCoercionHole, isFilledCoercionHole, + unpackCoercionHole, unpackCoercionHole_maybe, + checkCoercionHole, + + newImplication, + + -------------------------------- + -- Instantiation + newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, + newMetaTyVarTyVars, newMetaTyVarTyVarX, + newTyVarTyVar, cloneTyVarTyVar, + newPatSigTyVar, newSkolemTyVar, newWildCardX, + tcInstType, + tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt, + tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, + + freshenTyVarBndrs, freshenCoVarBndrsX, + + -------------------------------- + -- Zonking and tidying + zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, + tidyEvVar, tidyCt, tidySkolemInfo, + zonkTcTyVar, zonkTcTyVars, + zonkTcTyVarToTyVar, zonkTyVarTyVarPairs, + zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV, + zonkTyCoVarsAndFVList, + candidateQTyVarsOfType, candidateQTyVarsOfKind, + candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, + CandidatesQTvs(..), delCandidates, candidateKindVars, partitionCandidates, + zonkAndSkolemise, skolemiseQuantifiedTyVar, + defaultTyVar, quantifyTyVars, isQuantifiableTv, + zonkTcType, zonkTcTypes, zonkCo, + zonkTyCoVarKind, + + zonkEvVar, zonkWC, zonkSimples, + zonkId, zonkCoVar, + zonkCt, zonkSkolemInfo, + + skolemiseUnboundMetaTyVar, + + ------------------------------ + -- Levity polymorphism + ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr + ) where + +#include "HsVersions.h" + +-- friends: +import GHC.Prelude + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Class +import GHC.Types.Var +import GHC.Core.Predicate +import GHC.Tc.Types.Origin + +-- others: +import GHC.Tc.Utils.Monad -- TcType, amongst others +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +import GHC.Types.Id as Id +import GHC.Types.Name +import GHC.Types.Var.Set +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Types.Var.Env +import GHC.Types.Name.Env +import GHC.Builtin.Names +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Data.Pair +import GHC.Types.Unique.Set +import GHC.Driver.Session +import qualified GHC.LanguageExtensions as LangExt +import GHC.Types.Basic ( TypeOrKind(..) ) + +import Control.Monad +import GHC.Data.Maybe +import Data.List ( mapAccumL ) +import Control.Arrow ( second ) +import qualified Data.Semigroup as Semi + +{- +************************************************************************ +* * + Kind variables +* * +************************************************************************ +-} + +mkKindName :: Unique -> Name +mkKindName unique = mkSystemName unique kind_var_occ + +kind_var_occ :: OccName -- Just one for all MetaKindVars + -- They may be jiggled by tidying +kind_var_occ = mkOccName tvName "k" + +newMetaKindVar :: TcM TcKind +newMetaKindVar + = do { details <- newMetaDetails TauTv + ; uniq <- newUnique + ; let kv = mkTcTyVar (mkKindName uniq) 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 ty) } + +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 + d <- if isEqPrimPred pty then HoleDest <$> newCoercionHole YesBlockSubst pty + else EvVarDest <$> newEvVar pty + return $ CtWanted { ctev_dest = d + , ctev_pred = pty + , ctev_nosh = WDeriv + , ctev_loc = loc } + +newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] +newWanteds orig = mapM (newWanted orig Nothing) + +-- | Create a new 'CHoleCan' 'Ct'. +newHoleCt :: HoleSort -> Id -> Type -> TcM Ct +newHoleCt hole ev ty = do + loc <- getCtLocM HoleOrigin Nothing + pure $ CHoleCan { cc_ev = CtWanted { ctev_pred = ty + , ctev_dest = EvVarDest ev + , ctev_nosh = WDeriv + , ctev_loc = loc } + , cc_occ = getOccName ev + , cc_hole = hole } + +---------------------------------------------- +-- Cloning constraints +---------------------------------------------- + +cloneWanted :: Ct -> TcM Ct +cloneWanted ct + | ev@(CtWanted { ctev_dest = HoleDest old_hole, ctev_pred = pty }) <- ctEvidence ct + = do { co_hole <- newCoercionHole (ch_blocker old_hole) pty + ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) } + | otherwise + = return 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 } + +emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM () +-- Emit some new derived nominal equalities +emitDerivedEqs origin pairs + | null pairs + = return () + | otherwise + = do { loc <- getCtLocM origin Nothing + ; emitSimples (listToBag (map (mk_one loc) pairs)) } + where + mk_one loc (ty1, ty2) + = mkNonCanonical $ + CtDerived { ctev_pred = mkPrimEqPred ty1 ty2 + , ctev_loc = loc } + +-- | Emits a new equality constraint +emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion +emitWantedEq origin t_or_k role ty1 ty2 + = do { hole <- newCoercionHole YesBlockSubst pty + ; loc <- getCtLocM origin (Just t_or_k) + ; emitSimple $ mkNonCanonical $ + CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole + , ctev_nosh = WDeriv, ctev_loc = loc } + ; 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_nosh = WDeriv + , ctev_loc = loc } + ; emitSimple $ mkNonCanonical ctev + ; return new_cv } + +emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar] +emitWantedEvVars orig = mapM (emitWantedEvVar orig) + +newDict :: Class -> [TcType] -> TcM DictId +newDict cls tys + = do { name <- newSysName (mkDictOcc (getOccName cls)) + ; return (mkLocalId name (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 :: BlockSubstFlag -- should the presence of this hole block substitution? + -- See sub-wrinkle in TcCanonical + -- Note [Equalities with incompatible kinds] + -> TcPredType -> TcM CoercionHole +newCoercionHole blocker pred_ty + = do { co_var <- newEvVar pred_ty + ; traceTc "New coercion hole:" (ppr co_var <+> ppr blocker) + ; ref <- newMutVar Nothing + ; return $ CoercionHole { ch_co_var = co_var, ch_blocker = blocker + , 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 { +#if defined(DEBUG) + ; cts <- readTcRef ref + ; whenIsJust cts $ \old_co -> + pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co) +#endif + ; 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 $ + ASSERT2( 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 + +{- +************************************************************************ +* + Expected types +* +************************************************************************ + +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. +And, because there is only one branch of the case, we won't trigger +Note [Case branches must never infer a non-tau type] of GHC.Tc.Gen.Match. +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. This is triggered in +test gadt/gadt-escape1. + +-} + +-- actual data definition is in GHC.Tc.Utils.TcType + +newInferExpType :: TcM ExpType +newInferExpType + = 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 })) } + +-- | 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 + +-- | 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 _ = 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) + +tauifyExpType :: ExpType -> TcM ExpType +-- ^ Turn a (Infer hole) type into a (Check alpha), +-- where alpha is a fresh unification variable +tauifyExpType (Check ty) = return (Check ty) -- No-op for (Check ty) +tauifyExpType (Infer inf_res) = do { ty <- inferResultToType inf_res + ; return (Check 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 }) + = do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy + ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr) + -- See Note [TcLevel of ExpType] + ; writeMutVar ref (Just tau) + ; traceTc "Forcing ExpType to be monomorphic:" + (ppr u <+> text ":=" <+> ppr tau) + ; return tau } + + +{- ********************************************************************* +* * + SkolemTvs (immutable) +* * +********************************************************************* -} + +tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar])) + -- ^ How to instantiate the type variables + -> Id -- ^ Type to instantiate + -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result + -- (type vars, preds (incl equalities), rho) +tcInstType inst_tyvars id + = case tcSplitForAllTys (idType id) of + ([], rho) -> let -- There may be overloading despite no type variables; + -- (?x :: Int) => Int -> Int + (theta, tau) = tcSplitPhiTy rho + in + return ([], theta, tau) + + (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars + ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho) + tv_prs = map tyVarName tyvars `zip` tyvars' + ; return (tv_prs, theta, tau) } + +tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType) +-- Instantiate a type signature with skolem constants. +-- We could give them fresh names, but no need to do so +tcSkolDFunType dfun + = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun + ; return (map snd tv_prs, theta, tau) } + +tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar]) +-- Make skolem constants, but do *not* give them new names, as above +-- Moreover, make them "super skolems"; see comments with superSkolemTv +-- see Note [Kind substitution when instantiating] +-- Precondition: tyvars should be ordered by scoping +tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst + +tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar) +tcSuperSkolTyVar subst tv + = (extendTvSubstWithClone subst tv new_tv, new_tv) + where + kind = substTyUnchecked subst (tyVarKind tv) + new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv + +-- | Given a list of @['TyVar']@, skolemize the type variables, +-- returning a substitution mapping the original tyvars to the +-- skolems, and the list of newly bound skolems. +tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +-- See Note [Skolemising type variables] +tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst + +tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +-- See Note [Skolemising type variables] +tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False + +tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +-- See Note [Skolemising type variables] +tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst + +tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +-- See Note [Skolemising type variables] +tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst + +tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar] + -> TcM (TCvSubst, [TcTyVar]) +-- Skolemise one level deeper, hence pushTcLevel +-- See Note [Skolemising type variables] +tcInstSkolTyVarsPushLevel overlappable subst tvs + = do { tc_lvl <- getTcLevel + ; let pushed_lvl = pushTcLevel tc_lvl + ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs } + +tcInstSkolTyVarsAt :: TcLevel -> Bool + -> TCvSubst -> [TyVar] + -> TcM (TCvSubst, [TcTyVar]) +tcInstSkolTyVarsAt lvl overlappable subst tvs + = freshenTyCoVarsX new_skol_tv subst tvs + where + details = SkolemTv lvl overlappable + new_skol_tv name kind = mkTcTyVar name kind details + +------------------ +freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar]) +-- ^ Give fresh uniques to a bunch of TyVars, but they stay +-- as TyVars, rather than becoming TcTyVars +-- Used in GHC.Tc.Instance.Family.newFamInst, and Inst.newClsInst +freshenTyVarBndrs = freshenTyCoVars mkTyVar + +freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar]) +-- ^ Give fresh uniques to a bunch of CoVars +-- Used in GHC.Tc.Instance.Family.newFamInst +freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst + +------------------ +freshenTyCoVars :: (Name -> Kind -> TyCoVar) + -> [TyVar] -> TcM (TCvSubst, [TyCoVar]) +freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst + +freshenTyCoVarsX :: (Name -> Kind -> TyCoVar) + -> TCvSubst -> [TyCoVar] + -> TcM (TCvSubst, [TyCoVar]) +freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv) + +freshenTyCoVarX :: (Name -> Kind -> TyCoVar) + -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar) +-- This a complete freshening operation: +-- the skolems have a fresh unique, and a location from the monad +-- See Note [Skolemising type variables] +freshenTyCoVarX mk_tcv subst tycovar + = do { loc <- getSrcSpanM + ; uniq <- newUnique + ; let old_name = tyVarName tycovar + new_name = mkInternalName uniq (getOccName old_name) loc + new_kind = substTyUnchecked subst (tyVarKind tycovar) + new_tcv = mk_tcv new_name new_kind + subst1 = extendTCvSubstWithClone subst tycovar new_tcv + ; return (subst1, new_tcv) } + +{- Note [Skolemising type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The tcInstSkolTyVars family of functions instantiate a list of TyVars +to fresh skolem TcTyVars. Important notes: + +a) Level allocation. We generally skolemise /before/ calling + pushLevelAndCaptureConstraints. So we want their level to the level + of the soon-to-be-created implication, which has a level ONE HIGHER + than the current level. Hence the pushTcLevel. It feels like a + slight hack. + +b) The [TyVar] should be ordered (kind vars first) + See Note [Kind substitution when instantiating] + +c) It's a complete freshening operation: the skolems have a fresh + unique, and a location from the monad + +d) The resulting skolems are + non-overlappable for tcInstSkolTyVars, + but overlappable for tcInstSuperSkolTyVars + See GHC.Tc.Deriv.Infer Note [Overlap and deriving] for an example + of where this matters. + +Note [Kind substitution when instantiating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we instantiate a bunch of kind and type variables, first we +expect them to be topologically sorted. +Then we have to instantiate the kind variables, build a substitution +from old variables to the new variables, then instantiate the type +variables substituting the original kind. + +Exemple: If we want to instantiate + [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)] +we want + [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)] +instead of the buggous + [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)] + + +************************************************************************ +* * + MetaTvs (meta type variables; mutable) +* * +************************************************************************ +-} + +{- +Note [TyVarTv] +~~~~~~~~~~~~ + +A TyVarTv can unify with type *variables* only, including other TyVarTvs and +skolems. 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 (say, with a call to findDubTyVarTvs). + +Before #15050 this (under the name SigTv) was 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). + +The remaining uses of newTyVarTyVars are +* In kind signatures, see + GHC.Tc.TyCl Note [Inferring kinds for type declarations] + and Note [Kind checking for GADTs] +* In partial type signatures, see Note [Quantified variables in partial type signatures] +-} + +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" + FlatMetaTv -> fsLit "fmv" + FlatSkolTv -> fsLit "fsk" + TyVarTv -> fsLit "a" + +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 :: Name -> Kind -> TcM TcTyVar +newSkolemTyVar name kind + = do { lvl <- getTcLevel + ; return (mkTcTyVar name kind (SkolemTv 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 } + +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 } + +newFskTyVar :: TcType -> TcM TcTyVar +newFskTyVar fam_ty + = do { details <- newMetaDetails FlatSkolTv + ; name <- newMetaTyVarName (fsLit "fsk") + ; return (mkTcTyVar name (tcTypeKind fam_ty) details) } + +newFmvTyVar :: TcType -> TcM TcTyVar +-- Very like newMetaTyVar, except sets mtv_tclvl to one less +-- so that the fmv is untouchable. +newFmvTyVar fam_ty + = do { details <- newMetaDetails FlatMetaTv + ; name <- newMetaTyVarName (fsLit "s") + ; return (mkTcTyVar name (tcTypeKind fam_ty) details) } + +newMetaDetails :: MetaInfo -> TcM TcTyVarDetails +newMetaDetails info + = do { ref <- newMutVar Flexi + ; tclvl <- getTcLevel + ; return (MetaTv { mtv_info = info + , 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 = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) + readMutVar (metaTyVarRef tyvar) + +isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type) +isFilledMetaTyVar_maybe 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 :: 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) + = ASSERT2( False, text "Writing to non-tc tyvar" <+> ppr tyvar ) + return () + + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar + = writeMetaTyVarRef tyvar ref ty + + | otherwise + = ASSERT2( False, text "Writing to non-meta tyvar" <+> ppr tyvar ) + return () + +-------------------- +writeMetaTyVarRef :: 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 + | otherwise + = do { meta_details <- readMutVar ref; + -- Zonk kinds to allow the error check to work + ; zonked_tv_kind <- zonkTcType tv_kind + ; zonked_ty_kind <- zonkTcType ty_kind + ; let kind_check_ok = tcIsConstraintKind zonked_tv_kind + || tcEqKind zonked_ty_kind zonked_tv_kind + -- Hack alert! tcIsConstraintKind: see GHC.Tc.Gen.HsType + -- Note [Extra-constraint holes in partial type signatures] + + 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 + ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details ) + + -- Check for level OK + -- See Note [Level check when unifying] + ; MASSERT2( level_check_ok, level_check_msg ) + + -- Check Kinds ok + ; MASSERT2( kind_check_ok, kind_msg ) + + -- Do the write + ; writeMutVar ref (Indirect ty) } + where + tv_kind = tyVarKind tyvar + ty_kind = tcTypeKind ty + + tv_lvl = tcTyVarLevel tyvar + ty_lvl = tcTypeLevel ty + + level_check_ok = not (ty_lvl `strictlyDeeperThan` tv_lvl) + level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty + + double_upd_msg details = hang (text "Double update of meta tyvar") + 2 (ppr tyvar $$ ppr details) + +{- Note [Level check when unifying] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When unifying + alpha:lvl := ty +we expect that the TcLevel of 'ty' will be <= lvl. +However, during unflatting we do + fuv:l := ty:(l+1) +which is usually wrong; hence the check isFmmvTyVar in level_check_ok. +See Note [TcLevel assignment] in GHC.Tc.Utils.TcType. +-} + +{- +% Generating fresh variables for pattern match check +-} + + +{- +************************************************************************ +* * + 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! +-} + + +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 (tYPE 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 { kind <- newOpenTypeKind + ; newFlexiTyVarTy kind } + +newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [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 emptyTCvSubst + -- emptyTCvSubst 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 :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +-- Just like newMetaTyVars, but start with an existing substitution. +newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst + +newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +-- Make a new unification variable tyvar whose Name and Kind come from +-- an existing TyVar. We substitute kind variables in the kind. +newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar + +newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst + +newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +-- Just like newMetaTyVarX, but make a TyVarTv +newMetaTyVarTyVarX subst tyvar = new_meta_tv_x TyVarTv subst tyvar + +newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, 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 -> TCvSubst -> TyVar -> TcM (TCvSubst, 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 tcInferApps + -- 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 { ref <- newMutVar Flexi + ; name <- newMetaTyVarName (fsLit "p") + ; let details = MetaTv { mtv_info = TauTv + , mtv_ref = ref + , mtv_tclvl = tc_lvl } + ; 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'). + +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 ]) + + +candidateKindVars :: CandidatesQTvs -> TyVarSet +candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) + +partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (DTyVarSet, CandidatesQTvs) +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 = extracted_kvs `unionDVarSet` extracted_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 + +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 } + +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 _ tys) = foldlM go dv tys + go dv (FunTy _ arg res) = foldlM go dv [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 } + + ----------------- + 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 ofor quantification] + + | 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 _ co1 co2) = foldlM go_co dv [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 (NthCo _ _ 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_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 of 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 and untouchable type variables] +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 + :: 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 dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs }) + -- short-circuit common case + | isEmptyDVarSet dep_tkvs + , isEmptyDVarSet nondep_tkvs + = do { traceTc "quantifyTyVars has nothing to quantify" empty + ; return [] } + + | otherwise + = do { traceTc "quantifyTyVars 1" (ppr dvs) + + ; let dep_kvs = scopedSort $ dVarSetElems dep_tkvs + -- scopedSort: put the kind variables into + -- well-scoped order. + -- E.g. [k, (a::k)] not the other way round + + nondep_tvs = dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs) + -- 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 zonked by zonkTyCoVarsAndFV + + -- In the non-PolyKinds case, default the kind variables + -- to *, and zonk the tyvars as usual. Notice that this + -- may make quantifyTyVars return a shorter list + -- than it was passed, but that's ok + ; poly_kinds <- xoptM LangExt.PolyKinds + ; dep_kvs' <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs + ; nondep_tvs' <- mapMaybeM (zonk_quant False) nondep_tvs + ; let final_qtvs = dep_kvs' ++ nondep_tvs' + -- Because of the order, any kind variables + -- mentioned in the kinds of the nondep_tvs' + -- now refer to the dep_kvs' + + ; traceTc "quantifyTyVars 2" + (vcat [ text "nondep:" <+> pprTyVars nondep_tvs + , text "dep:" <+> pprTyVars dep_kvs + , text "dep_kvs'" <+> pprTyVars dep_kvs' + , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ]) + + -- We should never quantify over coercion variables; check this + ; let co_vars = filter isCoVar final_qtvs + ; MASSERT2( 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 + -- * Kind variables, with -XNoPolyKinds: don't quantify over these + -- * RuntimeRep variables: we never quantify over these + zonk_quant default_kind 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 + + | not (isTcTyVar tkv) + = return (Just tkv) -- For associated types in a class with a standalone + -- kind signature, we have the class variables in + -- scope, and they are TyVars not TcTyVars + | otherwise + = do { deflt_done <- defaultTyVar default_kind tkv + ; case deflt_done of + True -> return Nothing + False -> do { tv <- skolemiseQuantifiedTyVar tkv + ; return (Just tv) } } + +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 :: 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 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 <- zonkTcTyVarToTyVar tyvar + ; skolemiseQuantifiedTyVar zonked_tyvar } + + | otherwise + = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar ) + zonkTyCoVarKind tyvar + +skolemiseQuantifiedTyVar :: 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 tv + = case tcTyVarDetails tv of + SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv) + ; return (setTyVarKind tv kind) } + -- It might be a skolem type variable, + -- for example from a user type signature + + MetaTv {} -> skolemiseUnboundMetaTyVar tv + + _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk + +defaultTyVar :: Bool -- True <=> please default this kind variable to * + -> TcTyVar -- If it's a MetaTyVar then it is unbound + -> TcM Bool -- True <=> defaulted away altogether + +defaultTyVar default_kind tv + | not (isMetaTyVar tv) + = return False + + | isTyVarTyVar tv + -- Do not default TyVarTvs. Doing so would violate the invariants + -- on TyVarTvs; see Note [Signature skolems] in GHC.Tc.Utils.TcType. + -- #13343 is an example; #14555 is another + -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + = return False + + + | isRuntimeRepVar tv -- Do not quantify over a RuntimeRep var + -- unless it is a TyVarTv, handled earlier + = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) + ; writeMetaTyVar tv liftedRepTy + ; return True } + + | default_kind -- -XNoPolyKinds and this is a kind var + = default_kind_var tv -- so default it to * if possible + + | otherwise + = return False + + where + 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 (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 + +skolemiseUnboundMetaTyVar :: 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] +skolemiseUnboundMetaTyVar tv + = ASSERT2( isMetaTyVar tv, ppr tv ) + do { when debugIsOn (check_empty tv) + ; here <- getSrcSpanM -- Get the location from "here" + -- ie 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 + final_tv = mkTcTyVar final_name kind details + + ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) + ; writeMetaTyVar tv (mkTyVarTy final_tv) + ; return final_tv } + + where + details = SkolemTv (metaTyVarTcLevel tv) False + check_empty tv -- [Sept 04] Check for non-empty. + = when debugIsOn $ -- See note [Silly Type Synonym] + do { cts <- readMetaTyVar tv + ; case cts of + Flexi -> return () + Indirect ty -> WARN( True, ppr tv $$ ppr ty ) + return () } + +{- 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 () + +************************************************************************ +* * + 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 = ASSERT2( 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' <- zonkSkolemInfo info + ; wanted' <- zonkWCRec wanted + ; return (implic { ic_skols = skols' + , ic_given = given' + , ic_wanted = wanted' + , ic_info = info' }) } + +zonkEvVar :: EvVar -> TcM EvVar +zonkEvVar var = do { ty' <- zonkTcType (varType var) + ; return (setVarType var ty') } + + +zonkWC :: WantedConstraints -> TcM WantedConstraints +zonkWC wc = zonkWCRec wc + +zonkWCRec :: WantedConstraints -> TcM WantedConstraints +zonkWCRec (WC { wc_simple = simple, wc_impl = implic }) + = do { simple' <- zonkSimples simple + ; implic' <- mapBagM zonkImplication implic + ; return (WC { wc_simple = simple', wc_impl = implic' }) } + +zonkSimples :: Cts -> TcM Cts +zonkSimples cts = do { cts' <- mapBagM zonkCt cts + ; traceTc "zonkSimples done:" (ppr cts') + ; return cts' } + +{- Note [zonkCt behaviour] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +zonkCt tries to maintain the canonical form of a Ct. For example, + - a CDictCan should stay a CDictCan; + - a CHoleCan should stay a CHoleCan + - a CIrredCan should stay a CIrredCan with its cc_status flag intact + +Why?, for example: +- 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 CHoleCan, once we forget that it's a hole, we can never recover that info. + +- For CIrredCan we want to see if a constraint is insoluble with insolubleWC + +On the other hand, we change CTyEqCan to CNonCanonical, because of all of +CTyEqCan's invariants, which can break during zonking. Besides, the constraint +will be canonicalised again, so there is little benefit in keeping the +CTyEqCan structure. + +NB: we do not expect to see any CFunEqCans, because zonkCt is only +called on unflattened constraints. + +NB: Constraints are always re-flattened 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/ function free. +-} + +zonkCt :: Ct -> TcM Ct +-- See Note [zonkCt behaviour] +zonkCt ct@(CHoleCan { cc_ev = ev }) + = do { ev' <- zonkCtEvidence ev + ; return $ ct { cc_ev = ev' } } + +zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args }) + = do { ev' <- zonkCtEvidence ev + ; args' <- mapM zonkTcType args + ; return $ ct { cc_ev = ev', cc_tyargs = args' } } + +zonkCt (CTyEqCan { cc_ev = ev }) + = mkNonCanonical <$> zonkCtEvidence ev + +zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_status flag + = do { ev' <- zonkCtEvidence ev + ; return (ct { cc_ev = ev' }) } + +zonkCt ct + = ASSERT( not (isCFunEqCan ct) ) + -- We do not expect to see any CFunEqCans, because zonkCt is only called on + -- unflattened constraints. + do { fl' <- zonkCtEvidence (ctEvidence ct) + ; return (mkNonCanonical fl') } + +zonkCtEvidence :: CtEvidence -> TcM CtEvidence +zonkCtEvidence ctev@(CtGiven { ctev_pred = pred }) + = do { pred' <- zonkTcType pred + ; return (ctev { ctev_pred = pred'}) } +zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest }) + = do { pred' <- zonkTcType pred + ; let dest' = case dest of + EvVarDest ev -> EvVarDest $ setVarType ev pred' + -- necessary in simplifyInfer + HoleDest h -> HoleDest h + ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) } +zonkCtEvidence ctev@(CtDerived { ctev_pred = pred }) + = do { pred' <- zonkTcType pred + ; return (ctev { ctev_pred = pred' }) } + +zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo +zonkSkolemInfo (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty + ; return (SigSkol cx ty' tv_prs) } +zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys + ; return (InferSkol ntys') } + where + do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } +zonkSkolemInfo skol_info = return skol_info + +{- +%************************************************************************ +%* * +\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar} +* * +* For internal use only! * +* * +************************************************************************ + +-} + +-- 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 + | tcTyConIsPoly tc = return tc + | otherwise = do { tck' <- zonkTcType (tyConKind tc) + ; return (setTcTyConKind tc tck') } + +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 +zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar +zonkTcTyVarToTyVar tv + = do { ty <- zonkTcTyVar tv + ; let tv' = case tcGetTyVar_maybe ty of + Just tv' -> tv' + Nothing -> pprPanic "zonkTcTyVarToTyVar" + (ppr tv $$ ppr ty) + ; return tv' } + +zonkTyVarTyVarPairs :: [(Name,TcTyVar)] -> TcM [(Name,TcTyVar)] +zonkTyVarTyVarPairs prs + = mapM do_one prs + where + do_one (nm, tv) = do { tv' <- zonkTcTyVarToTyVar tv + ; return (nm, tv') } + +-- zonkId is used *during* typechecking just to zonk the Id's type +zonkId :: TcId -> TcM TcId +zonkId id + = do { ty' <- zonkTcType (idType id) + ; return (Id.setIdType id ty') } + +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 <- zonkSkolemInfo skol_info + ; let skol_info2 = tidySkolemInfo env skol_info1 + ; return (env, GivenOrigin skol_info2) } +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 m_ty2 orig t_or_k) + = do { (env1, ty1') <- zonkTidyTcType env ty1 + ; (env2, m_ty2') <- case m_ty2 of + Just ty2 -> second Just <$> zonkTidyTcType env1 ty2 + Nothing -> return (env1, Nothing) + ; (env3, orig') <- zonkTidyOrigin env2 orig + ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) } +zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2) + = do { (env1, p1') <- zonkTidyTcType env p1 + ; (env2, p2') <- zonkTidyTcType env1 p2 + ; return (env2, 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 orig = return (env, orig) + +---------------- +tidyCt :: TidyEnv -> Ct -> Ct +-- Used only in error reporting +tidyCt env ct + = ct { cc_ev = tidy_ev env (ctEvidence ct) } + where + tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence + -- NB: we do not tidy the ctev_evar field because we don't + -- show it in error messages + tidy_ev env ctev@(CtGiven { ctev_pred = pred }) + = ctev { ctev_pred = tidyType env pred } + tidy_ev env ctev@(CtWanted { ctev_pred = pred }) + = ctev { ctev_pred = tidyType env pred } + tidy_ev env ctev@(CtDerived { ctev_pred = pred }) + = ctev { ctev_pred = tidyType env pred } + +---------------- +tidyEvVar :: TidyEnv -> EvVar -> EvVar +tidyEvVar env var = setVarType var (tidyType env (varType var)) + +---------------- +tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo +tidySkolemInfo env (DerivSkol ty) = DerivSkol (tidyType env ty) +tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs +tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) +tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) +tidySkolemInfo _ info = info + +tidySigSkol :: TidyEnv -> UserTypeCtxt + -> TcType -> [(Name,TcTyVar)] -> SkolemInfo +-- We need to take special care when tidying SigSkol +-- See Note [SigSkol SkolemInfo] in Origin +tidySigSkol env cx ty tv_prs + = SigSkol cx (tidy_ty env ty) tv_prs' + where + tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs + inst_env = mkNameEnv tv_prs' + + tidy_ty env (ForAllTy (Bndr tv vis) ty) + = ForAllTy (Bndr tv' vis) (tidy_ty env' ty) + where + (env', tv') = tidy_tv_bndr env tv + + tidy_ty env ty@(FunTy _ arg res) + = ty { ft_arg = tidyType env arg, ft_res = tidy_ty env res } + + tidy_ty env ty = tidyType env ty + + tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) + tidy_tv_bndr env@(occ_env, subst) tv + | Just tv' <- lookupNameEnv inst_env (tyVarName tv) + = ((occ_env, extendVarEnv subst tv tv'), tv') + + | otherwise + = tidyVarBndr env tv + +------------------------------------------------------------------------- +{- +%************************************************************************ +%* * + Levity polymorphism checks +* * +************************************************************************* + +See Note [Levity polymorphism checking] in GHC.HsToCore.Monad + +-} + +-- | According to the rules around representation polymorphism +-- (see https://gitlab.haskell.org/ghc/ghc/wikis/no-sub-kinds), no binder +-- can have a representation-polymorphic type. This check ensures +-- that we respect this rule. It is a bit regrettable that this error +-- occurs in zonking, after which we should have reported all errors. +-- But it's hard to see where else to do it, because this can be discovered +-- only after all solving is done. And, perhaps most importantly, this +-- isn't really a compositional property of a type system, so it's +-- not a terrible surprise that the check has to go in an awkward spot. +ensureNotLevPoly :: Type -- its zonked type + -> SDoc -- where this happened + -> TcM () +ensureNotLevPoly ty doc + = whenNoErrs $ -- sometimes we end up zonking bogus definitions of type + -- forall a. a. See, for example, test ghci/scripts/T9140 + checkForLevPoly doc ty + + -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad +checkForLevPoly :: SDoc -> Type -> TcM () +checkForLevPoly = checkForLevPolyX addErr + +checkForLevPolyX :: Monad m + => (SDoc -> m ()) -- how to report an error + -> SDoc -> Type -> m () +checkForLevPolyX add_err extra ty + | isTypeLevPoly ty + = add_err (formatLevPolyErr ty $$ extra) + | otherwise + = return () + +formatLevPolyErr :: Type -- levity-polymorphic type + -> SDoc +formatLevPolyErr ty + = hang (text "A levity-polymorphic type is not allowed here:") + 2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty + , text "Kind:" <+> pprWithTYPE tidy_ki ]) + where + (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty + tidy_ki = tidyType tidy_env (tcTypeKind ty) + +{- +%************************************************************************ +%* * + 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' <- mapM zonkTcTyVarToTyVar $ + 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) + doc = 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, doc) } diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -0,0 +1,2306 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, DeriveFunctor, MultiWayIf, TupleSections, + ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Type subsumption and unification +module GHC.Tc.Utils.Unify ( + -- Full-blown subsumption + tcWrapResult, tcWrapResultO, tcSkolemise, tcSkolemiseET, + tcSubTypeHR, tcSubTypeO, tcSubType_NC, tcSubTypeDS, + tcSubTypeDS_NC_O, tcSubTypePat, + checkConstraints, checkTvConstraints, + buildImplicationFor, emitResidualTvConstraint, + + -- Various unifications + unifyType, unifyKind, + uType, promoteTcType, + swapOverTyVars, canSolveByUnification, + + -------------------------------- + -- Holes + tcInfer, + matchExpectedListTy, + matchExpectedTyConApp, + matchExpectedAppTy, + matchExpectedFunTys, + matchActualFunTys, matchActualFunTysPart, + matchExpectedFunKind, + + metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..) + + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr( debugPprType ) +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Types.Name( isSystemName ) +import GHC.Tc.Utils.Instantiate +import GHC.Core.TyCon +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim( tYPE ) +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.Utils.Misc +import qualified GHC.LanguageExtensions as LangExt +import GHC.Utils.Outputable as Outputable + +import Data.Maybe( isNothing ) +import Control.Monad +import Control.Arrow ( second ) + +{- +************************************************************************ +* * + 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. + +-} + +-- Use this one when you have an "expected" type. +matchExpectedFunTys :: forall a. + SDoc -- See Note [Herald for matchExpectedFunTys] + -> Arity + -> ExpRhoType -- deeply skolemised + -> ([ExpSigmaType] -> ExpRhoType -> TcM a) + -- must fill in these ExpTypes here + -> TcM (a, HsWrapper) +-- 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 arity orig_ty thing_inside + = case orig_ty of + Check ty -> go [] arity ty + _ -> defer [] arity orig_ty + where + go acc_arg_tys 0 ty + = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType ty) + ; return (result, idHsWrapper) } + + go acc_arg_tys n ty + | Just ty' <- tcView ty = go acc_arg_tys n ty' + + go acc_arg_tys n (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) + = ASSERT( af == VisArg ) + do { (result, wrap_res) <- go (mkCheckExpType arg_ty : acc_arg_tys) + (n-1) res_ty + ; return ( result + , mkWpFun idHsWrapper wrap_res arg_ty res_ty doc ) } + where + doc = text "When inferring the argument type of a function with type" <+> + quotes (ppr orig_ty) + + 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 :: [ExpSigmaType] -> Arity -> ExpRhoType -> TcM (a, HsWrapper) + defer acc_arg_tys n fun_ty + = do { more_arg_tys <- replicateM n newInferExpType + ; res_ty <- newInferExpType + ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty + ; more_arg_tys <- mapM readExpType more_arg_tys + ; res_ty <- readExpType res_ty + ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty + ; wrap <- tcSubTypeDS AppOrigin GenSigCtxt unif_fun_ty fun_ty + -- Not a good origin at all :-( + ; return (result, wrap) } + + ------------ + mk_ctxt :: [ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) + mk_ctxt arg_tys res_ty env + = do { (env', ty) <- zonkTidyTcType env (mkVisFunTys arg_tys' res_ty) + ; return ( env', mk_fun_tys_msg herald ty arity) } + where + arg_tys' = map (checkingExpType "matchExpectedFunTys") (reverse arg_tys) + -- this is safe b/c we're called from "go" + +-- Like 'matchExpectedFunTys', but used when you have an "actual" type, +-- for example in function application +matchActualFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys] + -> CtOrigin + -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType + -> Arity + -> TcSigmaType + -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) +-- If matchActualFunTys n ty = (wrap, [t1,..,tn], ty_r) +-- then wrap : ty ~> (t1 -> ... -> tn -> ty_r) +matchActualFunTys herald ct_orig mb_thing n_val_args_wanted fun_ty + = matchActualFunTysPart herald ct_orig mb_thing + n_val_args_wanted [] + n_val_args_wanted fun_ty + +-- | Variant of 'matchActualFunTys' that works when supplied only part +-- (that is, to the right of some arrows) of the full function type +matchActualFunTysPart + :: SDoc -- See Note [Herald for matchExpectedFunTys] + -> CtOrigin + -> Maybe (HsExpr GhcRn) -- The thing with type TcSigmaType + -> Arity -- Total number of value args in the call + -> [TcSigmaType] -- Types of values args to which function has + -- been applied already (reversed) + -> Arity -- Number of new value args wanted + -> TcSigmaType -- Type to analyse + -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) +-- See Note [matchActualFunTys error handling] for all these arguments +matchActualFunTysPart herald ct_orig mb_thing + n_val_args_in_call arg_tys_so_far + n_val_args_wanted fun_ty + = go n_val_args_wanted arg_tys_so_far fun_ty +-- 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 + +-- (*) Sometimes it's necessary to call matchActualFunTys with only part +-- (that is, to the right of some arrows) of the type of the function in +-- question. (See GHC.Tc.Gen.Expr.tcArgs.) This argument is the reversed list of +-- arguments already seen (that is, not part of the TcSigmaType passed +-- in elsewhere). + + where + -- This function has a bizarre mechanic: it accumulates arguments on + -- the way down and also builds an argument list on the way up. Why: + -- 1. The returns args list and the accumulated args list might be different. + -- The accumulated args include all the arg types for the function, + -- including those from before this function was called. The returned + -- list should include only those arguments produced by this call of + -- matchActualFunTys + -- + -- 2. The HsWrapper can be built only on the way up. It seems (more) + -- bizarre to build the HsWrapper but not the arg_tys. + -- + -- Refactoring is welcome. + go :: Arity + -> [TcSigmaType] -- Types of value args to which the function has + -- been applied so far (reversed) + -- Used only for error messages + -> TcSigmaType -- the remainder of the type as we're processing + -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) + go 0 _ ty = return (idHsWrapper, [], ty) + + go n so_far ty + | not (null tvs && null theta) + = do { (wrap1, rho) <- topInstantiate ct_orig ty + ; (wrap2, arg_tys, res_ty) <- go n so_far rho + ; return (wrap2 <.> wrap1, arg_tys, res_ty) } + where + (tvs, theta, _) = tcSplitSigmaTy ty + + go n so_far ty + | Just ty' <- tcView ty = go n so_far ty' + + go n so_far (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) + = ASSERT( af == VisArg ) + do { (wrap_res, tys, ty_r) <- go (n-1) (arg_ty:so_far) res_ty + ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r doc + , arg_ty : tys, ty_r ) } + where + doc = text "When inferring the argument type of a function with type" <+> + quotes (ppr fun_ty) + + go n so_far ty@(TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty' -> go n so_far ty' + Flexi -> defer n 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 n so_far ty = addErrCtxtM (mk_ctxt so_far ty) (defer n ty) + + ------------ + defer n fun_ty + = do { arg_tys <- replicateM n newOpenFlexiTyVarTy + ; res_ty <- newOpenFlexiTyVarTy + ; let unif_fun_ty = mkVisFunTys arg_tys res_ty + ; co <- unifyType mb_thing fun_ty unif_fun_ty + ; return (mkWpCastN co, arg_tys, res_ty) } + + ------------ + mk_ctxt :: [TcType] -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) + mk_ctxt arg_tys res_ty env + = do { (env', ty) <- zonkTidyTcType env $ + mkVisFunTys (reverse arg_tys) res_ty + ; return (env', mk_fun_tys_msg herald ty n_val_args_in_call) } + +mk_fun_tys_msg :: SDoc -> TcType -> Arity -> SDoc +mk_fun_tys_msg herald ty n_args_in_call + | n_args_in_call <= n_fun_args -- Enough args, in the end + = text "In the result of a function call" + | otherwise + = hang (herald <+> speakNOf n_args_in_call (text "value argument") <> comma) + 2 (sep [ text "but its type" <+> quotes (pprType ty) + , if n_fun_args == 0 then text "has none" + else text "has only" <+> speakN n_fun_args]) + where + (args, _) = tcSplitFunTys ty + n_fun_args = length args + +{- Note [matchActualFunTys error handling] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +matchActualFunTysPart 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 konw 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! +-} + +---------------------- +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 + = ASSERT(tc /= funTyCon) go orig_ty + where + go ty + | Just ty' <- tcView ty + = go ty' + + go ty@(TyConApp tycon args) + | tc == tycon -- Common case + = return (mkTcNomReflCo 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' <- tcView ty = go ty' + + | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty + = return (mkTcNomReflCo 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 = tcTypeKind orig_ty + kind1 = mkVisFunTy liftedTypeKind orig_kind + kind2 = liftedTypeKind -- m :: * -> k + -- arg type :: * + +{- +************************************************************************ +* * + 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 coercion function + co_fn :: actual_ty ~ expected_ty +which takes an HsExpr of type actual_ty into one of type +expected_ty. + +These functions do not actually check for subsumption. They check if +expected_ty is an appropriate annotation to use for something of type +actual_ty. This difference matters when thinking about visible type +application. For example, + + forall a. a -> forall b. b -> b + DOES NOT SUBSUME + forall a b. a -> b -> b + +because the type arguments appear in a different order. (Neither does +it work the other way around.) BUT, these types are appropriate annotations +for one another. Because the user directs annotations, it's OK if some +arguments shuffle around -- after all, it's what the user wants. +Bottom line: none of this changes with visible type application. + +There are a number of wrinkles (below). + +Notice that Wrinkle 1 and 2 both require eta-expansion, which technically +may increase termination. We just put up with this, in exchange for getting +more predictable type inference. + +Wrinkle 1: Note [Deep skolemisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want (forall a. Int -> a -> a) <= (Int -> forall a. a->a) +(see section 4.6 of "Practical type inference for higher rank types") +So we must deeply-skolemise the RHS before we instantiate the LHS. + +That is why tc_sub_type starts with a call to tcSkolemise (which does the +deep skolemisation), and then calls the DS variant (which assumes +that expected_ty is deeply skolemised) + +Wrinkle 2: Note [Co/contra-variance of subsumption checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider g :: (Int -> Int) -> Int + f1 :: (forall a. a -> a) -> Int + f1 = g + + f2 :: (forall a. a -> a) -> Int + f2 x = g x +f2 will typecheck, and it would be odd/fragile if f1 did not. +But f1 will only typecheck if we have that + (Int->Int) -> Int <= (forall a. a->a) -> Int +And that is only true if we do the full co/contravariant thing +in the subsumption check. That happens in the FunTy case of +tcSubTypeDS_NC_O, and is the sole reason for the WpFun form of +HsWrapper. + +Another powerful reason for doing this co/contra stuff is visible +in #9569, involving instantiation of constraint variables, +and again involving eta-expansion. + +Wrinkle 3: Note [Higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider tc150: + f y = \ (x::forall a. a->a). blah +The following happens: +* We will infer the type of the RHS, ie with a res_ty = alpha. +* Then the lambda will split alpha := beta -> gamma. +* And then we'll check tcSubType IsSwapped beta (forall a. a->a) + +So it's important that we unify beta := forall a. a->a, rather than +skolemising the type. +-} + + +-- | Call this variant when you are in a higher-rank situation and +-- you know the right-hand type is deeply skolemised. +tcSubTypeHR :: CtOrigin -- ^ of the actual type + -> Maybe (HsExpr GhcRn) -- ^ If present, it has type ty_actual + -> TcSigmaType -> ExpRhoType -> TcM HsWrapper +tcSubTypeHR orig = tcSubTypeDS_NC_O orig GenSigCtxt + +------------------------ +tcSubTypePat :: CtOrigin -> UserTypeCtxt + -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper +-- If wrap = tc_sub_type_et t1 t2 +-- => wrap :: t1 ~> t2 +tcSubTypePat orig ctxt (Check ty_actual) ty_expected + = tc_sub_tc_type eq_orig orig ctxt ty_actual ty_expected + where + eq_orig = TypeEqOrigin { uo_actual = ty_expected + , uo_expected = ty_actual + , uo_thing = Nothing + , uo_visible = True } + +tcSubTypePat _ _ (Infer inf_res) ty_expected + = do { co <- fillInferResult ty_expected inf_res + -- In patterns we do not instantatiate + + ; return (mkWpCastN (mkTcSymCo co)) } + +------------------------ +tcSubTypeO :: CtOrigin -- ^ of the actual type + -> UserTypeCtxt -- ^ of the expected type + -> TcSigmaType + -> ExpRhoType + -> TcM HsWrapper +tcSubTypeO orig ctxt ty_actual ty_expected + = addSubTypeCtxt ty_actual ty_expected $ + do { traceTc "tcSubTypeDS_O" (vcat [ pprCtOrigin orig + , pprUserTypeCtxt ctxt + , ppr ty_actual + , ppr ty_expected ]) + ; tcSubTypeDS_NC_O orig ctxt Nothing 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 + -- might not be filled if we're debugging. ugh. + ; mb_ty_expected <- readExpType_maybe ty_expected + ; (tidy_env, ty_expected) <- case mb_ty_expected of + Just ty -> second mkCheckExpType <$> + zonkTidyTcType tidy_env ty + Nothing -> return (tidy_env, ty_expected) + ; ty_expected <- readExpType ty_expected + ; (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) } + +--------------- +-- The "_NC" variants do not add a typechecker-error context; +-- the caller is assumed to do that + +tcSubType_NC :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +-- Checks that actual <= expected +-- Returns HsWrapper :: actual ~ expected +tcSubType_NC ctxt ty_actual ty_expected + = do { traceTc "tcSubType_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) + ; tc_sub_tc_type origin origin ctxt ty_actual ty_expected } + where + origin = TypeEqOrigin { uo_actual = ty_actual + , uo_expected = ty_expected + , uo_thing = Nothing + , uo_visible = True } + +tcSubTypeDS :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> ExpRhoType -> TcM HsWrapper +-- Just like tcSubType, but with the additional precondition that +-- ty_expected is deeply skolemised (hence "DS") +tcSubTypeDS orig ctxt ty_actual ty_expected + = addSubTypeCtxt ty_actual ty_expected $ + do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) + ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected } + +tcSubTypeDS_NC_O :: CtOrigin -- origin used for instantiation only + -> UserTypeCtxt + -> Maybe (HsExpr GhcRn) + -> TcSigmaType -> ExpRhoType -> TcM HsWrapper +-- Just like tcSubType, but with the additional precondition that +-- ty_expected is deeply skolemised +tcSubTypeDS_NC_O inst_orig ctxt m_thing ty_actual ty_expected + = case ty_expected of + Infer inf_res -> instantiateAndFillInferResult inst_orig ty_actual inf_res + Check ty -> tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty + where + eq_orig = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty + , uo_thing = ppr <$> m_thing + , uo_visible = True } + +--------------- +tc_sub_tc_type :: CtOrigin -- used when calling uType + -> CtOrigin -- used when instantiating + -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +-- If wrap = tc_sub_type t1 t2 +-- => wrap :: t1 ~> t2 +tc_sub_tc_type eq_orig inst_orig ctxt ty_actual ty_expected + | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] + , not (possibly_poly ty_actual) + = do { traceTc "tc_sub_tc_type (drop to equality)" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + ; mkWpCastN <$> + uType TypeLevel eq_orig ty_actual ty_expected } + + | otherwise -- This is the general case + = do { traceTc "tc_sub_tc_type (general case)" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + ; (sk_wrap, inner_wrap) <- tcSkolemise ctxt ty_expected $ + \ _ sk_rho -> + tc_sub_type_ds eq_orig inst_orig ctxt + ty_actual sk_rho + ; return (sk_wrap <.> inner_wrap) } + where + possibly_poly ty + | isForAllTy ty = True + | Just (_, res) <- splitFunTy_maybe ty = possibly_poly res + | otherwise = False + -- NB *not* tcSplitFunTy, because here we want + -- to decompose type-class arguments too + + definitely_poly ty + | (tvs, theta, tau) <- tcSplitSigmaTy ty + , (tv:_) <- tvs + , null theta + , isInsolubleOccursCheck NomEq tv tau + = True + | otherwise + = False + +{- Note [Don't skolemise unnecessarily] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are trying to solve + (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. + +So roughly: + * if the ty_expected has an outermost forall + (i.e. skolemisation is the next thing we'd do) + * and the ty_actual has no top-level polymorphism (but looking deeply) +then we can revert to simple equality. But we need to be careful. +These examples are all fine: + + * (Char -> forall a. a->a) <= (forall a. Char -> a -> a) + Polymorphism is buried in ty_actual + + * (Char->Char) <= (forall a. Char -> Char) + ty_expected isn't really polymorphic + + * (Char->Char) <= (forall a. (a~Char) => a -> a) + ty_expected isn't really polymorphic + + * (Char->Char) <= (forall a. F [a] Char -> Char) + where type instance F [x] t = t + ty_expected isn't really polymorphic + +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 + * ty_expected is /definitely/ polymorphic +-} + +--------------- +tc_sub_type_ds :: CtOrigin -- used when calling uType + -> CtOrigin -- used when instantiating + -> UserTypeCtxt -> TcSigmaType -> TcRhoType -> 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 eq_orig 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 + go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e + | Just ty_e' <- tcView ty_e = go ty_a ty_e' + + go (TyVarTy tv_a) ty_e + = do { lookup_res <- lookupTcTyVar tv_a + ; case lookup_res of + Filled ty_a' -> + do { traceTc "tcSubTypeDS_NC_O following filled act meta-tyvar:" + (ppr tv_a <+> text "-->" <+> ppr ty_a') + ; tc_sub_type_ds eq_orig inst_orig ctxt ty_a' ty_e } + Unfilled _ -> unify } + + -- Historical note (Sept 16): there was a case here for + -- go ty_a (TyVarTy alpha) + -- which, in the impredicative case unified alpha := ty_a + -- where th_a is a polytype. Not only is this probably bogus (we + -- simply do not have decent story for impredicative types), but it + -- caused #12616 because (also bizarrely) 'deriving' code had + -- -XImpredicativeTypes on. I deleted the entire case. + + go (FunTy { ft_af = VisArg, ft_arg = act_arg, ft_res = act_res }) + (FunTy { ft_af = VisArg, ft_arg = exp_arg, ft_res = exp_res }) + = -- See Note [Co/contra-variance of subsumption checking] + do { res_wrap <- tc_sub_type_ds eq_orig inst_orig ctxt act_res exp_res + ; arg_wrap <- tc_sub_tc_type eq_orig given_orig GenSigCtxt exp_arg act_arg + -- GenSigCtxt: See Note [Setting the argument context] + ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res doc) } + -- arg_wrap :: exp_arg ~> act_arg + -- res_wrap :: act-res ~> exp_res + where + given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg []) + doc = text "When checking that" <+> quotes (ppr ty_actual) <+> + text "is more polymorphic than" <+> quotes (ppr ty_expected) + + 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 + (eq_orig { uo_actual = in_rho + , uo_expected = ty_expected }) + inst_orig ctxt in_rho ty_e + ; return (body_wrap <.> in_wrap) } + + | otherwise -- Revert to unification + = inst_and_unify + -- 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_and_unify = do { (wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual + + -- If we haven't recurred through an arrow, then + -- the eq_orig will list ty_actual. In this case, + -- we want to update the origin to reflect the + -- instantiation. If we *have* recurred through + -- an arrow, it's better not to update. + ; let eq_orig' = case eq_orig of + TypeEqOrigin { uo_actual = orig_ty_actual } + | orig_ty_actual `tcEqType` ty_actual + , not (isIdHsWrapper wrap) + -> eq_orig { uo_actual = rho_a } + _ -> eq_orig + + ; cow <- uType TypeLevel eq_orig' rho_a ty_expected + ; return (mkWpCastN cow <.> wrap) } + + + -- use versions without synonyms expanded + unify = mkWpCastN <$> uType TypeLevel eq_orig ty_actual ty_expected + +{- Note [Settting 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 GHC.Tc.Utils.Unify.alwaysBuildImplication checks the UserTypeCtxt. + See Note [When to build an implication] +-} + +----------------- +-- needs both un-type-checked (for origins) and type-checked (for wrapping) +-- expressions +tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType + -> TcM (HsExpr GhcTcId) +tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr + +-- | Sometimes we don't have a @HsExpr Name@ to hand, and this is more +-- convenient. +tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType + -> TcM (HsExpr GhcTcId) +tcWrapResultO orig rn_expr expr actual_ty res_ty + = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty + , text "Expected:" <+> ppr res_ty ]) + ; cow <- tcSubTypeDS_NC_O orig GenSigCtxt + (Just rn_expr) actual_ty res_ty + ; return (mkHsWrap cow expr) } + + +{- ********************************************************************** +%* * + ExpType functions: tcInfer, instantiateAndFillInferResult +%* * +%********************************************************************* -} + +-- | Infer a type using a fresh ExpType +-- See also Note [ExpType] in GHC.Tc.Utils.TcMType +tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) +tcInfer tc_check + = do { res_ty <- newInferExpType + ; result <- tc_check res_ty + ; res_ty <- readExpType res_ty + ; return (result, res_ty) } + +instantiateAndFillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper +-- If wrap = instantiateAndFillInferResult t1 t2 +-- => wrap :: t1 ~> t2 +-- See Note [Instantiation of InferResult] +instantiateAndFillInferResult orig ty inf_res + = do { (wrap, rho) <- deeplyInstantiate orig ty + ; co <- fillInferResult rho inf_res + ; return (mkWpCastN co <.> wrap) } + +fillInferResult :: TcType -> InferResult -> TcM TcCoercionN +-- If wrap = fillInferResult t1 t2 +-- => wrap :: t1 ~> t2 +fillInferResult orig_ty (IR { ir_uniq = u, ir_lvl = res_lvl + , ir_ref = ref }) + = do { (ty_co, ty_to_fill_with) <- promoteTcType res_lvl orig_ty + + ; traceTc "Filling ExpType" $ + ppr u <+> text ":=" <+> ppr ty_to_fill_with + + ; when debugIsOn (check_hole ty_to_fill_with) + + ; writeTcRef ref (Just ty_to_fill_with) + + ; return ty_co } + where + check_hole ty -- Debug check only + = do { let ty_lvl = tcTypeLevel ty + ; MASSERT2( not (ty_lvl `strictlyDeeperThan` res_lvl), + ppr u $$ ppr res_lvl $$ ppr ty_lvl $$ + ppr ty <+> dcolon <+> ppr (tcTypeKind ty) $$ ppr orig_ty ) + ; cts <- readTcRef ref + ; case cts of + Just already_there -> pprPanic "writeExpType" + (vcat [ ppr u + , ppr ty + , ppr already_there ]) + Nothing -> return () } + +{- 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. + +-} + +{- ********************************************************************* +* * + Promoting types +* * +********************************************************************* -} + +promoteTcType :: TcLevel -> TcType -> TcM (TcCoercion, TcType) +-- See Note [Promoting a type] +-- 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 +promoteTcType dest_lvl ty + = do { cur_lvl <- getTcLevel + ; if (cur_lvl `sameDepthAs` dest_lvl) + then dont_promote_it + 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 (tYPE 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) } + + dont_promote_it :: TcM (TcCoercion, TcType) + dont_promote_it -- Check that ty :: TYPE rr, for some (fresh) rr + = do { res_kind <- newOpenTypeKind + ; let ty_kind = tcTypeKind ty + kind_orig = TypeEqOrigin { uo_actual = ty_kind + , uo_expected = res_kind + , uo_thing = Nothing + , uo_visible = False } + ; ki_co <- uType KindLevel kind_orig (tcTypeKind ty) res_kind + ; let co = mkTcGReflRightCo Nominal ty ki_co + ; return (co, ty `mkCastTy` ki_co) } + +{- 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. +-} + +{- ********************************************************************* +* * + Generalisation +* * +********************************************************************* -} + +-- | Take an "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@. +tcSkolemise :: UserTypeCtxt -> TcSigmaType + -> ([TcTyVar] -> TcType -> TcM result) + -- ^ These are only ever used for scoped type variables. + -> TcM (HsWrapper, result) + -- ^ The expression has type: spec_ty -> expected_ty + +tcSkolemise ctxt expected_ty thing_inside + -- We expect expected_ty to be a forall-type + -- If not, the call is a no-op + = do { traceTc "tcSkolemise" Outputable.empty + ; (wrap, tv_prs, given, rho') <- deeplySkolemise expected_ty + + ; lvl <- getTcLevel + ; when debugIsOn $ + traceTc "tcSkolemise" $ vcat [ + ppr lvl, + text "expected_ty" <+> ppr expected_ty, + text "inst tyvars" <+> ppr tv_prs, + text "given" <+> ppr given, + text "inst type" <+> ppr rho' ] + + -- Generally we must check that the "forall_tvs" haven't been constrained + -- The interesting bit here is that we must include the free variables + -- of the expected_ty. Here's an example: + -- runST (newVar True) + -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool)) + -- for (newVar True), with s fresh. Then we unify with the runST's arg type + -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool. + -- So now s' isn't unconstrained because it's linked to a. + -- + -- However [Oct 10] now that the untouchables are a range of + -- TcTyVars, all this is handled automatically with no need for + -- extra faffing around + + ; let tvs' = map snd tv_prs + skol_info = SigSkol ctxt expected_ty tv_prs + + ; (ev_binds, result) <- checkConstraints skol_info tvs' given $ + thing_inside tvs' rho' + + ; 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 'tcSkolemise' that takes an ExpType +tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType + -> (ExpRhoType -> TcM result) + -> TcM (HsWrapper, result) +tcSkolemiseET _ et@(Infer {}) thing_inside + = (idHsWrapper, ) <$> thing_inside et +tcSkolemiseET ctxt (Check ty) thing_inside + = tcSkolemise ctxt ty $ \_ -> thing_inside . mkCheckExpType + +checkConstraints :: SkolemInfo + -> [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 tcCheckExpr, + -- which uses tcSkolemise 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 Nothing skol_tvs tclvl wanted + ; return result } + +emitResidualTvConstraint :: SkolemInfo -> Maybe SDoc -> [TcTyVar] + -> TcLevel -> WantedConstraints -> TcM () +emitResidualTvConstraint skol_info m_telescope skol_tvs tclvl wanted + | isEmptyWC wanted + , isNothing m_telescope || skol_tvs `lengthAtMost` 1 + -- If m_telescope is (Just d), we must do the bad-telescope check, + -- so we must /not/ discard the implication even if there are no + -- wanted constraints. See Note [Checking telescopes] in GHC.Tc.Types.Constraint. + -- Lacking this check led to #16247 + = return () + + | otherwise + = do { ev_binds <- newNoTcEvBinds + ; implic <- newImplication + ; let status | insolubleWC wanted = IC_Insoluble + | otherwise = IC_Unsolved + -- If the inner constraints are insoluble, + -- we should mark the outer one similarly, + -- so that insolubleWC works on the outer one + + ; emitImplication $ + implic { ic_status = status + , ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_no_eqs = True + , ic_telescope = m_telescope + , ic_wanted = wanted + , ic_binds = ev_binds + , ic_info = skol_info } } + +implicationNeeded :: SkolemInfo -> [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 :: SkolemInfo -> 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 -> SkolemInfo -> [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 + = ASSERT2( 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 } + + ; 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 [D] b1 ~ b2, even though the two functions have + literally nothing to do with each other. #14185 is an example. + Building an implication keeps them separage. +-} + +{- +************************************************************************ +* * + Boxy unification +* * +************************************************************************ + +The exported functions are all defined as versions of some +non-exported generic functions. +-} + +unifyType :: Maybe (HsExpr GhcRn) -- ^ If present, has type 'ty1' + -> TcTauType -> TcTauType -> TcM TcCoercionN +-- Actual and expected types +-- Returns a coercion : ty1 ~ ty2 +unifyType thing ty1 ty2 = traceTc "utype" (ppr ty1 $$ ppr ty2 $$ ppr thing) >> + uType TypeLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 + , uo_thing = ppr <$> thing + , uo_visible = True } -- always called from a visible context + +unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN +unifyKind thing ty1 ty2 = traceTc "ukind" (ppr ty1 $$ ppr ty2 $$ ppr thing) >> + uType KindLevel origin ty1 ty2 + where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 + , uo_thing = ppr <$> thing + , uo_visible = True } -- also always from a visible context + +--------------- + +{- +%************************************************************************ +%* * + 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] +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 <- lookupTcTyVar tv1 + ; case lookup_res of + Filled ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1) + ; go ty1 ty2 } + Unfilled _ -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 } + go ty1 (TyVarTy tv2) + = do { lookup_res <- lookupTcTyVar tv2 + ; case lookup_res of + Filled ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2) + ; go ty1 ty2 } + Unfilled _ -> 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' <- tcView ty1 = go ty1' ty2 + | Just ty2' <- tcView ty2 = go ty1 ty2' + + -- Functions (or predicate functions) just check the two parts + go (FunTy _ fun1 arg1) (FunTy _ fun2 arg2) + = do { co_l <- uType t_or_k origin fun1 fun2 + ; co_r <- uType t_or_k origin arg1 arg2 + ; return $ mkFunCo Nominal 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 + = ASSERT2( 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 (mustBeSaturated 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 (mustBeSaturated 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 (Just 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 <- tcGetTyVar_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 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 { dflags <- getDynFlags + ; cur_lvl <- getTcLevel + ; go dflags cur_lvl } + where + go dflags cur_lvl + | canSolveByUnification cur_lvl tv1 ty2 + , MTVU_OK ty2' <- metaTyVarUpdateOK dflags tv1 ty2 + = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2') (tyVarKind tv1) + ; traceTc "uUnfilledVar2 ok" $ + vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) + , ppr ty2 <+> dcolon <+> ppr (tcTypeKind ty2) + , ppr (isTcReflCo co_k), ppr co_k ] + + ; if isTcReflCo 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 (mkTcNomReflCo ty2') } + + else defer } -- This cannot be solved now. See GHC.Tc.Solver.Canonical + -- Note [Equalities with incompatible kinds] + + | otherwise + = 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 } + + ty1 = mkTyVarTy tv1 + kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k) + + defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2 + +swapOverTyVars :: TcTyVar -> TcTyVar -> Bool +swapOverTyVars tv1 tv2 + -- 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 +-- See Note [TyVar/TyVar orientation] +lhsPriority tv + = ASSERT2( isTyVar tv, ppr tv) + case tcTyVarDetails tv of + RuntimeUnk -> 0 + SkolemTv {} -> 0 + MetaTv { mtv_info = info } -> case info of + FlatSkolTv -> 1 + TyVarTv -> 2 + TauTv -> 3 + FlatMetaTv -> 4 +{- Note [TyVar/TyVar orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (a ~ b), should we orient the CTyEqCan 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 use + - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1 + - in the constraint solver, in GHC.Tc.Solver.Canonical.canEqTyVarHomo + +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.floatEqualities + looks for meta tyvars on the left + + Tie-breaking rules for MetaTvs: + - FlatMetaTv = 4: always put on the left. + See Note [Fmv Orientation Invariant] + + NB: FlatMetaTvs always have the current level, never an + outer one. So nothing can be deeper than a FlatMetaTv. + + - TauTv = 3: if we have tyv_tv ~ tau_tv, + put tau_tv on the left because there are fewer + restrictions on updating TauTvs. Or to say it another + way, then we won't lose the TyVarTv flag + + - TyVarTv = 2: remember, flat-skols are *only* updated by + the unflattener, never unified, so TyVarTvs come next + + - FlatSkolTv = 1: put on the left in preference to a SkolemTv. + See Note [Eliminate flat-skols] + +* Names. If the level and priority comparisons are all + equal, try to eliminate a TyVars 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 [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.Monad 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 [Fmv Orientation Invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * We always orient a constraint + fmv ~ alpha + with fmv on the left, even if alpha is + a touchable unification variable + +Reason: doing it the other way round would unify alpha:=fmv, but that +really doesn't add any info to alpha. But a later constraint alpha ~ +Int might unlock everything. Comment:9 of #12526 gives a detailed +example. + +WARNING: I've gone to and fro on this one several times. +I'm now pretty sure that unifying alpha:=fmv is a bad idea! +So orienting with fmvs on the left is a good thing. + +This example comes from IndTypesPerfMerge. (Others include +T10226, T10009.) + From the ambiguity check for + f :: (F a ~ a) => a + we get: + [G] F a ~ a + [WD] F alpha ~ alpha, alpha ~ a + + From Givens we get + [G] F a ~ fsk, fsk ~ a + + Now if we flatten we get + [WD] alpha ~ fmv, F alpha ~ fmv, alpha ~ a + + Now, if we unified alpha := fmv, we'd get + [WD] F fmv ~ fmv, [WD] fmv ~ a + And now we are stuck. + +So instead the Fmv Orientation Invariant puts the fmv on the +left, giving + [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a + + Now we get alpha:=a, and everything works out + +Note [Eliminate flat-skols] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have [G] Num (F [a]) +then we flatten to + [G] Num fsk + [G] F [a] ~ fsk +where fsk is a flatten-skolem (FlatSkolTv). Suppose we have + type instance F [a] = a +then we'll reduce the second constraint to + [G] a ~ fsk +and then replace all uses of 'a' with fsk. That's bad because +in error messages instead of saying 'a' we'll say (F [a]). In all +places, including those where the programmer wrote 'a' in the first +place. Very confusing! See #7862. + +Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate +the fsk. + +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 + +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 to too nice to discard altogether, so I'm leaving these +notes. SLPJ Jan 18. +-} + +-- @trySpontaneousSolve wi@ solves equalities where one side is a +-- touchable unification variable. +-- Returns True <=> spontaneous solve happened +canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool +canSolveByUnification tclvl tv xi + | isTouchableMetaTyVar tclvl tv + = case metaTyVarInfo tv of + TyVarTv -> is_tyvar xi + _ -> True + + | otherwise -- Untouchable + = False + where + is_tyvar xi + = case tcGetTyVar_maybe xi of + Nothing -> False + Just tv -> case tcTyVarDetails tv of + MetaTv { mtv_info = info } + -> case info of + TyVarTv -> True + _ -> False + SkolemTv {} -> True + RuntimeUnk -> True + +{- 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. (We're not helped by the fact that +the flattener re-flattens all the arguments every time around.) 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. + +Note [Refactoring hazard: checkTauTvUpdate] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I (Richard E.) have a sad story about refactoring this code, retained here +to prevent others (or a future me!) from falling into the same traps. + +It all started with #11407, which was caused by the fact that the TyVarTy +case of defer_me didn't look in the kind. But it seemed reasonable to +simply remove the defer_me check instead. + +It referred to two Notes (since removed) that were out of date, and the +fast_check code in occurCheckExpand seemed to do just about the same thing as +defer_me. The one piece that defer_me did that wasn't repeated by +occurCheckExpand was the type-family check. (See Note [Prevent unification +with type families].) So I checked the result of occurCheckExpand for any +type family occurrences and deferred if there were any. This was done +in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 . + +This approach turned out not to be performant, because the expanded +type was bigger than the original type, and tyConsOfType (needed to +see if there are any type family occurrences) looks through type +synonyms. So it then struck me that we could dispense with the +defer_me check entirely. This simplified the code nicely, and it cut +the allocations in T5030 by half. But, as documented in Note [Prevent +unification with type families], this destroyed performance in +T3064. Regardless, I missed this regression and the change was +committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d . + +Bottom lines: + * defer_me is back, but now fixed w.r.t. #11407. + * Tread carefully before you start to refactor here. There can be + lots of hard-to-predict consequences. + +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. +-} + +data LookupTyVarResult -- The result of a lookupTcTyVar call + = Unfilled TcTyVarDetails -- SkolemTv or virgin MetaTv + | Filled TcType + +lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult +lookupTcTyVar tyvar + | MetaTv { mtv_ref = ref } <- details + = do { meta_details <- readMutVar ref + ; case meta_details of + Indirect ty -> return (Filled ty) + Flexi -> do { is_touchable <- isTouchableTcM tyvar + -- Note [Unifying untouchables] + ; if is_touchable then + return (Unfilled details) + else + return (Unfilled vanillaSkolemTv) } } + | otherwise + = return (Unfilled details) + where + details = tcTyVarDetails tyvar + +{- +Note [Unifying untouchables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat an untouchable type variable as if it was a skolem. That +ensures it won't unify with anything. It's a slight hack, because +we return a made-up TcTyVarDetails, but I think it works smoothly. +-} + +-- | Breaks apart a function kind into its pieces. +matchExpectedFunKind + :: Outputable fun + => fun -- ^ 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' <- tcView 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 _ arg res) + = do { co <- go (n-1) res + ; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co) } + + go n other + = defer n other + + defer n k + = do { arg_kinds <- newMetaKindVars n + ; res_kind <- newMetaKindVar + ; let new_fun = mkVisFunTys arg_kinds res_kind + origin = TypeEqOrigin { uo_actual = k + , uo_expected = new_fun + , uo_thing = Just (ppr hs_ty) + , uo_visible = True + } + ; uType KindLevel origin k new_fun } + +{- ********************************************************************* +* * + Occurrence checking +* * +********************************************************************* -} + + +{- Note [Occurrence checking: look inside kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are considering unifying + (alpha :: *) ~ Int -> (beta :: alpha -> alpha) +This may be an error (what is that alpha doing inside beta's kind?), +but we must not make the mistake of actually unifying or we'll +build an infinite data structure. So when looking for occurrences +of alpha in the rhs, we must look in the kinds of type variables +that occur there. + +NB: we may be able to remove the problem via expansion; see + Note [Occurs check expansion]. So we have to try that. + +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]) 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->*) + +-} + +data MetaTyVarUpdateResult a + = MTVU_OK a + | MTVU_Bad -- Forall, predicate, or type family + | MTVU_HoleBlocker -- Blocking coercion hole + -- See Note [Equalities with incompatible kinds] in TcCanonical + | MTVU_Occurs + deriving (Functor) + +instance Applicative MetaTyVarUpdateResult where + pure = MTVU_OK + (<*>) = ap + +instance Monad MetaTyVarUpdateResult where + MTVU_OK x >>= k = k x + MTVU_Bad >>= _ = MTVU_Bad + MTVU_HoleBlocker >>= _ = MTVU_HoleBlocker + MTVU_Occurs >>= _ = MTVU_Occurs + +instance Outputable a => Outputable (MetaTyVarUpdateResult a) where + ppr (MTVU_OK a) = text "MTVU_OK" <+> ppr a + ppr MTVU_Bad = text "MTVU_Bad" + ppr MTVU_HoleBlocker = text "MTVU_HoleBlocker" + ppr MTVU_Occurs = text "MTVU_Occurs" + +occCheckForErrors :: DynFlags -> TcTyVar -> Type -> MetaTyVarUpdateResult () +-- Just for error-message generation; so we return MetaTyVarUpdateResult +-- so the caller can report the right kind of error +-- Check whether +-- a) the given variable occurs in the given type. +-- b) there is a forall in the type (unless we have -XImpredicativeTypes) +occCheckForErrors dflags tv ty + = case preCheck dflags True tv ty of + MTVU_OK _ -> MTVU_OK () + MTVU_Bad -> MTVU_Bad + MTVU_HoleBlocker -> MTVU_HoleBlocker + MTVU_Occurs -> case occCheckExpand [tv] ty of + Nothing -> MTVU_Occurs + Just _ -> MTVU_OK () + +---------------- +metaTyVarUpdateOK :: DynFlags + -> TcTyVar -- tv :: k1 + -> TcType -- ty :: k2 + -> MetaTyVarUpdateResult TcType -- possibly-expanded ty +-- (metaTyVarUpdateOK tv ty) +-- We are about to update the meta-tyvar tv with ty +-- Check (a) that tv doesn't occur in ty (occurs check) +-- (b) that ty does not have any foralls +-- (in the impredicative case), or type functions +-- (c) that ty does not have any blocking coercion holes +-- See Note [Equalities with incompatible kinds] in TcCanonical +-- +-- We have two possible outcomes: +-- (1) Return the type to update the type variable with, +-- [we know the update is ok] +-- (2) Return Nothing, +-- [the update might be dodgy] +-- +-- Note that "Nothing" does not mean "definite error". For example +-- type family F a +-- type instance F Int = Int +-- consider +-- a ~ F a +-- This is perfectly reasonable, if we later get a ~ Int. For now, though, +-- we return Nothing, leaving it to the later constraint simplifier to +-- sort matters out. +-- +-- See Note [Refactoring hazard: checkTauTvUpdate] + +metaTyVarUpdateOK dflags tv ty + = case preCheck dflags False tv ty of + -- False <=> type families not ok + -- See Note [Prevent unification with type families] + MTVU_OK _ -> MTVU_OK ty + MTVU_Bad -> MTVU_Bad -- forall, predicate, type function + MTVU_HoleBlocker -> MTVU_HoleBlocker -- coercion hole + MTVU_Occurs -> case occCheckExpand [tv] ty of + Just expanded_ty -> MTVU_OK expanded_ty + Nothing -> MTVU_Occurs + +preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> MetaTyVarUpdateResult () +-- A quick check for +-- (a) a forall type (unless -XImpredicativeTypes) +-- (b) a predicate type (unless -XImpredicativeTypes) +-- (c) a type family +-- (d) a blocking coercion hole +-- (e) an occurrence of the type variable (occurs check) +-- +-- For (a), (b), and (c) we check only the top level of the type, NOT +-- inside the kinds of variables it mentions. For (d) we look deeply +-- in coercions, and for (e) we do look in the kinds of course. + +preCheck dflags ty_fam_ok tv ty + = fast_check ty + where + details = tcTyVarDetails tv + impredicative_ok = canUnifyWithPolyType dflags details + + ok :: MetaTyVarUpdateResult () + ok = MTVU_OK () + + fast_check :: TcType -> MetaTyVarUpdateResult () + fast_check (TyVarTy tv') + | tv == tv' = MTVU_Occurs + | otherwise = fast_check_occ (tyVarKind tv') + -- See Note [Occurrence checking: look inside kinds] + + fast_check (TyConApp tc tys) + | bad_tc tc = MTVU_Bad + | otherwise = mapM fast_check tys >> ok + fast_check (LitTy {}) = ok + fast_check (FunTy{ft_af = af, ft_arg = a, ft_res = r}) + | InvisArg <- af + , not impredicative_ok = MTVU_Bad + | otherwise = fast_check a >> fast_check r + fast_check (AppTy fun arg) = fast_check fun >> fast_check arg + fast_check (CastTy ty co) = fast_check ty >> fast_check_co co + fast_check (CoercionTy co) = fast_check_co co + fast_check (ForAllTy (Bndr tv' _) ty) + | not impredicative_ok = MTVU_Bad + | tv == tv' = ok + | otherwise = do { fast_check_occ (tyVarKind tv') + ; fast_check_occ ty } + -- Under a forall we look only for occurrences of + -- the type variable + + -- For kinds, we only do an occurs check; we do not worry + -- about type families or foralls + -- See Note [Checking for foralls] + fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs + | otherwise = ok + + -- no bother about impredicativity in coercions, as they're + -- inferred + fast_check_co co | not (gopt Opt_DeferTypeErrors dflags) + , badCoercionHoleCo co = MTVU_HoleBlocker + -- Wrinkle (4b) in TcCanonical Note [Equalities with incompatible kinds] + + | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs + | otherwise = ok + + bad_tc :: TyCon -> Bool + bad_tc tc + | not (impredicative_ok || isTauTyCon tc) = True + | not (ty_fam_ok || isFamFreeTyCon tc) = True + | otherwise = False + +canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool +canUnifyWithPolyType dflags details + = case details of + MetaTv { mtv_info = TyVarTv } -> False + MetaTv { mtv_info = TauTv } -> xopt LangExt.ImpredicativeTypes dflags + _other -> True + -- We can have non-meta tyvars in given constraints diff --git a/compiler/GHC/Tc/Utils/Unify.hs-boot b/compiler/GHC/Tc/Utils/Unify.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Utils/Unify.hs-boot @@ -0,0 +1,15 @@ +module GHC.Tc.Utils.Unify where + +import GHC.Prelude +import GHC.Tc.Utils.TcType ( TcTauType ) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.Evidence ( TcCoercion ) +import GHC.Hs.Expr ( HsExpr ) +import GHC.Hs.Types ( HsType ) +import GHC.Hs.Extension ( GhcRn ) + +-- This boot file exists only to tie the knot between +-- GHC.Tc.Utils.Unify and Inst + +unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion +unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -0,0 +1,1926 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + +-} + +{-# LANGUAGE CPP, TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | 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 ( + -- * Extracting types from HsSyn + hsLitType, hsPatType, hsLPatType, + + -- * Other HsSyn functions + mkHsDictLet, mkHsApp, + mkHsAppTy, mkHsCaseAlt, + 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, + zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX, + zonkTyBndrs, zonkTyBndrsX, + zonkTcTypeToType, zonkTcTypeToTypeX, + zonkTcTypesToTypes, zonkTcTypesToTypesX, + zonkTyVarOcc, + zonkCoToCo, + zonkEvBinds, zonkTcEvBinds, + zonkTcMethInfoToMethInfoX, + lookupTyVarOcc + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.Predicate +import GHC.Tc.Utils.Monad +import GHC.Builtin.Names +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.Core.TyCo.Ppr ( pprTyVar ) +import GHC.Builtin.Types.Prim +import GHC.Core.TyCon +import GHC.Builtin.Types +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Driver.Types +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Platform +import GHC.Types.Basic +import GHC.Data.Maybe +import GHC.Types.SrcLoc +import GHC.Data.Bag +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.Unique.FM +import GHC.Core + +import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) + +import Control.Monad +import Data.List ( partition ) +import Control.Arrow ( second ) + +{- +************************************************************************ +* * + Extracting the type from HsSyn +* * +************************************************************************ + +-} + +hsLPatType :: LPat GhcTc -> Type +hsLPatType (L _ p) = hsPatType p + +hsPatType :: Pat GhcTc -> Type +hsPatType (ParPat _ pat) = hsLPatType pat +hsPatType (WildPat ty) = ty +hsPatType (VarPat _ lvar) = idType (unLoc lvar) +hsPatType (BangPat _ pat) = hsLPatType pat +hsPatType (LazyPat _ pat) = hsLPatType pat +hsPatType (LitPat _ lit) = hsLitType lit +hsPatType (AsPat _ var _) = idType (unLoc var) +hsPatType (ViewPat ty _ _) = ty +hsPatType (ListPat (ListPatTc ty Nothing) _) = mkListTy ty +hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty +hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make +hsPatType (SumPat tys _ _ _ ) = mkSumTy tys +hsPatType (ConPat { pat_con = lcon + , pat_con_ext = ConPatTc + { cpt_arg_tys = tys + } + }) + = conLikeResTy (unLoc lcon) tys +hsPatType (SigPat ty _ _) = ty +hsPatType (NPat ty _ _ _) = ty +hsPatType (NPlusKPat ty _ _ _ _ _) = ty +hsPatType (XPat (CoPat _ _ ty)) = ty +hsPatType SplicePat{} = panic "hsPatType: SplicePat" + +hsLitType :: HsLit (GhcPass p) -> TcType +hsLitType (HsChar _ _) = charTy +hsLitType (HsCharPrim _ _) = charPrimTy +hsLitType (HsString _ _) = stringTy +hsLitType (HsStringPrim _ _) = addrPrimTy +hsLitType (HsInt _ _) = intTy +hsLitType (HsIntPrim _ _) = intPrimTy +hsLitType (HsWordPrim _ _) = wordPrimTy +hsLitType (HsInt64Prim _ _) = int64PrimTy +hsLitType (HsWord64Prim _ _) = word64PrimTy +hsLitType (HsInteger _ _ ty) = ty +hsLitType (HsRat _ _ ty) = ty +hsLitType (HsFloatPrim _ _) = floatPrimTy +hsLitType (HsDoublePrim _ _) = doublePrimTy + +-- Overloaded literals. Here mainly because it uses isIntTy etc + +shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId) +shortCutLit platform (HsIntegral int@(IL src neg i)) ty + | isIntTy ty && platformInIntRange platform i = Just (HsLit noExtField (HsInt noExtField int)) + | isWordTy ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i)) + | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty)) + | otherwise = shortCutLit platform (HsFractional (integralFractionalLit neg i)) ty + -- 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 + +shortCutLit _ (HsFractional f) ty + | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) + | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) + | otherwise = Nothing + +shortCutLit _ (HsIsString src s) ty + | isStringTy ty = Just (HsLit noExtField (HsString src s)) + | otherwise = Nothing + +mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc +mkLit con lit = HsApp noExtField (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. +-} + +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 + +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 -> Located TcId -> Located Id +zonkLIdOcc env = mapLoc (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 ty' <- zonkTcTypeToTypeX env (idType v) + ensureNotLevPoly ty' + (text "In the type of binder" <+> quotes (ppr v)) + + return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty')) + +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 GhcTcId -> 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 + = do { let var_ty = varType var + ; ty <- + {-# SCC "zonkEvBndr_zonkTcTypeToType" #-} + zonkTcTypeToTypeX env var_ty + ; return (setVarType var ty) } + +{- +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 + = ASSERT2( 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') } + +zonkTyVarBinders :: [VarBndr TcTyVar vis] + -> TcM (ZonkEnv, [VarBndr TyVar vis]) +zonkTyVarBinders tvbs = initZonkEnv $ \ ze -> zonkTyVarBindersX ze tvbs + +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 GhcTcId -> TcM (HsExpr GhcTc) +zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e + +zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc) +zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e + +zonkTopDecls :: Bag EvBind + -> LHsBinds GhcTcId + -> [LRuleDecl GhcTcId] -> [LTcSpecPrag] + -> [LForeignDecl GhcTcId] + -> 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 GhcTcId + -> 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 (wrapLocM zonk_ip_bind) binds + let + env1 = extendIdZonkEnvRec env + [ n | (L _ (IPBind _ (Right 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 x n e) + = do n' <- mapIPNameTc (zonkIdBndr env) n + e' <- zonkLExpr env e + return (IPBind x n' e') + +--------------------------------------------- +zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc) +zonkRecMonoBinds env binds + = fixM (\ ~(_, new_binds) -> do + { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds) + ; binds' <- zonkMonoBinds env1 binds + ; return (env1, binds') }) + +--------------------------------------------- +zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc) +zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds + +zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc) +zonk_lbind env = wrapLocM (zonk_bind env) + +zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc) +zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss + , pat_ext = NPatBindTc fvs ty}) + = 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 = NPatBindTc fvs new_ty }) } + +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 }) + = 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 }) } + +zonk_bind env (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 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 (AbsBinds { abs_ext = noExtField + , 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 })) <- lbind + = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id + -- Specifically /not/ zonkIdBndr; we do not + -- want to complain about a levity-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 } } + | otherwise + = zonk_lbind env lbind -- The normal case + + zonk_export :: ZonkEnv -> ABExport GhcTcId -> TcM (ABExport GhcTc) + zonk_export env (ABE{ abe_ext = x + , 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_ext = x + , 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 + ; let 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 (Located TcId) + -> HsPatSynDetails (Located Id) +zonkPatSynDetails env (PrefixCon as) + = PrefixCon (map (zonkLIdOcc env) as) +zonkPatSynDetails env (InfixCon a1 a2) + = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2) +zonkPatSynDetails env (RecCon flds) + = RecCon (map (fmap (zonkLIdOcc env)) flds) + +zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId + -> 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 :: ZonkEnv + -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) + -> MatchGroup GhcTcId (Located (body GhcTcId)) + -> TcM (MatchGroup GhcTc (Located (body GhcTc))) +zonkMatchGroup env zBody (MG { mg_alts = L l ms + , mg_ext = MatchGroupTc arg_tys res_ty + , mg_origin = origin }) + = do { ms' <- mapM (zonkMatch env zBody) ms + ; arg_tys' <- zonkTcTypesToTypesX env arg_tys + ; res_ty' <- zonkTcTypeToTypeX env res_ty + ; return (MG { mg_alts = L l ms' + , mg_ext = MatchGroupTc arg_tys' res_ty' + , mg_origin = origin }) } + +zonkMatch :: ZonkEnv + -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) + -> LMatch GhcTcId (Located (body GhcTcId)) + -> TcM (LMatch GhcTc (Located (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 :: ZonkEnv + -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) + -> GRHSs GhcTcId (Located (body GhcTcId)) + -> TcM (GRHSs GhcTc (Located (body GhcTc))) + +zonkGRHSs env zBody (GRHSs x grhss (L l 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 (wrapLocM zonk_grhs) grhss + return (GRHSs x new_grhss (L l new_binds)) + +{- +************************************************************************ +* * +\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} +* * +************************************************************************ +-} + +zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc] +zonkLExpr :: ZonkEnv -> LHsExpr GhcTcId -> TcM (LHsExpr GhcTc) +zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc) + +zonkLExprs env exprs = mapM (zonkLExpr env) exprs +zonkLExpr env expr = wrapLocM (zonkExpr env) expr + +zonkExpr env (HsVar x (L l id)) + = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) + return (HsVar x (L l (zonkIdOcc env id))) + +zonkExpr _ e@(HsConLikeOut {}) = return e + +zonkExpr _ (HsIPVar x id) + = return (HsIPVar x id) + +zonkExpr _ e@HsOverLabel{} = return e + +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 matches) + = do new_matches <- zonkMatchGroup env zonkLExpr matches + return (HsLamCase x 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 t) + = do new_e <- zonkLExpr env e + new_ty <- zonkTcTypeToTypeX env ty + return (HsAppType new_ty new_e t) + -- NB: the type is an HsType; can't zonk that! + +zonkExpr _ e@(HsRnBracketOut _ _ _) + = pprPanic "zonkExpr: HsRnBracketOut" (ppr e) + +zonkExpr env (HsTcBracketOut x wrap body bs) + = do wrap' <- traverse zonkQuoteWrap wrap + bs' <- mapM (zonk_b env) bs + return (HsTcBracketOut x wrap' body 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') + +zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) = + runTopSplice s >>= zonkExpr env + +zonkExpr _ e@(HsSpliceE _ _) = pprPanic "zonkExpr: HsSpliceE" (ppr e) + +zonkExpr env (OpApp fixity e1 op e2) + = do new_e1 <- zonkLExpr env e1 + new_op <- zonkLExpr env op + new_e2 <- zonkLExpr env e2 + return (OpApp fixity new_e1 new_op new_e2) + +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 e) + = do new_e <- zonkLExpr env e + return (HsPar x new_e) + +zonkExpr env (SectionL x expr op) + = do new_expr <- zonkLExpr env expr + new_op <- zonkLExpr env op + return (SectionL x new_expr new_op) + +zonkExpr env (SectionR x op expr) + = do new_op <- zonkLExpr env op + new_expr <- zonkLExpr env expr + return (SectionR x new_op new_expr) + +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 (L l (Present x e)) = do { e' <- zonkLExpr env e + ; return (L l (Present x e')) } + zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t + ; return (L l (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 fun e1 e2 e3) + = do (env1, new_fun) <- zonkSyntaxExpr env fun + new_e1 <- zonkLExpr env1 e1 + new_e2 <- zonkLExpr env1 e2 + new_e3 <- zonkLExpr env1 e3 + return (HsIf x new_fun new_e1 new_e2 new_e3) + +zonkExpr env (HsMultiIf ty alts) + = do { alts' <- mapM (wrapLocM 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 (L l binds) expr) + = do (new_env, new_binds) <- zonkLocalBinds env binds + new_expr <- zonkLExpr new_env expr + return (HsLet x (L l new_binds) 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 wit exprs) + = do (env1, new_wit) <- zonkWit env wit + new_ty <- zonkTcTypeToTypeX env1 ty + new_exprs <- zonkLExprs env1 exprs + return (ExplicitList new_ty new_wit new_exprs) + where zonkWit env Nothing = return (env, Nothing) + zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln + +zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds }) + = do { new_con_expr <- zonkExpr env (rcon_con_expr ext) + ; new_rbinds <- zonkRecFields env rbinds + ; return (expr { rcon_ext = ext { rcon_con_expr = new_con_expr } + , rcon_flds = new_rbinds }) } + +zonkExpr env (RecordUpd { rupd_flds = rbinds + , rupd_expr = expr + , rupd_ext = RecordUpdTc + { rupd_cons = cons, rupd_in_tys = in_tys + , rupd_out_tys = out_tys, rupd_wrap = req_wrap }}) + = do { new_expr <- zonkLExpr env expr + ; new_in_tys <- mapM (zonkTcTypeToTypeX env) in_tys + ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys + ; new_rbinds <- zonkRecUpdFields env rbinds + ; (_, new_recwrap) <- zonkCoFn env req_wrap + ; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds + , rupd_ext = RecordUpdTc + { rupd_cons = cons, rupd_in_tys = new_in_tys + , rupd_out_tys = new_out_tys + , rupd_wrap = new_recwrap }}) } + +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 expr) + = HsStatic fvs <$> zonkLExpr env expr + +zonkExpr env (XExpr (HsWrap co_fn expr)) + = do (env1, new_co_fn) <- zonkCoFn env co_fn + new_expr <- zonkExpr env1 expr + return (XExpr (HsWrap new_co_fn new_expr)) + +zonkExpr _ e@(HsUnboundVar {}) + = return e + +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 GhcTcId + -> 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 GhcTcId -> TcM (LHsCmd GhcTc) +zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc) + +zonkLCmd env cmd = wrapLocM (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 c) + = do new_c <- zonkLCmd env c + return (HsCmdPar x new_c) + +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 ms) + = do new_ms <- zonkMatchGroup env zonkLCmd ms + return (HsCmdLamCase x 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 (L l binds) cmd) + = do (new_env, new_binds) <- zonkLocalBinds env binds + new_cmd <- zonkLCmd new_env cmd + return (HsCmdLet x (L l new_binds) 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 GhcTcId -> TcM (LHsCmdTop GhcTc) +zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd + +zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> 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 (tcTypeKind new_stack_tys) ) + -- desugarer assumes that this is not levity 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 d) = do { (env1, c1') <- zonkCoFn env c1 + ; (env2, c2') <- zonkCoFn env1 c2 + ; t1' <- zonkTcTypeToTypeX env2 t1 + ; return (env2, WpFun c1' c2' t1' d) } +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') } + +------------------------------------------------------------------------- +zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc) +zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e }) + = do { ty' <- zonkTcTypeToTypeX env ty + ; e' <- zonkExpr env e + ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) } + +------------------------------------------------------------------------- +zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> 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 :: ZonkEnv + -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) + -> [LStmt GhcTcId (Located (body GhcTcId))] + -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))]) +zonkStmts env _ [] = return (env, []) +zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s + ; (env2, ss') <- zonkStmts env1 zBody ss + ; return (env2, s' : ss') } + +zonkStmt :: ZonkEnv + -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) + -> Stmt GhcTcId (Located (body GhcTcId)) + -> TcM (ZonkEnv, Stmt GhcTc (Located (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 GhcTcId GhcTcId + -> 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 = 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 = 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' <- fmapMaybeM (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 (L l binds)) + = do (env1, new_binds) <- zonkLocalBinds env binds + return (env1, LetStmt x (L l new_binds)) + +zonkStmt env zBody (BindStmt xbs pat body) + = do { (env1, new_bind) <- zonkSyntaxExpr env (xbstc_bindOp 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_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 GhcTcId, ApplicativeArg GhcTcId) -> LPat GhcTcId + get_pat (_, ApplicativeArgOne _ pat _ _) = pat + get_pat (_, ApplicativeArgMany _ _ _ pat) = pat + + replace_pat :: LPat GhcTcId + -> (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 _) + = (op, ApplicativeArgMany x a b pat) + + 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) + = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts + ; new_ret <- zonkExpr env1 ret + ; return (ApplicativeArgMany x new_stmts new_ret pat) } + +------------------------------------------------------------------------- +zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId) +zonkRecFields env (HsRecFields flds dd) + = do { flds' <- mapM zonk_rbind flds + ; return (HsRecFields flds' dd) } + where + zonk_rbind (L l fld) + = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld) + ; new_expr <- zonkLExpr env (hsRecFieldArg fld) + ; return (L l (fld { hsRecFieldLbl = new_id + , hsRecFieldArg = new_expr })) } + +zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId] + -> TcM [LHsRecUpdField GhcTcId] +zonkRecUpdFields env = mapM zonk_rbind + where + zonk_rbind (L l fld) + = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld) + ; new_expr <- zonkLExpr env (hsRecFieldArg fld) + ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id + , hsRecFieldArg = new_expr })) } + +------------------------------------------------------------------------- +mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a + -> TcM (Either (Located HsIPName) b) +mapIPNameTc _ (Left x) = return (Left x) +mapIPNameTc f (Right x) = do r <- f x + return (Right r) + +{- +************************************************************************ +* * +\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 = wrapLocSndM (zonk_pat env) pat + +zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc) +zonk_pat env (ParPat x p) + = do { (env', p') <- zonkPat env p + ; return (env', ParPat x p') } + +zonk_pat env (WildPat ty) + = do { ty' <- zonkTcTypeToTypeX env ty + ; ensureNotLevPoly ty' + (text "In a wildcard pattern") + ; 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) pat) + = do { v' <- zonkIdBndr env v + ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat + ; return (env', AsPat x (L loc v') 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 (ListPatTc ty Nothing) pats) + = do { ty' <- zonkTcTypeToTypeX env ty + ; (env', pats') <- zonkPats env pats + ; return (env', ListPat (ListPatTc ty' Nothing) pats') } + +zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats) + = do { (env', wit') <- zonkSyntaxExpr env wit + ; ty2' <- zonkTcTypeToTypeX env' ty2 + ; ty' <- zonkTcTypeToTypeX env' ty + ; (env'', pats') <- zonkPats env' pats + ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) 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_con = L _ con + , 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 + + -- an unboxed tuple pattern (but only an unboxed tuple pattern) + -- might have levity-polymorphic arguments. Check for this badness. + ; case con of + RealDataCon dc + | isUnboxedTupleTyCon (dataConTyCon dc) + -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys) + _ -> return () + + ; (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 + } + } + ) + } + where + doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p + +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 (CoPat co_fn pat ty)) + = do { (env', co_fn') <- zonkCoFn env co_fn + ; (env'', pat') <- zonkPat env' (noLoc pat) + ; ty' <- zonkTcTypeToTypeX env'' ty + ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty') + } + +zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) + +--------------------------- +zonkConStuff :: ZonkEnv + -> HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc)) + -> TcM (ZonkEnv, + HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc))) +zonkConStuff env (PrefixCon pats) + = do { (env', pats') <- zonkPats env pats + ; return (env', PrefixCon 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 (hsRecFieldArg . unLoc) rpats) + ; let rpats' = zipWith (\(L l rp) p' -> + L l (rp { hsRecFieldArg = 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 GhcTcId] + -> TcM [LForeignDecl GhcTc] +zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls + +zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> 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 GhcTcId] -> TcM [LRuleDecl GhcTc] +zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs + +zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> 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 GhcTcId -> TcM (ZonkEnv, LRuleBndr GhcTcId) + 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 (dc, bndrs, rhs) + = do (env1, bndrs') <- zonkCoreBndrsX env bndrs + rhs' <- zonkCoreExpr env1 rhs + return $ (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 t1 t2) + = do { t1' <- zonkEvTerm env t1 + ; t2' <- zonkEvTerm env t2 + ; return (EvTypeableTrFun 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 (mkTcReflCo 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!) + +Solution: (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 turns out to be viable from a perf point of view + + But the code 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.) + + Is the extra work worth it? Some non-sytematic perf measurements + suggest that compiler allocation is reduced overall (by 0.5% or so) + but compile time really doesn't change. +-} + +zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType +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 mtv_env ref mtv_details } } + | otherwise + = 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 -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv + Just tv' -> return (mkTyVarTy tv') + + zonk_meta mtv_env ref Flexi + = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv) + ; ty <- commitFlexi flexi tv kind + ; writeMetaTyVarRef tv ref ty -- Belt and braces + ; finish_meta mtv_env ty } + + zonk_meta mtv_env _ (Indirect ty) + = do { zty <- zonkTcTypeToTypeX env ty + ; finish_meta mtv_env zty } + + finish_meta mtv_env ty + = do { let mtv_env' = extendVarEnv mtv_env tv ty + ; writeTcRef mtv_env_ref mtv_env' + ; return ty } + +lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar +lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv + = lookupVarEnv tv_env tv + +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 + | isRuntimeRepTy zonked_kind + -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) + ; return liftedRepTy } + | 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 + 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) + ; when debugIsOn $ + whenNoErrs $ + MASSERT2( False + , text "Type-correct 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 + +zonkTcTypesToTypes :: [TcType] -> TcM [Type] +zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys + +zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type +zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type] +zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion +(zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo, _) + = mapTyCoX zonk_tycomapper + +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 new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Validity.hs @@ -0,0 +1,2907 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, TupleSections, ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Tc.Validity ( + Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, + checkValidTheta, + checkValidInstance, checkValidInstHead, validDerivPred, + checkTySynRhs, + checkValidCoAxiom, checkValidCoAxBranch, + checkValidTyFamEqn, checkConsistentFamInst, + badATErr, arityErr, + checkTyConTelescope, + allDistinctTyVars + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Data.Maybe + +-- friends: +import GHC.Tc.Utils.Unify ( tcSubType_NC ) +import GHC.Tc.Solver ( simplifyAmbiguityCheck ) +import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) ) +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Tc.Utils.TcType hiding ( sizeType, sizeTypes ) +import GHC.Builtin.Types ( heqTyConName, eqTyConName, coercibleTyConName ) +import GHC.Builtin.Names +import GHC.Core.Type +import GHC.Core.Unify ( tcMatchTyX_BM, BindFlag(..) ) +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Predicate +import GHC.Tc.Types.Origin + +-- others: +import GHC.Iface.Type ( pprIfaceType, pprIfaceTypeApp ) +import GHC.CoreToIface ( toIfaceTyCon, toIfaceTcArgs, toIfaceType ) +import GHC.Hs +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env ( tcInitTidyEnv, tcInitOpenTidyEnv ) +import GHC.Tc.Instance.FunDeps +import GHC.Core.FamInstEnv + ( isDominatedBy, injectiveBranches, InjectivityCheckResult(..) ) +import GHC.Tc.Instance.Family +import GHC.Types.Name +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Var ( VarBndr(..), mkTyVar ) +import GHC.Utils.FV +import GHC.Utils.Error +import GHC.Driver.Session +import GHC.Utils.Misc +import GHC.Data.List.SetOps +import GHC.Types.SrcLoc +import GHC.Utils.Outputable as Outputable +import GHC.Types.Unique ( mkAlphaTyVarUnique ) +import GHC.Data.Bag ( emptyBag ) +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.Foldable +import Data.List ( (\\), nub ) +import qualified Data.List.NonEmpty as NE + +{- +************************************************************************ +* * + Checking for ambiguity +* * +************************************************************************ + +Note [The ambiguity check for type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +checkAmbiguity is a check on *user-supplied type signatures*. It is +*purely* there to report functions that cannot possibly be called. So for +example we want to reject: + f :: C a => Int +The idea is there can be no legal calls to 'f' because every call will +give rise to an ambiguous constraint. We could soundly omit the +ambiguity check on type signatures entirely, at the expense of +delaying ambiguity errors to call sites. Indeed, the flag +-XAllowAmbiguousTypes switches off the ambiguity check. + +What about things like this: + class D a b | a -> b where .. + h :: D Int b => Int +The Int may well fix 'b' at the call site, so that signature should +not be rejected. Moreover, using *visible* fundeps is too +conservative. Consider + class X a b where ... + class D a b | a -> b where ... + instance D a b => X [a] b where... + h :: X a b => a -> a +Here h's type looks ambiguous in 'b', but here's a legal call: + ...(h [True])... +That gives rise to a (X [Bool] beta) constraint, and using the +instance means we need (D Bool beta) and that fixes 'beta' via D's +fundep! + +Behind all these special cases there is a simple guiding principle. +Consider + + f :: + f = ...blah... + + g :: + g = f + +You would think that the definition of g would surely typecheck! +After all f has exactly the same type, and g=f. But in fact f's type +is instantiated and the instantiated constraints are solved against +the originals, so in the case an ambiguous type it won't work. +Consider our earlier example f :: C a => Int. Then in g's definition, +we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a), +and fail. + +So in fact we use this as our *definition* of ambiguity. We use a +very similar test for *inferred* types, to ensure that they are +unambiguous. See Note [Impedance matching] in GHC.Tc.Gen.Bind. + +This test is very conveniently implemented by calling + tcSubType +This neatly takes account of the functional dependency stuff above, +and implicit parameter (see Note [Implicit parameters and ambiguity]). +And this is what checkAmbiguity does. + +What about this, though? + g :: C [a] => Int +Is every call to 'g' ambiguous? After all, we might have + instance C [a] where ... +at the call site. So maybe that type is ok! Indeed even f's +quintessentially ambiguous type might, just possibly be callable: +with -XFlexibleInstances we could have + instance C a where ... +and now a call could be legal after all! Well, we'll reject this +unless the instance is available *here*. + +Note [When to call checkAmbiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We call checkAmbiguity + (a) on user-specified type signatures + (b) in checkValidType + +Conncerning (b), you might wonder about nested foralls. What about + f :: forall b. (forall a. Eq a => b) -> b +The nested forall is ambiguous. Originally we called checkAmbiguity +in the forall case of check_type, but that had two bad consequences: + * We got two error messages about (Eq b) in a nested forall like this: + g :: forall a. Eq a => forall b. Eq b => a -> a + * If we try to check for ambiguity of a nested forall like + (forall a. Eq a => b), the implication constraint doesn't bind + all the skolems, which results in "No skolem info" in error + messages (see #10432). + +To avoid this, we call checkAmbiguity once, at the top, in checkValidType. +(I'm still a bit worried about unbound skolems when the type mentions +in-scope type variables.) + +In fact, because of the co/contra-variance implemented in tcSubType, +this *does* catch function f above. too. + +Concerning (a) the ambiguity check is only used for *user* types, not +for types coming from interface files. The latter can legitimately +have ambiguous types. Example + + class S a where s :: a -> (Int,Int) + instance S Char where s _ = (1,1) + f:: S a => [a] -> Int -> (Int,Int) + f (_::[a]) x = (a*x,b) + where (a,b) = s (undefined::a) + +Here the worker for f gets the type + fw :: forall a. S a => Int -> (# Int, Int #) + + +Note [Implicit parameters and ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only a *class* predicate can give rise to ambiguity +An *implicit parameter* cannot. For example: + foo :: (?x :: [a]) => Int + foo = length ?x +is fine. The call site will supply a particular 'x' + +Furthermore, the type variables fixed by an implicit parameter +propagate to the others. E.g. + foo :: (Show a, ?x::[a]) => Int + foo = show (?x++?x) +The type of foo looks ambiguous. But it isn't, because at a call site +we might have + let ?x = 5::Int in foo +and all is well. In effect, implicit parameters are, well, parameters, +so we can take their type variables into account as part of the +"tau-tvs" stuff. This is done in the function 'GHC.Tc.Instance.FunDeps.grow'. +-} + +checkAmbiguity :: UserTypeCtxt -> Type -> TcM () +checkAmbiguity ctxt ty + | wantAmbiguityCheck ctxt + = 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 $ + tcSubType_NC ctxt ty ty + ; simplifyAmbiguityCheck ty wanted + + ; traceTc "Done ambiguity check for" (ppr ty) } + + | otherwise + = return () + where + mk_msg allow_ambiguous + = vcat [ text "In the ambiguity check for" <+> what + , ppUnless allow_ambiguous ambig_msg ] + ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes" + what | Just n <- isSigMaybe ctxt = quotes (ppr n) + | otherwise = pprUserTypeCtxt ctxt + +wantAmbiguityCheck :: UserTypeCtxt -> Bool +wantAmbiguityCheck ctxt + = case ctxt of -- See Note [When we don't check for ambiguity] + GhciCtxt {} -> False + TySynCtxt {} -> False + TypeAppCtxt -> False + StandaloneKindSigCtxt{} -> False + _ -> True + +checkUserTypeError :: Type -> TcM () +-- Check to see if the type signature mentions "TypeError blah" +-- anywhere in it, and fail if so. +-- +-- Very unsatisfactorily (#11144) we need to tidy the type +-- because it may have come from an /inferred/ signature, not a +-- user-supplied one. This is really only a half-baked fix; +-- the other errors in checkValidType don't do tidying, and so +-- may give bad error messages when given an inferred type. +checkUserTypeError = check + where + check ty + | Just msg <- userTypeError_maybe ty = fail_with msg + | Just (_,ts) <- splitTyConApp_maybe ty = mapM_ check ts + | Just (t1,t2) <- splitAppTy_maybe ty = check t1 >> check t2 + | Just (_,t1) <- splitForAllTy_maybe ty = check t1 + | otherwise = return () + + fail_with msg = do { env0 <- tcInitTidyEnv + ; let (env1, tidy_msg) = tidyOpenType env0 msg + ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) } + + +{- Note [When we don't check for ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a few places we do not want to check a user-specified type for ambiguity + +* GhciCtxt: Allow ambiguous types in GHCi's :kind command + E.g. type family T a :: * -- T :: forall k. k -> * + Then :k T should work in GHCi, not complain that + (T k) is ambiguous! + +* TySynCtxt: type T a b = C a b => blah + It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow + cure the ambiguity. So we defer the ambiguity check to the use site. + + There is also an implementation reason (#11608). In the RHS of + a type synonym we don't (currently) instantiate 'a' and 'b' with + TcTyVars before calling checkValidType, so we get assertion failures + from doing an ambiguity check on a type with TyVars in it. Fixing this + would not be hard, but let's wait till there's a reason. + +* TypeAppCtxt: visible type application + f @ty + No need to check ty for ambiguity + +* StandaloneKindSigCtxt: type T :: ksig + Kinds need a different ambiguity check than types, and the currently + implemented check is only good for types. See #14419, in particular + https://gitlab.haskell.org/ghc/ghc/issues/14419#note_160844 + +************************************************************************ +* * + Checking validity of a user-defined type +* * +************************************************************************ + +When dealing with a user-written type, we first translate it from an HsType +to a Type, performing kind checking, and then check various things that should +be true about it. We don't want to perform these checks at the same time +as the initial translation because (a) they are unnecessary for interface-file +types and (b) when checking a mutually recursive group of type and class decls, +we can't "look" at the tycons/classes yet. Also, the checks are rather +diverse, and used to really mess up the other code. + +One thing we check for is 'rank'. + + Rank 0: monotypes (no foralls) + Rank 1: foralls at the front only, Rank 0 inside + Rank 2: foralls at the front, Rank 1 on left of fn arrow, + + basic ::= tyvar | T basic ... basic + + r2 ::= forall tvs. cxt => r2a + r2a ::= r1 -> r2a | basic + r1 ::= forall tvs. cxt => r0 + r0 ::= r0 -> r0 | basic + +Another thing is to check that type synonyms are saturated. +This might not necessarily show up in kind checking. + type A i = i + data T k = MkT (k Int) + f :: T A -- BAD! +-} + +checkValidType :: UserTypeCtxt -> Type -> TcM () +-- Checks that a user-written type is valid for the given context +-- Assumes argument is fully zonked +-- Not used for instance decls; checkValidInstance instead +checkValidType ctxt ty + = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) + ; rankn_flag <- xoptM LangExt.RankNTypes + ; impred_flag <- xoptM LangExt.ImpredicativeTypes + ; let gen_rank :: Rank -> Rank + gen_rank r | rankn_flag = ArbitraryRank + | otherwise = r + + rank1 = gen_rank r1 + rank0 = gen_rank r0 + + r0 = rankZeroMonoType + r1 = LimitedRank True r0 + + rank + = case ctxt of + DefaultDeclCtxt-> MustBeMonoType + ResSigCtxt -> MustBeMonoType + PatSigCtxt -> rank0 + RuleSigCtxt _ -> rank1 + TySynCtxt _ -> rank0 + + ExprSigCtxt -> rank1 + KindSigCtxt -> rank1 + StandaloneKindSigCtxt{} -> rank1 + TypeAppCtxt | impred_flag -> ArbitraryRank + | otherwise -> tyConArgMonoType + -- Normally, ImpredicativeTypes is handled in check_arg_type, + -- but visible type applications don't go through there. + -- So we do this check here. + + FunSigCtxt {} -> rank1 + InfSigCtxt {} -> rank1 -- Inferred types should obey the + -- same rules as declared ones + + ConArgCtxt _ -> rank1 -- We are given the type of the entire + -- constructor, hence rank 1 + PatSynCtxt _ -> rank1 + + ForSigCtxt _ -> rank1 + SpecInstCtxt -> rank1 + ThBrackCtxt -> rank1 + GhciCtxt {} -> ArbitraryRank + + TyVarBndrKindCtxt _ -> rank0 + DataKindCtxt _ -> rank1 + TySynKindCtxt _ -> rank1 + TyFamResKindCtxt _ -> rank1 + + _ -> panic "checkValidType" + -- Can't happen; not used for *user* sigs + + ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) + ; expand <- initialExpandMode + ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt + , ve_rank = rank, ve_expand = expand } + + -- Check the internal validity of the type itself + -- Fail if bad things happen, else we misleading + -- (and more complicated) errors in checkAmbiguity + ; checkNoErrs $ + do { check_type ve ty + ; checkUserTypeError ty + ; traceTc "done ct" (ppr ty) } + + -- Check for ambiguous types. See Note [When to call checkAmbiguity] + -- NB: this will happen even for monotypes, but that should be cheap; + -- and there may be nested foralls for the subtype test to examine + ; checkAmbiguity ctxt ty + + ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) } + +checkValidMonoType :: Type -> TcM () +-- Assumes argument is fully zonked +checkValidMonoType ty + = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) + ; expand <- initialExpandMode + ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = SigmaCtxt + , ve_rank = MustBeMonoType, ve_expand = expand } + ; check_type ve ty } + +checkTySynRhs :: UserTypeCtxt -> TcType -> TcM () +checkTySynRhs ctxt ty + | tcReturnsConstraintKind actual_kind + = do { ck <- xoptM LangExt.ConstraintKinds + ; if ck + then when (tcIsConstraintKind actual_kind) + (do { dflags <- getDynFlags + ; expand <- initialExpandMode + ; check_pred_ty emptyTidyEnv dflags ctxt expand ty }) + else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) } + + | otherwise + = return () + where + actual_kind = tcTypeKind ty + +{- +Note [Higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~ +Technically + Int -> forall a. a->a +is still a rank-1 type, but it's not Haskell 98 (#5957). So the +validity checker allow a forall after an arrow only if we allow it +before -- that is, with Rank2Types or RankNTypes +-} + +data Rank = ArbitraryRank -- Any rank ok + + | LimitedRank -- Note [Higher rank types] + Bool -- Forall ok at top + Rank -- Use for function arguments + + | MonoType SDoc -- Monotype, with a suggestion of how it could be a polytype + + | MustBeMonoType -- Monotype regardless of flags + +instance Outputable Rank where + ppr ArbitraryRank = text "ArbitraryRank" + ppr (LimitedRank top_forall_ok r) + = text "LimitedRank" <+> ppr top_forall_ok + <+> parens (ppr r) + ppr (MonoType msg) = text "MonoType" <+> parens msg + ppr MustBeMonoType = text "MustBeMonoType" + +rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank +rankZeroMonoType = MonoType (text "Perhaps you intended to use RankNTypes") +tyConArgMonoType = MonoType (text "GHC doesn't yet support impredicative polymorphism") +synArgMonoType = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms") +constraintMonoType = MonoType (vcat [ text "A constraint must be a monotype" + , text "Perhaps you intended to use QuantifiedConstraints" ]) + +funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result +funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) +funArgResRank other_rank = (other_rank, other_rank) + +forAllAllowed :: Rank -> Bool +forAllAllowed ArbitraryRank = True +forAllAllowed (LimitedRank forall_ok _) = forall_ok +forAllAllowed _ = False + +allConstraintsAllowed :: UserTypeCtxt -> Bool +-- We don't allow arbitrary constraints in kinds +allConstraintsAllowed (TyVarBndrKindCtxt {}) = False +allConstraintsAllowed (DataKindCtxt {}) = False +allConstraintsAllowed (TySynKindCtxt {}) = False +allConstraintsAllowed (TyFamResKindCtxt {}) = False +allConstraintsAllowed (StandaloneKindSigCtxt {}) = False +allConstraintsAllowed _ = True + +-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the +-- context for the type of a term, where visible, dependent quantification is +-- currently disallowed. +-- +-- An example of something that is unambiguously the type of a term is the +-- @forall a -> a -> a@ in @foo :: forall a -> a -> a@. On the other hand, the +-- same type in @type family Foo :: forall a -> a -> a@ is unambiguously the +-- kind of a type, not the type of a term, so it is permitted. +-- +-- For more examples, see +-- @testsuite/tests/dependent/should_compile/T16326_Compile*.hs@ (for places +-- where VDQ is permitted) and +-- @testsuite/tests/dependent/should_fail/T16326_Fail*.hs@ (for places where +-- VDQ is disallowed). +vdqAllowed :: UserTypeCtxt -> Bool +-- Currently allowed in the kinds of types... +vdqAllowed (KindSigCtxt {}) = True +vdqAllowed (StandaloneKindSigCtxt {}) = True +vdqAllowed (TySynCtxt {}) = True +vdqAllowed (ThBrackCtxt {}) = True +vdqAllowed (GhciCtxt {}) = True +vdqAllowed (TyVarBndrKindCtxt {}) = True +vdqAllowed (DataKindCtxt {}) = True +vdqAllowed (TySynKindCtxt {}) = True +vdqAllowed (TyFamResKindCtxt {}) = True +-- ...but not in the types of terms. +vdqAllowed (ConArgCtxt {}) = False + -- We could envision allowing VDQ in data constructor types so long as the + -- constructor is only ever used at the type level, but for now, GHC adopts + -- the stance that VDQ is never allowed in data constructor types. +vdqAllowed (FunSigCtxt {}) = False +vdqAllowed (InfSigCtxt {}) = False +vdqAllowed (ExprSigCtxt {}) = False +vdqAllowed (TypeAppCtxt {}) = False +vdqAllowed (PatSynCtxt {}) = False +vdqAllowed (PatSigCtxt {}) = False +vdqAllowed (RuleSigCtxt {}) = False +vdqAllowed (ResSigCtxt {}) = False +vdqAllowed (ForSigCtxt {}) = False +vdqAllowed (DefaultDeclCtxt {}) = False +-- We count class constraints as "types of terms". All of the cases below deal +-- with class constraints. +vdqAllowed (InstDeclCtxt {}) = False +vdqAllowed (SpecInstCtxt {}) = False +vdqAllowed (GenSigCtxt {}) = False +vdqAllowed (ClassSCCtxt {}) = False +vdqAllowed (SigmaCtxt {}) = False +vdqAllowed (DataTyCtxt {}) = False +vdqAllowed (DerivClauseCtxt {}) = False + +{- +Note [Correctness and performance of type synonym validity checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the type A arg1 arg2, where A is a type synonym. How should we check +this type for validity? We have three distinct choices, corresponding to the +three constructors of ExpandMode: + +1. Expand the application of A, and check the resulting type (`Expand`). +2. Don't expand the application of A. Only check the arguments (`NoExpand`). +3. Check the arguments *and* check the expanded type (`Both`). + +It's tempting to think that we could always just pick choice (3), but this +results in serious performance issues when checking a type like in the +signature for `f` below: + + type S = ... + f :: S (S (S (S (S (S ....(S Int)...)))) + +When checking the type of `f`, we'll check the outer `S` application with and +without expansion, and in *each* of those checks, we'll check the next `S` +application with and without expansion... the result is exponential blowup! So +clearly we don't want to use `Both` 100% of the time. + +On the other hand, neither is it correct to use exclusively `Expand` or +exclusively `NoExpand` 100% of the time: + +* If one always expands, then one can miss erroneous programs like the one in + the `tcfail129` test case: + + type Foo a = String -> Maybe a + type Bar m = m Int + blah = undefined :: Bar Foo + + If we expand `Bar Foo` immediately, we'll miss the fact that the `Foo` type + synonyms is unsaturated. +* If one never expands and only checks the arguments, then one can miss + erroneous programs like the one in #16059: + + type Foo b = Eq b => b + f :: forall b (a :: Foo b). Int + + The kind of `a` contains a constraint, which is illegal, but this will only + be caught if `Foo b` is expanded. + +Therefore, it's impossible to have these validity checks be simultaneously +correct and performant if one sticks exclusively to a single `ExpandMode`. In +that case, the solution is to vary the `ExpandMode`s! In more detail: + +1. When we start validity checking, we start with `Expand` if + LiberalTypeSynonyms is enabled (see Note [Liberal type synonyms] for why we + do this), and we start with `Both` otherwise. The `initialExpandMode` + function is responsible for this. +2. When expanding an application of a type synonym (in `check_syn_tc_app`), we + determine which things to check based on the current `ExpandMode` argument. + Importantly, if the current mode is `Both`, then we check the arguments in + `NoExpand` mode and check the expanded type in `Both` mode. + + Switching to `NoExpand` when checking the arguments is vital to avoid + exponential blowup. One consequence of this choice is that if you have + the following type synonym in one module (with RankNTypes enabled): + + {-# LANGUAGE RankNTypes #-} + module A where + type A = forall a. a + + And you define the following in a separate module *without* RankNTypes + enabled: + + module B where + + import A + + type Const a b = a + f :: Const Int A -> Int + + Then `f` will be accepted, even though `A` (which is technically a rank-n + type) appears in its type. We view this as an acceptable compromise, since + `A` never appears in the type of `f` post-expansion. If `A` _did_ appear in + a type post-expansion, such as in the following variant: + + g :: Const A A -> Int + + Then that would be rejected unless RankNTypes were enabled. +-} + +-- | When validity-checking an application of a type synonym, should we +-- check the arguments, check the expanded type, or both? +-- See Note [Correctness and performance of type synonym validity checking] +data ExpandMode + = Expand -- ^ Only check the expanded type. + | NoExpand -- ^ Only check the arguments. + | Both -- ^ Check both the arguments and the expanded type. + +instance Outputable ExpandMode where + ppr e = text $ case e of + Expand -> "Expand" + NoExpand -> "NoExpand" + Both -> "Both" + +-- | If @LiberalTypeSynonyms@ is enabled, we start in 'Expand' mode for the +-- reasons explained in @Note [Liberal type synonyms]@. Otherwise, we start +-- in 'Both' mode. +initialExpandMode :: TcM ExpandMode +initialExpandMode = do + liberal_flag <- xoptM LangExt.LiberalTypeSynonyms + pure $ if liberal_flag then Expand else Both + +-- | Information about a type being validity-checked. +data ValidityEnv = ValidityEnv + { ve_tidy_env :: TidyEnv + , ve_ctxt :: UserTypeCtxt + , ve_rank :: Rank + , ve_expand :: ExpandMode } + +instance Outputable ValidityEnv where + ppr (ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt + , ve_rank = rank, ve_expand = expand }) = + hang (text "ValidityEnv") + 2 (vcat [ text "ve_tidy_env" <+> ppr env + , text "ve_ctxt" <+> pprUserTypeCtxt ctxt + , text "ve_rank" <+> ppr rank + , text "ve_expand" <+> ppr expand ]) + +---------------------------------------- +check_type :: ValidityEnv -> Type -> TcM () +-- The args say what the *type context* requires, independent +-- of *flag* settings. You test the flag settings at usage sites. +-- +-- Rank is allowed rank for function args +-- Rank 0 means no for-alls anywhere + +check_type _ (TyVarTy _) = return () + +check_type ve (AppTy ty1 ty2) + = do { check_type ve ty1 + ; check_arg_type False ve ty2 } + +check_type ve ty@(TyConApp tc tys) + | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc + = check_syn_tc_app ve ty tc tys + | isUnboxedTupleTyCon tc = check_ubx_tuple ve ty tys + | otherwise = mapM_ (check_arg_type False ve) tys + +check_type _ (LitTy {}) = return () + +check_type ve (CastTy ty _) = check_type ve ty + +-- Check for rank-n types, such as (forall x. x -> x) or (Show x => x). +-- +-- Critically, this case must come *after* the case for TyConApp. +-- See Note [Liberal type synonyms]. +check_type ve@(ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt + , ve_rank = rank, ve_expand = expand }) ty + | not (null tvbs && null theta) + = do { traceTc "check_type" (ppr ty $$ ppr rank) + ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty) + -- Reject e.g. (Maybe (?x::Int => Int)), + -- with a decent error message + + ; checkConstraintsOK ve theta ty + -- Reject forall (a :: Eq b => b). blah + -- In a kind signature we don't allow constraints + + ; checkTcM (all (isInvisibleArgFlag . binderArgFlag) tvbs + || vdqAllowed ctxt) + (illegalVDQTyErr env ty) + -- Reject visible, dependent quantification in the type of a + -- term (e.g., `f :: forall a -> a -> Maybe a`) + + ; check_valid_theta env' SigmaCtxt expand theta + -- Allow type T = ?x::Int => Int -> Int + -- but not type T = ?x::Int + + ; check_type (ve{ve_tidy_env = env'}) tau + -- Allow foralls to right of arrow + + ; checkEscapingKind env' tvbs' theta tau } + where + (tvbs, phi) = tcSplitForAllVarBndrs ty + (theta, tau) = tcSplitPhiTy phi + (env', tvbs') = tidyTyCoVarBinders env tvbs + +check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy _ arg_ty res_ty) + = do { check_type (ve{ve_rank = arg_rank}) arg_ty + ; check_type (ve{ve_rank = res_rank}) res_ty } + where + (arg_rank, res_rank) = funArgResRank rank + +check_type _ ty = pprPanic "check_type" (ppr ty) + +---------------------------------------- +check_syn_tc_app :: ValidityEnv + -> KindOrType -> TyCon -> [KindOrType] -> TcM () +-- Used for type synonyms and type synonym families, +-- which must be saturated, +-- but not data families, which need not be saturated +check_syn_tc_app (ve@ValidityEnv{ ve_ctxt = ctxt, ve_expand = expand }) + ty tc tys + | tys `lengthAtLeast` tc_arity -- Saturated + -- Check that the synonym has enough args + -- This applies equally to open and closed synonyms + -- It's OK to have an *over-applied* type synonym + -- data Tree a b = ... + -- type Foo a = Tree [a] + -- f :: Foo a b -> ... + = case expand of + _ | isTypeFamilyTyCon tc + -> check_args_only expand + -- See Note [Correctness and performance of type synonym validity + -- checking] + Expand -> check_expansion_only expand + NoExpand -> check_args_only expand + Both -> check_args_only NoExpand *> check_expansion_only Both + + | GhciCtxt True <- ctxt -- Accept outermost under-saturated type synonym or + -- type family constructors in GHCi :kind commands. + -- See Note [Unsaturated type synonyms in GHCi] + = check_args_only expand + + | otherwise + = failWithTc (tyConArityErr tc tys) + where + tc_arity = tyConArity tc + + check_arg :: ExpandMode -> KindOrType -> TcM () + check_arg expand = + check_arg_type (isTypeSynonymTyCon tc) (ve{ve_expand = expand}) + + check_args_only, check_expansion_only :: ExpandMode -> TcM () + check_args_only expand = mapM_ (check_arg expand) tys + + check_expansion_only expand + = ASSERT2( isTypeSynonymTyCon tc, ppr tc ) + case tcView ty of + Just ty' -> let err_ctxt = text "In the expansion of type synonym" + <+> quotes (ppr tc) + in addErrCtxt err_ctxt $ + check_type (ve{ve_expand = expand}) ty' + Nothing -> pprPanic "check_syn_tc_app" (ppr ty) + +{- +Note [Unsaturated type synonyms in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, GHC disallows unsaturated uses of type synonyms or type +families. For instance, if one defines `type Const a b = a`, then GHC will not +permit using `Const` unless it is applied to (at least) two arguments. There is +an exception to this rule, however: GHCi's :kind command. For instance, it +is quite common to look up the kind of a type constructor like so: + + λ> :kind Const + Const :: j -> k -> j + λ> :kind Const Int + Const Int :: k -> Type + +Strictly speaking, the two uses of `Const` above are unsaturated, but this +is an extremely benign (and useful) example of unsaturation, so we allow it +here as a special case. + +That being said, we do not allow unsaturation carte blanche in GHCi. Otherwise, +this GHCi interaction would be possible: + + λ> newtype Fix f = MkFix (f (Fix f)) + λ> type Id a = a + λ> :kind Fix Id + Fix Id :: Type + +This is rather dodgy, so we move to disallow this. We only permit unsaturated +synonyms in GHCi if they are *top-level*—that is, if the synonym is the +outermost type being applied. This allows `Const` and `Const Int` in the +first example, but not `Fix Id` in the second example, as `Id` is not the +outermost type being applied (`Fix` is). + +We track this outermost property in the GhciCtxt constructor of UserTypeCtxt. +A field of True in GhciCtxt indicates that we're in an outermost position. Any +time we invoke `check_arg` to check the validity of an argument, we switch the +field to False. +-} + +---------------------------------------- +check_ubx_tuple :: ValidityEnv -> KindOrType -> [KindOrType] -> TcM () +check_ubx_tuple (ve@ValidityEnv{ve_tidy_env = env}) ty tys + = do { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples + ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty) + + ; impred <- xoptM LangExt.ImpredicativeTypes + ; let rank' = if impred then ArbitraryRank else tyConArgMonoType + -- c.f. check_arg_type + -- However, args are allowed to be unlifted, or + -- more unboxed tuples, so can't use check_arg_ty + ; mapM_ (check_type (ve{ve_rank = rank'})) tys } + +---------------------------------------- +check_arg_type + :: Bool -- ^ Is this the argument to a type synonym? + -> ValidityEnv -> KindOrType -> TcM () +-- The sort of type that can instantiate a type variable, +-- or be the argument of a type constructor. +-- Not an unboxed tuple, but now *can* be a forall (since impredicativity) +-- Other unboxed types are very occasionally allowed as type +-- arguments depending on the kind of the type constructor +-- +-- For example, we want to reject things like: +-- +-- instance Ord a => Ord (forall s. T s a) +-- and +-- g :: T s (forall b.b) +-- +-- NB: unboxed tuples can have polymorphic or unboxed args. +-- This happens in the workers for functions returning +-- product types with polymorphic components. +-- But not in user code. +-- Anyway, they are dealt with by a special case in check_tau_type + +check_arg_type _ _ (CoercionTy {}) = return () + +check_arg_type type_syn (ve@ValidityEnv{ve_ctxt = ctxt, ve_rank = rank}) ty + = do { impred <- xoptM LangExt.ImpredicativeTypes + ; let rank' = case rank of -- Predictive => must be monotype + -- Rank-n arguments to type synonyms are OK, provided + -- that LiberalTypeSynonyms is enabled. + _ | type_syn -> synArgMonoType + MustBeMonoType -> MustBeMonoType -- Monotype, regardless + _other | impred -> ArbitraryRank + | otherwise -> tyConArgMonoType + -- Make sure that MustBeMonoType is propagated, + -- so that we don't suggest -XImpredicativeTypes in + -- (Ord (forall a.a)) => a -> a + -- and so that if it Must be a monotype, we check that it is! + ctxt' :: UserTypeCtxt + ctxt' + | GhciCtxt _ <- ctxt = GhciCtxt False + -- When checking an argument, set the field of GhciCtxt to + -- False to indicate that we are no longer in an outermost + -- position (and thus unsaturated synonyms are no longer + -- allowed). + -- See Note [Unsaturated type synonyms in GHCi] + | otherwise = ctxt + + ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty } + +---------------------------------------- +forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc) +forAllTyErr env rank ty + = ( env + , vcat [ hang herald 2 (ppr_tidy env ty) + , suggestion ] ) + where + (tvs, _theta, _tau) = tcSplitSigmaTy ty + herald | null tvs = text "Illegal qualified type:" + | otherwise = text "Illegal polymorphic type:" + suggestion = case rank of + LimitedRank {} -> text "Perhaps you intended to use RankNTypes" + MonoType d -> d + _ -> Outputable.empty -- Polytype is always illegal + +-- | Reject type variables that would escape their escape through a kind. +-- See @Note [Type variables escaping through kinds]@. +checkEscapingKind :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> TcM () +checkEscapingKind env tvbs theta tau = + case occCheckExpand (binderVars tvbs) phi_kind of + -- Ensure that none of the tvs occur in the kind of the forall + -- /after/ expanding type synonyms. + -- See Note [Phantom type variables in kinds] in GHC.Core.Type + Nothing -> failWithTcM $ forAllEscapeErr env tvbs theta tau tau_kind + Just _ -> pure () + where + tau_kind = tcTypeKind tau + phi_kind | null theta = tau_kind + | otherwise = liftedTypeKind + -- If there are any constraints, the kind is *. (#11405) + +forAllEscapeErr :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> Kind + -> (TidyEnv, SDoc) +forAllEscapeErr env tvbs theta tau tau_kind + = ( env + , vcat [ hang (text "Quantified type's kind mentions quantified type variable") + 2 (text "type:" <+> quotes (ppr (mkSigmaTy tvbs theta tau))) + -- NB: Don't tidy this type since the tvbs were already tidied + -- previously, and re-tidying them will make the names of type + -- variables different from tau_kind. + , hang (text "where the body of the forall has this kind:") + 2 (quotes (ppr_tidy env tau_kind)) ] ) + +{- +Note [Type variables escaping through kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + + type family T (r :: RuntimeRep) :: TYPE r + foo :: forall r. T r + +Something smells funny about the type of `foo`. If you spell out the kind +explicitly, it becomes clearer from where the smell originates: + + foo :: ((forall r. T r) :: TYPE r) + +The type variable `r` appears in the result kind, which escapes the scope of +its binding site! This is not desirable, so we establish a validity check +(`checkEscapingKind`) to catch any type variables that might escape through +kinds in this way. +-} + +ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +ubxArgTyErr env ty + = ( env, vcat [ sep [ text "Illegal unboxed tuple type as function argument:" + , ppr_tidy env ty ] + , text "Perhaps you intended to use UnboxedTuples" ] ) + +checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM () +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) $ + constraintTyErr (ve_tidy_env ve) ty + +constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +constraintTyErr env ty + = (env, text "Illegal constraint in a kind:" <+> ppr_tidy env ty) + +-- | Reject a use of visible, dependent quantification in the type of a term. +illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +illegalVDQTyErr env ty = + (env, vcat + [ hang (text "Illegal visible, dependent quantification" <+> + text "in the type of a term:") + 2 (ppr_tidy env ty) + , text "(GHC does not yet support this)" ] ) + +{- +Note [Liberal type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If -XLiberalTypeSynonyms is on, expand closed type synonyms *before* +doing validity checking. This allows us to instantiate a synonym defn +with a for-all type, or with a partially-applied type synonym. + e.g. type T a b = a + type S m = m () + f :: S (T Int) +Here, T is partially applied, so it's illegal in H98. But if you +expand S first, then T we get just + f :: Int +which is fine. + +IMPORTANT: suppose T is a type synonym. Then we must do validity +checking on an application (T ty1 ty2) + + *either* before expansion (i.e. check ty1, ty2) + *or* after expansion (i.e. expand T ty1 ty2, and then check) + BUT NOT BOTH + +If we do both, we get exponential behaviour!! + + data TIACons1 i r c = c i ::: r c + type TIACons2 t x = TIACons1 t (TIACons1 t x) + type TIACons3 t x = TIACons2 t (TIACons1 t x) + type TIACons4 t x = TIACons2 t (TIACons2 t x) + type TIACons7 t x = TIACons4 t (TIACons3 t x) + +The order in which you do validity checking is also somewhat delicate. Consider +the `check_type` function, which drives the validity checking for unsaturated +uses of type synonyms. There is a special case for rank-n types, such as +(forall x. x -> x) or (Show x => x), since those require at least one language +extension to use. It used to be the case that this case came before every other +case, but this can lead to bugs. Imagine you have this scenario (from #15954): + + type A a = Int + type B (a :: Type -> Type) = forall x. x -> x + type C = B A + +If the rank-n case came first, then in the process of checking for `forall`s +or contexts, we would expand away `B A` to `forall x. x -> x`. This is because +the functions that split apart `forall`s/contexts +(tcSplitForAllVarBndrs/tcSplitPhiTy) expand type synonyms! If `B A` is expanded +away to `forall x. x -> x` before the actually validity checks occur, we will +have completely obfuscated the fact that we had an unsaturated application of +the `A` type synonym. + +We have since learned from our mistakes and now put this rank-n case /after/ +the case for TyConApp, which ensures that an unsaturated `A` TyConApp will be +caught properly. But be careful! We can't make the rank-n case /last/ either, +as the FunTy case must came after the rank-n case. Otherwise, something like +(Eq a => Int) would be treated as a function type (FunTy), which just +wouldn't do. + +************************************************************************ +* * +\subsection{Checking a theta or source type} +* * +************************************************************************ + +Note [Implicit parameters in instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Implicit parameters _only_ allowed in type signatures; not in instance +decls, superclasses etc. The reason for not allowing implicit params in +instances is a bit subtle. If we allowed + instance (?x::Int, Eq a) => Foo [a] where ... +then when we saw + (e :: (?x::Int) => t) +it would be unclear how to discharge all the potential uses of the ?x +in e. For example, a constraint Foo [Int] might come out of e, and +applying the instance decl would show up two uses of ?x. #8912. +-} + +checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM () +-- Assumes argument is fully zonked +checkValidTheta ctxt theta + = addErrCtxtM (checkThetaCtxt ctxt theta) $ + do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta) + ; expand <- initialExpandMode + ; check_valid_theta env ctxt expand theta } + +------------------------- +check_valid_theta :: TidyEnv -> UserTypeCtxt -> ExpandMode + -> [PredType] -> TcM () +check_valid_theta _ _ _ [] + = return () +check_valid_theta env ctxt expand theta + = do { dflags <- getDynFlags + ; warnTcM (Reason Opt_WarnDuplicateConstraints) + (wopt Opt_WarnDuplicateConstraints dflags && notNull dups) + (dupPredWarn env dups) + ; traceTc "check_valid_theta" (ppr theta) + ; mapM_ (check_pred_ty env dflags ctxt expand) theta } + where + (_,dups) = removeDups nonDetCmpType theta + -- It's OK to use nonDetCmpType because dups only appears in the + -- warning + +------------------------- +{- Note [Validity checking for constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We look through constraint synonyms so that we can see the underlying +constraint(s). For example + type Foo = ?x::Int + instance Foo => C T +We should reject the instance because it has an implicit parameter in +the context. + +But we record, in 'under_syn', whether we have looked under a synonym +to avoid requiring language extensions at the use site. Main example +(#9838): + + {-# LANGUAGE ConstraintKinds #-} + module A where + type EqShow a = (Eq a, Show a) + + module B where + import A + foo :: EqShow a => a -> String + +We don't want to require ConstraintKinds in module B. +-} + +check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> ExpandMode + -> PredType -> TcM () +-- Check the validity of a predicate in a signature +-- See Note [Validity checking for constraints] +check_pred_ty env dflags ctxt expand pred + = do { check_type ve pred + ; check_pred_help False env dflags ctxt pred } + where + rank | xopt LangExt.QuantifiedConstraints dflags + = ArbitraryRank + | otherwise + = constraintMonoType + + ve :: ValidityEnv + ve = ValidityEnv{ ve_tidy_env = env + , ve_ctxt = SigmaCtxt + , ve_rank = rank + , ve_expand = expand } + +check_pred_help :: Bool -- True <=> under a type synonym + -> TidyEnv + -> DynFlags -> UserTypeCtxt + -> PredType -> TcM () +check_pred_help under_syn env dflags ctxt pred + | Just pred' <- tcView pred -- Switch on under_syn when going under a + -- synonym (#9838, yuk) + = check_pred_help True env dflags ctxt pred' + + | otherwise -- A bit like classifyPredType, but not the same + -- E.g. we treat (~) like (~#); and we look inside tuples + = case classifyPredType pred of + ClassPred cls tys + | isCTupleClass cls -> check_tuple_pred under_syn env dflags ctxt pred tys + | otherwise -> check_class_pred env dflags ctxt pred cls tys + + EqPred _ _ _ -> pprPanic "check_pred_help" (ppr pred) + -- EqPreds, such as (t1 ~ #t2) or (t1 ~R# t2), don't even have kind Constraint + -- and should never appear before the '=>' of a type. Thus + -- f :: (a ~# b) => blah + -- is wrong. For user written signatures, it'll be rejected by kind-checking + -- well before we get to validity checking. For inferred types we are careful + -- to box such constraints in GHC.Tc.Utils.TcType.pickQuantifiablePreds, as described + -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType + + ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head + IrredPred {} -> check_irred_pred under_syn env dflags ctxt pred + +check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM () +check_eq_pred env dflags pred + = -- Equational constraints are valid in all contexts if type + -- families are permitted + checkTcM (xopt LangExt.TypeFamilies dflags + || xopt LangExt.GADTs dflags) + (eqPredTyErr env pred) + +check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt + -> PredType -> ThetaType -> PredType -> TcM () +check_quant_pred env dflags ctxt pred theta head_pred + = addErrCtxt (text "In the quantified constraint" <+> quotes (ppr pred)) $ + do { -- Check the instance head + case classifyPredType head_pred of + -- SigmaCtxt tells checkValidInstHead that + -- this is the head of a quantified constraint + ClassPred cls tys -> do { checkValidInstHead SigmaCtxt cls tys + ; check_pred_help False env dflags ctxt head_pred } + -- need check_pred_help to do extra pred-only validity + -- checks, such as for (~). Otherwise, we get #17563 + -- NB: checks for the context are covered by the check_type + -- in check_pred_ty + IrredPred {} | hasTyVarHead head_pred + -> return () + _ -> failWithTcM (badQuantHeadErr env pred) + + -- Check for termination + ; unless (xopt LangExt.UndecidableInstances dflags) $ + checkInstTermination theta head_pred + } + +check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM () +check_tuple_pred under_syn env dflags ctxt pred ts + = do { -- See Note [ConstraintKinds in predicates] + checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags) + (predTupleErr env pred) + ; mapM_ (check_pred_help under_syn env dflags ctxt) ts } + -- This case will not normally be executed because without + -- -XConstraintKinds tuple types are only kind-checked as * + +check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM () +check_irred_pred under_syn env dflags ctxt pred + -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint + -- where X is a type function + = do { -- If it looks like (x t1 t2), require ConstraintKinds + -- see Note [ConstraintKinds in predicates] + -- But (X t1 t2) is always ok because we just require ConstraintKinds + -- at the definition site (#9838) + failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags) + && hasTyVarHead pred) + (predIrredErr env pred) + + -- Make sure it is OK to have an irred pred in this context + -- See Note [Irreducible predicates in superclasses] + ; failIfTcM (is_superclass ctxt + && not (xopt LangExt.UndecidableInstances dflags) + && has_tyfun_head pred) + (predSuperClassErr env pred) } + where + is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False } + has_tyfun_head ty + = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> isTypeFamilyTyCon tc + Nothing -> False + +{- Note [ConstraintKinds in predicates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't check for -XConstraintKinds under a type synonym, because that +was done at the type synonym definition site; see #9838 +e.g. module A where + type C a = (Eq a, Ix a) -- Needs -XConstraintKinds + module B where + import A + f :: C a => a -> a -- Does *not* need -XConstraintKinds + +Note [Irreducible predicates in superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Allowing type-family calls in class superclasses is somewhat dangerous +because we can write: + + type family Fooish x :: * -> Constraint + type instance Fooish () = Foo + class Fooish () a => Foo a where + +This will cause the constraint simplifier to loop because every time we canonicalise a +(Foo a) class constraint we add a (Fooish () a) constraint which will be immediately +solved to add+canonicalise another (Foo a) constraint. -} + +------------------------- +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, + -- but here we want to treat them as equalities + = check_eq_pred env dflags pred + + | isIPClass cls + = do { check_arity + ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) } + + | otherwise -- Includes Coercible + = do { check_arity + ; checkSimplifiableClassConstraint env dflags ctxt cls tys + ; checkTcM arg_tys_ok (predTyVarErr env pred) } + where + check_arity = checkTc (tys `lengthIs` classArity cls) + (tyConArityErr (classTyCon cls) tys) + + -- Check the arguments of a class constraint + flexible_contexts = xopt LangExt.FlexibleContexts dflags + undecidable_ok = xopt LangExt.UndecidableInstances dflags + arg_tys_ok = case ctxt of + SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine + InstDeclCtxt {} -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys + -- Further checks on head and theta + -- in checkInstTermination + _ -> checkValidClsArgs flexible_contexts cls tys + +checkSimplifiableClassConstraint :: TidyEnv -> DynFlags -> UserTypeCtxt + -> Class -> [TcType] -> TcM () +-- See Note [Simplifiable given constraints] +checkSimplifiableClassConstraint env dflags ctxt cls tys + | not (wopt Opt_WarnSimplifiableClassConstraints dflags) + = return () + | xopt LangExt.MonoLocalBinds dflags + = return () + + | DataTyCtxt {} <- ctxt -- Don't do this check for the "stupid theta" + = return () -- of a data type declaration + + | cls `hasKey` coercibleTyConKey + = return () -- Oddly, we treat (Coercible t1 t2) as unconditionally OK + -- matchGlobalInst will reply "yes" because we can reduce + -- (Coercible a b) to (a ~R# b) + + | otherwise + = do { result <- matchGlobalInst dflags False cls tys + ; case result of + OneInst { cir_what = what } + -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints) + (simplifiable_constraint_warn 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") ] + +{- 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 +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 +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). + +So this warning is switched on only if we have NoMonoLocalBinds; in +that case the warning discourages users from writing simplifiable +class constraints. + +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 +level instances. For example (#13526), consider + + instance {-# OVERLAPPABLE #-} Eq (T a) where ... + instance Eq (T Char) where .. + f :: Eq (T a) => ... + +We don't want to complain about this, even though the context +(Eq (T a)) matches an instance, because the user may be +deliberately deferring the choice so that the Eq (T Char) +has a chance to fire when 'f' is called. And the fragility +only matters when there's a risk that the instance might +fire instead of the local 'given'; and there is no such +risk in this case. Just use the same rules as for instance +firing! +-} + +------------------------- +okIPCtxt :: UserTypeCtxt -> Bool + -- See Note [Implicit parameters in instance decls] +okIPCtxt (FunSigCtxt {}) = True +okIPCtxt (InfSigCtxt {}) = True +okIPCtxt ExprSigCtxt = True +okIPCtxt TypeAppCtxt = True +okIPCtxt PatSigCtxt = True +okIPCtxt ResSigCtxt = True +okIPCtxt GenSigCtxt = True +okIPCtxt (ConArgCtxt {}) = True +okIPCtxt (ForSigCtxt {}) = True -- ?? +okIPCtxt ThBrackCtxt = True +okIPCtxt (GhciCtxt {}) = True +okIPCtxt SigmaCtxt = True +okIPCtxt (DataTyCtxt {}) = True +okIPCtxt (PatSynCtxt {}) = True +okIPCtxt (TySynCtxt {}) = True -- e.g. type Blah = ?x::Int + -- #11466 + +okIPCtxt (KindSigCtxt {}) = False +okIPCtxt (StandaloneKindSigCtxt {}) = False +okIPCtxt (ClassSCCtxt {}) = False +okIPCtxt (InstDeclCtxt {}) = False +okIPCtxt (SpecInstCtxt {}) = False +okIPCtxt (RuleSigCtxt {}) = False +okIPCtxt DefaultDeclCtxt = False +okIPCtxt DerivClauseCtxt = False +okIPCtxt (TyVarBndrKindCtxt {}) = False +okIPCtxt (DataKindCtxt {}) = False +okIPCtxt (TySynKindCtxt {}) = False +okIPCtxt (TyFamResKindCtxt {}) = False + +{- +Note [Kind polymorphic type classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +MultiParam check: + + class C f where... -- C :: forall k. k -> Constraint + instance C Maybe where... + + The dictionary gets type [C * Maybe] even if it's not a MultiParam + type class. + +Flexibility check: + + class C f where... -- C :: forall k. k -> Constraint + data D a = D a + instance C D where + + The dictionary gets type [C * (D *)]. IA0_TODO it should be + generalized actually. +-} + +checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc) +checkThetaCtxt ctxt theta env + = return ( env + , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta) + , text "While checking" <+> pprUserTypeCtxt ctxt ] ) + +eqPredTyErr, predTupleErr, predIrredErr, + predSuperClassErr, badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) +badQuantHeadErr env pred + = ( env + , hang (text "Quantified predicate must have a class or type variable head:") + 2 (ppr_tidy env pred) ) +eqPredTyErr env pred + = ( env + , text "Illegal equational constraint" <+> ppr_tidy env pred $$ + parens (text "Use GADTs or TypeFamilies to permit this") ) +predTupleErr env pred + = ( env + , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred) + 2 (parens constraintKindsMsg) ) +predIrredErr env pred + = ( env + , hang (text "Illegal constraint:" <+> ppr_tidy env pred) + 2 (parens constraintKindsMsg) ) +predSuperClassErr env pred + = ( env + , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred) + <+> text "in a superclass context") + 2 (parens undecidableMsg) ) + +predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) +predTyVarErr env pred + = (env + , vcat [ hang (text "Non type-variable argument") + 2 (text "in the constraint:" <+> ppr_tidy env pred) + , parens (text "Use FlexibleContexts to permit this") ]) + +badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc) +badIPPred env pred + = ( env + , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) ) + +constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +constraintSynErr env kind + = ( env + , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind)) + 2 (parens constraintKindsMsg) ) + +dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc) +dupPredWarn env dups + = ( env + , text "Duplicate constraint" <> plural primaryDups <> text ":" + <+> pprWithCommas (ppr_tidy env) primaryDups ) + where + primaryDups = map NE.head dups + +tyConArityErr :: TyCon -> [TcType] -> SDoc +-- For type-constructor arity errors, be careful to report +-- the number of /visible/ arguments required and supplied, +-- 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 + where + vis_tks = filterOutInvisibleTypes tc tks + + -- tc_type_arity = number of *type* args expected + -- tc_type_args = number of *type* args encountered + tc_type_arity = count isVisibleTyConBinder (tyConBinders tc) + tc_type_args = length vis_tks + +arityErr :: Outputable a => SDoc -> a -> Int -> Int -> SDoc +arityErr what name n m + = 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"] + +{- +************************************************************************ +* * +\subsection{Checking for a decent instance head type} +* * +************************************************************************ + +@checkValidInstHead@ checks the type {\em and} its syntactic constraints: +it must normally look like: @instance Foo (Tycon a b c ...) ...@ + +The exceptions to this syntactic checking: (1)~if the @GlasgowExts@ +flag is on, or (2)~the instance is imported (they must have been +compiled elsewhere). In these cases, we let them go through anyway. + +We can also have instances for functions: @instance Foo (a -> b) ...@. +-} + +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 + ; checkValidTypePats (classTyCon clas) cls_args + } + +{- + +Note [Instances of built-in classes in signature files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +User defined instances for KnownNat, KnownSymbol and Typeable are +disallowed -- they are generated when needed by GHC itself on-the-fly. + +However, if they occur in a Backpack signature file, they have an +entirely different meaning. Suppose in M.hsig we see + + signature M where + data T :: Nat + instance KnownNat T + +That says that any module satisfying M.hsig must provide a KnownNat +instance for T. We absolultely need that instance when compiling a +module that imports M.hsig: see #15379 and +Note [Fabricating Evidence for Literals in Backpack] in GHC.Tc.Instance.Class. + +Hence, checkValidInstHead accepts a user-written instance declaration +in hsig files, where `is_sig` is True. + +-} + +check_special_inst_head :: DynFlags -> Bool -> Bool + -> UserTypeCtxt -> Class -> [Type] -> TcM () +-- Wow! There are a surprising number of ad-hoc special cases here. +check_special_inst_head dflags is_boot is_sig ctxt clas cls_args + + -- If not in an hs-boot file, abstract classes cannot have instances + | isAbstractClass clas + , not is_boot + = failWithTc abstract_class_msg + + -- For Typeable, don't complain about instances for + -- standalone deriving; they are no-ops, and we warn about + -- it in GHC.Tc.Deriv.deriveStandalone. + | clas_nm == typeableClassName + , not is_sig + -- Note [Instances of built-in classes in signature files] + , hand_written_bindings + = failWithTc rejected_class_msg + + -- Handwritten instances of KnownNat/KnownSymbol class + -- are always forbidden (#12837) + | clas_nm `elem` [ knownNatClassName, knownSymbolClassName ] + , not is_sig + -- Note [Instances of built-in classes in signature files] + , hand_written_bindings + = failWithTc rejected_class_msg + + -- 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 ] + , not quantified_constraint + = failWithTc rejected_class_msg + + -- Check for hand-written Generic instances (disallowed in Safe Haskell) + | clas_nm `elem` genericClassNames + , hand_written_bindings + = do { failIfTc (safeLanguageOn dflags) gen_inst_err + ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } + + | clas_nm == hasFieldClassName + = checkHasFieldInst clas cls_args + + | isCTupleClass clas + = failWithTc tuple_class_msg + + -- 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) + + | otherwise + = pure () + where + clas_nm = getName clas + ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args + + hand_written_bindings + = case ctxt of + InstDeclCtxt stand_alone -> not stand_alone + SpecInstCtxt -> False + DerivClauseCtxt -> False + _ -> True + + check_h98_arg_shape = case ctxt of + SpecInstCtxt -> False + DerivClauseCtxt -> False + SigmaCtxt -> False + _ -> True + -- SigmaCtxt: once we are in quantified-constraint land, we + -- aren't so picky about enforcing H98-language restrictions + -- E.g. we want to allow a head like Coercible (m a) (m b) + + + -- When we are looking at the head of a quantified constraint, + -- check_quant_pred sets ctxt to SigmaCtxt + quantified_constraint = case ctxt of + 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." + + rejected_class_msg = text "Class" <+> quotes (ppr clas_nm) + <+> text "does not support user-specified instances" + tuple_class_msg = text "You can't specify an instance for a tuple constraint" + + gen_inst_err = rejected_class_msg $$ nest 2 (text "(in Safe Haskell)") + + abstract_class_msg = text "Cannot define instance for abstract class" + <+> quotes (ppr clas_nm) + + mb_ty_args_msg + | not (xopt LangExt.TypeSynonymInstances dflags) + , not (all tcInstHeadTyNotSynonym ty_args) + = Just head_type_synonym_msg + + | not (xopt LangExt.FlexibleInstances dflags) + , not (all tcInstHeadTyAppAllTyVars ty_args) + = Just head_type_args_tyvars_msg + + | length ty_args /= 1 + , not (xopt LangExt.MultiParamTypeClasses dflags) + , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args) + = Just head_one_type_msg + + | otherwise + = Nothing + +tcInstHeadTyNotSynonym :: Type -> Bool +-- Used in Haskell-98 mode, for the argument types of an instance head +-- These must not be type synonyms, but everywhere else type synonyms +-- are transparent, so we need a special function here +tcInstHeadTyNotSynonym ty + = case ty of -- Do not use splitTyConApp, + -- because that expands synonyms! + TyConApp tc _ -> not (isTypeSynonymTyCon tc) + _ -> True + +tcInstHeadTyAppAllTyVars :: Type -> Bool +-- Used in Haskell-98 mode, for the argument types of an instance head +-- These must be a constructor applied to type variable arguments +-- or a type-level literal. +-- But we allow kind instantiations. +tcInstHeadTyAppAllTyVars ty + | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty) + = ok (filterOutInvisibleTypes tc tys) -- avoid kinds + | LitTy _ <- ty = True -- accept type literals (#13833) + | otherwise + = False + where + -- Check that all the types are type variables, + -- and that each is distinct + ok tys = equalLength tvs tys && hasNoDups tvs + where + tvs = mapMaybe tcGetTyVar_maybe tys + +dropCasts :: Type -> Type +-- See Note [Casts during validity checking] +-- This function can turn a well-kinded type into an ill-kinded +-- one, so I've kept it local to this module +-- To consider: drop only HoleCo casts +dropCasts (CastTy ty _) = dropCasts ty +dropCasts (AppTy t1 t2) = mkAppTy (dropCasts t1) (dropCasts t2) +dropCasts ty@(FunTy _ t1 t2) = ty { ft_arg = dropCasts t1, ft_res = dropCasts t2 } +dropCasts (TyConApp tc tys) = mkTyConApp tc (map dropCasts tys) +dropCasts (ForAllTy b ty) = ForAllTy (dropCastsB b) (dropCasts ty) +dropCasts ty = ty -- LitTy, TyVarTy, CoercionTy + +dropCastsB :: TyVarBinder -> TyVarBinder +dropCastsB b = b -- Don't bother in the kind of a forall + +instTypeErr :: Class -> [Type] -> SDoc -> SDoc +instTypeErr cls tys msg + = 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] = + case splitTyConApp_maybe r_ty of + Nothing -> whoops (text "Record data type must be specified") + Just (tc, _) + | isFamilyTyCon tc + -> whoops (text "Record data type may not be a data family") + | otherwise -> case isStrLitTy x_ty of + Just lbl + | isJust (lookupTyConFieldLabel lbl tc) + -> whoops (ppr tc <+> text "already has a field" + <+> quotes (ppr lbl)) + | otherwise -> return () + Nothing + | null (tyConFieldLabels tc) -> return () + | otherwise -> whoops (ppr tc <+> text "has fields") + where + whoops = addErrTc . instTypeErr cls tys +checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys) + +{- Note [Casts during validity checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the (bogus) + instance Eq Char# +We elaborate to 'Eq (Char# |> UnivCo(hole))' where the hole is an +insoluble equality constraint for * ~ #. We'll report the insoluble +constraint separately, but we don't want to *also* complain that Eq is +not applied to a type constructor. So we look gaily look through +CastTys here. + +Another example: Eq (Either a). Then we actually get a cast in +the middle: + Eq ((Either |> g) a) + + +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 +declare their own instances, provided they do not clash with the +built-in behaviour. In particular, we forbid: + + 1. `HasField _ r _` where r is a variable + + 2. `HasField _ (T ...) _` if T is a data family + (because it might have fields introduced later) + + 3. `HasField x (T ...) _` where x is a variable, + if T has any fields at all + + 4. `HasField "foo" (T ...) _` if T has a "foo" field + +The usual functional dependency checks also apply. + + +Note [Valid 'deriving' predicate] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +validDerivPred checks for OK 'deriving' context. See Note [Exotic +derived instance contexts] in GHC.Tc.Deriv. However the predicate is +here because it uses sizeTypes, fvTypes. + +It checks for three things + + * No repeated variables (hasNoDups fvs) + + * No type constructors. This is done by comparing + sizeTypes tys == length (fvTypes tys) + sizeTypes counts variables and constructors; fvTypes returns variables. + So if they are the same, there must be no constructors. But there + might be applications thus (f (g x)). + + Note that tys only includes 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 sizeTypes + would count as a constructor! See #11833. + + * Also check for a bizarre corner case, when the derived instance decl + would look like + 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. + +Note [Equality class instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can't have users writing instances for the equality classes. But we +still need to be able to write instances for them ourselves. So we allow +instances only in the defining module. + +-} + +validDerivPred :: TyVarSet -> PredType -> Bool +-- See Note [Valid 'deriving' predicate] +validDerivPred tv_set pred + = case classifyPredType pred of + ClassPred cls tys -> cls `hasKey` typeableClassKey + -- Typeable constraints are bigger than they appear due + -- to kind polymorphism, but that's OK + || check_tys cls tys + EqPred {} -> False -- reject equality constraints + _ -> True -- Non-class predicates are ok + where + check_tys cls tys + = hasNoDups fvs + -- use sizePred to ignore implicit args + && lengthIs fvs (sizePred pred) + && all (`elemVarSet` tv_set) fvs + where tys' = filterOutInvisibleTypes (classTyCon cls) tys + fvs = fvTypes tys' + +{- +************************************************************************ +* * +\subsection{Checking instance for termination} +* * +************************************************************************ +-} + +{- Note [Instances and constraint synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, we don't allow instances for constraint synonyms at all. +Consider these (#13267): + type C1 a = Show (a -> Bool) + instance C1 Int where -- I1 + show _ = "ur" + +This elicits "show is not a (visible) method of class C1", which isn't +a great message. But it comes from the renamer, so it's hard to improve. + +This needs a bit more care: + type C2 a = (Show a, Show Int) + instance C2 Int -- I2 + +If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose +the instance head, we'll expand the synonym on fly, and it'll look like + instance (%,%) (Show Int, Show Int) +and we /really/ don't want that. So we carefully do /not/ expand +synonyms, by matching on TyConApp directly. +-} + +checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () +checkValidInstance ctxt hs_type ty + | not is_tc_app + = failWithTc (hang (text "Instance head is not headed by a class:") + 2 ( ppr tau)) + + | isNothing mb_cls + = failWithTc (vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc) + , text "A class instance must be for a class" ]) + + | not arity_ok + = failWithTc (text "Arity mis-match in instance head") + + | otherwise + = do { setSrcSpan head_loc $ + checkValidInstHead ctxt clas inst_tys + + ; traceTc "checkValidInstance {" (ppr ty) + + ; env0 <- tcInitTidyEnv + ; expand <- initialExpandMode + ; check_valid_theta env0 ctxt expand theta + + -- The Termination and Coverate Conditions + -- Check that instance inference will terminate (if we care) + -- For Haskell 98 this will already have been done by checkValidTheta, + -- but as we may be using other extensions we need to check. + -- + -- Note that the Termination Condition is *more conservative* than + -- the checkAmbiguity test we do on other type signatures + -- e.g. Bar a => Bar Int is ambiguous, but it also fails + -- the termination condition, because 'a' appears more often + -- in the constraint than in the head + ; undecidable_ok <- xoptM LangExt.UndecidableInstances + ; if undecidable_ok + then checkAmbiguity ctxt ty + else checkInstTermination theta tau + + ; 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 + + ; return () } + where + (_tvs, theta, tau) = tcSplitSigmaTy ty + is_tc_app = case tau of { TyConApp {} -> True; _ -> False } + TyConApp tc inst_tys = tau -- See Note [Instances and constraint synonyms] + mb_cls = tyConClass_maybe tc + Just clas = mb_cls + arity_ok = inst_tys `lengthIs` classArity clas + + -- The location of the "head" of the instance + head_loc = getLoc (getLHsInstDeclHead hs_type) + +{- +Note [Paterson conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Termination test: the so-called "Paterson conditions" (see Section 5 of +"Understanding functional dependencies via Constraint Handling Rules, +JFP Jan 2007). + +We check that each assertion in the context satisfies: + (1) no variable has more occurrences in the assertion than in the head, and + (2) the assertion has fewer constructors and variables (taken together + and counting repetitions) than the head. +This is only needed with -fglasgow-exts, as Haskell 98 restrictions +(which have already been checked) guarantee termination. + +The underlying idea is that + + for any ground substitution, each assertion in the + context has fewer type constructors than the head. +-} + +checkInstTermination :: ThetaType -> TcPredType -> TcM () +-- See Note [Paterson conditions] +checkInstTermination theta head_pred + = check_preds emptyVarSet theta + where + head_fvs = fvType head_pred + head_size = sizeType head_pred + + check_preds :: VarSet -> [PredType] -> TcM () + check_preds foralld_tvs preds = mapM_ (check foralld_tvs) preds + + check :: VarSet -> PredType -> TcM () + check foralld_tvs pred + = case classifyPredType pred of + EqPred {} -> return () -- See #4200. + IrredPred {} -> check2 foralld_tvs pred (sizeType pred) + ClassPred cls tys + | isTerminatingClass cls + -> return () + + | isCTupleClass cls -- Look inside tuple predicates; #8359 + -> check_preds foralld_tvs tys + + | otherwise -- Other ClassPreds + -> check2 foralld_tvs pred bogus_size + where + bogus_size = 1 + sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys) + -- See Note [Invisible arguments and termination] + + ForAllPred tvs _ head_pred' + -> check (foralld_tvs `extendVarSetList` tvs) head_pred' + -- Termination of the quantified predicate itself is checked + -- when the predicates are individually checked for validity + + check2 foralld_tvs pred pred_size + | not (null bad_tvs) = failWithTc (noMoreMsg bad_tvs what (ppr head_pred)) + | not (isTyFamFree pred) = failWithTc (nestedMsg what) + | pred_size >= head_size = failWithTc (smallerMsg what (ppr head_pred)) + | otherwise = return () + -- isTyFamFree: see Note [Type families in instance contexts] + where + what = text "constraint" <+> quotes (ppr pred) + bad_tvs = filterOut (`elemVarSet` foralld_tvs) (fvType pred) + \\ head_fvs + +smallerMsg :: SDoc -> SDoc -> SDoc +smallerMsg what inst_head + = vcat [ hang (text "The" <+> what) + 2 (sep [ text "is no smaller than" + , text "the instance head" <+> quotes inst_head ]) + , parens undecidableMsg ] + +noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -> SDoc +noMoreMsg tvs what inst_head + = vcat [ hang (text "Variable" <> plural tvs1 <+> quotes (pprWithCommas ppr tvs1) + <+> occurs <+> text "more often") + 2 (sep [ text "in the" <+> what + , text "than in the instance head" <+> quotes inst_head ]) + , parens undecidableMsg ] + where + tvs1 = nub tvs + occurs = if isSingleton tvs1 then text "occurs" + else text "occur" + +undecidableMsg, constraintKindsMsg :: SDoc +undecidableMsg = text "Use UndecidableInstances to permit this" +constraintKindsMsg = text "Use ConstraintKinds to permit this" + +{- Note [Type families in instance contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Are these OK? + type family F a + instance F a => C (Maybe [a]) where ... + instance C (F a) => C [[[a]]] where ... + +No: the type family in the instance head might blow up to an +arbitrarily large type, depending on how 'a' is instantiated. +So we require UndecidableInstances if we have a type family +in the instance head. #15172. + +Note [Invisible arguments and termination] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When checking the ​Paterson conditions for termination an instance +declaration, we check for the number of "constructors and variables" +in the instance head and constraints. Question: Do we look at + + * All the arguments, visible or invisible? + * Just the visible arguments? + +I think both will ensure termination, provided we are consistent. +Currently we are /not/ consistent, which is really a bug. It's +described in #15177, which contains a number of examples. +The suspicious bits are the calls to filterOutInvisibleTypes. +-} + + +{- +************************************************************************ +* * + Checking type instance well-formedness and termination +* * +************************************************************************ +-} + +checkValidCoAxiom :: CoAxiom Branched -> TcM () +checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) + = do { mapM_ (checkValidCoAxBranch fam_tc) branch_list + ; foldlM_ check_branch_compat [] branch_list } + where + branch_list = fromBranches branches + injectivity = tyConInjectivityInfo fam_tc + + check_branch_compat :: [CoAxBranch] -- previous branches in reverse order + -> CoAxBranch -- current branch + -> TcM [CoAxBranch]-- current branch : previous branches + -- Check for + -- (a) this branch is dominated by previous ones + -- (b) failure of injectivity + check_branch_compat prev_branches cur_branch + | cur_branch `isDominatedBy` prev_branches + = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $ + inaccessibleCoAxBranch fam_tc cur_branch + ; return prev_branches } + | otherwise + = do { check_injectivity prev_branches cur_branch + ; return (cur_branch : prev_branches) } + + -- Injectivity check: check whether a new (CoAxBranch) can extend + -- already checked equations without violating injectivity + -- annotation supplied by the user. + -- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv + check_injectivity prev_branches cur_branch + | Injective inj <- injectivity + = do { dflags <- getDynFlags + ; let conflicts = + fst $ foldl' (gather_conflicts inj prev_branches cur_branch) + ([], 0) prev_branches + ; reportConflictingInjectivityErrs fam_tc conflicts cur_branch + ; reportInjectivityErrors dflags ax cur_branch inj } + | otherwise + = return () + + gather_conflicts inj prev_branches cur_branch (acc, n) branch + -- n is 0-based index of branch in prev_branches + = case injectiveBranches inj cur_branch branch of + -- Case 1B2 in Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv + InjectivityUnified ax1 ax2 + | ax1 `isDominatedBy` (replace_br prev_branches n ax2) + -> (acc, n + 1) + | otherwise + -> (branch : acc, n + 1) + InjectivityAccepted -> (acc, n + 1) + + -- Replace n-th element in the list. Assumes 0-based indexing. + replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch] + replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs + + +-- Check that a "type instance" is well-formed (which includes decidability +-- unless -XUndecidableInstances is given). +-- +checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM () +checkValidCoAxBranch fam_tc + (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = typats + , cab_rhs = rhs, cab_loc = loc }) + = setSrcSpan loc $ + checkValidTyFamEqn fam_tc (tvs++cvs) typats rhs + +-- | Do validity checks on a type family equation, including consistency +-- with any enclosing class instance head, termination, and lack of +-- polytypes. +checkValidTyFamEqn :: TyCon -- ^ of the type family + -> [Var] -- ^ Bound variables in the equation + -> [Type] -- ^ Type patterns + -> Type -- ^ Rhs + -> TcM () +checkValidTyFamEqn fam_tc qvs typats rhs + = do { checkValidTypePats fam_tc typats + + -- Check for things used on the right but not bound on the left + ; checkFamPatBinders fam_tc qvs typats rhs + + -- Check for oversaturated visible kind arguments in a type family + -- equation. + -- See Note [Oversaturated type family equations] + ; when (isTypeFamilyTyCon fam_tc) $ + case drop (tyConArity fam_tc) typats of + [] -> pure () + spec_arg:_ -> + addErr $ text "Illegal oversaturated visible kind argument:" + <+> quotes (char '@' <> pprParendType spec_arg) + + -- The argument patterns, and RHS, are all boxed tau types + -- E.g Reject type family F (a :: k1) :: k2 + -- type instance F (forall a. a->a) = ... + -- type instance F Int# = ... + -- type instance F Int = forall a. a->a + -- type instance F Int = Int# + -- See #9357 + ; checkValidMonoType rhs + + -- We have a decidable instance unless otherwise permitted + ; undecidable_ok <- xoptM LangExt.UndecidableInstances + ; traceTc "checkVTFE" (ppr fam_tc $$ ppr rhs $$ ppr (tcTyFamInsts rhs)) + ; unless undecidable_ok $ + mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) } + +-- Make sure that each type family application is +-- (1) strictly smaller than the lhs, +-- (2) mentions no type variable more often than the lhs, and +-- (3) does not contain any further type family instances. +-- +checkFamInstRhs :: TyCon -> [Type] -- LHS + -> [(TyCon, [Type])] -- type family calls in RHS + -> [MsgDoc] +checkFamInstRhs lhs_tc lhs_tys famInsts + = mapMaybe check famInsts + where + lhs_size = sizeTyConAppArgs lhs_tc lhs_tys + inst_head = pprType (TyConApp lhs_tc lhs_tys) + lhs_fvs = fvTypes lhs_tys + check (tc, tys) + | not (all isTyFamFree tys) = Just (nestedMsg what) + | not (null bad_tvs) = Just (noMoreMsg bad_tvs what inst_head) + | lhs_size <= fam_app_size = Just (smallerMsg what inst_head) + | otherwise = Nothing + where + what = text "type family application" + <+> quotes (pprType (TyConApp tc tys)) + fam_app_size = sizeTyConAppArgs tc tys + bad_tvs = fvTypes tys \\ lhs_fvs + -- The (\\) is list difference; e.g. + -- [a,b,a,a] \\ [a,a] = [b,a] + -- So we are counting repetitions + +----------------- +checkFamPatBinders :: TyCon + -> [TcTyVar] -- Bound on LHS of family instance + -> [TcType] -- LHS patterns + -> Type -- RHS + -> TcM () +-- We do these binder checks now, in tcFamTyPatsAndGen, rather +-- than later, in checkValidFamEqn, for two reasons: +-- - We have the implicitly and explicitly +-- bound type variables conveniently to hand +-- - If implicit variables are out of scope it may +-- cause a crash; notably in tcConDecl in tcDataFamInstDecl +checkFamPatBinders fam_tc qtvs pats rhs + = do { traceTc "checkFamPatBinders" $ + vcat [ debugPprType (mkTyConApp fam_tc pats) + , ppr (mkTyConApp fam_tc pats) + , text "qtvs:" <+> ppr qtvs + , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs) + , text "cpt_tvs:" <+> ppr cpt_tvs + , text "inj_cpt_tvs:" <+> ppr inj_cpt_tvs ] + + -- Check for implicitly-bound tyvars, mentioned on the + -- RHS but not bound on the LHS + -- data T = MkT (forall (a::k). blah) + -- data family D Int = MkD (forall (a::k). blah) + -- 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 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") + } + where + cpt_tvs = tyCoVarsOfTypes pats + inj_cpt_tvs = fvVarSet $ injectiveVarsOfTypes False pats + -- The type variables that are in injective positions. + -- See Note [Dodgy binding sites in type family instances] + -- NB: The False above is irrelevant, as we never have type families in + -- patterns. + -- + -- NB: It's OK to use the nondeterministic `fvVarSet` function here, + -- since the order of `inj_cpt_tvs` is never revealed in an error + -- message. + rhs_fvs = tyCoFVsOfType rhs + used_tvs = cpt_tvs `unionVarSet` fvVarSet rhs_fvs + bad_qtvs = filterOut (`elemVarSet` used_tvs) qtvs + -- Bound but not used at all + bad_rhs_tvs = filterOut (`elemVarSet` inj_cpt_tvs) (fvVarList rhs_fvs) + -- 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)) $ + 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)) + + +-- | Checks that a list of type patterns is valid in a matching (LHS) +-- position of a class instances or type/data family instance. +-- +-- Specifically: +-- * All monotypes +-- * No type-family applications +checkValidTypePats :: TyCon -> [Type] -> TcM () +checkValidTypePats tc pat_ty_args + = do { -- Check that each of pat_ty_args is a monotype. + -- One could imagine generalising to allow + -- instance C (forall a. a->a) + -- but we don't know what all the consequences might be. + traverse_ checkValidMonoType pat_ty_args + + -- 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 $ + ty_fam_inst_illegal_err tf_is_invis_arg + (mkTyConApp 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) + +nestedMsg :: SDoc -> SDoc +nestedMsg what + = sep [ text "Illegal nested" <+> what + , parens undecidableMsg ] + +badATErr :: Name -> Name -> SDoc +badATErr clas op + = hsep [text "Class", quotes (ppr clas), + text "does not have an associated type", quotes (ppr op)] + + +------------------------- +checkConsistentFamInst :: AssocInstInfo + -> TyCon -- ^ Family tycon + -> CoAxBranch + -> TcM () +-- See Note [Checking consistent instantiation] + +checkConsistentFamInst NotAssociated _ _ + = return () + +checkConsistentFamInst (InClsInst { ai_class = clas + , ai_tyvars = inst_tvs + , ai_inst_env = mini_env }) + fam_tc branch + = do { traceTc "checkConsistentFamInst" (vcat [ ppr inst_tvs + , ppr arg_triples + , ppr mini_env + , ppr ax_tvs + , ppr ax_arg_tys + , ppr arg_triples ]) + -- 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) + (badATErr (className clas) (tyConName fam_tc)) + + ; check_match arg_triples + } + where + (ax_tvs, ax_arg_tys, _) = etaExpandCoAxBranch branch + + arg_triples :: [(Type,Type, ArgFlag)] + arg_triples = [ (cls_arg_ty, at_arg_ty, vis) + | (fam_tc_tv, vis, at_arg_ty) + <- zip3 (tyConTyVars fam_tc) + (tyConArgFlags fam_tc ax_arg_tys) + ax_arg_tys + , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ] + + pp_wrong_at_arg vis + = pprWithExplicitKindsWhen (isInvisibleArgFlag 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) (mkTyVarOcc "_") noSrcSpan + + -- For check_match, bind_me, see + -- Note [Matching in the consistent-instantiation check] + check_match :: [(Type,Type,ArgFlag)] -> TcM () + check_match triples = go emptyTCvSubst emptyTCvSubst triples + + go _ _ [] = return () + go lr_subst rl_subst ((ty1,ty2,vis):triples) + | Just lr_subst1 <- tcMatchTyX_BM bind_me lr_subst ty1 ty2 + , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1 + = go lr_subst1 rl_subst1 triples + | otherwise + = addErrTc (pp_wrong_at_arg vis) + + -- The /scoped/ type variables from the class-instance header + -- should not be alpha-renamed. Inferred ones can be. + no_bind_set = mkVarSet inst_tvs + bind_me tv | tv `elemVarSet` no_bind_set = Skolem + | otherwise = BindMe + + +{- Note [Check type-family instance binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type family instance, we require (of course), type variables +used on the RHS are matched on the LHS. This is checked by +checkFamPatBinders. Here is an interesting example: + + type family T :: k + type instance T = (Nothing :: Maybe a) + +Upon a cursory glance, it may appear that the kind variable `a` is unbound +since there are no (visible) LHS patterns in `T`. However, there is an +*invisible* pattern due to the return kind, so inside of GHC, the instance +looks closer to this: + + type family T @k :: k + type instance T @(Maybe a) = (Nothing :: Maybe a) + +Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in +fact not unbound. Contrast that with this example (#13985) + + type instance T = Proxy (Nothing :: Maybe a) + +This would looks like this inside of GHC: + + type instance T @(*) = Proxy (Nothing :: Maybe a) + +So this time, `a` is neither bound by a visible nor invisible type pattern on +the LHS, so `a` would be reported as not in scope. + +Finally, here's one more brain-teaser (from #9574). In the example below: + + class Funct f where + type Codomain f :: * + instance Funct ('KProxy :: KProxy o) where + type Codomain 'KProxy = NatTr (Proxy :: o -> *) + +As it turns out, `o` is in scope in this example. That is because `o` is +bound by the kind signature of the LHS type pattern 'KProxy. To make this more +obvious, one can also write the instance like so: + + instance Funct ('KProxy :: KProxy o) where + type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *) + +Note [Dodgy binding sites in type family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example (from #7536): + + type T a = Int + type instance F (T a) = a + +This `F` instance is extremely fishy, since the RHS, `a`, purports to be +"bound" by the LHS pattern `T a`. "Bound" has scare quotes around it because +`T a` expands to `Int`, which doesn't mention at all, so it's as if one had +actually written: + + type instance F Int = a + +That is clearly bogus, so to reject this, we check that every type variable +that is mentioned on the RHS is /actually/ bound on the LHS. In other words, +we need to do something slightly more sophisticated that just compute the free +variables of the LHS patterns. + +It's tempting to just expand all type synonyms on the LHS and then compute +their free variables, but even that isn't sophisticated enough. After all, +an impish user could write the following (#17008): + + type family ConstType (a :: Type) :: Type where + ConstType _ = Type + + type family F (x :: ConstType a) :: Type where + F (x :: ConstType a) = a + +Just like in the previous example, the `a` on the RHS isn't actually bound +on the LHS, but this time a type family is responsible for the deception, not +a type synonym. + +We avoid both issues by requiring that all RHS type variables are mentioned +in injective positions on the left-hand side (by way of +`injectiveVarsOfTypes`). For instance, the `a` in `T a` is not in an injective +position, as `T` is not an injective type constructor, so we do not count that. +Similarly for the `a` in `ConstType a`. + +Note [Matching in the consistent-instantiation check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Matching the class-instance header to family-instance tyvars is +tricker than it sounds. Consider (#13972) + class C (a :: k) where + type T k :: Type + instance C Left where + type T (a -> Either a b) = Int + +Here there are no lexically-scoped variables from (C Left). +Yet the real class-instance header is C @(p -> Either @p @q)) (Left @p @q) +while the type-family instance is T (a -> Either @a @b) +So we allow alpha-renaming of variables that don't come +from the class-instance header. + +We track the lexically-scoped type variables from the +class-instance header in ai_tyvars. + +Here's another example (#14045a) + class C (a :: k) where + data S (a :: k) + instance C (z :: Bool) where + data S :: Bool -> Type where + +Again, there is no lexical connection, but we will get + class-instance header: C @Bool (z::Bool) + family instance S @Bool (a::Bool) + +When looking for mis-matches, we check left-to-right, +kinds first. If we look at types first, we'll fail to +suggest -fprint-explicit-kinds for a mis-match with + T @k vs T @Type +somewhere deep inside the type + +Note [Checking consistent instantiation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #11450 for background discussion on this check. + + class C a b where + type T a x b + +With this class decl, if we have an instance decl + instance C ty1 ty2 where ... +then the type instance must look like + type T ty1 v ty2 = ... +with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'. +For example: + + instance C [p] Int + type T [p] y Int = (p,y,y) + +Note that + +* We used to allow completely different bound variables in the + associated type instance; e.g. + instance C [p] Int + type T [q] y Int = ... + But from GHC 8.2 onwards, we don't. It's much simpler this way. + See #11450. + +* When the class variable isn't used on the RHS of the type instance, + it's tempting to allow wildcards, thus + instance C [p] Int + type T [_] y Int = (y,y) + But it's awkward to do the test, and it doesn't work if the + variable is repeated: + instance C (p,p) Int + type T (_,_) y Int = (y,y) + Even though 'p' is not used on the RHS, we still need to use 'p' + on the LHS to establish the repeated pattern. So to keep it simple + we just require equality. + +* For variables in associated type families that are not bound by the class + itself, we do _not_ check if they are over-specific. In other words, + it's perfectly acceptable to have an instance like this: + + instance C [p] Int where + type T [p] (Maybe x) Int = x + + While the first and third arguments to T are required to be exactly [p] and + Int, respectively, since they are bound by C, the second argument is allowed + to be more specific than just a type variable. Furthermore, it is permissible + to define multiple equations for T that differ only in the non-class-bound + argument: + + instance C [p] Int where + type T [p] (Maybe x) Int = x + type T [p] (Either x y) Int = x -> y + + We once considered requiring that non-class-bound variables in associated + type family instances be instantiated with distinct type variables. However, + that requirement proved too restrictive in practice, as there were examples + of extremely simple associated type family instances that this check would + reject, and fixing them required tiresome boilerplate in the form of + auxiliary type families. For instance, you would have to define the above + example as: + + instance C [p] Int where + type T [p] x Int = CAux x + + type family CAux x where + CAux (Maybe x) = x + CAux (Either x y) = x -> y + + We decided that this restriction wasn't buying us much, so we opted not + to pursue that design (see also GHC #13398). + +Implementation + * Form the mini-envt from the class type variables a,b + to the instance decl types [p],Int: [a->[p], b->Int] + + * Look at the tyvars a,x,b of the type family constructor T + (it shares tyvars with the class C) + + * Apply the mini-evnt to them, and check that the result is + consistent with the instance types [p] y Int. (where y can be any type, as + it is not scoped over the class type variables. + +We make all the instance type variables scope over the +type instances, of course, which picks up non-obvious kinds. Eg + class Foo (a :: k) where + type F a + instance Foo (b :: k -> k) where + type F b = Int +Here the instance is kind-indexed and really looks like + type F (k->k) (b::k->k) = Int +But if the 'b' didn't scope, we would make F's instance too +poly-kinded. + +Note [Printing conflicts with class header] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's remarkably painful to give a decent error message for conflicts +with the class header. Consider + clase C b where + type F a b c + instance C [b] where + type F x Int _ _ = ... + +Here we want to report a conflict between + Expected: F _ [b] _ + Actual: F x Int _ _ + +But if the type instance shadows the class variable like this +(rename/should_fail/T15828): + instance C [b] where + type forall b. F x (Tree b) _ _ = ... + +then we must use a fresh variable name + Expected: F _ [b] _ + Actual: F x [b1] _ _ + +Notice that: + - We want to print an underscore in the "Expected" type in + positions where the class header has no influence over the + parameter. Hence the fancy footwork in pp_expected_ty + + - Although the binders in the axiom are already tidy, we must + re-tidy them to get a fresh variable name when we shadow + + - The (ax_tvs \\ inst_tvs) is to avoid tidying one of the + class-instance variables a second time, from 'a' to 'a1' say. + Remember, the ax_tvs of the axiom share identity with the + class-instance variables, inst_tvs.. + + - We use tidyCoAxBndrsForUser to get underscores rather than + _1, _2, etc in the axiom tyvars; see the definition of + tidyCoAxBndrsForUser + +This all seems absurdly complicated. + +Note [Unused explicitly bound variables in a family pattern] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Why is 'unusedExplicitForAllErr' not just a warning? + +Consider the following examples: + + type instance F a = Maybe b + type instance forall b. F a = Bool + type instance forall b. F a = Maybe b + +In every case, b is a type variable not determined by the LHS pattern. The +first is caught by the renamer, but we catch the last two here. Perhaps one +could argue that the second should be accepted, albeit with a warning, but +consider the fact that in a type family instance, there is no way to interact +with such a varable. At least with @x :: forall a. Int@ we can use visibile +type application, like @x \@Bool 1@. (Of course it does nothing, but it is +permissible.) In the type family case, the only sensible explanation is that +the user has made a mistake -- thus we throw an error. + +Note [Oversaturated type family equations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type family tycons have very rigid arities. We want to reject something like +this: + + type family Foo :: Type -> Type where + Foo x = ... + +Because Foo has arity zero (i.e., it doesn't bind anything to the left of the +double colon), we want to disallow any equation for Foo that has more than zero +arguments, such as `Foo x = ...`. The algorithm here is pretty simple: if an +equation has more arguments than the arity of the type family, reject. + +Things get trickier when visible kind application enters the picture. Consider +the following example: + + type family Bar (x :: j) :: forall k. Either j k where + Bar 5 @Symbol = ... + +The arity of Bar is two, since it binds two variables, `j` and `x`. But even +though Bar's equation has two arguments, it's still invalid. Imagine the same +equation in Core: + + Bar Nat 5 Symbol = ... + +Here, it becomes apparent that Bar is actually taking /three/ arguments! So +we can't just rely on a simple counting argument to reject +`Bar 5 @Symbol = ...`, since it only has two user-written arguments. +Moreover, there's one explicit argument (5) and one visible kind argument +(@Symbol), which matches up perfectly with the fact that Bar has one required +binder (x) and one specified binder (j), so that's not a valid way to detect +oversaturation either. + +To solve this problem in a robust way, we do the following: + +1. When kind-checking, we count the number of user-written *required* + arguments and check if there is an equal number of required tycon binders. + If not, reject. (See `wrongNumberOfParmsErr` in GHC.Tc.TyCl.) + + We perform this step during kind-checking, not during validity checking, + since we can give better error messages if we catch it early. +2. When validity checking, take all of the (Core) type patterns from on + equation, drop the first n of them (where n is the arity of the type family + tycon), and check if there are any types leftover. If so, reject. + + Why does this work? We know that after dropping the first n type patterns, + none of the leftover types can be required arguments, since step (1) would + have already caught that. Moreover, the only places where visible kind + applications should be allowed are in the first n types, since those are the + only arguments that can correspond to binding forms. Therefore, the + remaining arguments must correspond to oversaturated uses of visible kind + applications, which are precisely what we want to reject. + +Note that we only perform this check for type families, and not for data +families. This is because it is perfectly acceptable to oversaturate data +family instance equations: see Note [Arity of data families] in GHC.Core.FamInstEnv. + +************************************************************************ +* * + Telescope checking +* * +************************************************************************ + +Note [Bad TyCon telescopes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Now that we can mix type and kind variables, there are an awful lot of +ways to shoot yourself in the foot. Here are some. + + data SameKind :: k -> k -> * -- just to force unification + +1. data T1 a k (b :: k) (x :: SameKind a b) + +The problem here is that we discover that a and b should have the same +kind. But this kind mentions k, which is bound *after* a. +(Testcase: dependent/should_fail/BadTelescope) + +2. data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) + +Note that b is not bound. Yet its kind mentions a. Because we have +a nice rule that all implicitly bound variables come before others, +this is bogus. + +To catch these errors, we call checkTyConTelescope during kind-checking +datatype declarations. This checks for + +* Ill-scoped binders. From (1) and (2) above we can get putative + kinds like + T1 :: forall (a:k) (k:*) (b:k). SameKind a b -> * + where 'k' is mentioned a's kind before k is bound + + This is easy to check for: just look for + out-of-scope variables in the kind + +* We should arguably also check for ambiguous binders + but we don't. See Note [Ambiguous kind vars]. + +See also + * Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl. + * Note [Checking telescopes] in GHC.Tc.Types.Constraint discusses how + this check works for `forall x y z.` written in a type. + +Note [Ambiguous kind vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to be concerned about ambiguous binders. Suppose we have the kind + S1 :: forall k -> * -> * + S2 :: forall k. * -> * +Here S1 is OK, because k is Required, and at a use of S1 we will +see (S1 *) or (S1 (*->*)) or whatever. + +But S2 is /not/ OK because 'k' is Specfied (and hence invisible) and +we have no way (ever) to figure out how 'k' should be instantiated. +For example if we see (S2 Int), that tells us nothing about k's +instantiation. (In this case we'll instantiate it to Any, but that +seems wrong.) This is really the same test as we make for ambiguous +type in term type signatures. + +Now, it's impossible for a Specified variable not to occur +at all in the kind -- after all, it is Specified so it must have +occurred. (It /used/ to be possible; see tests T13983 and T7873. But +with the advent of the forall-or-nothing rule for kind variables, +those strange cases went away.) + +But one might worry about + type v k = * + S3 :: forall k. V k -> * +which appears to mention 'k' but doesn't really. Or + S4 :: forall k. F k -> * +where F is a type function. But we simply don't check for +those cases of ambiguity, yet anyway. The worst that can happen +is ambiguity at the call sites. + +Historical note: this test used to be called reportFloatingKvs. +-} + +-- | Check a list of binders to see if they make a valid telescope. +-- See Note [Bad TyCon telescopes] +type TelescopeAcc + = ( TyVarSet -- Bound earlier in the telescope + , Bool -- At least one binder occurred (in a kind) before + -- it was bound in the telescope. E.g. + ) -- T :: forall (a::k) k. blah + +checkTyConTelescope :: TyCon -> TcM () +checkTyConTelescope tc + | bad_scope + = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes] + addErr $ + 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) ] + + | otherwise + = return () + where + tcbs = tyConBinders tc + tvs = binderVars tcbs + sorted_tvs = scopedSort tvs + + (_, bad_scope) = foldl add_one (emptyVarSet, False) tcbs + + add_one :: TelescopeAcc -> TyConBinder -> TelescopeAcc + add_one (bound, bad_scope) tcb + = ( bound `extendVarSet` tv + , bad_scope || not (isEmptyVarSet (fkvs `minusVarSet` bound)) ) + where + tv = binderVar tcb + fkvs = tyCoVarsOfType (tyVarKind tv) + + inferred_tvs = [ binderVar tcb + | tcb <- tcbs, Inferred == tyConBinderArgFlag tcb ] + specified_tvs = [ binderVar tcb + | tcb <- tcbs, Specified == tyConBinderArgFlag 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]]) + +{- +************************************************************************ +* * +\subsection{Auxiliary functions} +* * +************************************************************************ +-} + +-- Free variables of a type, retaining repetitions, and expanding synonyms +-- This ignores coercions, as coercions aren't user-written +fvType :: Type -> [TyCoVar] +fvType ty | Just exp_ty <- tcView ty = fvType exp_ty +fvType (TyVarTy tv) = [tv] +fvType (TyConApp _ tys) = fvTypes tys +fvType (LitTy {}) = [] +fvType (AppTy fun arg) = fvType fun ++ fvType arg +fvType (FunTy _ arg res) = fvType arg ++ fvType res +fvType (ForAllTy (Bndr tv _) ty) + = fvType (tyVarKind tv) ++ + filter (/= tv) (fvType ty) +fvType (CastTy ty _) = fvType ty +fvType (CoercionTy {}) = [] + +fvTypes :: [Type] -> [TyVar] +fvTypes tys = concatMap fvType tys + +sizeType :: Type -> Int +-- Size of a type: the number of variables and constructors +sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty +sizeType (TyVarTy {}) = 1 +sizeType (TyConApp tc tys) = 1 + sizeTyConAppArgs tc tys +sizeType (LitTy {}) = 1 +sizeType (AppTy fun arg) = sizeType fun + sizeType arg +sizeType (FunTy _ arg res) = sizeType arg + sizeType res + 1 +sizeType (ForAllTy _ ty) = sizeType ty +sizeType (CastTy ty _) = sizeType ty +sizeType (CoercionTy _) = 0 + +sizeTypes :: [Type] -> Int +sizeTypes = foldr ((+) . sizeType) 0 + +sizeTyConAppArgs :: TyCon -> [Type] -> Int +sizeTyConAppArgs _tc tys = sizeTypes tys -- (filterOutInvisibleTypes tc tys) + -- See Note [Invisible arguments and termination] + +-- Size of a predicate +-- +-- We are considering whether class constraints terminate. +-- Equality constraints and constraints for the implicit +-- parameter class always terminate so it is safe to say "size 0". +-- See #4200. +sizePred :: PredType -> Int +sizePred ty = goClass ty + where + goClass p = go (classifyPredType p) + + go (ClassPred cls tys') + | isTerminatingClass cls = 0 + | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys') + -- The filtering looks bogus + -- See Note [Invisible arguments and termination] + go (EqPred {}) = 0 + go (IrredPred ty) = sizeType ty + go (ForAllPred _ _ pred) = goClass pred + +-- | When this says "True", ignore this class constraint during +-- a termination check +isTerminatingClass :: Class -> Bool +isTerminatingClass cls + = isIPClass cls -- Implicit parameter constraints always terminate because + -- there are no instances for them --- they are only solved + -- by "local instances" in expressions + || isEqPredClass cls + || cls `hasKey` typeableClassKey + || cls `hasKey` coercibleTyConKey + +-- | Tidy before printing a type +ppr_tidy :: TidyEnv -> Type -> SDoc +ppr_tidy env ty = pprType (tidyType env ty) + +allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool +-- (allDistinctTyVars tvs tys) returns True if tys are +-- a) all tyvars +-- b) all distinct +-- c) disjoint from tvs +allDistinctTyVars _ [] = True +allDistinctTyVars tkvs (ty : tys) + = case getTyVar_maybe ty of + Nothing -> False + Just tv | tv `elemVarSet` tkvs -> False + | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -24,29 +24,29 @@ ) where -import GhcPrelude +import GHC.Prelude import GHC.Hs as Hs -import PrelNames +import GHC.Builtin.Names import GHC.Types.Name.Reader import qualified GHC.Types.Name as Name -import GHC.Types.Module -import RdrHsSyn +import GHC.Unit.Module +import GHC.Parser.PostProcess import GHC.Types.Name.Occurrence as OccName import GHC.Types.SrcLoc import GHC.Core.Type import qualified GHC.Core.Coercion as Coercion ( Role(..) ) -import TysWiredIn +import GHC.Builtin.Types import GHC.Types.Basic as Hs import GHC.Types.ForeignCall import GHC.Types.Unique -import ErrUtils -import Bag +import GHC.Utils.Error +import GHC.Data.Bag import GHC.Utils.Lexeme -import Util -import FastString -import Outputable -import MonadUtils ( foldrM ) +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Monad ( foldrM ) import qualified Data.ByteString as BS import Control.Monad( unless, ap ) @@ -605,8 +605,6 @@ where all_tvs = hsQTvExplicit tvs' ++ ex_tvs - add_forall _ _ (XConDecl nec) = noExtCon nec - cvtConstr (GadtC [] _strtys _ty) = failWith (text "GadtC must have at least one constructor name") @@ -674,7 +672,7 @@ cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs) cvtForD (ImportF callconv safety from nm ty) -- the prim and javascript calling conventions do not support headers - -- and are inserted verbatim, analogous to mkImport in RdrHsSyn + -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess | callconv == TH.Prim || callconv == TH.JavaScript = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing (CFunction (StaticTarget (SourceText from) @@ -1077,7 +1075,7 @@ UInfixE x * (UInfixE y + z) ---> (x * y) + z This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and -@mkHsOpTyRn@ in GHC.Rename.Types), which expects that the input will be completely +@mkHsOpTyRn@ in GHC.Rename.HsType), which expects that the input will be completely right-biased for types and left-biased for everything else. So we left-bias the trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@. @@ -1149,7 +1147,7 @@ cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs)) cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } -cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } +cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkPsBindStmt p' e' } cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds ; returnL $ LetStmt noExtField (noLoc ds') } cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss @@ -1270,12 +1268,22 @@ ; return $ SumPat noExtField p' alt arity } cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps ; let pps = map (parenthesizePat appPrec) ps' - ; return $ ConPatIn s' (PrefixCon pps) } + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = s' + , pat_args = PrefixCon pps + } + } cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 ; wrapParL (ParPat noExtField) $ - ConPatIn s' $ - InfixCon (parenthesizePat opPrec p1') - (parenthesizePat opPrec p2') } + ConPat + { pat_con_ext = NoExtField + , pat_con = s' + , pat_args = InfixCon + (parenthesizePat opPrec p1') + (parenthesizePat opPrec p2') + } + } -- See Note [Operator association] cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] cvtp (ParensP p) = do { p' <- cvtPat p; @@ -1288,8 +1296,12 @@ ; return $ AsPat noExtField s' p' } cvtp TH.WildP = return $ WildPat noExtField cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs - ; return $ ConPatIn c' - $ Hs.RecCon (HsRecFields fs' Nothing) } + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = c' + , pat_args = Hs.RecCon $ HsRecFields fs' Nothing + } + } cvtp (ListP ps) = do { ps' <- cvtPats ps ; return $ ListPat noExtField ps'} @@ -1319,7 +1331,12 @@ cvtOpAppP x op y = do { op' <- cNameL op ; y' <- cvtPat y - ; return (ConPatIn op' (InfixCon x y')) } + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = op' + , pat_args = InfixCon x y' + } + } ----------------------------------------------------------- -- Types and type variables @@ -1912,8 +1929,8 @@ mk_mod :: TH.ModName -> ModuleName mk_mod mod = mkModuleName (TH.modString mod) -mk_pkg :: TH.PkgName -> UnitId -mk_pkg pkg = stringToUnitId (TH.pkgString pkg) +mk_pkg :: TH.PkgName -> Unit +mk_pkg pkg = stringToUnit (TH.pkgString pkg) mk_uniq :: Int -> Unique mk_uniq u = mkUniqueGrimily u @@ -1998,7 +2015,7 @@ Due to the two forall quantifiers and constraint contexts (either of which might be empty), pattern synonym type signatures are treated specially in `GHC.HsToCore.Quote`, `GHC.ThToHs`, and -`typecheck/TcSplice.hs`: +`typecheck/GHC.Tc.Gen.Splice.hs`: (a) When desugaring a pattern synonym from HsSyn to TH.Dec in `GHC.HsToCore.Quote`, we represent its *full* type signature in TH, i.e.: @@ -2015,7 +2032,7 @@ where initial empty `univs` type variables or an empty `reqs` constraint context are represented *explicitly* as `() =>`. - (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always + (c) When reifying a pattern synonym in `typecheck/GHC.Tc.Gen.Splice.hs`, we always return its *full* type, i.e.: ForallT univs reqs (ForallT exis provs ty) diff --git a/compiler/GHC/Types/Name/Shape.hs b/compiler/GHC/Types/Name/Shape.hs --- a/compiler/GHC/Types/Name/Shape.hs +++ b/compiler/GHC/Types/Name/Shape.hs @@ -13,19 +13,19 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Types -import GHC.Types.Module +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 TcRnMonad -import Util +import GHC.Tc.Utils.Monad +import GHC.Utils.Misc import GHC.Iface.Env import Control.Monad @@ -59,8 +59,8 @@ --- The 'NameShape' type is defined in TcRnTypes, because TcRnTypes --- needs to refer to NameShape, and having TcRnTypes import +-- The 'NameShape' type is defined in GHC.Tc.Types, because GHC.Tc.Types +-- needs to refer to NameShape, and having GHC.Tc.Types import -- NameShape (even by SOURCE) would cause a large number of -- modules to be pulled into the DynFlags cycle. {- @@ -160,7 +160,7 @@ -} -- | Substitution on @{A.T}@. We enforce the invariant that the --- 'nameModule' of keys of this map have 'moduleUnitId' @hole@ +-- 'nameModule' of keys of this map have 'moduleUnit' @hole@ -- (meaning that if we have a hole substitution, the keys of the map -- are never affected.) Alternatively, this is isomorphic to -- @Map ('ModuleName', 'OccName') 'Name'@. diff --git a/compiler/GHC/Utils/Asm.hs b/compiler/GHC/Utils/Asm.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Utils/Asm.hs @@ -0,0 +1,21 @@ +-- | Various utilities used in generating assembler. +-- +-- These are used not only by the native code generator, but also by the +-- GHC.Driver.Pipeline +module GHC.Utils.Asm + ( sectionType + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Utils.Outputable + +-- | Generate a section type (e.g. @\@progbits@). See #13937. +sectionType :: Platform -- ^ Target platform + -> String -- ^ section type + -> SDoc -- ^ pretty assembler fragment +sectionType platform ty = + case platformArch platform of + ArchARM{} -> char '%' <> text ty + _ -> char '@' <> text ty diff --git a/compiler/GHC/Utils/Monad/State.hs b/compiler/GHC/Utils/Monad/State.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Utils/Monad/State.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE UnboxedTuples #-} + +module GHC.Utils.Monad.State where + +import GHC.Prelude + +newtype State s a = State { runState' :: s -> (# a, s #) } + deriving (Functor) + +instance Applicative (State s) where + pure x = State $ \s -> (# x, s #) + m <*> n = State $ \s -> case runState' m s of + (# f, s' #) -> case runState' n s' of + (# x, s'' #) -> (# f x, s'' #) + +instance Monad (State s) where + m >>= n = State $ \s -> case runState' m s of + (# r, s' #) -> runState' (n r) s' + +get :: State s s +get = State $ \s -> (# s, s #) + +gets :: (s -> a) -> State s a +gets f = State $ \s -> (# f s, s #) + +put :: s -> State s () +put s' = State $ \_ -> (# (), s' #) + +modify :: (s -> s) -> State s () +modify f = State $ \s -> (# (), f s #) + + +evalState :: State s a -> s -> a +evalState s i = case runState' s i of + (# a, _ #) -> a + + +execState :: State s a -> s -> s +execState s i = case runState' s i of + (# _, s' #) -> s' + + +runState :: State s a -> s -> (a, s) +runState s i = case runState' s i of + (# a, s' #) -> (a, s') diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h --- a/compiler/HsVersions.h +++ b/compiler/HsVersions.h @@ -15,25 +15,25 @@ #define GLOBAL_VAR(name,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ -name = Util.global (value); +name = GHC.Utils.Misc.global (value); #define GLOBAL_VAR_M(name,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ -name = Util.globalM (value); +name = GHC.Utils.Misc.globalM (value); #define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ -name = Util.sharedGlobal (value) (accessor); \ +name = GHC.Utils.Misc.sharedGlobal (value) (accessor); \ foreign import ccall unsafe saccessor \ accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); #define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ -name = Util.sharedGlobalM (value) (accessor); \ +name = GHC.Utils.Misc.sharedGlobalM (value) (accessor); \ foreign import ccall unsafe saccessor \ accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs deleted file mode 100644 --- a/compiler/iface/BuildTyCl.hs +++ /dev/null @@ -1,418 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module BuildTyCl ( - buildDataCon, - buildPatSyn, - TcMethInfo, MethInfo, buildClass, - mkNewTyConRhs, - newImplicitBinder, newTyConRepName - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Iface.Env -import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) -import TysWiredIn( isCTupleTyConName ) -import TysPrim ( voidPrimTy ) -import GHC.Core.DataCon -import GHC.Core.PatSyn -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Basic -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Id.Make -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Core.Type -import GHC.Types.Id -import TcType - -import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) -import GHC.Driver.Session -import TcRnMonad -import GHC.Types.Unique.Supply -import Util -import Outputable - - -mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs --- ^ Monadic because it makes a Name for the coercion TyCon --- We pass the Name of the parent TyCon, as well as the TyCon itself, --- because the latter is part of a knot, whereas the former is not. -mkNewTyConRhs tycon_name tycon con - = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc - ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs - ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax) - ; return (NewTyCon { data_con = con, - nt_rhs = rhs_ty, - nt_etad_rhs = (etad_tvs, etad_rhs), - nt_co = nt_ax, - nt_lev_poly = isKindLevPoly res_kind } ) } - -- Coreview looks through newtypes with a Nothing - -- for nt_co, or uses explicit coercions otherwise - where - tvs = tyConTyVars tycon - roles = tyConRoles tycon - res_kind = tyConResKind tycon - con_arg_ty = case dataConRepArgTys con of - [arg_ty] -> arg_ty - tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys) - rhs_ty = substTyWith (dataConUnivTyVars con) - (mkTyVarTys tvs) con_arg_ty - -- Instantiate the newtype's RHS with the - -- type variables from the tycon - -- NB: a newtype DataCon has a type that must look like - -- forall tvs. -> T tvs - -- Note that we *can't* use dataConInstOrigArgTys here because - -- the newtype arising from class Foo a => Bar a where {} - -- has a single argument (Foo a) that is a *type class*, so - -- dataConInstOrigArgTys returns []. - - etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can - etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty - etad_rhs :: Type -- See Note [Tricky iface loop] in GHC.Iface.Load - (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty - - eta_reduce :: [TyVar] -- Reversed - -> [Role] -- also reversed - -> Type -- Rhs type - -> ([TyVar], [Role], Type) -- Eta-reduced version - -- (tyvars in normal order) - eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty, - Just tv <- getTyVar_maybe arg, - tv == a, - not (a `elemVarSet` tyCoVarsOfType fun) - = eta_reduce as rs fun - eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty) - ------------------------------------------------------- -buildDataCon :: FamInstEnvs - -> Name - -> Bool -- Declared infix - -> TyConRepName - -> [HsSrcBang] - -> Maybe [HsImplBang] - -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make - -> [FieldLabel] -- Field labels - -> [TyVar] -- Universals - -> [TyCoVar] -- Existentials - -> [TyVarBinder] -- User-written 'TyVarBinder's - -> [EqSpec] -- Equality spec - -> KnotTied ThetaType -- Does not include the "stupid theta" - -- or the GADT equalities - -> [KnotTied Type] -- Arguments - -> KnotTied Type -- Result types - -> KnotTied TyCon -- Rep tycon - -> NameEnv ConTag -- Maps the Name of each DataCon to its - -- ConTag - -> TcRnIf m n DataCon --- A wrapper for DataCon.mkDataCon that --- a) makes the worker Id --- b) makes the wrapper Id if necessary, including --- allocating its unique (hence monadic) -buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs - field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty - rep_tycon tag_map - = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc - ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc - -- This last one takes the name of the data constructor in the source - -- code, which (for Haskell source anyway) will be in the DataName name - -- space, and puts it into the VarName name space - - ; traceIf (text "buildDataCon 1" <+> ppr src_name) - ; us <- newUniqueSupply - ; dflags <- getDynFlags - ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs - tag = lookupNameEnv_NF tag_map src_name - -- See Note [Constructor tag allocation], fixes #14657 - data_con = mkDataCon src_name declared_infix prom_info - src_bangs field_lbls - univ_tvs ex_tvs user_tvbs eq_spec ctxt - arg_tys res_ty NoRRI rep_tycon tag - stupid_ctxt dc_wrk dc_rep - dc_wrk = mkDataConWorkId work_name data_con - dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name - impl_bangs data_con) - - ; traceIf (text "buildDataCon 2" <+> ppr src_name) - ; return data_con } - - --- The stupid context for a data constructor should be limited to --- the type variables mentioned in the arg_tys --- ToDo: Or functionally dependent on? --- This whole stupid theta thing is, well, stupid. -mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType] -mkDataConStupidTheta tycon arg_tys univ_tvs - | null stupid_theta = [] -- The common case - | otherwise = filter in_arg_tys stupid_theta - where - tc_subst = zipTvSubst (tyConTyVars tycon) - (mkTyVarTys univ_tvs) - stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) - -- Start by instantiating the master copy of the - -- stupid theta, taken from the TyCon - - arg_tyvars = tyCoVarsOfTypes arg_tys - in_arg_tys pred = not $ isEmptyVarSet $ - tyCoVarsOfType pred `intersectVarSet` arg_tyvars - - ------------------------------------------------------- -buildPatSyn :: Name -> Bool - -> (Id,Bool) -> Maybe (Id, Bool) - -> ([TyVarBinder], ThetaType) -- ^ Univ and req - -> ([TyVarBinder], ThetaType) -- ^ Ex and prov - -> [Type] -- ^ Argument types - -> Type -- ^ Result type - -> [FieldLabel] -- ^ Field labels for - -- a record pattern synonym - -> PatSyn -buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder - (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys - pat_ty field_labels - = -- The assertion checks that the matcher is - -- compatible with the pattern synonym - ASSERT2((and [ univ_tvs `equalLength` univ_tvs1 - , ex_tvs `equalLength` ex_tvs1 - , pat_ty `eqType` substTy subst pat_ty1 - , prov_theta `eqTypes` substTys subst prov_theta1 - , req_theta `eqTypes` substTys subst req_theta1 - , compareArgTys arg_tys (substTys subst arg_tys1) - ]) - , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1 - , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1 - , ppr pat_ty <+> twiddle <+> ppr pat_ty1 - , ppr prov_theta <+> twiddle <+> ppr prov_theta1 - , ppr req_theta <+> twiddle <+> ppr req_theta1 - , ppr arg_tys <+> twiddle <+> ppr arg_tys1])) - mkPatSyn src_name declared_infix - (univ_tvs, req_theta) (ex_tvs, prov_theta) - arg_tys pat_ty - matcher builder field_labels - where - ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id - ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau - (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma - (arg_tys1, _) = (tcSplitFunTys cont_tau) - twiddle = char '~' - subst = zipTvSubst (univ_tvs1 ++ ex_tvs1) - (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs))) - - -- For a nullary pattern synonym we add a single void argument to the - -- matcher to preserve laziness in the case of unlifted types. - -- See #12746 - compareArgTys :: [Type] -> [Type] -> Bool - compareArgTys [] [x] = x `eqType` voidPrimTy - compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys - - ------------------------------------------------------- -type TcMethInfo = MethInfo -- this variant needs zonking -type MethInfo -- A temporary intermediate, to communicate - -- between tcClassSigs and buildClass. - = ( Name -- Name of the class op - , Type -- Type of the class op - , Maybe (DefMethSpec (SrcSpan, Type))) - -- Nothing => no default method - -- - -- Just VanillaDM => There is an ordinary - -- polymorphic default method - -- - -- Just (GenericDM (loc, ty)) => There is a generic default metho - -- Here is its type, and the location - -- of the type signature - -- We need that location /only/ to attach it to the - -- generic default method's Name; and we need /that/ - -- only to give the right location of an ambiguity error - -- for the generic default method, spat out by checkValidClass - -buildClass :: Name -- Name of the class/tycon (they have the same Name) - -> [TyConBinder] -- Of the tycon - -> [Role] - -> [FunDep TyVar] -- Functional dependencies - -- Super classes, associated types, method info, minimal complete def. - -- This is Nothing if the class is abstract. - -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef) - -> TcRnIf m n Class - -buildClass tycon_name binders roles fds Nothing - = fixM $ \ rec_clas -> -- Only name generation inside loop - do { traceIf (text "buildClass") - - ; tc_rep_name <- newTyConRepName tycon_name - ; let univ_tvs = binderVars binders - tycon = mkClassTyCon tycon_name binders roles - AbstractTyCon rec_clas tc_rep_name - result = mkAbstractClass tycon_name univ_tvs fds tycon - ; traceIf (text "buildClass" <+> ppr tycon) - ; return result } - -buildClass tycon_name binders roles fds - (Just (sc_theta, at_items, sig_stuff, mindef)) - = fixM $ \ rec_clas -> -- Only name generation inside loop - do { traceIf (text "buildClass") - - ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc - ; tc_rep_name <- newTyConRepName tycon_name - - ; op_items <- mapM (mk_op_item rec_clas) sig_stuff - -- Build the selector id and default method id - - -- Make selectors for the superclasses - ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc) - (takeList sc_theta [fIRST_TAG..]) - ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas - | sc_name <- sc_sel_names] - -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we - -- can construct names for the selectors. Thus - -- class (C a, C b) => D a b where ... - -- gives superclass selectors - -- D_sc1, D_sc2 - -- (We used to call them D_C, but now we can have two different - -- superclasses both called C!) - - ; let use_newtype = isSingleton arg_tys - -- Use a newtype if the data constructor - -- (a) has exactly one value field - -- i.e. exactly one operation or superclass taken together - -- (b) that value is of lifted type (which they always are, because - -- we box equality superclasses) - -- See note [Class newtypes and equality predicates] - - -- We treat the dictionary superclasses as ordinary arguments. - -- That means that in the case of - -- class C a => D a - -- we don't get a newtype with no arguments! - args = sc_sel_names ++ op_names - op_tys = [ty | (_,ty,_) <- sig_stuff] - op_names = [op | (op,_,_) <- sig_stuff] - arg_tys = sc_theta ++ op_tys - rec_tycon = classTyCon rec_clas - univ_bndrs = tyConTyVarBinders binders - univ_tvs = binderVars univ_bndrs - - ; rep_nm <- newTyConRepName datacon_name - ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs") - datacon_name - False -- Not declared infix - rep_nm - (map (const no_bang) args) - (Just (map (const HsLazy) args)) - [{- No fields -}] - univ_tvs - [{- no existentials -}] - univ_bndrs - [{- No GADT equalities -}] - [{- No theta -}] - arg_tys - (mkTyConApp rec_tycon (mkTyVarTys univ_tvs)) - rec_tycon - (mkTyConTagMap rec_tycon) - - ; rhs <- case () of - _ | use_newtype - -> mkNewTyConRhs tycon_name rec_tycon dict_con - | isCTupleTyConName tycon_name - -> return (TupleTyCon { data_con = dict_con - , tup_sort = ConstraintTuple }) - | otherwise - -> return (mkDataTyConRhs [dict_con]) - - ; let { tycon = mkClassTyCon tycon_name binders roles - rhs rec_clas tc_rep_name - -- A class can be recursive, and in the case of newtypes - -- this matters. For example - -- class C a where { op :: C b => a -> b -> Int } - -- Because C has only one operation, it is represented by - -- a newtype, and it should be a *recursive* newtype. - -- [If we don't make it a recursive newtype, we'll expand the - -- newtype like a synonym, but that will lead to an infinite - -- type] - - ; result = mkClass tycon_name univ_tvs fds - sc_theta sc_sel_ids at_items - op_items mindef tycon - } - ; traceIf (text "buildClass" <+> ppr tycon) - ; return result } - where - no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict - - mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem - mk_op_item rec_clas (op_name, _, dm_spec) - = do { dm_info <- mk_dm_info op_name dm_spec - ; return (mkDictSelId op_name rec_clas, dm_info) } - - mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type)) - -> TcRnIf n m (Maybe (Name, DefMethSpec Type)) - mk_dm_info _ Nothing - = return Nothing - mk_dm_info op_name (Just VanillaDM) - = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc - ; return (Just (dm_name, VanillaDM)) } - mk_dm_info op_name (Just (GenericDM (loc, dm_ty))) - = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc - ; return (Just (dm_name, GenericDM dm_ty)) } - -{- -Note [Class newtypes and equality predicates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - class (a ~ F b) => C a b where - op :: a -> b - -We cannot represent this by a newtype, even though it's not -existential, because there are two value fields (the equality -predicate and op. See #2238 - -Moreover, - class (a ~ F b) => C a b where {} -Here we can't use a newtype either, even though there is only -one field, because equality predicates are unboxed, and classes -are boxed. --} - -newImplicitBinder :: Name -- Base name - -> (OccName -> OccName) -- Occurrence name modifier - -> TcRnIf m n Name -- Implicit name --- Called in BuildTyCl to allocate the implicit binders of type/class decls --- For source type/class decls, this is the first occurrence --- For iface ones, GHC.Iface.Load has already allocated a suitable name in the cache -newImplicitBinder base_name mk_sys_occ - = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name) - -newImplicitBinderLoc :: Name -- Base name - -> (OccName -> OccName) -- Occurrence name modifier - -> SrcSpan - -> TcRnIf m n Name -- Implicit name --- Just the same, but lets you specify the SrcSpan -newImplicitBinderLoc base_name mk_sys_occ loc - | Just mod <- nameModule_maybe base_name - = newGlobalBinder mod occ loc - | otherwise -- When typechecking a [d| decl bracket |], - -- TH generates types, classes etc with Internal names, - -- so we follow suit for the implicit binders - = do { uniq <- newUnique - ; return (mkInternalName uniq occ loc) } - where - occ = mk_sys_occ (nameOccName base_name) - --- | Make the 'TyConRepName' for this 'TyCon' -newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName -newTyConRepName tc_name - | Just mod <- nameModule_maybe tc_name - , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name) - = newGlobalBinder mod occ noSrcSpan - | otherwise - = newImplicitBinder tc_name mkTyConRepOcc diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs deleted file mode 100644 --- a/compiler/iface/FlagChecker.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | This module manages storing the various GHC option flags in a modules --- interface file as part of the recompilation checking infrastructure. -module FlagChecker ( - fingerprintDynFlags - , fingerprintOptFlags - , fingerprintHpcFlags - ) where - -import GhcPrelude - -import Binary -import GHC.Driver.Session -import GHC.Driver.Types -import GHC.Types.Module -import GHC.Types.Name -import Fingerprint -import BinFingerprint --- import Outputable - -import qualified EnumSet -import System.FilePath (normalise) - --- | Produce a fingerprint of a @DynFlags@ value. We only base --- the finger print on important fields in @DynFlags@ so that --- the recompilation checker can use this fingerprint. --- --- NB: The 'Module' parameter is the 'Module' recorded by the --- *interface* file, not the actual 'Module' according to our --- 'DynFlags'. -fingerprintDynFlags :: DynFlags -> Module - -> (BinHandle -> Name -> IO ()) - -> IO Fingerprint - -fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = - let mainis = if mainModIs == this_mod then Just mainFunIs else Nothing - -- see #5878 - -- pkgopts = (thisPackage dflags, sort $ packageFlags dflags) - safeHs = setSafeMode safeHaskell - -- oflags = sort $ filter filterOFlags $ flags dflags - - -- *all* the extension flags and the language - lang = (fmap fromEnum language, - map fromEnum $ EnumSet.toList extensionFlags) - - -- -I, -D and -U flags affect CPP - cpp = ( map normalise $ flattenIncludes includePaths - -- normalise: eliminate spurious differences due to "./foo" vs "foo" - , picPOpts dflags - , opt_P_signature dflags) - -- See Note [Repeated -optP hashing] - - -- Note [path flags and recompilation] - paths = [ hcSuf ] - - -- -fprof-auto etc. - prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0 - - -- Ticky - ticky = - map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk] - - flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel)) - - in -- pprTrace "flags" (ppr flags) $ - computeFingerprint nameio flags - --- Fingerprint the optimisation info. We keep this separate from the rest of --- the flags because GHCi users (especially) may wish to ignore changes in --- optimisation level or optimisation flags so as to use as many pre-existing --- object files as they can. --- See Note [Ignoring some flag changes] -fingerprintOptFlags :: DynFlags - -> (BinHandle -> Name -> IO ()) - -> IO Fingerprint -fingerprintOptFlags DynFlags{..} nameio = - let - -- See https://gitlab.haskell.org/ghc/ghc/issues/10923 - -- We used to fingerprint the optimisation level, but as Joachim - -- Breitner pointed out in comment 9 on that ticket, it's better - -- to ignore that and just look at the individual optimisation flags. - opt_flags = map fromEnum $ filter (`EnumSet.member` optimisationFlags) - (EnumSet.toList generalFlags) - - in computeFingerprint nameio opt_flags - --- Fingerprint the HPC info. We keep this separate from the rest of --- the flags because GHCi users (especially) may wish to use an object --- file compiled for HPC when not actually using HPC. --- See Note [Ignoring some flag changes] -fingerprintHpcFlags :: DynFlags - -> (BinHandle -> Name -> IO ()) - -> IO Fingerprint -fingerprintHpcFlags dflags@DynFlags{..} nameio = - let - -- -fhpc, see https://gitlab.haskell.org/ghc/ghc/issues/11798 - -- hpcDir is output-only, so we should recompile if it changes - hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing - - in computeFingerprint nameio hpc - - -{- Note [path flags and recompilation] - -There are several flags that we deliberately omit from the -recompilation check; here we explain why. - --osuf, -odir, -hisuf, -hidir - If GHC decides that it does not need to recompile, then - it must have found an up-to-date .hi file and .o file. - There is no point recording these flags - the user must - have passed the correct ones. Indeed, the user may - have compiled the source file in one-shot mode using - -o to specify the .o file, and then loaded it in GHCi - using -odir. - --stubdir - We omit this one because it is automatically set by -outputdir, and - we don't want changes in -outputdir to automatically trigger - recompilation. This could be wrong, but only in very rare cases. - --i (importPaths) - For the same reason as -osuf etc. above: if GHC decides not to - recompile, then it must have already checked all the .hi files on - which the current module depends, so it must have found them - successfully. It is occasionally useful to be able to cd to a - different directory and use -i flags to enable GHC to find the .hi - files; we don't want this to force recompilation. - -The only path-related flag left is -hcsuf. --} - -{- Note [Ignoring some flag changes] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Normally, --make tries to reuse only compilation products that are -the same as those that would have been produced compiling from -scratch. Sometimes, however, users would like to be more aggressive -about recompilation avoidance. This is particularly likely when -developing using GHCi (see #13604). Currently, we allow users to -ignore optimisation changes using -fignore-optim-changes, and to -ignore HPC option changes using -fignore-hpc-changes. If there's a -demand for it, we could also allow changes to -fprof-auto-* flags -(although we can't allow -prof flags to differ). The key thing about -these options is that we can still successfully link a library or -executable when some of its components differ in these ways. - -The way we accomplish this is to leave the optimization and HPC -options out of the flag hash, hashing them separately. --} - -{- Note [Repeated -optP hashing] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We invoke fingerprintDynFlags for each compiled module to include -the hash of relevant DynFlags in the resulting interface file. --optP (preprocessor) flags are part of that hash. --optP flags can come from multiple places: - - 1. -optP flags directly passed on command line. - 2. -optP flags implied by other flags. Eg. -DPROFILING implied by -prof. - 3. -optP flags added with {-# OPTIONS -optP-D__F__ #-} in a file. - -When compiling many modules at once with many -optP command line arguments -the work of hashing -optP flags would be repeated. This can get expensive -and as noted on #14697 it can take 7% of time and 14% of allocations on -a real codebase. - -The obvious solution is to cache the hash of -optP flags per GHC invocation. -However, one has to be careful there, as the flags that were added in 3. way -have to be accounted for. - -The current strategy is as follows: - - 1. Lazily compute the hash of sOpt_p in sOpt_P_fingerprint whenever sOpt_p - is modified. This serves dual purpose. It ensures correctness for when - we add per file -optP flags and lets us save work for when we don't. - 2. When computing the fingerprint in fingerprintDynFlags use the cached - value *and* fingerprint the additional implied (see 2. above) -optP flags. - This is relatively cheap and saves the headache of fingerprinting all - the -optP flags and tracking all the places that could invalidate the - cache. --} diff --git a/compiler/main/Ar.hs b/compiler/main/Ar.hs deleted file mode 100644 --- a/compiler/main/Ar.hs +++ /dev/null @@ -1,268 +0,0 @@ -{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-} -{- Note: [The need for Ar.hs] -Building `-staticlib` required the presence of libtool, and was a such -restricted to mach-o only. As libtool on macOS and gnu libtool are very -different, there was no simple portable way to support this. - -libtool for static archives does essentially: concatinate the input archives, -add the input objects, and create a symbol index. Using `ar` for this task -fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same -features across platforms (e.g. index prefixed retrieval of objects with -the same name.) - -As Archives are rather simple structurally, we can just build the archives -with Haskell directly and use ranlib on the final result to get the symbol -index. This should allow us to work around with the differences/abailability -of libtool across different platforms. --} -module Ar - (ArchiveEntry(..) - ,Archive(..) - ,afilter - - ,parseAr - - ,loadAr - ,loadObj - ,writeBSDAr - ,writeGNUAr - - ,isBSDSymdef - ,isGNUSymdef - ) - where - -import GhcPrelude - -import Data.List (mapAccumL, isPrefixOf) -import Data.Monoid ((<>)) -import Data.Binary.Get -import Data.Binary.Put -import Control.Monad -import Control.Applicative -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as L -#if !defined(mingw32_HOST_OS) -import qualified System.Posix.Files as POSIX -#endif -import System.FilePath (takeFileName) - -data ArchiveEntry = ArchiveEntry - { filename :: String -- ^ File name. - , filetime :: Int -- ^ File modification time. - , fileown :: Int -- ^ File owner. - , filegrp :: Int -- ^ File group. - , filemode :: Int -- ^ File mode. - , filesize :: Int -- ^ File size. - , filedata :: B.ByteString -- ^ File bytes. - } deriving (Eq, Show) - -newtype Archive = Archive [ArchiveEntry] - deriving (Eq, Show, Semigroup, Monoid) - -afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive -afilter f (Archive xs) = Archive (filter f xs) - -isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool -isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a) -isGNUSymdef a = "/" == (filename a) - --- | Archives have numeric values padded with '\x20' to the right. -getPaddedInt :: B.ByteString -> Int -getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20') - -putPaddedInt :: Int -> Int -> Put -putPaddedInt padding i = putPaddedString '\x20' padding (show i) - -putPaddedString :: Char -> Int -> String -> Put -putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad) - -getBSDArchEntries :: Get [ArchiveEntry] -getBSDArchEntries = do - empty <- isEmpty - if empty then - return [] - else do - name <- getByteString 16 - when ('/' `C.elem` name && C.take 3 name /= "#1/") $ - fail "Looks like GNU Archive" - time <- getPaddedInt <$> getByteString 12 - own <- getPaddedInt <$> getByteString 6 - grp <- getPaddedInt <$> getByteString 6 - mode <- getPaddedInt <$> getByteString 8 - st_size <- getPaddedInt <$> getByteString 10 - end <- getByteString 2 - when (end /= "\x60\x0a") $ - fail ("[BSD Archive] Invalid archive header end marker for name: " ++ - C.unpack name) - off1 <- liftM fromIntegral bytesRead :: Get Int - -- BSD stores extended filenames, by writing #1/ into the - -- name field, the first @length@ bytes then represent the file name - -- thus the payload size is filesize + file name length. - name <- if C.unpack (C.take 3 name) == "#1/" then - liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name) - else - return $ C.unpack $ C.takeWhile (/= ' ') name - off2 <- liftM fromIntegral bytesRead :: Get Int - file <- getByteString (st_size - (off2 - off1)) - -- data sections are two byte aligned (see #15396) - when (odd st_size) $ - void (getByteString 1) - - rest <- getBSDArchEntries - return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest - --- | GNU Archives feature a special '//' entry that contains the --- extended names. Those are referred to as /, where num is the --- offset into the '//' entry. --- In addition, filenames are terminated with '/' in the archive. -getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry] -getGNUArchEntries extInfo = do - empty <- isEmpty - if empty - then return [] - else - do - name <- getByteString 16 - time <- getPaddedInt <$> getByteString 12 - own <- getPaddedInt <$> getByteString 6 - grp <- getPaddedInt <$> getByteString 6 - mode <- getPaddedInt <$> getByteString 8 - st_size <- getPaddedInt <$> getByteString 10 - end <- getByteString 2 - when (end /= "\x60\x0a") $ - fail ("[BSD Archive] Invalid archive header end marker for name: " ++ - C.unpack name) - file <- getByteString st_size - -- data sections are two byte aligned (see #15396) - when (odd st_size) $ - void (getByteString 1) - name <- return . C.unpack $ - if C.unpack (C.take 1 name) == "/" - then case C.takeWhile (/= ' ') name of - name@"/" -> name -- symbol table - name@"//" -> name -- extendedn file names table - name -> getExtName extInfo (read . C.unpack $ C.drop 1 name) - else C.takeWhile (/= '/') name - case name of - "/" -> getGNUArchEntries extInfo - "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file)) - _ -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo - - where - getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString - getExtName Nothing _ = error "Invalid extended filename reference." - getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info - --- | put an Archive Entry. This assumes that the entries --- have been preprocessed to account for the extenden file name --- table section "//" e.g. for GNU Archives. Or that the names --- have been move into the payload for BSD Archives. -putArchEntry :: ArchiveEntry -> PutM () -putArchEntry (ArchiveEntry name time own grp mode st_size file) = do - putPaddedString ' ' 16 name - putPaddedInt 12 time - putPaddedInt 6 own - putPaddedInt 6 grp - putPaddedInt 8 mode - putPaddedInt 10 (st_size + pad) - putByteString "\x60\x0a" - putByteString file - when (pad == 1) $ - putWord8 0x0a - where - pad = st_size `mod` 2 - -getArchMagic :: Get () -getArchMagic = do - magic <- liftM C.unpack $ getByteString 8 - if magic /= "!\n" - then fail $ "Invalid magic number " ++ show magic - else return () - -putArchMagic :: Put -putArchMagic = putByteString $ C.pack "!\n" - -getArch :: Get Archive -getArch = Archive <$> do - getArchMagic - getBSDArchEntries <|> getGNUArchEntries Nothing - -putBSDArch :: Archive -> PutM () -putBSDArch (Archive as) = do - putArchMagic - mapM_ putArchEntry (processEntries as) - - where - padStr pad size str = take size $ str <> repeat pad - nameSize name = case length name `divMod` 4 of - (n, 0) -> 4 * n - (n, _) -> 4 * (n + 1) - needExt name = length name > 16 || ' ' `elem` name - processEntry :: ArchiveEntry -> ArchiveEntry - processEntry archive@(ArchiveEntry name _ _ _ _ st_size _) - | needExt name = archive { filename = "#1/" <> show sz - , filedata = C.pack (padStr '\0' sz name) <> filedata archive - , filesize = st_size + sz } - | otherwise = archive - - where sz = nameSize name - - processEntries = map processEntry - -putGNUArch :: Archive -> PutM () -putGNUArch (Archive as) = do - putArchMagic - mapM_ putArchEntry (processEntries as) - - where - processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry) - processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _) - | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2 - , filedata = filedata extInfo <> C.pack name <> "/\n" } - , archive { filename = "/" <> show (filesize extInfo) } ) - | otherwise = ( extInfo, archive { filename = name <> "/" } ) - - processEntries :: [ArchiveEntry] -> [ArchiveEntry] - processEntries = - uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty) - -parseAr :: B.ByteString -> Archive -parseAr = runGet getArch . L.fromChunks . pure - -writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO () -writeBSDAr fp = L.writeFile fp . runPut . putBSDArch -writeGNUAr fp = L.writeFile fp . runPut . putGNUArch - -loadAr :: FilePath -> IO Archive -loadAr fp = parseAr <$> B.readFile fp - -loadObj :: FilePath -> IO ArchiveEntry -loadObj fp = do - payload <- B.readFile fp - (modt, own, grp, mode) <- fileInfo fp - return $ ArchiveEntry - (takeFileName fp) modt own grp mode - (B.length payload) payload - --- | Take a filePath and return (mod time, own, grp, mode in decimal) -fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal) -#if defined(mingw32_HOST_OS) --- on windows mod time, owner group and mode are zero. -fileInfo _ = pure (0,0,0,0) -#else -fileInfo fp = go <$> POSIX.getFileStatus fp - where go status = ( fromEnum $ POSIX.modificationTime status - , fromIntegral $ POSIX.fileOwner status - , fromIntegral $ POSIX.fileGroup status - , oct2dec . fromIntegral $ POSIX.fileMode status - ) - -oct2dec :: Int -> Int -oct2dec = foldl' (\a b -> a * 10 + b) 0 . reverse . dec 8 - where dec _ 0 = [] - dec b i = let (rest, last) = i `quotRem` b - in last:dec b rest - -#endif diff --git a/compiler/main/Elf.hs b/compiler/main/Elf.hs deleted file mode 100644 --- a/compiler/main/Elf.hs +++ /dev/null @@ -1,460 +0,0 @@ -{- ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2015 --- --- ELF format tools --- ------------------------------------------------------------------------------ --} - -module Elf ( - readElfSectionByName, - readElfNoteAsString, - makeElfNote - ) where - -import GhcPrelude - -import AsmUtils -import Exception -import GHC.Driver.Session -import GHC.Platform -import ErrUtils -import Maybes (MaybeT(..),runMaybeT) -import Util (charToC) -import Outputable (text,hcat,SDoc) - -import Control.Monad (when) -import Data.Binary.Get -import Data.Word -import Data.Char (ord) -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as B8 - -{- Note [ELF specification] - ~~~~~~~~~~~~~~~~~~~~~~~~ - - ELF (Executable and Linking Format) is described in the System V Application - Binary Interface (or ABI). The latter is composed of two parts: a generic - part and a processor specific part. The generic ABI describes the parts of - the interface that remain constant across all hardware implementations of - System V. - - The latest release of the specification of the generic ABI is the version - 4.1 from March 18, 1997: - - - http://www.sco.com/developers/devspecs/gabi41.pdf - - Since 1997, snapshots of the draft for the "next" version are published: - - - http://www.sco.com/developers/gabi/ - - Quoting the notice on the website: "There is more than one instance of these - chapters to permit references to older instances to remain valid. All - modifications to these chapters are forward-compatible, so that correct use - of an older specification will not be invalidated by a newer instance. - Approximately on a yearly basis, a new instance will be saved, as it reaches - what appears to be a stable state." - - Nevertheless we will see that since 1998 it is not true for Note sections. - - Many ELF sections - ----------------- - - ELF-4.1: the normal section number fields in ELF are limited to 16 bits, - which runs out of bits when you try to cram in more sections than that. Two - fields are concerned: the one containing the number of the sections and the - one containing the index of the section that contains section's names. (The - same thing applies to the field containing the number of segments, but we - don't care about it here). - - ELF-next: to solve this, theses fields in the ELF header have an escape - value (different for each case), and the actual section number is stashed - into unused fields in the first section header. - - We support this extension as it is forward-compatible with ELF-4.1. - Moreover, GHC may generate objects with a lot of sections with the - "function-sections" feature (one section per function). - - Note sections - ------------- - - Sections with type "note" (SHT_NOTE in the specification) are used to add - arbitrary data into an ELF file. An entry in a note section is composed of a - name, a type and a value. - - ELF-4.1: "The note information in sections and program header elements holds - any number of entries, each of which is an array of 4-byte words in the - format of the target processor." Each entry has the following format: - | namesz | Word32: size of the name string (including the ending \0) - | descsz | Word32: size of the value - | type | Word32: type of the note - | name | Name string (with \0 padding to ensure 4-byte alignment) - | ... | - | desc | Value (with \0 padding to ensure 4-byte alignment) - | ... | - - ELF-next: "The note information in sections and program header elements - holds a variable amount of entries. In 64-bit objects (files with - e_ident[EI_CLASS] equal to ELFCLASS64), each entry is an array of 8-byte - words in the format of the target processor. In 32-bit objects (files with - e_ident[EI_CLASS] equal to ELFCLASS32), each entry is an array of 4-byte - words in the format of the target processor." (from 1998-2015 snapshots) - - This is not forward-compatible with ELF-4.1. In practice, for almost all - platforms namesz, descz and type fields are 4-byte words for both 32-bit and - 64-bit objects (see elf.h and readelf source code). - - The only exception in readelf source code is for IA_64 machines with OpenVMS - OS: "This OS has so many departures from the ELF standard that we test it at - many places" (comment for is_ia64_vms() in readelf.c). In this case, namesz, - descsz and type fields are 8-byte words and name and value fields are padded - to ensure 8-byte alignment. - - We don't support this platform in the following code. Reading a note section - could be done easily (by testing Machine and OS fields in the ELF header). - Writing a note section, however, requires that we generate a different - assembly code for GAS depending on the target platform and this is a little - bit more involved. - --} - - --- | ELF header --- --- The ELF header indicates the native word size (32-bit or 64-bit) and the --- endianness of the target machine. We directly store getters for words of --- different sizes as it is more convenient to use. We also store the word size --- as it is useful to skip some uninteresting fields. --- --- Other information such as the target machine and OS are left out as we don't --- use them yet. We could add them in the future if we ever need them. -data ElfHeader = ElfHeader - { gw16 :: Get Word16 -- ^ Get a Word16 with the correct endianness - , gw32 :: Get Word32 -- ^ Get a Word32 with the correct endianness - , gwN :: Get Word64 -- ^ Get a Word with the correct word size - -- and endianness - , wordSize :: Int -- ^ Word size in bytes - } - - --- | Read the ELF header -readElfHeader :: DynFlags -> ByteString -> IO (Maybe ElfHeader) -readElfHeader dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF header") - return Nothing - where - getHeader = do - magic <- getWord32be - ws <- getWord8 - endian <- getWord8 - version <- getWord8 - skip 9 -- skip OSABI, ABI version and padding - when (magic /= 0x7F454C46 || version /= 1) $ fail "Invalid ELF header" - - case (ws, endian) of - -- ELF 32, little endian - (1,1) -> return . Just $ ElfHeader - getWord16le - getWord32le - (fmap fromIntegral getWord32le) 4 - -- ELF 32, big endian - (1,2) -> return . Just $ ElfHeader - getWord16be - getWord32be - (fmap fromIntegral getWord32be) 4 - -- ELF 64, little endian - (2,1) -> return . Just $ ElfHeader - getWord16le - getWord32le - (fmap fromIntegral getWord64le) 8 - -- ELF 64, big endian - (2,2) -> return . Just $ ElfHeader - getWord16be - getWord32be - (fmap fromIntegral getWord64be) 8 - _ -> fail "Invalid ELF header" - - ------------------- --- SECTIONS ------------------- - - --- | Description of the section table -data SectionTable = SectionTable - { sectionTableOffset :: Word64 -- ^ offset of the table describing sections - , sectionEntrySize :: Word16 -- ^ size of an entry in the section table - , sectionEntryCount :: Word64 -- ^ number of sections - , sectionNameIndex :: Word32 -- ^ index of a special section which - -- contains section's names - } - --- | Read the ELF section table -readElfSectionTable :: DynFlags - -> ElfHeader - -> ByteString - -> IO (Maybe SectionTable) - -readElfSectionTable dflags hdr bs = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF section table") - return Nothing - where - getSectionTable :: Get SectionTable - getSectionTable = do - skip (24 + 2*wordSize hdr) -- skip header and some other fields - secTableOffset <- gwN hdr - skip 10 - entrySize <- gw16 hdr - entryCount <- gw16 hdr - secNameIndex <- gw16 hdr - return (SectionTable secTableOffset entrySize - (fromIntegral entryCount) - (fromIntegral secNameIndex)) - - action = do - secTable <- runGetOrThrow getSectionTable bs - -- In some cases, the number of entries and the index of the section - -- containing section's names must be found in unused fields of the first - -- section entry (see Note [ELF specification]) - let - offSize0 = fromIntegral $ sectionTableOffset secTable + 8 - + 3 * fromIntegral (wordSize hdr) - offLink0 = fromIntegral $ offSize0 + fromIntegral (wordSize hdr) - - entryCount' <- if sectionEntryCount secTable /= 0 - then return (sectionEntryCount secTable) - else runGetOrThrow (gwN hdr) (LBS.drop offSize0 bs) - entryNameIndex' <- if sectionNameIndex secTable /= 0xffff - then return (sectionNameIndex secTable) - else runGetOrThrow (gw32 hdr) (LBS.drop offLink0 bs) - return (Just $ secTable - { sectionEntryCount = entryCount' - , sectionNameIndex = entryNameIndex' - }) - - --- | A section -data Section = Section - { entryName :: ByteString -- ^ Name of the section - , entryBS :: ByteString -- ^ Content of the section - } - --- | Read a ELF section -readElfSectionByIndex :: DynFlags - -> ElfHeader - -> SectionTable - -> Word64 - -> ByteString - -> IO (Maybe Section) - -readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF section") - return Nothing - where - -- read an entry from the section table - getEntry = do - nameIndex <- gw32 hdr - skip (4+2*wordSize hdr) - offset <- fmap fromIntegral $ gwN hdr - size <- fmap fromIntegral $ gwN hdr - let bs' = LBS.take size (LBS.drop offset bs) - return (nameIndex,bs') - - -- read the entry with the given index in the section table - getEntryByIndex x = runGetOrThrow getEntry bs' - where - bs' = LBS.drop off bs - off = fromIntegral $ sectionTableOffset secTable + - x * fromIntegral (sectionEntrySize secTable) - - -- Get the name of a section - getEntryName nameIndex = do - let idx = fromIntegral (sectionNameIndex secTable) - (_,nameTable) <- getEntryByIndex idx - let bs' = LBS.drop nameIndex nameTable - runGetOrThrow getLazyByteStringNul bs' - - action = do - (nameIndex,bs') <- getEntryByIndex (fromIntegral i) - name <- getEntryName (fromIntegral nameIndex) - return (Just $ Section name bs') - - --- | Find a section from its name. Return the section contents. --- --- We do not perform any check on the section type. -findSectionFromName :: DynFlags - -> ElfHeader - -> SectionTable - -> String - -> ByteString - -> IO (Maybe ByteString) -findSectionFromName dflags hdr secTable name bs = - rec [0..sectionEntryCount secTable - 1] - where - -- convert the required section name into a ByteString to perform - -- ByteString comparison instead of String comparison - name' = B8.pack name - - -- compare recursively each section name and return the contents of - -- the matching one, if any - rec [] = return Nothing - rec (x:xs) = do - me <- readElfSectionByIndex dflags hdr secTable x bs - case me of - Just e | entryName e == name' -> return (Just (entryBS e)) - _ -> rec xs - - --- | Given a section name, read its contents as a ByteString. --- --- If the section isn't found or if there is any parsing error, we return --- Nothing -readElfSectionByName :: DynFlags - -> ByteString - -> String - -> IO (Maybe LBS.ByteString) - -readElfSectionByName dflags bs name = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF section \"" ++ name ++ "\"") - return Nothing - where - action = runMaybeT $ do - hdr <- MaybeT $ readElfHeader dflags bs - secTable <- MaybeT $ readElfSectionTable dflags hdr bs - MaybeT $ findSectionFromName dflags hdr secTable name bs - ------------------- --- NOTE SECTIONS ------------------- - --- | read a Note as a ByteString --- --- If you try to read a note from a section which does not support the Note --- format, the parsing is likely to fail and Nothing will be returned -readElfNoteBS :: DynFlags - -> ByteString - -> String - -> String - -> IO (Maybe LBS.ByteString) - -readElfNoteBS dflags bs sectionName noteId = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF note \"" ++ noteId ++ - "\" in section \"" ++ sectionName ++ "\"") - return Nothing - where - -- align the getter on n bytes - align n = do - m <- bytesRead - if m `mod` n == 0 - then return () - else skip 1 >> align n - - -- noteId as a bytestring - noteId' = B8.pack noteId - - -- read notes recursively until the one with a valid identifier is found - findNote hdr = do - align 4 - namesz <- gw32 hdr - descsz <- gw32 hdr - _ <- gw32 hdr -- we don't use the note type - name <- if namesz == 0 - then return LBS.empty - else getLazyByteStringNul - align 4 - desc <- if descsz == 0 - then return LBS.empty - else getLazyByteString (fromIntegral descsz) - if name == noteId' - then return $ Just desc - else findNote hdr - - - action = runMaybeT $ do - hdr <- MaybeT $ readElfHeader dflags bs - sec <- MaybeT $ readElfSectionByName dflags bs sectionName - MaybeT $ runGetOrThrow (findNote hdr) sec - --- | read a Note as a String --- --- If you try to read a note from a section which does not support the Note --- format, the parsing is likely to fail and Nothing will be returned -readElfNoteAsString :: DynFlags - -> FilePath - -> String - -> String - -> IO (Maybe String) - -readElfNoteAsString dflags path sectionName noteId = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF note \"" ++ noteId ++ - "\" in section \"" ++ sectionName ++ "\"") - return Nothing - where - action = do - bs <- LBS.readFile path - note <- readElfNoteBS dflags bs sectionName noteId - return (fmap B8.unpack note) - - --- | Generate the GAS code to create a Note section --- --- Header fields for notes are 32-bit long (see Note [ELF specification]). -makeElfNote :: Platform -> String -> String -> Word32 -> String -> SDoc -makeElfNote platform sectionName noteName typ contents = hcat [ - text "\t.section ", - text sectionName, - text ",\"\",", - sectionType platform "note", - text "\n", - text "\t.balign 4\n", - - -- note name length (+ 1 for ending \0) - asWord32 (length noteName + 1), - - -- note contents size - asWord32 (length contents), - - -- note type - asWord32 typ, - - -- note name (.asciz for \0 ending string) + padding - text "\t.asciz \"", - text noteName, - text "\"\n", - text "\t.balign 4\n", - - -- note contents (.ascii to avoid ending \0) + padding - text "\t.ascii \"", - text (escape contents), - text "\"\n", - text "\t.balign 4\n"] - where - escape :: String -> String - escape = concatMap (charToC.fromIntegral.ord) - - asWord32 :: Show a => a -> SDoc - asWord32 x = hcat [ - text "\t.4byte ", - text (show x), - text "\n"] - - ------------------- --- Helpers ------------------- - --- | runGet in IO monad that throws an IOException on failure -runGetOrThrow :: Get a -> LBS.ByteString -> IO a -runGetOrThrow g bs = case runGetOrFail g bs of - Left _ -> fail "Error while reading file" - Right (_,_,a) -> return a diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs deleted file mode 100644 --- a/compiler/main/HscStats.hs +++ /dev/null @@ -1,188 +0,0 @@ --- | --- Statistics for per-module compilations --- --- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 --- - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module HscStats ( ppSourceStats ) where - -import GhcPrelude - -import Bag -import GHC.Hs -import Outputable -import GHC.Types.SrcLoc -import Util - -import Data.Char - --- | Source Statistics -ppSourceStats :: Bool -> Located HsModule -> SDoc -ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) - = (if short then hcat else vcat) - (map pp_val - [("ExportAll ", export_all), -- 1 if no export list - ("ExportDecls ", export_ds), - ("ExportModules ", export_ms), - ("Imports ", imp_no), - (" ImpSafe ", imp_safe), - (" ImpQual ", imp_qual), - (" ImpAs ", imp_as), - (" ImpAll ", imp_all), - (" ImpPartial ", imp_partial), - (" ImpHiding ", imp_hiding), - ("FixityDecls ", fixity_sigs), - ("DefaultDecls ", default_ds), - ("TypeDecls ", type_ds), - ("DataDecls ", data_ds), - ("NewTypeDecls ", newt_ds), - ("TypeFamilyDecls ", type_fam_ds), - ("DataConstrs ", data_constrs), - ("DataDerivings ", data_derivs), - ("ClassDecls ", class_ds), - ("ClassMethods ", class_method_ds), - ("DefaultMethods ", default_method_ds), - ("InstDecls ", inst_ds), - ("InstMethods ", inst_method_ds), - ("InstType ", inst_type_ds), - ("InstData ", inst_data_ds), - ("TypeSigs ", bind_tys), - ("ClassOpSigs ", generic_sigs), - ("ValBinds ", val_bind_ds), - ("FunBinds ", fn_bind_ds), - ("PatSynBinds ", patsyn_ds), - ("InlineMeths ", method_inlines), - ("InlineBinds ", bind_inlines), - ("SpecialisedMeths ", method_specs), - ("SpecialisedBinds ", bind_specs) - ]) - where - decls = map unLoc ldecls - - pp_val (_, 0) = empty - pp_val (str, n) - | not short = hcat [text str, int n] - | otherwise = hcat [text (trim str), equals, int n, semi] - - trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) - - (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) - = count_sigs [d | SigD _ d <- decls] - -- NB: this omits fixity decls on local bindings and - -- in class decls. ToDo - - tycl_decls = [d | TyClD _ d <- decls] - (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = - countTyClDecls tycl_decls - - inst_decls = [d | InstD _ d <- decls] - inst_ds = length inst_decls - default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls - val_decls = [d | ValD _ d <- decls] - - real_exports = case exports of { Nothing -> []; Just (L _ es) -> es } - n_exports = length real_exports - export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True - ; _ -> False}) - real_exports - export_ds = n_exports - export_ms - export_all = case exports of { Nothing -> 1; _ -> 0 } - - (val_bind_ds, fn_bind_ds, patsyn_ds) - = sum3 (map count_bind val_decls) - - (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding) - = sum7 (map import_info imports) - (data_constrs, data_derivs) - = sum2 (map data_info tycl_decls) - (class_method_ds, default_method_ds) - = sum2 (map class_info tycl_decls) - (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) - = sum5 (map inst_info inst_decls) - - count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0) - count_bind (PatBind {}) = (0,1,0) - count_bind (FunBind {}) = (0,1,0) - count_bind (PatSynBind {}) = (0,0,1) - count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) - - count_sigs sigs = sum5 (map sig_info sigs) - - sig_info (FixSig {}) = (1,0,0,0,0) - sig_info (TypeSig {}) = (0,1,0,0,0) - sig_info (SpecSig {}) = (0,0,1,0,0) - sig_info (InlineSig {}) = (0,0,0,1,0) - sig_info (ClassOpSig {}) = (0,0,0,0,1) - sig_info _ = (0,0,0,0,0) - - import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual - , ideclAs = as, ideclHiding = spec })) - = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) - import_info (L _ (XImportDecl nec)) = noExtCon nec - - safe_info False = 0 - safe_info True = 1 - qual_info NotQualified = 0 - qual_info _ = 1 - as_info Nothing = 0 - as_info (Just _) = 1 - spec_info Nothing = (0,0,0,0,1,0,0) - spec_info (Just (False, _)) = (0,0,0,0,0,1,0) - spec_info (Just (True, _)) = (0,0,0,0,0,0,1) - - data_info (DataDecl { tcdDataDefn = HsDataDefn - { dd_cons = cs - , dd_derivs = L _ derivs}}) - = ( length cs - , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s) - 0 derivs ) - data_info _ = (0,0) - - class_info decl@(ClassDecl {}) - = (classops, addpr (sum3 (map count_bind methods))) - where - methods = map unLoc $ bagToList (tcdMeths decl) - (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl)) - class_info _ = (0,0) - - inst_info (TyFamInstD {}) = (0,0,0,1,0) - inst_info (DataFamInstD {}) = (0,0,0,0,1) - inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths - , cid_sigs = inst_sigs - , cid_tyfam_insts = ats - , cid_datafam_insts = adts } }) - = case count_sigs (map unLoc inst_sigs) of - (_,_,ss,is,_) -> - (addpr (sum3 (map count_bind methods)), - ss, is, length ats, length adts) - where - methods = map unLoc $ bagToList inst_meths - inst_info (ClsInstD _ (XClsInstDecl nec)) = noExtCon nec - inst_info (XInstDecl nec) = noExtCon nec - - -- TODO: use Sum monoid - addpr :: (Int,Int,Int) -> Int - sum2 :: [(Int, Int)] -> (Int, Int) - sum3 :: [(Int, Int, Int)] -> (Int, Int, Int) - sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int) - sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int) - add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int) - -> (Int, Int, Int, Int, Int, Int, Int) - - addpr (x,y,z) = x+y+z - sum2 = foldr add2 (0,0) - where - add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) - sum3 = foldr add3 (0,0,0) - where - add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3) - sum5 = foldr add5 (0,0,0,0,0) - where - add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) - sum7 = foldr add7 (0,0,0,0,0,0,0) - - add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7) diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs deleted file mode 100644 --- a/compiler/main/StaticPtrTable.hs +++ /dev/null @@ -1,294 +0,0 @@ --- | Code generation for the Static Pointer Table --- --- (c) 2014 I/O Tweag --- --- Each module that uses 'static' keyword declares an initialization function of --- the form hs_spt_init_() which is emitted into the _stub.c file and --- annotated with __attribute__((constructor)) so that it gets executed at --- startup time. --- --- The function's purpose is to call hs_spt_insert to insert the static --- pointers of this module in the hashtable of the RTS, and it looks something --- like this: --- --- > static void hs_hpc_init_Main(void) __attribute__((constructor)); --- > static void hs_hpc_init_Main(void) { --- > --- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; --- > extern StgPtr Main_r2wb_closure; --- > hs_spt_insert(k0, &Main_r2wb_closure); --- > --- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; --- > extern StgPtr Main_r2wc_closure; --- > hs_spt_insert(k1, &Main_r2wc_closure); --- > --- > } --- --- where the constants are fingerprints produced from the static forms. --- --- The linker must find the definitions matching the @extern StgPtr @ --- declarations. For this to work, the identifiers of static pointers need to be --- exported. This is done in GHC.Core.Op.SetLevels.newLvlVar. --- --- There is also a finalization function for the time when the module is --- unloaded. --- --- > static void hs_hpc_fini_Main(void) __attribute__((destructor)); --- > static void hs_hpc_fini_Main(void) { --- > --- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; --- > hs_spt_remove(k0); --- > --- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; --- > hs_spt_remove(k1); --- > --- > } --- - -{-# LANGUAGE ViewPatterns, TupleSections #-} -module StaticPtrTable - ( sptCreateStaticBinds - , sptModuleInitCode - ) where - -{- Note [Grand plan for static forms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Static forms go through the compilation phases as follows. -Here is a running example: - - f x = let k = map toUpper - in ...(static k)... - -* The renamer looks for out-of-scope names in the body of the static - form, as always. If all names are in scope, the free variables of the - body are stored in AST at the location of the static form. - -* The typechecker verifies that all free variables occurring in the - static form are floatable to top level (see Note [Meaning of - IdBindingInfo] in TcRnTypes). In our example, 'k' is floatable. - Even though it is bound in a nested let, we are fine. - -* The desugarer replaces the static form with an application of the - function 'makeStatic' (defined in module GHC.StaticPtr.Internal of - base). So we get - - f x = let k = map toUpper - in ...fromStaticPtr (makeStatic location k)... - -* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic' - to the top level. Thus the FloatOut pass is always executed, even when - optimizations are disabled. So we get - - k = map toUpper - static_ptr = makeStatic location k - f x = ...fromStaticPtr static_ptr... - - The FloatOut pass is careful to produce an /exported/ Id for a floated - 'makeStatic' call, so the binding is not removed or inlined by the - simplifier. - E.g. the code for `f` above might look like - - static_ptr = makeStatic location k - f x = ...(case static_ptr of ...)... - - which might be simplified to - - f x = ...(case makeStatic location k of ...)... - - BUT the top-level binding for static_ptr must remain, so that it can be - collected to populate the Static Pointer Table. - - Making the binding exported also has a necessary effect during the - CoreTidy pass. - -* The CoreTidy pass replaces all bindings of the form - - b = /\ ... -> makeStatic location value - - with - - b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value - - where a distinct key is generated for each binding. - -* If we are compiling to object code we insert a C stub (generated by - sptModuleInitCode) into the final object which runs when the module is loaded, - inserting the static forms defined by the module into the RTS's static pointer - table. - -* If we are compiling for the byte-code interpreter, we instead explicitly add - the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter - process' SPT table using the addSptEntry interpreter message. This happens - in upsweep after we have compiled the module (see GHC.Driver.Make.upsweep'). --} - -import GhcPrelude - -import GHC.Cmm.CLabel -import GHC.Core -import GHC.Core.Utils (collectMakeStaticArgs) -import GHC.Core.DataCon -import GHC.Driver.Session -import GHC.Driver.Types -import GHC.Types.Id -import GHC.Core.Make (mkStringExprFSWith) -import GHC.Types.Module -import GHC.Types.Name -import Outputable -import GHC.Platform -import PrelNames -import TcEnv (lookupGlobal) -import GHC.Core.Type - -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State -import Data.List -import Data.Maybe -import GHC.Fingerprint -import qualified GHC.LanguageExtensions as LangExt - --- | Replaces all bindings of the form --- --- > b = /\ ... -> makeStatic location value --- --- with --- --- > b = /\ ... -> --- > StaticPtr key (StaticPtrInfo "pkg key" "module" location) value --- --- where a distinct key is generated for each binding. --- --- It also yields the C stub that inserts these bindings into the static --- pointer table. -sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram - -> IO ([SptEntry], CoreProgram) -sptCreateStaticBinds hsc_env this_mod binds - | not (xopt LangExt.StaticPointers dflags) = - return ([], binds) - | otherwise = do - -- Make sure the required interface files are loaded. - _ <- lookupGlobal hsc_env unpackCStringName - (fps, binds') <- evalStateT (go [] [] binds) 0 - return (fps, binds') - where - go fps bs xs = case xs of - [] -> return (reverse fps, reverse bs) - bnd : xs' -> do - (fps', bnd') <- replaceStaticBind bnd - go (reverse fps' ++ fps) (bnd' : bs) xs' - - dflags = hsc_dflags hsc_env - platform = targetPlatform dflags - - -- Generates keys and replaces 'makeStatic' with 'StaticPtr'. - -- - -- The 'Int' state is used to produce a different key for each binding. - replaceStaticBind :: CoreBind - -> StateT Int IO ([SptEntry], CoreBind) - replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e - return (maybeToList mfp, NonRec b' e') - replaceStaticBind (Rec rbs) = do - (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs - return (catMaybes mfps, Rec rbs') - - replaceStatic :: Id -> CoreExpr - -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr)) - replaceStatic b e@(collectTyBinders -> (tvs, e0)) = - case collectMakeStaticArgs e0 of - Nothing -> return (Nothing, (b, e)) - Just (_, t, info, arg) -> do - (fp, e') <- mkStaticBind t info arg - return (Just (SptEntry b fp), (b, foldr Lam e' tvs)) - - mkStaticBind :: Type -> CoreExpr -> CoreExpr - -> StateT Int IO (Fingerprint, CoreExpr) - mkStaticBind t srcLoc e = do - i <- get - put (i + 1) - staticPtrInfoDataCon <- - lift $ lookupDataConHscEnv staticPtrInfoDataConName - let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i - info <- mkConApp staticPtrInfoDataCon <$> - (++[srcLoc]) <$> - mapM (mkStringExprFSWith (lift . lookupIdHscEnv)) - [ unitIdFS $ moduleUnitId this_mod - , moduleNameFS $ moduleName this_mod - ] - - -- The module interface of GHC.StaticPtr should be loaded at least - -- when looking up 'fromStatic' during type-checking. - staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName - return (fp, mkConApp staticPtrDataCon - [ Type t - , mkWord64LitWordRep platform w0 - , mkWord64LitWordRep platform w1 - , info - , e ]) - - mkStaticPtrFingerprint :: Int -> Fingerprint - mkStaticPtrFingerprint n = fingerprintString $ intercalate ":" - [ unitIdString $ moduleUnitId this_mod - , moduleNameString $ moduleName this_mod - , show n - ] - - -- Choose either 'Word64#' or 'Word#' to represent the arguments of the - -- 'Fingerprint' data constructor. - mkWord64LitWordRep platform = - case platformWordSize platform of - PW4 -> mkWord64LitWord64 - PW8 -> mkWordLit platform . toInteger - - lookupIdHscEnv :: Name -> IO Id - lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>= - maybe (getError n) (return . tyThingId) - - lookupDataConHscEnv :: Name -> IO DataCon - lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>= - maybe (getError n) (return . tyThingDataCon) - - getError n = pprPanic "sptCreateStaticBinds.get: not found" $ - text "Couldn't find" <+> ppr n - --- | @sptModuleInitCode module fps@ is a C stub to insert the static entries --- of @module@ into the static pointer table. --- --- @fps@ is a list associating each binding corresponding to a static entry with --- its fingerprint. -sptModuleInitCode :: Module -> [SptEntry] -> SDoc -sptModuleInitCode _ [] = Outputable.empty -sptModuleInitCode this_mod entries = vcat - [ text "static void hs_spt_init_" <> ppr this_mod - <> text "(void) __attribute__((constructor));" - , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)" - , braces $ vcat $ - [ text "static StgWord64 k" <> int i <> text "[2] = " - <> pprFingerprint fp <> semi - $$ text "extern StgPtr " - <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi - $$ text "hs_spt_insert" <> parens - (hcat $ punctuate comma - [ char 'k' <> int i - , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n)) - ] - ) - <> semi - | (i, SptEntry n fp) <- zip [0..] entries - ] - , text "static void hs_spt_fini_" <> ppr this_mod - <> text "(void) __attribute__((destructor));" - , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)" - , braces $ vcat $ - [ text "StgWord64 k" <> int i <> text "[2] = " - <> pprFingerprint fp <> semi - $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi - | (i, (SptEntry _ fp)) <- zip [0..] entries - ] - ] - where - pprFingerprint :: Fingerprint -> SDoc - pprFingerprint (Fingerprint w1 w2) = - braces $ hcat $ punctuate comma - [ integer (fromIntegral w1) <> text "ULL" - , integer (fromIntegral w2) <> text "ULL" - ] diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs deleted file mode 100644 --- a/compiler/main/SysTools.hs +++ /dev/null @@ -1,475 +0,0 @@ -{- ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2001-2003 --- --- Access to system tools: gcc, cp, rm etc --- ------------------------------------------------------------------------------ --} - -{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables #-} - -module SysTools ( - -- * Initialisation - initSysTools, - lazyInitLlvmConfig, - - -- * Interface to system tools - module SysTools.Tasks, - module SysTools.Info, - - linkDynLib, - - copy, - copyWithHeader, - - -- * General utilities - Option(..), - expandTopDir, - - -- * Platform-specifics - libmLinkOpts, - - -- * Mac OS X frameworks - getPkgFrameworkOpts, - getFrameworkOpts - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Settings - -import GHC.Types.Module -import GHC.Driver.Packages -import Outputable -import ErrUtils -import GHC.Platform -import GHC.Driver.Session -import GHC.Driver.Ways - -import Control.Monad.Trans.Except (runExceptT) -import System.FilePath -import System.IO -import System.IO.Unsafe (unsafeInterleaveIO) -import SysTools.ExtraObj -import SysTools.Info -import SysTools.Tasks -import SysTools.BaseDir -import SysTools.Settings -import qualified Data.Set as Set - -{- -Note [How GHC finds toolchain utilities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -SysTools.initSysProgs figures out exactly where all the auxiliary programs -are, and initialises mutable variables to make it easy to call them. -To do this, it makes use of definitions in Config.hs, which is a Haskell -file containing variables whose value is figured out by the build system. - -Config.hs contains two sorts of things - - cGCC, The *names* of the programs - cCPP e.g. cGCC = gcc - cUNLIT cCPP = gcc -E - etc They do *not* include paths - - - cUNLIT_DIR The *path* to the directory containing unlit, split etc - cSPLIT_DIR *relative* to the root of the build tree, - for use when running *in-place* in a build tree (only) - - ---------------------------------------------- -NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented): - -Another hair-brained scheme for simplifying the current tool location -nightmare in GHC: Simon originally suggested using another -configuration file along the lines of GCC's specs file - which is fine -except that it means adding code to read yet another configuration -file. What I didn't notice is that the current package.conf is -general enough to do this: - -Package - {name = "tools", import_dirs = [], source_dirs = [], - library_dirs = [], hs_libraries = [], extra_libraries = [], - include_dirs = [], c_includes = [], package_deps = [], - extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.], - extra_cc_opts = [], extra_ld_opts = []} - -Which would have the advantage that we get to collect together in one -place the path-specific package stuff with the path-specific tool -stuff. - End of NOTES ---------------------------------------------- - -************************************************************************ -* * -\subsection{Initialisation} -* * -************************************************************************ --} - --- Note [LLVM configuration] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The `llvm-targets` and `llvm-passes` files are shipped with GHC and contain --- information needed by the LLVM backend to invoke `llc` and `opt`. --- Specifically: --- --- * llvm-targets maps autoconf host triples to the corresponding LLVM --- `data-layout` declarations. This information is extracted from clang using --- the script in utils/llvm-targets/gen-data-layout.sh and should be updated --- whenever we target a new version of LLVM. --- --- * llvm-passes maps GHC optimization levels to sets of LLVM optimization --- flags that GHC should pass to `opt`. --- --- This information is contained in files rather the GHC source to allow users --- to add new targets to GHC without having to recompile the compiler. --- --- Since this information is only needed by the LLVM backend we load it lazily --- with unsafeInterleaveIO. Consequently it is important that we lazily pattern --- match on LlvmConfig until we actually need its contents. - -lazyInitLlvmConfig :: String - -> IO LlvmConfig -lazyInitLlvmConfig top_dir - = unsafeInterleaveIO $ do -- see Note [LLVM configuration] - targets <- readAndParse "llvm-targets" mkLlvmTarget - passes <- readAndParse "llvm-passes" id - return $ LlvmConfig { llvmTargets = targets, llvmPasses = passes } - where - readAndParse name builder = - do let llvmConfigFile = top_dir name - llvmConfigStr <- readFile llvmConfigFile - case maybeReadFuzzy llvmConfigStr of - Just s -> return (fmap builder <$> s) - Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile) - - mkLlvmTarget :: (String, String, String) -> LlvmTarget - mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs) - - -initSysTools :: String -- TopDir path - -> IO Settings -- Set all the mutable variables above, holding - -- (a) the system programs - -- (b) the package-config file - -- (c) the GHC usage message -initSysTools top_dir = do - res <- runExceptT $ initSettings top_dir - case res of - Right a -> pure a - Left (SettingsError_MissingData msg) -> pgmError msg - Left (SettingsError_BadData msg) -> pgmError msg - -{- Note [Windows stack usage] - -See: #8870 (and #8834 for related info) and #12186 - -On Windows, occasionally we need to grow the stack. In order to do -this, we would normally just bump the stack pointer - but there's a -catch on Windows. - -If the stack pointer is bumped by more than a single page, then the -pages between the initial pointer and the resulting location must be -properly committed by the Windows virtual memory subsystem. This is -only needed in the event we bump by more than one page (i.e 4097 bytes -or more). - -Windows compilers solve this by emitting a call to a special function -called _chkstk, which does this committing of the pages for you. - -The reason this was causing a segfault was because due to the fact the -new code generator tends to generate larger functions, we needed more -stack space in GHC itself. In the x86 codegen, we needed approximately -~12kb of stack space in one go, which caused the process to segfault, -as the intervening pages were not committed. - -GCC can emit such a check for us automatically but only when the flag --fstack-check is used. - -See https://gcc.gnu.org/onlinedocs/gnat_ugn/Stack-Overflow-Checking.html -for more information. - --} - -copy :: DynFlags -> String -> FilePath -> FilePath -> IO () -copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to - -copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath - -> IO () -copyWithHeader dflags purpose maybe_header from to = do - showPass dflags purpose - - hout <- openBinaryFile to WriteMode - hin <- openBinaryFile from ReadMode - ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up - maybe (return ()) (header hout) maybe_header - hPutStr hout ls - hClose hout - hClose hin - where - -- write the header string in UTF-8. The header is something like - -- {-# LINE "foo.hs" #-} - -- and we want to make sure a Unicode filename isn't mangled. - header h str = do - hSetEncoding h utf8 - hPutStr h str - hSetBinaryMode h True - -{- -************************************************************************ -* * -\subsection{Support code} -* * -************************************************************************ --} - -linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO () -linkDynLib dflags0 o_files dep_packages - = do - let -- This is a rather ugly hack to fix dynamically linked - -- GHC on Windows. If GHC is linked with -threaded, then - -- it links against libHSrts_thr. But if base is linked - -- against libHSrts, then both end up getting loaded, - -- and things go wrong. We therefore link the libraries - -- with the same RTS flags that we link GHC with. - dflags1 = if platformMisc_ghcThreaded $ platformMisc dflags0 - then addWay' WayThreaded dflags0 - else dflags0 - dflags2 = if platformMisc_ghcDebugged $ platformMisc dflags1 - then addWay' WayDebug dflags1 - else dflags1 - dflags = updateWays dflags2 - - verbFlags = getVerbFlags dflags - o_file = outputFile dflags - - pkgs <- getPreloadPackagesAnd dflags dep_packages - - let pkg_lib_paths = collectLibraryPaths dflags pkgs - let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths - get_pkg_lib_path_opts l - | ( osElfTarget (platformOS (targetPlatform dflags)) || - osMachOTarget (platformOS (targetPlatform dflags)) ) && - dynLibLoader dflags == SystemDependent && - WayDyn `Set.member` ways dflags - = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l] - -- See Note [-Xlinker -rpath vs -Wl,-rpath] - | otherwise = ["-L" ++ l] - - let lib_paths = libraryPaths dflags - let lib_path_opts = map ("-L"++) lib_paths - - -- We don't want to link our dynamic libs against the RTS package, - -- because the RTS lib comes in several flavours and we want to be - -- able to pick the flavour when a binary is linked. - -- On Windows we need to link the RTS import lib as Windows does - -- not allow undefined symbols. - -- The RTS library path is still added to the library search path - -- above in case the RTS is being explicitly linked in (see #3807). - let platform = targetPlatform dflags - os = platformOS platform - pkgs_no_rts = case os of - OSMinGW32 -> - pkgs - _ -> - filter ((/= rtsUnitId) . packageConfigId) pkgs - let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts - in package_hs_libs ++ extra_libs ++ other_flags - - -- probably _stub.o files - -- and last temporary shared object file - let extra_ld_inputs = ldInputs dflags - - -- frameworks - pkg_framework_opts <- getPkgFrameworkOpts dflags platform - (map unitId pkgs) - let framework_opts = getFrameworkOpts dflags platform - - case os of - OSMinGW32 -> do - ------------------------------------------------------------- - -- Making a DLL - ------------------------------------------------------------- - let output_fn = case o_file of - Just s -> s - Nothing -> "HSdll.dll" - - runLink dflags ( - map Option verbFlags - ++ [ Option "-o" - , FileOption "" output_fn - , Option "-shared" - ] ++ - [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a") - | gopt Opt_SharedImplib dflags - ] - ++ map (FileOption "") o_files - - -- Permit the linker to auto link _symbol to _imp_symbol - -- This lets us link against DLLs without needing an "import library" - ++ [Option "-Wl,--enable-auto-import"] - - ++ extra_ld_inputs - ++ map Option ( - lib_path_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) - _ | os == OSDarwin -> do - ------------------------------------------------------------------- - -- Making a darwin dylib - ------------------------------------------------------------------- - -- About the options used for Darwin: - -- -dynamiclib - -- Apple's way of saying -shared - -- -undefined dynamic_lookup: - -- Without these options, we'd have to specify the correct - -- dependencies for each of the dylibs. Note that we could - -- (and should) do without this for all libraries except - -- the RTS; all we need to do is to pass the correct - -- HSfoo_dyn.dylib files to the link command. - -- This feature requires Mac OS X 10.3 or later; there is - -- a similar feature, -flat_namespace -undefined suppress, - -- which works on earlier versions, but it has other - -- disadvantages. - -- -single_module - -- Build the dynamic library as a single "module", i.e. no - -- dynamic binding nonsense when referring to symbols from - -- within the library. The NCG assumes that this option is - -- specified (on i386, at least). - -- -install_name - -- Mac OS/X stores the path where a dynamic library is (to - -- be) installed in the library itself. It's called the - -- "install name" of the library. Then any library or - -- executable that links against it before it's installed - -- will search for it in its ultimate install location. - -- By default we set the install name to the absolute path - -- at build time, but it can be overridden by the - -- -dylib-install-name option passed to ghc. Cabal does - -- this. - ------------------------------------------------------------------- - - let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - - instName <- case dylibInstallName dflags of - Just n -> return n - Nothing -> return $ "@rpath" `combine` (takeFileName output_fn) - runLink dflags ( - map Option verbFlags - ++ [ Option "-dynamiclib" - , Option "-o" - , FileOption "" output_fn - ] - ++ map Option o_files - ++ [ Option "-undefined", - Option "dynamic_lookup", - Option "-single_module" ] - ++ (if platformArch platform == ArchX86_64 - then [ ] - else [ Option "-Wl,-read_only_relocs,suppress" ]) - ++ [ Option "-install_name", Option instName ] - ++ map Option lib_path_opts - ++ extra_ld_inputs - ++ map Option framework_opts - ++ map Option pkg_lib_path_opts - ++ map Option pkg_link_opts - ++ map Option pkg_framework_opts - ++ [ Option "-Wl,-dead_strip_dylibs" ] - ) - _ -> do - ------------------------------------------------------------------- - -- Making a DSO - ------------------------------------------------------------------- - - let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - unregisterised = platformUnregisterised (targetPlatform dflags) - let bsymbolicFlag = -- we need symbolic linking to resolve - -- non-PIC intra-package-relocations for - -- performance (where symbolic linking works) - -- See Note [-Bsymbolic assumptions by GHC] - ["-Wl,-Bsymbolic" | not unregisterised] - - runLink dflags ( - map Option verbFlags - ++ libmLinkOpts - ++ [ Option "-o" - , FileOption "" output_fn - ] - ++ map Option o_files - ++ [ Option "-shared" ] - ++ map Option bsymbolicFlag - -- Set the library soname. We use -h rather than -soname as - -- Solaris 10 doesn't support the latter: - ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ] - ++ extra_ld_inputs - ++ map Option lib_path_opts - ++ map Option pkg_lib_path_opts - ++ map Option pkg_link_opts - ) - --- | Some platforms require that we explicitly link against @libm@ if any --- math-y things are used (which we assume to include all programs). See #14022. -libmLinkOpts :: [Option] -libmLinkOpts = -#if defined(HAVE_LIBM) - [Option "-lm"] -#else - [] -#endif - -getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String] -getPkgFrameworkOpts dflags platform dep_packages - | platformUsesFrameworks platform = do - pkg_framework_path_opts <- do - pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages - return $ map ("-F" ++) pkg_framework_paths - - pkg_framework_opts <- do - pkg_frameworks <- getPackageFrameworks dflags dep_packages - return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ] - - return (pkg_framework_path_opts ++ pkg_framework_opts) - - | otherwise = return [] - -getFrameworkOpts :: DynFlags -> Platform -> [String] -getFrameworkOpts dflags platform - | platformUsesFrameworks platform = framework_path_opts ++ framework_opts - | otherwise = [] - where - framework_paths = frameworkPaths dflags - framework_path_opts = map ("-F" ++) framework_paths - - frameworks = cmdlineFrameworks dflags - -- reverse because they're added in reverse order from the cmd line: - framework_opts = concat [ ["-framework", fw] - | fw <- reverse frameworks ] - -{- -Note [-Bsymbolic assumptions by GHC] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -GHC has a few assumptions about interaction of relocations in NCG and linker: - -1. -Bsymbolic resolves internal references when the shared library is linked, - which is important for performance. -2. When there is a reference to data in a shared library from the main program, - the runtime linker relocates the data object into the main program using an - R_*_COPY relocation. -3. If we used -Bsymbolic, then this results in multiple copies of the data - object, because some references have already been resolved to point to the - original instance. This is bad! - -We work around [3.] for native compiled code by avoiding the generation of -R_*_COPY relocations. - -Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable --Bsymbolic linking there. - -See related tickets: #4210, #15338 --} diff --git a/compiler/main/SysTools/ExtraObj.hs b/compiler/main/SysTools/ExtraObj.hs deleted file mode 100644 --- a/compiler/main/SysTools/ExtraObj.hs +++ /dev/null @@ -1,244 +0,0 @@ ------------------------------------------------------------------------------ --- --- GHC Extra object linking code --- --- (c) The GHC Team 2017 --- ------------------------------------------------------------------------------ - -module SysTools.ExtraObj ( - mkExtraObj, mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary, - checkLinkInfo, getLinkInfo, getCompilerInfo, - ghcLinkInfoSectionName, ghcLinkInfoNoteName, platformSupportsSavingLinkOpts, - haveRtsOptsFlags -) where - -import AsmUtils -import ErrUtils -import GHC.Driver.Session -import GHC.Driver.Packages -import GHC.Platform -import Outputable -import GHC.Types.SrcLoc ( noSrcSpan ) -import GHC.Types.Module -import Elf -import Util -import GhcPrelude - -import Control.Monad -import Data.Maybe - -import Control.Monad.IO.Class - -import FileCleanup -import SysTools.Tasks -import SysTools.Info - -mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath -mkExtraObj dflags extn xs - = do cFile <- newTempName dflags TFL_CurrentModule extn - oFile <- newTempName dflags TFL_GhcSession "o" - writeFile cFile xs - ccInfo <- liftIO $ getCompilerInfo dflags - runCc Nothing dflags - ([Option "-c", - FileOption "" cFile, - Option "-o", - FileOption "" oFile] - ++ if extn /= "s" - then cOpts - else asmOpts ccInfo) - return oFile - where - -- Pass a different set of options to the C compiler depending one whether - -- we're compiling C or assembler. When compiling C, we pass the usual - -- set of include directories and PIC flags. - cOpts = map Option (picCCOpts dflags) - ++ map (FileOption "-I") - (includeDirs $ getPackageDetails dflags rtsUnitId) - - -- When compiling assembler code, we drop the usual C options, and if the - -- compiler is Clang, we add an extra argument to tell Clang to ignore - -- unused command line options. See trac #11684. - asmOpts ccInfo = - if any (ccInfo ==) [Clang, AppleClang, AppleClang51] - then [Option "-Qunused-arguments"] - else [] - --- When linking a binary, we need to create a C main() function that --- starts everything off. This used to be compiled statically as part --- of the RTS, but that made it hard to change the -rtsopts setting, --- so now we generate and compile a main() stub as part of every --- binary and pass the -rtsopts setting directly to the RTS (#5373) --- --- On Windows, when making a shared library we also may need a DllMain. --- -mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath -mkExtraObjToLinkIntoBinary dflags = do - when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do - putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) - (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ - text " Call hs_init_ghc() from your main() function to set these options.") - - mkExtraObj dflags "c" (showSDoc dflags main) - where - main - | gopt Opt_NoHsMain dflags = Outputable.empty - | otherwise - = case ghcLink dflags of - LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32 - then dllMain - else Outputable.empty - _ -> exeMain - - exeMain = vcat [ - text "#include ", - text "extern StgClosure ZCMain_main_closure;", - text "int main(int argc, char *argv[])", - char '{', - text " RtsConfig __conf = defaultRtsConfig;", - text " __conf.rts_opts_enabled = " - <> text (show (rtsOptsEnabled dflags)) <> semi, - text " __conf.rts_opts_suggestions = " - <> text (if rtsOptsSuggestions dflags - then "true" - else "false") <> semi, - text "__conf.keep_cafs = " - <> text (if gopt Opt_KeepCAFs dflags - then "true" - else "false") <> semi, - case rtsOpts dflags of - Nothing -> Outputable.empty - Just opts -> text " __conf.rts_opts= " <> - text (show opts) <> semi, - text " __conf.rts_hs_main = true;", - text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);", - char '}', - char '\n' -- final newline, to keep gcc happy - ] - - dllMain = vcat [ - text "#include ", - text "#include ", - text "#include ", - char '\n', - text "bool", - text "WINAPI", - text "DllMain ( HINSTANCE hInstance STG_UNUSED", - text " , DWORD reason STG_UNUSED", - text " , LPVOID reserved STG_UNUSED", - text " )", - text "{", - text " return true;", - text "}", - char '\n' -- final newline, to keep gcc happy - ] - --- Write out the link info section into a new assembly file. Previously --- this was included as inline assembly in the main.c file but this --- is pretty fragile. gas gets upset trying to calculate relative offsets --- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: DynFlags -> [InstalledUnitId] -> IO [FilePath] -mkNoteObjsToLinkIntoBinary dflags dep_packages = do - link_info <- getLinkInfo dflags dep_packages - - if (platformSupportsSavingLinkOpts (platformOS platform )) - then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info)) - else return [] - - where - platform = targetPlatform dflags - link_opts info = hcat [ - -- "link info" section (see Note [LinkInfo section]) - makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info, - - -- ALL generated assembly must have this section to disable - -- executable stacks. See also - -- compiler/nativeGen/AsmCodeGen.hs for another instance - -- where we need to do this. - if platformHasGnuNonexecStack platform - then text ".section .note.GNU-stack,\"\"," - <> sectionType platform "progbits" <> char '\n' - else Outputable.empty - ] - --- | Return the "link info" string --- --- See Note [LinkInfo section] -getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String -getLinkInfo dflags dep_packages = do - package_link_opts <- getPackageLinkOpts dflags dep_packages - pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) - then getPackageFrameworks dflags dep_packages - else return [] - let extra_ld_inputs = ldInputs dflags - let - link_info = (package_link_opts, - pkg_frameworks, - rtsOpts dflags, - rtsOptsEnabled dflags, - gopt Opt_NoHsMain dflags, - map showOpt extra_ld_inputs, - getOpts dflags opt_l) - -- - return (show link_info) - -platformSupportsSavingLinkOpts :: OS -> Bool -platformSupportsSavingLinkOpts os - | os == OSSolaris2 = False -- see #5382 - | otherwise = osElfTarget os - --- See Note [LinkInfo section] -ghcLinkInfoSectionName :: String -ghcLinkInfoSectionName = ".debug-ghc-link-info" - -- if we use the ".debug" prefix, then strip will strip it by default - --- Identifier for the note (see Note [LinkInfo section]) -ghcLinkInfoNoteName :: String -ghcLinkInfoNoteName = "GHC link info" - --- Returns 'False' if it was, and we can avoid linking, because the --- previous binary was linked with "the same options". -checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool -checkLinkInfo dflags pkg_deps exe_file - | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) - -- ToDo: Windows and OS X do not use the ELF binary format, so - -- readelf does not work there. We need to find another way to do - -- this. - = return False -- conservatively we should return True, but not - -- linking in this case was the behaviour for a long - -- time so we leave it as-is. - | otherwise - = do - link_info <- getLinkInfo dflags pkg_deps - debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) - m_exe_link_info <- readElfNoteAsString dflags exe_file - ghcLinkInfoSectionName ghcLinkInfoNoteName - let sameLinkInfo = (Just link_info == m_exe_link_info) - debugTraceMsg dflags 3 $ case m_exe_link_info of - Nothing -> text "Exe link info: Not found" - Just s - | sameLinkInfo -> text ("Exe link info is the same") - | otherwise -> text ("Exe link info is different: " ++ s) - return (not sameLinkInfo) - -{- Note [LinkInfo section] - ~~~~~~~~~~~~~~~~~~~~~~~ - -The "link info" is a string representing the parameters of the link. We save -this information in the binary, and the next time we link, if nothing else has -changed, we use the link info stored in the existing binary to decide whether -to re-link or not. - -The "link info" string is stored in a ELF section called ".debug-ghc-link-info" -(see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to -not follow the specified record-based format (see #11022). - --} - -haveRtsOptsFlags :: DynFlags -> Bool -haveRtsOptsFlags dflags = - isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of - RtsOptsSafeOnly -> False - _ -> True diff --git a/compiler/main/SysTools/Info.hs b/compiler/main/SysTools/Info.hs deleted file mode 100644 --- a/compiler/main/SysTools/Info.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- --- Compiler information functions --- --- (c) The GHC Team 2017 --- ------------------------------------------------------------------------------ -module SysTools.Info where - -import Exception -import ErrUtils -import GHC.Driver.Session -import Outputable -import Util - -import Data.List -import Data.IORef - -import System.IO - -import GHC.Platform -import GhcPrelude - -import SysTools.Process - -{- Note [Run-time linker info] - -See also: #5240, #6063, #10110 - -Before 'runLink', we need to be sure to get the relevant information -about the linker we're using at runtime to see if we need any extra -options. For example, GNU ld requires '--reduce-memory-overheads' and -'--hash-size=31' in order to use reasonable amounts of memory (see -trac #5240.) But this isn't supported in GNU gold. - -Generally, the linker changing from what was detected at ./configure -time has always been possible using -pgml, but on Linux it can happen -'transparently' by installing packages like binutils-gold, which -change what /usr/bin/ld actually points to. - -Clang vs GCC notes: - -For gcc, 'gcc -Wl,--version' gives a bunch of output about how to -invoke the linker before the version information string. For 'clang', -the version information for 'ld' is all that's output. For this -reason, we typically need to slurp up all of the standard error output -and look through it. - -Other notes: - -We cache the LinkerInfo inside DynFlags, since clients may link -multiple times. The definition of LinkerInfo is there to avoid a -circular dependency. - --} - -{- Note [ELF needed shared libs] - -Some distributions change the link editor's default handling of -ELF DT_NEEDED tags to include only those shared objects that are -needed to resolve undefined symbols. For Template Haskell we need -the last temporary shared library also if it is not needed for the -currently linked temporary shared library. We specify --no-as-needed -to override the default. This flag exists in GNU ld and GNU gold. - -The flag is only needed on ELF systems. On Windows (PE) and Mac OS X -(Mach-O) the flag is not needed. - --} - -{- Note [Windows static libGCC] - -The GCC versions being upgraded to in #10726 are configured with -dynamic linking of libgcc supported. This results in libgcc being -linked dynamically when a shared library is created. - -This introduces thus an extra dependency on GCC dll that was not -needed before by shared libraries created with GHC. This is a particular -issue on Windows because you get a non-obvious error due to this missing -dependency. This dependent dll is also not commonly on your path. - -For this reason using the static libgcc is preferred as it preserves -the same behaviour that existed before. There are however some very good -reasons to have the shared version as well as described on page 181 of -https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf : - -"There are several situations in which an application should use the - shared ‘libgcc’ instead of the static version. The most common of these - is when the application wishes to throw and catch exceptions across different - shared libraries. In that case, each of the libraries as well as the application - itself should use the shared ‘libgcc’. " - --} - -neededLinkArgs :: LinkerInfo -> [Option] -neededLinkArgs (GnuLD o) = o -neededLinkArgs (GnuGold o) = o -neededLinkArgs (LlvmLLD o) = o -neededLinkArgs (DarwinLD o) = o -neededLinkArgs (SolarisLD o) = o -neededLinkArgs (AixLD o) = o -neededLinkArgs UnknownLD = [] - --- Grab linker info and cache it in DynFlags. -getLinkerInfo :: DynFlags -> IO LinkerInfo -getLinkerInfo dflags = do - info <- readIORef (rtldInfo dflags) - case info of - Just v -> return v - Nothing -> do - v <- getLinkerInfo' dflags - writeIORef (rtldInfo dflags) (Just v) - return v - --- See Note [Run-time linker info]. -getLinkerInfo' :: DynFlags -> IO LinkerInfo -getLinkerInfo' dflags = do - let platform = targetPlatform dflags - os = platformOS platform - (pgm,args0) = pgm_l dflags - args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ args1 - args3 = filter notNull (map showOpt args2) - - -- Try to grab the info from the process output. - parseLinkerInfo stdo _stde _exitc - | any ("GNU ld" `isPrefixOf`) stdo = - -- GNU ld specifically needs to use less memory. This especially - -- hurts on small object files. #5240. - -- Set DT_NEEDED for all shared libraries. #10110. - -- TODO: Investigate if these help or hurt when using split sections. - return (GnuLD $ map Option ["-Wl,--hash-size=31", - "-Wl,--reduce-memory-overheads", - -- ELF specific flag - -- see Note [ELF needed shared libs] - "-Wl,--no-as-needed"]) - - | any ("GNU gold" `isPrefixOf`) stdo = - -- GNU gold only needs --no-as-needed. #10110. - -- ELF specific flag, see Note [ELF needed shared libs] - return (GnuGold [Option "-Wl,--no-as-needed"]) - - | any ("LLD" `isPrefixOf`) stdo = - return (LlvmLLD $ map Option [ - -- see Note [ELF needed shared libs] - "-Wl,--no-as-needed"]) - - -- Unknown linker. - | otherwise = fail "invalid --version output, or linker is unsupported" - - -- Process the executable call - info <- catchIO (do - case os of - OSSolaris2 -> - -- Solaris uses its own Solaris linker. Even all - -- GNU C are recommended to configure with Solaris - -- linker instead of using GNU binutils linker. Also - -- all GCC distributed with Solaris follows this rule - -- precisely so we assume here, the Solaris linker is - -- used. - return $ SolarisLD [] - OSAIX -> - -- IBM AIX uses its own non-binutils linker as well - return $ AixLD [] - OSDarwin -> - -- Darwin has neither GNU Gold or GNU LD, but a strange linker - -- that doesn't support --version. We can just assume that's - -- what we're using. - return $ DarwinLD [] - OSMinGW32 -> - -- GHC doesn't support anything but GNU ld on Windows anyway. - -- Process creation is also fairly expensive on win32, so - -- we short-circuit here. - return $ GnuLD $ map Option - [ -- Reduce ld memory usage - "-Wl,--hash-size=31" - , "-Wl,--reduce-memory-overheads" - -- Emit gcc stack checks - -- Note [Windows stack usage] - , "-fstack-check" - -- Force static linking of libGCC - -- Note [Windows static libGCC] - , "-static-libgcc" ] - _ -> do - -- In practice, we use the compiler as the linker here. Pass - -- -Wl,--version to get linker version info. - (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm - (["-Wl,--version"] ++ args3) - c_locale_env - -- Split the output by lines to make certain kinds - -- of processing easier. In particular, 'clang' and 'gcc' - -- have slightly different outputs for '-Wl,--version', but - -- it's still easy to figure out. - parseLinkerInfo (lines stdo) (lines stde) exitc - ) - (\err -> do - debugTraceMsg dflags 2 - (text "Error (figuring out linker information):" <+> - text (show err)) - errorMsg dflags $ hang (text "Warning:") 9 $ - text "Couldn't figure out linker information!" $$ - text "Make sure you're using GNU ld, GNU gold" <+> - text "or the built in OS X linker, etc." - return UnknownLD) - return info - --- Grab compiler info and cache it in DynFlags. -getCompilerInfo :: DynFlags -> IO CompilerInfo -getCompilerInfo dflags = do - info <- readIORef (rtccInfo dflags) - case info of - Just v -> return v - Nothing -> do - v <- getCompilerInfo' dflags - writeIORef (rtccInfo dflags) (Just v) - return v - --- See Note [Run-time linker info]. -getCompilerInfo' :: DynFlags -> IO CompilerInfo -getCompilerInfo' dflags = do - let pgm = pgm_c dflags - -- Try to grab the info from the process output. - parseCompilerInfo _stdo stde _exitc - -- Regular GCC - | any ("gcc version" `isInfixOf`) stde = - return GCC - -- Regular clang - | any ("clang version" `isInfixOf`) stde = - return Clang - -- FreeBSD clang - | any ("FreeBSD clang version" `isInfixOf`) stde = - return Clang - -- Xcode 5.1 clang - | any ("Apple LLVM version 5.1" `isPrefixOf`) stde = - return AppleClang51 - -- Xcode 5 clang - | any ("Apple LLVM version" `isPrefixOf`) stde = - return AppleClang - -- Xcode 4.1 clang - | any ("Apple clang version" `isPrefixOf`) stde = - return AppleClang - -- Unknown linker. - | otherwise = fail "invalid -v output, or compiler is unsupported" - - -- Process the executable call - info <- catchIO (do - (exitc, stdo, stde) <- - readProcessEnvWithExitCode pgm ["-v"] c_locale_env - -- Split the output by lines to make certain kinds - -- of processing easier. - parseCompilerInfo (lines stdo) (lines stde) exitc - ) - (\err -> do - debugTraceMsg dflags 2 - (text "Error (figuring out C compiler information):" <+> - text (show err)) - errorMsg dflags $ hang (text "Warning:") 9 $ - text "Couldn't figure out C compiler information!" $$ - text "Make sure you're using GNU gcc, or clang" - return UnknownCC) - return info diff --git a/compiler/main/SysTools/Process.hs b/compiler/main/SysTools/Process.hs deleted file mode 100644 --- a/compiler/main/SysTools/Process.hs +++ /dev/null @@ -1,387 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- --- Misc process handling code for SysTools --- --- (c) The GHC Team 2017 --- ------------------------------------------------------------------------------ -module SysTools.Process where - -#include "HsVersions.h" - -import Exception -import ErrUtils -import GHC.Driver.Session -import FastString -import Outputable -import Panic -import GhcPrelude -import Util -import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) - -import Control.Concurrent -import Data.Char - -import System.Exit -import System.Environment -import System.FilePath -import System.IO -import System.IO.Error as IO -import System.Process - -import FileCleanup - --- | Enable process jobs support on Windows if it can be expected to work (e.g. --- @process >= 1.6.8.0@). -enableProcessJobs :: CreateProcess -> CreateProcess -#if defined(MIN_VERSION_process) -enableProcessJobs opts = opts { use_process_jobs = True } -#else -enableProcessJobs opts = opts -#endif - --- Similar to System.Process.readCreateProcessWithExitCode, but stderr is --- inherited from the parent process, and output to stderr is not captured. -readCreateProcessWithExitCode' - :: CreateProcess - -> IO (ExitCode, String) -- ^ stdout -readCreateProcessWithExitCode' proc = do - (_, Just outh, _, pid) <- - createProcess proc{ std_out = CreatePipe } - - -- fork off a thread to start consuming the output - output <- hGetContents outh - outMVar <- newEmptyMVar - _ <- forkIO $ evaluate (length output) >> putMVar outMVar () - - -- wait on the output - takeMVar outMVar - hClose outh - - -- wait on the process - ex <- waitForProcess pid - - return (ex, output) - -replaceVar :: (String, String) -> [(String, String)] -> [(String, String)] -replaceVar (var, value) env = - (var, value) : filter (\(var',_) -> var /= var') env - --- | Version of @System.Process.readProcessWithExitCode@ that takes a --- key-value tuple to insert into the environment. -readProcessEnvWithExitCode - :: String -- ^ program path - -> [String] -- ^ program args - -> (String, String) -- ^ addition to the environment - -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr) -readProcessEnvWithExitCode prog args env_update = do - current_env <- getEnvironment - readCreateProcessWithExitCode (enableProcessJobs $ proc prog args) { - env = Just (replaceVar env_update current_env) } "" - --- Don't let gcc localize version info string, #8825 -c_locale_env :: (String, String) -c_locale_env = ("LANGUAGE", "C") - --- If the -B option is set, add to PATH. This works around --- a bug in gcc on Windows Vista where it can't find its auxiliary --- binaries (see bug #1110). -getGccEnv :: [Option] -> IO (Maybe [(String,String)]) -getGccEnv opts = - if null b_dirs - then return Nothing - else do env <- getEnvironment - return (Just (mangle_paths env)) - where - (b_dirs, _) = partitionWith get_b_opt opts - - get_b_opt (Option ('-':'B':dir)) = Left dir - get_b_opt other = Right other - - -- Work around #1110 on Windows only (lest we stumble into #17266). -#if defined(mingw32_HOST_OS) - mangle_paths = map mangle_path - mangle_path (path,paths) | map toUpper path == "PATH" - = (path, '\"' : head b_dirs ++ "\";" ++ paths) - mangle_path other = other -#else - mangle_paths = id -#endif - - ------------------------------------------------------------------------------ --- Running an external program - -runSomething :: DynFlags - -> String -- For -v message - -> String -- Command name (possibly a full path) - -- assumed already dos-ified - -> [Option] -- Arguments - -- runSomething will dos-ify them - -> IO () - -runSomething dflags phase_name pgm args = - runSomethingFiltered dflags id phase_name pgm args Nothing Nothing - --- | Run a command, placing the arguments in an external response file. --- --- This command is used in order to avoid overlong command line arguments on --- Windows. The command line arguments are first written to an external, --- temporary response file, and then passed to the linker via @filepath. --- response files for passing them in. See: --- --- https://gcc.gnu.org/wiki/Response_Files --- https://gitlab.haskell.org/ghc/ghc/issues/10777 -runSomethingResponseFile - :: DynFlags -> (String->String) -> String -> String -> [Option] - -> Maybe [(String,String)] -> IO () - -runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env = - runSomethingWith dflags phase_name pgm args $ \real_args -> do - fp <- getResponseFile real_args - let args = ['@':fp] - r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env - return (r,()) - where - getResponseFile args = do - fp <- newTempName dflags TFL_CurrentModule "rsp" - withFile fp WriteMode $ \h -> do -#if defined(mingw32_HOST_OS) - hSetEncoding h latin1 -#else - hSetEncoding h utf8 -#endif - hPutStr h $ unlines $ map escape args - return fp - - -- Note: Response files have backslash-escaping, double quoting, and are - -- whitespace separated (some implementations use newline, others any - -- whitespace character). Therefore, escape any backslashes, newlines, and - -- double quotes in the argument, and surround the content with double - -- quotes. - -- - -- Another possibility that could be considered would be to convert - -- backslashes in the argument to forward slashes. This would generally do - -- the right thing, since backslashes in general only appear in arguments - -- as part of file paths on Windows, and the forward slash is accepted for - -- those. However, escaping is more reliable, in case somehow a backslash - -- appears in a non-file. - escape x = concat - [ "\"" - , concatMap - (\c -> - case c of - '\\' -> "\\\\" - '\n' -> "\\n" - '\"' -> "\\\"" - _ -> [c]) - x - , "\"" - ] - -runSomethingFiltered - :: DynFlags -> (String->String) -> String -> String -> [Option] - -> Maybe FilePath -> Maybe [(String,String)] -> IO () - -runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do - runSomethingWith dflags phase_name pgm args $ \real_args -> do - r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env - return (r,()) - -runSomethingWith - :: DynFlags -> String -> String -> [Option] - -> ([String] -> IO (ExitCode, a)) - -> IO a - -runSomethingWith dflags phase_name pgm args io = do - let real_args = filter notNull (map showOpt args) - cmdLine = showCommandForUser pgm real_args - traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args - -handleProc :: String -> String -> IO (ExitCode, r) -> IO r -handleProc pgm phase_name proc = do - (rc, r) <- proc `catchIO` handler - case rc of - ExitSuccess{} -> return r - ExitFailure n -> throwGhcExceptionIO ( - ProgramError ("`" ++ takeFileName pgm ++ "'" ++ - " failed in phase `" ++ phase_name ++ "'." ++ - " (Exit code: " ++ show n ++ ")")) - where - handler err = - if IO.isDoesNotExistError err - then does_not_exist - else throwGhcExceptionIO (ProgramError $ show err) - - does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm)) - - -builderMainLoop :: DynFlags -> (String -> String) -> FilePath - -> [String] -> Maybe FilePath -> Maybe [(String, String)] - -> IO ExitCode -builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do - chan <- newChan - - -- We use a mask here rather than a bracket because we want - -- to distinguish between cleaning up with and without an - -- exception. This is to avoid calling terminateProcess - -- unless an exception was raised. - let safely inner = mask $ \restore -> do - -- acquire - -- On Windows due to how exec is emulated the old process will exit and - -- a new process will be created. This means waiting for termination of - -- the parent process will get you in a race condition as the child may - -- not have finished yet. This caused #16450. To fix this use a - -- process job to track all child processes and wait for each one to - -- finish. - let procdata = - enableProcessJobs - $ (proc pgm real_args) { cwd = mb_cwd - , env = mb_env - , std_in = CreatePipe - , std_out = CreatePipe - , std_err = CreatePipe - } - (Just hStdIn, Just hStdOut, Just hStdErr, hProcess) <- restore $ - createProcess_ "builderMainLoop" procdata - let cleanup_handles = do - hClose hStdIn - hClose hStdOut - hClose hStdErr - r <- try $ restore $ do - hSetBuffering hStdOut LineBuffering - hSetBuffering hStdErr LineBuffering - let make_reader_proc h = forkIO $ readerProc chan h filter_fn - bracketOnError (make_reader_proc hStdOut) killThread $ \_ -> - bracketOnError (make_reader_proc hStdErr) killThread $ \_ -> - inner hProcess - case r of - -- onException - Left (SomeException e) -> do - terminateProcess hProcess - cleanup_handles - throw e - -- cleanup when there was no exception - Right s -> do - cleanup_handles - return s - safely $ \h -> do - -- we don't want to finish until 2 streams have been complete - -- (stdout and stderr) - log_loop chan (2 :: Integer) - -- after that, we wait for the process to finish and return the exit code. - waitForProcess h - where - -- t starts at the number of streams we're listening to (2) decrements each - -- time a reader process sends EOF. We are safe from looping forever if a - -- reader thread dies, because they send EOF in a finally handler. - log_loop _ 0 = return () - log_loop chan t = do - msg <- readChan chan - case msg of - BuildMsg msg -> do - putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) msg - log_loop chan t - BuildError loc msg -> do - putLogMsg dflags NoReason SevError (mkSrcSpan loc loc) - (defaultUserStyle dflags) msg - log_loop chan t - EOF -> - log_loop chan (t-1) - -readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO () -readerProc chan hdl filter_fn = - (do str <- hGetContents hdl - loop (linesPlatform (filter_fn str)) Nothing) - `finally` - writeChan chan EOF - -- ToDo: check errors more carefully - -- ToDo: in the future, the filter should be implemented as - -- a stream transformer. - where - loop [] Nothing = return () - loop [] (Just err) = writeChan chan err - loop (l:ls) in_err = - case in_err of - Just err@(BuildError srcLoc msg) - | leading_whitespace l -> do - loop ls (Just (BuildError srcLoc (msg $$ text l))) - | otherwise -> do - writeChan chan err - checkError l ls - Nothing -> do - checkError l ls - _ -> panic "readerProc/loop" - - checkError l ls - = case parseError l of - Nothing -> do - writeChan chan (BuildMsg (text l)) - loop ls Nothing - Just (file, lineNum, colNum, msg) -> do - let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum - loop ls (Just (BuildError srcLoc (text msg))) - - leading_whitespace [] = False - leading_whitespace (x:_) = isSpace x - -parseError :: String -> Maybe (String, Int, Int, String) -parseError s0 = case breakColon s0 of - Just (filename, s1) -> - case breakIntColon s1 of - Just (lineNum, s2) -> - case breakIntColon s2 of - Just (columnNum, s3) -> - Just (filename, lineNum, columnNum, s3) - Nothing -> - Just (filename, lineNum, 0, s2) - Nothing -> Nothing - Nothing -> Nothing - --- | Break a line of an error message into a filename and the rest of the line, --- taking care to ignore colons in Windows drive letters (as noted in #17786). --- For instance, --- --- * @"hi.c: ABCD"@ is mapped to @Just ("hi.c", "ABCD")@ --- * @"C:\hi.c: ABCD"@ is mapped to @Just ("C:\hi.c", "ABCD")@ -breakColon :: String -> Maybe (String, String) -breakColon = go [] - where - -- Don't break on Windows drive letters (e.g. @C:\@ or @C:/@) - go accum (':':'\\':rest) = go ('\\':':':accum) rest - go accum (':':'/':rest) = go ('/':':':accum) rest - go accum (':':rest) = Just (reverse accum, rest) - go accum (c:rest) = go (c:accum) rest - go _accum [] = Nothing - -breakIntColon :: String -> Maybe (Int, String) -breakIntColon xs = case break (':' ==) xs of - (ys, _:zs) - | not (null ys) && all isAscii ys && all isDigit ys -> - Just (read ys, zs) - _ -> Nothing - -data BuildMessage - = BuildMsg !SDoc - | BuildError !SrcLoc !SDoc - | EOF - --- Divvy up text stream into lines, taking platform dependent --- line termination into account. -linesPlatform :: String -> [String] -#if !defined(mingw32_HOST_OS) -linesPlatform ls = lines ls -#else -linesPlatform "" = [] -linesPlatform xs = - case lineBreak xs of - (as,xs1) -> as : linesPlatform xs1 - where - lineBreak "" = ("","") - lineBreak ('\r':'\n':xs) = ([],xs) - lineBreak ('\n':xs) = ([],xs) - lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs) - -#endif diff --git a/compiler/main/SysTools/Settings.hs b/compiler/main/SysTools/Settings.hs deleted file mode 100644 --- a/compiler/main/SysTools/Settings.hs +++ /dev/null @@ -1,253 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module SysTools.Settings - ( SettingsError (..) - , initSettings - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Settings - -import Config -import CliOption -import FileSettings -import Fingerprint -import GHC.Platform -import GhcNameVersion -import Outputable -import Settings -import SysTools.BaseDir -import ToolSettings - -import Control.Monad.Trans.Except -import Control.Monad.IO.Class -import qualified Data.Map as Map -import System.FilePath -import System.Directory - -data SettingsError - = SettingsError_MissingData String - | SettingsError_BadData String - -initSettings - :: forall m - . MonadIO m - => String -- ^ TopDir path - -> ExceptT SettingsError m Settings -initSettings top_dir = do - -- see Note [topdir: How GHC finds its files] - -- NB: top_dir is assumed to be in standard Unix - -- format, '/' separated - mtool_dir <- liftIO $ findToolDir top_dir - -- see Note [tooldir: How GHC finds mingw on Windows] - - let installed :: FilePath -> FilePath - installed file = top_dir file - libexec :: FilePath -> FilePath - libexec file = top_dir "bin" file - settingsFile = installed "settings" - platformConstantsFile = installed "platformConstants" - - readFileSafe :: FilePath -> ExceptT SettingsError m String - readFileSafe path = liftIO (doesFileExist path) >>= \case - True -> liftIO $ readFile path - False -> throwE $ SettingsError_MissingData $ "Missing file: " ++ path - - settingsStr <- readFileSafe settingsFile - platformConstantsStr <- readFileSafe platformConstantsFile - settingsList <- case maybeReadFuzzy settingsStr of - Just s -> pure s - Nothing -> throwE $ SettingsError_BadData $ - "Can't parse " ++ show settingsFile - let mySettings = Map.fromList settingsList - platformConstants <- case maybeReadFuzzy platformConstantsStr of - Just s -> pure s - Nothing -> throwE $ SettingsError_BadData $ - "Can't parse " ++ show platformConstantsFile - -- See Note [Settings file] for a little more about this file. We're - -- 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 $ - getFilePathSetting0 top_dir settingsFile mySettings key - getToolSetting :: String -> ExceptT SettingsError m String - getToolSetting key = expandToolDir mtool_dir <$> getSetting key - getBooleanSetting :: String -> ExceptT SettingsError m Bool - getBooleanSetting key = either pgmError pure $ - getBooleanSetting0 settingsFile mySettings key - targetPlatformString <- getSetting "target platform string" - tablesNextToCode <- getBooleanSetting "Tables next to code" - myExtraGccViaCFlags <- getSetting "GCC extra via C opts" - -- On Windows, mingw is distributed with GHC, - -- so we look in TopDir/../mingw/bin, - -- as well as TopDir/../../mingw/bin for hadrian. - -- It would perhaps be nice to be able to override this - -- with the settings file, but it would be a little fiddly - -- to make that possible, so for now you can't. - cc_prog <- getToolSetting "C compiler command" - cc_args_str <- getSetting "C compiler flags" - cxx_args_str <- getSetting "C++ compiler flags" - gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" - cpp_prog <- getToolSetting "Haskell CPP command" - cpp_args_str <- getSetting "Haskell CPP flags" - - platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings - - let unreg_cc_args = if platformUnregisterised platform - then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] - else [] - cpp_args = map Option (words cpp_args_str) - cc_args = words cc_args_str ++ unreg_cc_args - cxx_args = words cxx_args_str - ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" - ldSupportsBuildId <- getBooleanSetting "ld supports build-id" - ldSupportsFilelist <- getBooleanSetting "ld supports filelist" - ldIsGnuLd <- getBooleanSetting "ld is GNU ld" - - let globalpkgdb_path = installed "package.conf.d" - ghc_usage_msg_path = installed "ghc-usage.txt" - ghci_usage_msg_path = installed "ghci-usage.txt" - - -- For all systems, unlit, split, mangle are GHC utilities - -- architecture-specific stuff is done when building Config.hs - unlit_path <- getToolSetting "unlit command" - - windres_path <- getToolSetting "windres command" - libtool_path <- getToolSetting "libtool command" - ar_path <- getToolSetting "ar command" - ranlib_path <- getToolSetting "ranlib command" - - -- TODO this side-effect doesn't belong here. Reading and parsing the settings - -- should be idempotent and accumulate no resources. - tmpdir <- liftIO $ getTemporaryDirectory - - touch_path <- getToolSetting "touch command" - - mkdll_prog <- getToolSetting "dllwrap command" - let mkdll_args = [] - - -- cpp is derived from gcc on all platforms - -- HACK, see setPgmP below. We keep 'words' here to remember to fix - -- Config.hs one day. - - - -- Other things being equal, as and ld are simply gcc - cc_link_args_str <- getSetting "C compiler link flags" - let as_prog = cc_prog - as_args = map Option cc_args - ld_prog = cc_prog - ld_args = map Option (cc_args ++ words cc_link_args_str) - - llvmTarget <- getSetting "LLVM target" - - -- We just assume on command line - lc_prog <- getSetting "LLVM llc command" - lo_prog <- getSetting "LLVM opt command" - lcc_prog <- getSetting "LLVM clang command" - - let iserv_prog = libexec "ghc-iserv" - - integerLibrary <- getSetting "integer library" - integerLibraryType <- case integerLibrary of - "integer-gmp" -> pure IntegerGMP - "integer-simple" -> pure IntegerSimple - _ -> pgmError $ unwords - [ "Entry for" - , show "integer library" - , "must be one of" - , show "integer-gmp" - , "or" - , show "integer-simple" - ] - - ghcWithInterpreter <- getBooleanSetting "Use interpreter" - ghcWithNativeCodeGen <- getBooleanSetting "Use native code generator" - ghcWithSMP <- getBooleanSetting "Support SMP" - ghcRTSWays <- getSetting "RTS ways" - leadingUnderscore <- getBooleanSetting "Leading underscore" - useLibFFI <- getBooleanSetting "Use LibFFI" - ghcThreaded <- getBooleanSetting "Use Threads" - ghcDebugged <- getBooleanSetting "Use Debugging" - ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw" - - return $ Settings - { sGhcNameVersion = GhcNameVersion - { ghcNameVersion_programName = "ghc" - , ghcNameVersion_projectVersion = cProjectVersion - } - - , sFileSettings = FileSettings - { fileSettings_tmpDir = normalise tmpdir - , fileSettings_ghcUsagePath = ghc_usage_msg_path - , fileSettings_ghciUsagePath = ghci_usage_msg_path - , fileSettings_toolDir = mtool_dir - , fileSettings_topDir = top_dir - , fileSettings_globalPackageDatabase = globalpkgdb_path - } - - , sToolSettings = ToolSettings - { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind - , toolSettings_ldSupportsBuildId = ldSupportsBuildId - , toolSettings_ldSupportsFilelist = ldSupportsFilelist - , toolSettings_ldIsGnuLd = ldIsGnuLd - , toolSettings_ccSupportsNoPie = gccSupportsNoPie - - , toolSettings_pgm_L = unlit_path - , toolSettings_pgm_P = (cpp_prog, cpp_args) - , toolSettings_pgm_F = "" - , toolSettings_pgm_c = cc_prog - , toolSettings_pgm_a = (as_prog, as_args) - , toolSettings_pgm_l = (ld_prog, ld_args) - , toolSettings_pgm_dll = (mkdll_prog,mkdll_args) - , toolSettings_pgm_T = touch_path - , toolSettings_pgm_windres = windres_path - , toolSettings_pgm_libtool = libtool_path - , toolSettings_pgm_ar = ar_path - , toolSettings_pgm_ranlib = ranlib_path - , toolSettings_pgm_lo = (lo_prog,[]) - , toolSettings_pgm_lc = (lc_prog,[]) - , toolSettings_pgm_lcc = (lcc_prog,[]) - , toolSettings_pgm_i = iserv_prog - , toolSettings_opt_L = [] - , toolSettings_opt_P = [] - , toolSettings_opt_P_fingerprint = fingerprint0 - , toolSettings_opt_F = [] - , toolSettings_opt_c = cc_args - , toolSettings_opt_cxx = cxx_args - , toolSettings_opt_a = [] - , toolSettings_opt_l = [] - , toolSettings_opt_windres = [] - , toolSettings_opt_lcc = [] - , toolSettings_opt_lo = [] - , toolSettings_opt_lc = [] - , toolSettings_opt_i = [] - - , toolSettings_extraGccViaCFlags = words myExtraGccViaCFlags - } - - , sTargetPlatform = platform - , sPlatformMisc = PlatformMisc - { platformMisc_targetPlatformString = targetPlatformString - , platformMisc_integerLibrary = integerLibrary - , platformMisc_integerLibraryType = integerLibraryType - , platformMisc_ghcWithInterpreter = ghcWithInterpreter - , platformMisc_ghcWithNativeCodeGen = ghcWithNativeCodeGen - , platformMisc_ghcWithSMP = ghcWithSMP - , platformMisc_ghcRTSWays = ghcRTSWays - , platformMisc_tablesNextToCode = tablesNextToCode - , platformMisc_leadingUnderscore = leadingUnderscore - , platformMisc_libFFI = useLibFFI - , platformMisc_ghcThreaded = ghcThreaded - , platformMisc_ghcDebugged = ghcDebugged - , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw - , platformMisc_llvmTarget = llvmTarget - } - - , sPlatformConstants = platformConstants - - , sRawSettings = settingsList - } diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs deleted file mode 100644 --- a/compiler/main/SysTools/Tasks.hs +++ /dev/null @@ -1,373 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- --- Tasks running external programs for SysTools --- --- (c) The GHC Team 2017 --- ------------------------------------------------------------------------------ -module SysTools.Tasks where - -import Exception -import ErrUtils -import GHC.Driver.Types -import GHC.Driver.Session -import Outputable -import GHC.Platform -import Util - -import Data.List - -import System.IO -import System.Process -import GhcPrelude - -import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersion, parseLlvmVersion) - -import SysTools.Process -import SysTools.Info - -{- -************************************************************************ -* * -\subsection{Running an external program} -* * -************************************************************************ --} - -runUnlit :: DynFlags -> [Option] -> IO () -runUnlit dflags args = traceToolCommand dflags "unlit" $ do - let prog = pgm_L dflags - opts = getOpts dflags opt_L - runSomething dflags "Literate pre-processor" prog - (map Option opts ++ args) - -runCpp :: DynFlags -> [Option] -> IO () -runCpp dflags args = traceToolCommand dflags "cpp" $ do - let (p,args0) = pgm_P dflags - args1 = map Option (getOpts dflags opt_P) - args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] - ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] - mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "C pre-processor" p - (args0 ++ args1 ++ args2 ++ args) Nothing mb_env - -runPp :: DynFlags -> [Option] -> IO () -runPp dflags args = traceToolCommand dflags "pp" $ do - let prog = pgm_F dflags - opts = map Option (getOpts dflags opt_F) - runSomething dflags "Haskell pre-processor" prog (args ++ opts) - --- | Run compiler of C-like languages and raw objects (such as gcc or clang). -runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO () -runCc mLanguage dflags args = traceToolCommand dflags "cc" $ do - let p = pgm_c dflags - args1 = map Option userOpts - args2 = languageOptions ++ args ++ args1 - -- We take care to pass -optc flags in args1 last to ensure that the - -- user can override flags passed by GHC. See #14452. - mb_env <- getGccEnv args2 - runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env - where - -- discard some harmless warnings from gcc that we can't turn off - cc_filter = unlines . doFilter . lines - - {- - gcc gives warnings in chunks like so: - In file included from /foo/bar/baz.h:11, - from /foo/bar/baz2.h:22, - from wibble.c:33: - /foo/flibble:14: global register variable ... - /foo/flibble:15: warning: call-clobbered r... - We break it up into its chunks, remove any call-clobbered register - warnings from each chunk, and then delete any chunks that we have - emptied of warnings. - -} - doFilter = unChunkWarnings . filterWarnings . chunkWarnings [] - -- We can't assume that the output will start with an "In file inc..." - -- line, so we start off expecting a list of warnings rather than a - -- location stack. - chunkWarnings :: [String] -- The location stack to use for the next - -- list of warnings - -> [String] -- The remaining lines to look at - -> [([String], [String])] - chunkWarnings loc_stack [] = [(loc_stack, [])] - chunkWarnings loc_stack xs - = case break loc_stack_start xs of - (warnings, lss:xs') -> - case span loc_start_continuation xs' of - (lsc, xs'') -> - (loc_stack, warnings) : chunkWarnings (lss : lsc) xs'' - _ -> [(loc_stack, xs)] - - filterWarnings :: [([String], [String])] -> [([String], [String])] - filterWarnings [] = [] - -- If the warnings are already empty then we are probably doing - -- something wrong, so don't delete anything - filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs - filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of - [] -> filterWarnings zs - ys' -> (xs, ys') : filterWarnings zs - - unChunkWarnings :: [([String], [String])] -> [String] - unChunkWarnings [] = [] - unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs - - loc_stack_start s = "In file included from " `isPrefixOf` s - loc_start_continuation s = " from " `isPrefixOf` s - wantedWarning w - | "warning: call-clobbered register used" `isContainedIn` w = False - | otherwise = True - - -- force the C compiler to interpret this file as C when - -- compiling .hc files, by adding the -x c option. - -- Also useful for plain .c files, just in case GHC saw a - -- -x c option. - (languageOptions, userOpts) = case mLanguage of - Nothing -> ([], userOpts_c) - Just language -> ([Option "-x", Option languageName], opts) - where - (languageName, opts) = case language of - LangC -> ("c", userOpts_c) - LangCxx -> ("c++", userOpts_cxx) - LangObjc -> ("objective-c", userOpts_c) - LangObjcxx -> ("objective-c++", userOpts_cxx) - LangAsm -> ("assembler", []) - RawObject -> ("c", []) -- claim C for lack of a better idea - userOpts_c = getOpts dflags opt_c - userOpts_cxx = getOpts dflags opt_cxx - -isContainedIn :: String -> String -> Bool -xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) - --- | Run the linker with some arguments and return the output -askLd :: DynFlags -> [Option] -> IO String -askLd dflags args = traceToolCommand dflags "linker" $ do - let (p,args0) = pgm_l dflags - args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - runSomethingWith dflags "gcc" p args2 $ \real_args -> - readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } - -runAs :: DynFlags -> [Option] -> IO () -runAs dflags args = traceToolCommand dflags "as" $ do - let (p,args0) = pgm_a dflags - args1 = map Option (getOpts dflags opt_a) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "Assembler" p args2 Nothing mb_env - --- | Run the LLVM Optimiser -runLlvmOpt :: DynFlags -> [Option] -> IO () -runLlvmOpt dflags args = traceToolCommand dflags "opt" $ do - let (p,args0) = pgm_lo dflags - args1 = map Option (getOpts dflags opt_lo) - -- We take care to pass -optlo flags (e.g. args0) last to ensure that the - -- user can override flags passed by GHC. See #14821. - runSomething dflags "LLVM Optimiser" p (args1 ++ args ++ args0) - --- | Run the LLVM Compiler -runLlvmLlc :: DynFlags -> [Option] -> IO () -runLlvmLlc dflags args = traceToolCommand dflags "llc" $ do - let (p,args0) = pgm_lc dflags - args1 = map Option (getOpts dflags opt_lc) - runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args) - --- | Run the clang compiler (used as an assembler for the LLVM --- backend on OS X as LLVM doesn't support the OS X system --- assembler) -runClang :: DynFlags -> [Option] -> IO () -runClang dflags args = traceToolCommand dflags "clang" $ do - let (clang,_) = pgm_lcc dflags - -- be careful what options we call clang with - -- see #5903 and #7617 for bugs caused by this. - (_,args0) = pgm_a dflags - args1 = map Option (getOpts dflags opt_a) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - Exception.catch (do - runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env - ) - (\(err :: SomeException) -> do - errorMsg dflags $ - text ("Error running clang! you need clang installed to use the" ++ - " LLVM backend") $+$ - text "(or GHC tried to execute clang incorrectly)" - throwIO err - ) - --- | Figure out which version of LLVM we are running this session -figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion) -figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do - let (pgm,opts) = pgm_lc dflags - args = filter notNull (map showOpt opts) - -- we grab the args even though they should be useless just in - -- case the user is using a customised 'llc' that requires some - -- of the options they've specified. llc doesn't care what other - -- options are specified when '-version' is used. - args' = args ++ ["-version"] - catchIO (do - (pin, pout, perr, _) <- runInteractiveProcess pgm args' - Nothing Nothing - {- > llc -version - LLVM (http://llvm.org/): - LLVM version 3.5.2 - ... - -} - hSetBinaryMode pout False - _ <- hGetLine pout - vline <- hGetLine pout - let mb_ver = parseLlvmVersion vline - hClose pin - hClose pout - hClose perr - return mb_ver - ) - (\err -> do - debugTraceMsg dflags 2 - (text "Error (figuring out LLVM version):" <+> - text (show err)) - errorMsg dflags $ vcat - [ text "Warning:", nest 9 $ - text "Couldn't figure out LLVM version!" $$ - text ("Make sure you have installed LLVM " ++ - llvmVersionStr supportedLlvmVersion) ] - return Nothing) - - -runLink :: DynFlags -> [Option] -> IO () -runLink dflags args = traceToolCommand dflags "linker" $ do - -- See Note [Run-time linker info] - -- - -- `-optl` args come at the end, so that later `-l` options - -- given there manually can fill in symbols needed by - -- Haskell libraries coming in via `args`. - linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags - let (p,args0) = pgm_l dflags - optl_args = map Option (getOpts dflags opt_l) - args2 = args0 ++ linkargs ++ args ++ optl_args - mb_env <- getGccEnv args2 - runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env - where - ld_filter = case (platformOS (targetPlatform dflags)) of - OSSolaris2 -> sunos_ld_filter - _ -> id -{- - SunOS/Solaris ld emits harmless warning messages about unresolved - symbols in case of compiling into shared library when we do not - link against all the required libs. That is the case of GHC which - does not link against RTS library explicitly in order to be able to - choose the library later based on binary application linking - parameters. The warnings look like: - -Undefined first referenced - symbol in file -stg_ap_n_fast ./T2386_Lib.o -stg_upd_frame_info ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o -newCAF ./T2386_Lib.o -stg_bh_upd_frame_info ./T2386_Lib.o -stg_ap_ppp_fast ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o -stg_ap_p_fast ./T2386_Lib.o -stg_ap_pp_fast ./T2386_Lib.o -ld: warning: symbol referencing errors - - this is actually coming from T2386 testcase. The emitting of those - warnings is also a reason why so many TH testcases fail on Solaris. - - Following filter code is SunOS/Solaris linker specific and should - filter out only linker warnings. Please note that the logic is a - little bit more complex due to the simple reason that we need to preserve - any other linker emitted messages. If there are any. Simply speaking - if we see "Undefined" and later "ld: warning:..." then we omit all - text between (including) the marks. Otherwise we copy the whole output. --} - sunos_ld_filter :: String -> String - sunos_ld_filter = unlines . sunos_ld_filter' . lines - sunos_ld_filter' x = if (undefined_found x && ld_warning_found x) - then (ld_prefix x) ++ (ld_postfix x) - else x - breakStartsWith x y = break (isPrefixOf x) y - ld_prefix = fst . breakStartsWith "Undefined" - undefined_found = not . null . snd . breakStartsWith "Undefined" - ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors" - ld_postfix = tail . snd . ld_warn_break - ld_warning_found = not . null . snd . ld_warn_break - - -runLibtool :: DynFlags -> [Option] -> IO () -runLibtool dflags args = traceToolCommand dflags "libtool" $ do - linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags - let args1 = map Option (getOpts dflags opt_l) - args2 = [Option "-static"] ++ args1 ++ args ++ linkargs - libtool = pgm_libtool dflags - mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "Linker" libtool args2 Nothing mb_env - -runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO () -runAr dflags cwd args = traceToolCommand dflags "ar" $ do - let ar = pgm_ar dflags - runSomethingFiltered dflags id "Ar" ar args cwd Nothing - -askAr :: DynFlags -> Maybe FilePath -> [Option] -> IO String -askAr dflags mb_cwd args = traceToolCommand dflags "ar" $ do - let ar = pgm_ar dflags - runSomethingWith dflags "Ar" ar args $ \real_args -> - readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd } - -runRanlib :: DynFlags -> [Option] -> IO () -runRanlib dflags args = traceToolCommand dflags "ranlib" $ do - let ranlib = pgm_ranlib dflags - runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing - -runMkDLL :: DynFlags -> [Option] -> IO () -runMkDLL dflags args = traceToolCommand dflags "mkdll" $ do - let (p,args0) = pgm_dll dflags - args1 = args0 ++ args - mb_env <- getGccEnv (args0++args) - runSomethingFiltered dflags id "Make DLL" p args1 Nothing mb_env - -runWindres :: DynFlags -> [Option] -> IO () -runWindres dflags args = traceToolCommand dflags "windres" $ do - let cc = pgm_c dflags - cc_args = map Option (sOpt_c (settings dflags)) - windres = pgm_windres dflags - opts = map Option (getOpts dflags opt_windres) - quote x = "\"" ++ x ++ "\"" - args' = -- If windres.exe and gcc.exe are in a directory containing - -- spaces then windres fails to run gcc. We therefore need - -- to tell it what command to use... - Option ("--preprocessor=" ++ - unwords (map quote (cc : - map showOpt opts ++ - ["-E", "-xc", "-DRC_INVOKED"]))) - -- ...but if we do that then if windres calls popen then - -- it can't understand the quoting, so we have to use - -- --use-temp-file so that it interprets it correctly. - -- See #1828. - : Option "--use-temp-file" - : args - mb_env <- getGccEnv cc_args - runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env - -touch :: DynFlags -> String -> String -> IO () -touch dflags purpose arg = traceToolCommand dflags "touch" $ - runSomething dflags purpose (pgm_T dflags) [FileOption "" arg] - --- * Tracing utility - --- | Record in the eventlog when the given tool command starts --- and finishes, prepending the given 'String' with --- \"systool:\", to easily be able to collect and process --- all the systool events. --- --- For those events to show up in the eventlog, you need --- to run GHC with @-v2@ or @-ddump-timings@. -traceToolCommand :: DynFlags -> String -> IO a -> IO a -traceToolCommand dflags tool = withTiming - dflags (text $ "systool:" ++ tool) (const ()) diff --git a/compiler/main/UpdateCafInfos.hs b/compiler/main/UpdateCafInfos.hs deleted file mode 100644 --- a/compiler/main/UpdateCafInfos.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-} - -module UpdateCafInfos - ( updateModDetailsCafInfos - ) where - -import GhcPrelude - -import GHC.Core -import GHC.Driver.Session -import GHC.Driver.Types -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Core.InstEnv -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import Util -import GHC.Types.Var -import Outputable - -#include "HsVersions.h" - --- | Update CafInfos of all occurences (in rules, unfoldings, class instances) -updateModDetailsCafInfos - :: DynFlags - -> NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY. - -> ModDetails -- ^ ModDetails to update - -> ModDetails - -updateModDetailsCafInfos dflags _ mod_details - | gopt Opt_OmitInterfacePragmas dflags - = mod_details - -updateModDetailsCafInfos _ non_cafs mod_details = - {- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -} - let - ModDetails{ md_types = type_env -- for unfoldings - , md_insts = insts - , md_rules = rules - } = mod_details - - -- type TypeEnv = NameEnv TyThing - ~type_env' = mapNameEnv (updateTyThingCafInfos type_env' non_cafs) type_env - -- Not strict! - - !insts' = strictMap (updateInstCafInfos type_env' non_cafs) insts - !rules' = strictMap (updateRuleCafInfos type_env') rules - in - mod_details{ md_types = type_env' - , md_insts = insts' - , md_rules = rules' - } - --------------------------------------------------------------------------------- --- Rules --------------------------------------------------------------------------------- - -updateRuleCafInfos :: TypeEnv -> CoreRule -> CoreRule -updateRuleCafInfos _ rule@BuiltinRule{} = rule -updateRuleCafInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. } - --------------------------------------------------------------------------------- --- Instances --------------------------------------------------------------------------------- - -updateInstCafInfos :: TypeEnv -> NameSet -> ClsInst -> ClsInst -updateInstCafInfos type_env non_cafs = - updateClsInstDFun (updateIdUnfolding type_env . updateIdCafInfo non_cafs) - --------------------------------------------------------------------------------- --- TyThings --------------------------------------------------------------------------------- - -updateTyThingCafInfos :: TypeEnv -> NameSet -> TyThing -> TyThing - -updateTyThingCafInfos type_env non_cafs (AnId id) = - AnId (updateIdUnfolding type_env (updateIdCafInfo non_cafs id)) - -updateTyThingCafInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom - --------------------------------------------------------------------------------- --- Unfoldings --------------------------------------------------------------------------------- - -updateIdUnfolding :: TypeEnv -> Id -> Id -updateIdUnfolding type_env id = - case idUnfolding id of - CoreUnfolding{ .. } -> - setIdUnfolding id CoreUnfolding{ uf_tmpl = updateGlobalIds type_env uf_tmpl, .. } - DFunUnfolding{ .. } -> - setIdUnfolding id DFunUnfolding{ df_args = map (updateGlobalIds type_env) df_args, .. } - _ -> id - --------------------------------------------------------------------------------- --- Expressions --------------------------------------------------------------------------------- - -updateIdCafInfo :: NameSet -> Id -> Id -updateIdCafInfo non_cafs id - | idName id `elemNameSet` non_cafs - = -- pprTrace "updateIdCafInfo" (text "Marking" <+> ppr id <+> parens (ppr (idName id)) <+> text "as non-CAFFY") $ - id `setIdCafInfo` NoCafRefs - | otherwise - = id - --------------------------------------------------------------------------------- - -updateGlobalIds :: NameEnv TyThing -> CoreExpr -> CoreExpr --- Update occurrences of GlobalIds as directed by 'env' --- The 'env' maps a GlobalId to a version with accurate CAF info --- (and in due course perhaps other back-end-related info) -updateGlobalIds env e = go env e - where - go_id :: NameEnv TyThing -> Id -> Id - go_id env var = - case lookupNameEnv env (varName var) of - Nothing -> var - Just (AnId id) -> id - Just other -> pprPanic "UpdateCafInfos.updateGlobalIds" $ - text "Found a non-Id for Id Name" <+> ppr (varName var) $$ - nest 4 (text "Id:" <+> ppr var $$ - text "TyThing:" <+> ppr other) - - go :: NameEnv TyThing -> CoreExpr -> CoreExpr - go env (Var v) = Var (go_id env v) - go _ e@Lit{} = e - go env (App e1 e2) = App (go env e1) (go env e2) - go env (Lam b e) = assertNotInNameEnv env [b] (Lam b (go env e)) - go env (Let bs e) = Let (go_binds env bs) (go env e) - go env (Case e b ty alts) = - assertNotInNameEnv env [b] (Case (go env e) b ty (map go_alt alts)) - where - go_alt (k,bs,e) = assertNotInNameEnv env bs (k, bs, go env e) - go env (Cast e c) = Cast (go env e) c - go env (Tick t e) = Tick t (go env e) - go _ e@Type{} = e - go _ e@Coercion{} = e - - go_binds :: NameEnv TyThing -> CoreBind -> CoreBind - go_binds env (NonRec b e) = - assertNotInNameEnv env [b] (NonRec b (go env e)) - go_binds env (Rec prs) = - assertNotInNameEnv env (map fst prs) (Rec (mapSnd (go env) prs)) - --- In `updateGlobaLIds` Names of local binders should not shadow Name of --- globals. This assertion is to check that. -assertNotInNameEnv :: NameEnv a -> [Id] -> b -> b -assertNotInNameEnv env ids x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs deleted file mode 100644 --- a/compiler/prelude/PrelInfo.hs +++ /dev/null @@ -1,287 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - --} - -{-# LANGUAGE CPP #-} - --- | The @PrelInfo@ interface to the compiler's prelude knowledge. --- --- This module serves as the central gathering point for names which the --- compiler knows something about. This includes functions for, --- --- * discerning whether a 'Name' is known-key --- --- * given a 'Unique', looking up its corresponding known-key 'Name' --- --- See Note [Known-key names] and Note [About wired-in things] for information --- about the two types of prelude things in GHC. --- -module PrelInfo ( - -- * Known-key names - isKnownKeyName, - lookupKnownKeyName, - lookupKnownNameInfo, - - -- ** Internal use - -- | 'knownKeyNames' is exported to seed the original name cache only; - -- if you find yourself wanting to look at it you might consider using - -- 'lookupKnownKeyName' or 'isKnownKeyName'. - knownKeyNames, - - -- * Miscellaneous - wiredInIds, ghcPrimIds, - primOpRules, builtinRules, - - ghcPrimExports, - primOpId, - - -- * Random other things - maybeCharLikeCon, maybeIntLikeCon, - - -- * Class categories - isNumericClass, isStandardClass - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import KnownUniques -import GHC.Types.Unique ( isValidKnownKeyUnique ) - -import GHC.Core.ConLike ( ConLike(..) ) -import THNames ( templateHaskellNames ) -import PrelNames -import GHC.Core.Op.ConstantFold -import GHC.Types.Avail -import PrimOp -import GHC.Core.DataCon -import GHC.Types.Id -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Id.Make -import Outputable -import TysPrim -import TysWiredIn -import GHC.Driver.Types -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Types.Unique.FM -import Util -import TcTypeNats ( typeNatTyCons ) - -import Control.Applicative ((<|>)) -import Data.List ( intercalate ) -import Data.Array -import Data.Maybe - -{- -************************************************************************ -* * -\subsection[builtinNameInfo]{Lookup built-in names} -* * -************************************************************************ - -Note [About wired-in things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Wired-in things are Ids\/TyCons that are completely known to the compiler. - They are global values in GHC, (e.g. listTyCon :: TyCon). - -* A wired-in Name contains the thing itself inside the Name: - see Name.wiredInNameTyThing_maybe - (E.g. listTyConName contains listTyCon. - -* The name cache is initialised with (the names of) all wired-in things - (except tuples and sums; see Note [Infinite families of known-key names]) - -* The type environment itself contains no wired in things. The type - checker sees if the Name is wired in before looking up the name in - the type environment. - -* GHC.Iface.Make prunes out wired-in things before putting them in an interface file. - So interface files never contain wired-in things. --} - - --- | This list is used to ensure that when you say "Prelude.map" in your source --- code, or in an interface file, you get a Name with the correct known key (See --- Note [Known-key names] in PrelNames) -knownKeyNames :: [Name] -knownKeyNames - | debugIsOn - , Just badNamesStr <- knownKeyNamesOkay all_names - = panic ("badAllKnownKeyNames:\n" ++ badNamesStr) - -- NB: We can't use ppr here, because this is sometimes evaluated in a - -- context where there are no DynFlags available, leading to a cryptic - -- "<
>" error. (This seems to happen only in the - -- stage 2 compiler, for reasons I [Richard] have no clue of.) - | otherwise - = all_names - where - all_names = - concat [ wired_tycon_kk_names funTyCon - , concatMap wired_tycon_kk_names primTyCons - - , concatMap wired_tycon_kk_names wiredInTyCons - -- Does not include tuples - - , concatMap wired_tycon_kk_names typeNatTyCons - - , map idName wiredInIds - , map (idName . primOpId) allThePrimOps - , map (idName . primOpWrapperId) allThePrimOps - , basicKnownKeyNames - , templateHaskellNames - ] - -- All of the names associated with a wired-in TyCon. - -- This includes the TyCon itself, its DataCons and promoted TyCons. - wired_tycon_kk_names :: TyCon -> [Name] - wired_tycon_kk_names tc = - tyConName tc : (rep_names tc ++ implicits) - where implicits = concatMap thing_kk_names (implicitTyConThings tc) - - wired_datacon_kk_names :: DataCon -> [Name] - wired_datacon_kk_names dc = - dataConName dc : rep_names (promoteDataCon dc) - - thing_kk_names :: TyThing -> [Name] - thing_kk_names (ATyCon tc) = wired_tycon_kk_names tc - thing_kk_names (AConLike (RealDataCon dc)) = wired_datacon_kk_names dc - thing_kk_names thing = [getName thing] - - -- The TyConRepName for a known-key TyCon has a known key, - -- but isn't itself an implicit thing. Yurgh. - -- NB: if any of the wired-in TyCons had record fields, the record - -- field names would be in a similar situation. Ditto class ops. - -- But it happens that there aren't any - rep_names tc = case tyConRepName_maybe tc of - Just n -> [n] - Nothing -> [] - --- | Check the known-key names list of consistency. -knownKeyNamesOkay :: [Name] -> Maybe String -knownKeyNamesOkay all_names - | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names - = Just $ " Out-of-range known-key uniques: [" - ++ intercalate ", " (map (occNameString . nameOccName) ns) ++ - "]" - | null badNamesPairs - = Nothing - | otherwise - = Just badNamesStr - where - namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) singleton m n n) - emptyUFM all_names - badNamesEnv = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv - badNamesPairs = nonDetUFMToList badNamesEnv - -- It's OK to use nonDetUFMToList here because the ordering only affects - -- the message when we get a panic - badNamesStrs = map pairToStr badNamesPairs - badNamesStr = unlines badNamesStrs - - pairToStr (uniq, ns) = " " ++ - show uniq ++ - ": [" ++ - intercalate ", " (map (occNameString . nameOccName) ns) ++ - "]" - --- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a --- known-key thing. -lookupKnownKeyName :: Unique -> Maybe Name -lookupKnownKeyName u = - knownUniqueName u <|> lookupUFM knownKeysMap u - --- | Is a 'Name' known-key? -isKnownKeyName :: Name -> Bool -isKnownKeyName n = - isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap - -knownKeysMap :: UniqFM Name -knownKeysMap = listToUFM [ (nameUnique n, n) | n <- knownKeyNames ] - --- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by --- GHCi's ':info' command. -lookupKnownNameInfo :: Name -> SDoc -lookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of - -- If we do find a doc, we add comment delimiters to make the output - -- of ':info' valid Haskell. - Nothing -> empty - Just doc -> vcat [text "{-", doc, text "-}"] - --- A map from Uniques to SDocs, used in GHCi's ':info' command. (#12390) -knownNamesInfo :: NameEnv SDoc -knownNamesInfo = unitNameEnv coercibleTyConName $ - vcat [ text "Coercible is a special constraint with custom solving rules." - , text "It is not a class." - , text "Please see section `The Coercible constraint`" - , text "of the user's guide for details." ] - -{- -We let a lot of "non-standard" values be visible, so that we can make -sense of them in interface pragmas. It's cool, though they all have -"non-standard" names, so they won't get past the parser in user code. - -************************************************************************ -* * - PrimOpIds -* * -************************************************************************ --} - -primOpIds :: Array Int Id --- A cache of the PrimOp Ids, indexed by PrimOp tag -primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) - | op <- allThePrimOps ] - -primOpId :: PrimOp -> Id -primOpId op = primOpIds ! primOpTag op - -{- -************************************************************************ -* * - Export lists for pseudo-modules (GHC.Prim) -* * -************************************************************************ - -GHC.Prim "exports" all the primops and primitive types, some -wired-in Ids. --} - -ghcPrimExports :: [IfaceExport] -ghcPrimExports - = map (avail . idName) ghcPrimIds ++ - map (avail . idName . primOpId) allThePrimOps ++ - [ AvailTC n [n] [] - | tc <- funTyCon : exposedPrimTyCons, let n = tyConName tc ] - -{- -************************************************************************ -* * - Built-in keys -* * -************************************************************************ - -ToDo: make it do the ``like'' part properly (as in 0.26 and before). --} - -maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool -maybeCharLikeCon con = con `hasKey` charDataConKey -maybeIntLikeCon con = con `hasKey` intDataConKey - -{- -************************************************************************ -* * - Class predicates -* * -************************************************************************ --} - -isNumericClass, isStandardClass :: Class -> Bool - -isNumericClass clas = classKey clas `is_elem` numericClassKeys -isStandardClass clas = classKey clas `is_elem` standardClassKeys - -is_elem :: Eq a => a -> [a] -> Bool -is_elem = isIn "is_X_Class" diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs deleted file mode 100644 --- a/compiler/prelude/THNames.hs +++ /dev/null @@ -1,1093 +0,0 @@ --- %************************************************************************ --- %* * --- The known-key names for Template Haskell --- %* * --- %************************************************************************ - -module THNames where - -import GhcPrelude () - -import PrelNames( mk_known_key_name ) -import GHC.Types.Module( Module, mkModuleNameFS, mkModule, thUnitId ) -import GHC.Types.Name( Name ) -import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName ) -import GHC.Types.Name.Reader( RdrName, nameRdrName ) -import GHC.Types.Unique -import FastString - --- To add a name, do three things --- --- 1) Allocate a key --- 2) Make a "Name" --- 3) Add the name to templateHaskellNames - -templateHaskellNames :: [Name] --- The names that are implicitly mentioned by ``bracket'' --- Should stay in sync with the import list of GHC.HsToCore.Quote - -templateHaskellNames = [ - returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, - mkNameSName, - liftStringName, - unTypeName, - unTypeQName, - unsafeTExpCoerceName, - - -- Lit - charLName, stringLName, integerLName, intPrimLName, wordPrimLName, - floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, - charPrimLName, - -- Pat - litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, - conPName, tildePName, bangPName, infixPName, - asPName, wildPName, recPName, listPName, sigPName, viewPName, - -- FieldPat - fieldPatName, - -- Match - matchName, - -- Clause - clauseName, - -- Exp - varEName, conEName, litEName, appEName, appTypeEName, infixEName, - infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName, - tupEName, unboxedTupEName, unboxedSumEName, - condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName, - fromEName, fromThenEName, fromToEName, fromThenToEName, - listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName, - labelEName, implicitParamVarEName, - -- FieldExp - fieldExpName, - -- Body - guardedBName, normalBName, - -- Guard - normalGEName, patGEName, - -- Stmt - bindSName, letSName, noBindSName, parSName, recSName, - -- Dec - funDName, valDName, dataDName, newtypeDName, tySynDName, - classDName, instanceWithOverlapDName, - standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName, - pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, - pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, - dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, - dataInstDName, newtypeInstDName, tySynInstDName, - infixLDName, infixRDName, infixNDName, - roleAnnotDName, patSynDName, patSynSigDName, - implicitParamBindDName, - -- Cxt - cxtName, - - -- SourceUnpackedness - noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName, - -- SourceStrictness - noSourceStrictnessName, sourceLazyName, sourceStrictName, - -- Con - normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName, - -- Bang - bangName, - -- BangType - bangTypeName, - -- VarBangType - varBangTypeName, - -- PatSynDir (for pattern synonyms) - unidirPatSynName, implBidirPatSynName, explBidirPatSynName, - -- PatSynArgs (for pattern synonyms) - prefixPatSynName, infixPatSynName, recordPatSynName, - -- Type - forallTName, forallVisTName, varTName, conTName, infixTName, appTName, - appKindTName, equalityTName, tupleTName, unboxedTupleTName, - unboxedSumTName, arrowTName, listTName, sigTName, litTName, - promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, - wildCardTName, implicitParamTName, - -- TyLit - numTyLitName, strTyLitName, - -- TyVarBndr - plainTVName, kindedTVName, - -- Role - nominalRName, representationalRName, phantomRName, inferRName, - -- Kind - starKName, constraintKName, - -- FamilyResultSig - noSigName, kindSigName, tyVarSigName, - -- InjectivityAnn - injectivityAnnName, - -- Callconv - cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName, - -- Safety - unsafeName, - safeName, - interruptibleName, - -- Inline - noInlineDataConName, inlineDataConName, inlinableDataConName, - -- RuleMatch - conLikeDataConName, funLikeDataConName, - -- Phases - allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName, - -- Overlap - overlappableDataConName, overlappingDataConName, overlapsDataConName, - incoherentDataConName, - -- DerivStrategy - stockStrategyName, anyclassStrategyName, - newtypeStrategyName, viaStrategyName, - -- TExp - tExpDataConName, - -- RuleBndr - ruleVarName, typedRuleVarName, - -- FunDep - funDepName, - -- TySynEqn - tySynEqnName, - -- AnnTarget - valueAnnotationName, typeAnnotationName, moduleAnnotationName, - -- DerivClause - derivClauseName, - - -- The type classes - liftClassName, quoteClassName, - - -- And the tycons - qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchTyConName, - expQTyConName, fieldExpTyConName, predTyConName, - stmtTyConName, decsTyConName, conTyConName, bangTypeTyConName, - varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName, - typeTyConName, tyVarBndrTyConName, clauseTyConName, - patQTyConName, funDepTyConName, decsQTyConName, - ruleBndrTyConName, tySynEqnTyConName, - roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName, - overlapTyConName, derivClauseTyConName, derivStrategyTyConName, - - -- Quasiquoting - quoteDecName, quoteTypeName, quoteExpName, quotePatName] - -thSyn, thLib, qqLib :: Module -thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax") -thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal") -qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") - -mkTHModule :: FastString -> Module -mkTHModule m = mkModule thUnitId (mkModuleNameFS m) - -libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: 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 - --------------------- TH.Syntax ----------------------- -liftClassName :: Name -liftClassName = thCls (fsLit "Lift") liftClassKey - -quoteClassName :: Name -quoteClassName = thCls (fsLit "Quote") quoteClassKey - -qTyConName, nameTyConName, fieldExpTyConName, patTyConName, - fieldPatTyConName, expTyConName, decTyConName, typeTyConName, - matchTyConName, clauseTyConName, funDepTyConName, predTyConName, - tExpTyConName, injAnnTyConName, overlapTyConName, decsTyConName :: Name -qTyConName = thTc (fsLit "Q") qTyConKey -nameTyConName = thTc (fsLit "Name") nameTyConKey -fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey -patTyConName = thTc (fsLit "Pat") patTyConKey -fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey -expTyConName = thTc (fsLit "Exp") expTyConKey -decTyConName = thTc (fsLit "Dec") decTyConKey -decsTyConName = libTc (fsLit "Decs") decsTyConKey -typeTyConName = thTc (fsLit "Type") typeTyConKey -matchTyConName = thTc (fsLit "Match") matchTyConKey -clauseTyConName = thTc (fsLit "Clause") clauseTyConKey -funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey -predTyConName = thTc (fsLit "Pred") predTyConKey -tExpTyConName = thTc (fsLit "TExp") tExpTyConKey -injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey -overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey - -returnQName, bindQName, sequenceQName, newNameName, liftName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, - mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName, - unsafeTExpCoerceName, liftTypedName :: Name -returnQName = thFun (fsLit "returnQ") returnQIdKey -bindQName = thFun (fsLit "bindQ") bindQIdKey -sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey -newNameName = thFun (fsLit "newName") newNameIdKey -liftName = thFun (fsLit "lift") liftIdKey -liftStringName = thFun (fsLit "liftString") liftStringIdKey -mkNameName = thFun (fsLit "mkName") mkNameIdKey -mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey -mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey -mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey -mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey -mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey -unTypeName = thFun (fsLit "unType") unTypeIdKey -unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey -unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey -liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey - - --------------------- TH.Lib ----------------------- --- data Lit = ... -charLName, stringLName, integerLName, intPrimLName, wordPrimLName, - floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, - charPrimLName :: Name -charLName = libFun (fsLit "charL") charLIdKey -stringLName = libFun (fsLit "stringL") stringLIdKey -integerLName = libFun (fsLit "integerL") integerLIdKey -intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey -wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey -floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey -doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey -rationalLName = libFun (fsLit "rationalL") rationalLIdKey -stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey -charPrimLName = libFun (fsLit "charPrimL") charPrimLIdKey - --- data Pat = ... -litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName, - infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName, - sigPName, viewPName :: Name -litPName = libFun (fsLit "litP") litPIdKey -varPName = libFun (fsLit "varP") varPIdKey -tupPName = libFun (fsLit "tupP") tupPIdKey -unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey -unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey -conPName = libFun (fsLit "conP") conPIdKey -infixPName = libFun (fsLit "infixP") infixPIdKey -tildePName = libFun (fsLit "tildeP") tildePIdKey -bangPName = libFun (fsLit "bangP") bangPIdKey -asPName = libFun (fsLit "asP") asPIdKey -wildPName = libFun (fsLit "wildP") wildPIdKey -recPName = libFun (fsLit "recP") recPIdKey -listPName = libFun (fsLit "listP") listPIdKey -sigPName = libFun (fsLit "sigP") sigPIdKey -viewPName = libFun (fsLit "viewP") viewPIdKey - --- type FieldPat = ... -fieldPatName :: Name -fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey - --- data Match = ... -matchName :: Name -matchName = libFun (fsLit "match") matchIdKey - --- data Clause = ... -clauseName :: Name -clauseName = libFun (fsLit "clause") clauseIdKey - --- data Exp = ... -varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName, - sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, - unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName, - caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName, - labelEName, implicitParamVarEName :: Name -varEName = libFun (fsLit "varE") varEIdKey -conEName = libFun (fsLit "conE") conEIdKey -litEName = libFun (fsLit "litE") litEIdKey -appEName = libFun (fsLit "appE") appEIdKey -appTypeEName = libFun (fsLit "appTypeE") appTypeEIdKey -infixEName = libFun (fsLit "infixE") infixEIdKey -infixAppName = libFun (fsLit "infixApp") infixAppIdKey -sectionLName = libFun (fsLit "sectionL") sectionLIdKey -sectionRName = libFun (fsLit "sectionR") sectionRIdKey -lamEName = libFun (fsLit "lamE") lamEIdKey -lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey -tupEName = libFun (fsLit "tupE") tupEIdKey -unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey -unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey -condEName = libFun (fsLit "condE") condEIdKey -multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey -letEName = libFun (fsLit "letE") letEIdKey -caseEName = libFun (fsLit "caseE") caseEIdKey -doEName = libFun (fsLit "doE") doEIdKey -mdoEName = libFun (fsLit "mdoE") mdoEIdKey -compEName = libFun (fsLit "compE") compEIdKey --- ArithSeq skips a level -fromEName, fromThenEName, fromToEName, fromThenToEName :: Name -fromEName = libFun (fsLit "fromE") fromEIdKey -fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey -fromToEName = libFun (fsLit "fromToE") fromToEIdKey -fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey --- end ArithSeq -listEName, sigEName, recConEName, recUpdEName :: Name -listEName = libFun (fsLit "listE") listEIdKey -sigEName = libFun (fsLit "sigE") sigEIdKey -recConEName = libFun (fsLit "recConE") recConEIdKey -recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey -staticEName = libFun (fsLit "staticE") staticEIdKey -unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey -labelEName = libFun (fsLit "labelE") labelEIdKey -implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey - --- type FieldExp = ... -fieldExpName :: Name -fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey - --- data Body = ... -guardedBName, normalBName :: Name -guardedBName = libFun (fsLit "guardedB") guardedBIdKey -normalBName = libFun (fsLit "normalB") normalBIdKey - --- data Guard = ... -normalGEName, patGEName :: Name -normalGEName = libFun (fsLit "normalGE") normalGEIdKey -patGEName = libFun (fsLit "patGE") patGEIdKey - --- data Stmt = ... -bindSName, letSName, noBindSName, parSName, recSName :: Name -bindSName = libFun (fsLit "bindS") bindSIdKey -letSName = libFun (fsLit "letS") letSIdKey -noBindSName = libFun (fsLit "noBindS") noBindSIdKey -parSName = libFun (fsLit "parS") parSIdKey -recSName = libFun (fsLit "recS") recSIdKey - --- data Dec = ... -funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, - instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName, - pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, - pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, - dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName, - openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName, - infixNDName, roleAnnotDName, patSynDName, patSynSigDName, - pragCompleteDName, implicitParamBindDName :: Name -funDName = libFun (fsLit "funD") funDIdKey -valDName = libFun (fsLit "valD") valDIdKey -dataDName = libFun (fsLit "dataD") dataDIdKey -newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey -tySynDName = libFun (fsLit "tySynD") tySynDIdKey -classDName = libFun (fsLit "classD") classDIdKey -instanceWithOverlapDName = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey -standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey -sigDName = libFun (fsLit "sigD") sigDIdKey -kiSigDName = libFun (fsLit "kiSigD") kiSigDIdKey -defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey -forImpDName = libFun (fsLit "forImpD") forImpDIdKey -pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey -pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey -pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey -pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey -pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey -pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey -pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey -dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey -newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey -tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey -openTypeFamilyDName = libFun (fsLit "openTypeFamilyD") openTypeFamilyDIdKey -closedTypeFamilyDName = libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey -dataFamilyDName = libFun (fsLit "dataFamilyD") dataFamilyDIdKey -infixLDName = libFun (fsLit "infixLD") infixLDIdKey -infixRDName = libFun (fsLit "infixRD") infixRDIdKey -infixNDName = libFun (fsLit "infixND") infixNDIdKey -roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey -patSynDName = libFun (fsLit "patSynD") patSynDIdKey -patSynSigDName = libFun (fsLit "patSynSigD") patSynSigDIdKey -implicitParamBindDName = libFun (fsLit "implicitParamBindD") implicitParamBindDIdKey - --- type Ctxt = ... -cxtName :: Name -cxtName = libFun (fsLit "cxt") cxtIdKey - --- data SourceUnpackedness = ... -noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name -noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey -sourceNoUnpackName = libFun (fsLit "sourceNoUnpack") sourceNoUnpackKey -sourceUnpackName = libFun (fsLit "sourceUnpack") sourceUnpackKey - --- data SourceStrictness = ... -noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name -noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey -sourceLazyName = libFun (fsLit "sourceLazy") sourceLazyKey -sourceStrictName = libFun (fsLit "sourceStrict") sourceStrictKey - --- data Con = ... -normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name -normalCName = libFun (fsLit "normalC" ) normalCIdKey -recCName = libFun (fsLit "recC" ) recCIdKey -infixCName = libFun (fsLit "infixC" ) infixCIdKey -forallCName = libFun (fsLit "forallC" ) forallCIdKey -gadtCName = libFun (fsLit "gadtC" ) gadtCIdKey -recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey - --- data Bang = ... -bangName :: Name -bangName = libFun (fsLit "bang") bangIdKey - --- type BangType = ... -bangTypeName :: Name -bangTypeName = libFun (fsLit "bangType") bangTKey - --- type VarBangType = ... -varBangTypeName :: Name -varBangTypeName = libFun (fsLit "varBangType") varBangTKey - --- data PatSynDir = ... -unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name -unidirPatSynName = libFun (fsLit "unidir") unidirPatSynIdKey -implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey -explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey - --- data PatSynArgs = ... -prefixPatSynName, infixPatSynName, recordPatSynName :: Name -prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey -infixPatSynName = libFun (fsLit "infixPatSyn") infixPatSynIdKey -recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey - --- data Type = ... -forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName, - unboxedTupleTName, unboxedSumTName, arrowTName, listTName, appTName, - appKindTName, sigTName, equalityTName, litTName, promotedTName, - promotedTupleTName, promotedNilTName, promotedConsTName, - wildCardTName, implicitParamTName :: Name -forallTName = libFun (fsLit "forallT") forallTIdKey -forallVisTName = libFun (fsLit "forallVisT") forallVisTIdKey -varTName = libFun (fsLit "varT") varTIdKey -conTName = libFun (fsLit "conT") conTIdKey -tupleTName = libFun (fsLit "tupleT") tupleTIdKey -unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey -unboxedSumTName = libFun (fsLit "unboxedSumT") unboxedSumTIdKey -arrowTName = libFun (fsLit "arrowT") arrowTIdKey -listTName = libFun (fsLit "listT") listTIdKey -appTName = libFun (fsLit "appT") appTIdKey -appKindTName = libFun (fsLit "appKindT") appKindTIdKey -sigTName = libFun (fsLit "sigT") sigTIdKey -equalityTName = libFun (fsLit "equalityT") equalityTIdKey -litTName = libFun (fsLit "litT") litTIdKey -promotedTName = libFun (fsLit "promotedT") promotedTIdKey -promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey -promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey -promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey -wildCardTName = libFun (fsLit "wildCardT") wildCardTIdKey -infixTName = libFun (fsLit "infixT") infixTIdKey -implicitParamTName = libFun (fsLit "implicitParamT") implicitParamTIdKey - --- data TyLit = ... -numTyLitName, strTyLitName :: Name -numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey -strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey - --- data TyVarBndr = ... -plainTVName, kindedTVName :: Name -plainTVName = libFun (fsLit "plainTV") plainTVIdKey -kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey - --- data Role = ... -nominalRName, representationalRName, phantomRName, inferRName :: Name -nominalRName = libFun (fsLit "nominalR") nominalRIdKey -representationalRName = libFun (fsLit "representationalR") representationalRIdKey -phantomRName = libFun (fsLit "phantomR") phantomRIdKey -inferRName = libFun (fsLit "inferR") inferRIdKey - --- data Kind = ... -starKName, constraintKName :: Name -starKName = libFun (fsLit "starK") starKIdKey -constraintKName = libFun (fsLit "constraintK") constraintKIdKey - --- data FamilyResultSig = ... -noSigName, kindSigName, tyVarSigName :: Name -noSigName = libFun (fsLit "noSig") noSigIdKey -kindSigName = libFun (fsLit "kindSig") kindSigIdKey -tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey - --- data InjectivityAnn = ... -injectivityAnnName :: Name -injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey - --- data Callconv = ... -cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name -cCallName = libFun (fsLit "cCall") cCallIdKey -stdCallName = libFun (fsLit "stdCall") stdCallIdKey -cApiCallName = libFun (fsLit "cApi") cApiCallIdKey -primCallName = libFun (fsLit "prim") primCallIdKey -javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey - --- data Safety = ... -unsafeName, safeName, interruptibleName :: Name -unsafeName = libFun (fsLit "unsafe") unsafeIdKey -safeName = libFun (fsLit "safe") safeIdKey -interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey - --- newtype TExp a = ... -tExpDataConName :: Name -tExpDataConName = thCon (fsLit "TExp") tExpDataConKey - --- data RuleBndr = ... -ruleVarName, typedRuleVarName :: Name -ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey -typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey - --- data FunDep = ... -funDepName :: Name -funDepName = libFun (fsLit "funDep") funDepIdKey - --- data TySynEqn = ... -tySynEqnName :: Name -tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey - --- data AnnTarget = ... -valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name -valueAnnotationName = libFun (fsLit "valueAnnotation") valueAnnotationIdKey -typeAnnotationName = libFun (fsLit "typeAnnotation") typeAnnotationIdKey -moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey - --- type DerivClause = ... -derivClauseName :: Name -derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey - --- data DerivStrategy = ... -stockStrategyName, anyclassStrategyName, newtypeStrategyName, - viaStrategyName :: Name -stockStrategyName = libFun (fsLit "stockStrategy") stockStrategyIdKey -anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey -newtypeStrategyName = libFun (fsLit "newtypeStrategy") newtypeStrategyIdKey -viaStrategyName = libFun (fsLit "viaStrategy") viaStrategyIdKey - -patQTyConName, expQTyConName, stmtTyConName, - conTyConName, bangTypeTyConName, - varBangTypeTyConName, typeQTyConName, - decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName, - derivClauseTyConName, kindTyConName, tyVarBndrTyConName, - derivStrategyTyConName :: Name --- These are only used for the types of top-level splices -expQTyConName = libTc (fsLit "ExpQ") expQTyConKey -decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec] -typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey -patQTyConName = libTc (fsLit "PatQ") patQTyConKey - --- These are used in GHC.HsToCore.Quote but always wrapped in a type variable -stmtTyConName = thTc (fsLit "Stmt") stmtTyConKey -conTyConName = thTc (fsLit "Con") conTyConKey -bangTypeTyConName = thTc (fsLit "BangType") bangTypeTyConKey -varBangTypeTyConName = thTc (fsLit "VarBangType") varBangTypeTyConKey -ruleBndrTyConName = thTc (fsLit "RuleBndr") ruleBndrTyConKey -tySynEqnTyConName = thTc (fsLit "TySynEqn") tySynEqnTyConKey -roleTyConName = libTc (fsLit "Role") roleTyConKey -derivClauseTyConName = thTc (fsLit "DerivClause") derivClauseTyConKey -kindTyConName = thTc (fsLit "Kind") kindTyConKey -tyVarBndrTyConName = thTc (fsLit "TyVarBndr") tyVarBndrTyConKey -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 - --- data Inline = ... -noInlineDataConName, inlineDataConName, inlinableDataConName :: Name -noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey -inlineDataConName = thCon (fsLit "Inline") inlineDataConKey -inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey - --- data RuleMatch = ... -conLikeDataConName, funLikeDataConName :: Name -conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey -funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey - --- data Phases = ... -allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name -allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey -fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey -beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey - --- data Overlap = ... -overlappableDataConName, - overlappingDataConName, - overlapsDataConName, - incoherentDataConName :: Name -overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey -overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey -overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey -incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey - -{- ********************************************************************* -* * - Class keys -* * -********************************************************************* -} - --- ClassUniques available: 200-299 --- Check in PrelNames if you want to change this - -liftClassKey :: Unique -liftClassKey = mkPreludeClassUnique 200 - -quoteClassKey :: Unique -quoteClassKey = mkPreludeClassUnique 201 - -{- ********************************************************************* -* * - TyCon keys -* * -********************************************************************* -} - --- TyConUniques available: 200-299 --- Check in PrelNames if you want to change this - -expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, - patTyConKey, - stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey, - tyVarBndrTyConKey, decTyConKey, bangTypeTyConKey, varBangTypeTyConKey, - fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, - funDepTyConKey, predTyConKey, - predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey, - roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey, - overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey - :: Unique -expTyConKey = mkPreludeTyConUnique 200 -matchTyConKey = mkPreludeTyConUnique 201 -clauseTyConKey = mkPreludeTyConUnique 202 -qTyConKey = mkPreludeTyConUnique 203 -expQTyConKey = mkPreludeTyConUnique 204 -patTyConKey = mkPreludeTyConUnique 206 -stmtTyConKey = mkPreludeTyConUnique 209 -conTyConKey = mkPreludeTyConUnique 210 -typeQTyConKey = mkPreludeTyConUnique 211 -typeTyConKey = mkPreludeTyConUnique 212 -decTyConKey = mkPreludeTyConUnique 213 -bangTypeTyConKey = mkPreludeTyConUnique 214 -varBangTypeTyConKey = mkPreludeTyConUnique 215 -fieldExpTyConKey = mkPreludeTyConUnique 216 -fieldPatTyConKey = mkPreludeTyConUnique 217 -nameTyConKey = mkPreludeTyConUnique 218 -patQTyConKey = mkPreludeTyConUnique 219 -funDepTyConKey = mkPreludeTyConUnique 222 -predTyConKey = mkPreludeTyConUnique 223 -predQTyConKey = mkPreludeTyConUnique 224 -tyVarBndrTyConKey = mkPreludeTyConUnique 225 -decsQTyConKey = mkPreludeTyConUnique 226 -ruleBndrTyConKey = mkPreludeTyConUnique 227 -tySynEqnTyConKey = mkPreludeTyConUnique 228 -roleTyConKey = mkPreludeTyConUnique 229 -tExpTyConKey = mkPreludeTyConUnique 230 -injAnnTyConKey = mkPreludeTyConUnique 231 -kindTyConKey = mkPreludeTyConUnique 232 -overlapTyConKey = mkPreludeTyConUnique 233 -derivClauseTyConKey = mkPreludeTyConUnique 234 -derivStrategyTyConKey = mkPreludeTyConUnique 235 -decsTyConKey = mkPreludeTyConUnique 236 - -{- ********************************************************************* -* * - DataCon keys -* * -********************************************************************* -} - --- DataConUniques available: 100-150 --- If you want to change this, make sure you check in PrelNames - --- data Inline = ... -noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique -noInlineDataConKey = mkPreludeDataConUnique 200 -inlineDataConKey = mkPreludeDataConUnique 201 -inlinableDataConKey = mkPreludeDataConUnique 202 - --- data RuleMatch = ... -conLikeDataConKey, funLikeDataConKey :: Unique -conLikeDataConKey = mkPreludeDataConUnique 203 -funLikeDataConKey = mkPreludeDataConUnique 204 - --- data Phases = ... -allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique -allPhasesDataConKey = mkPreludeDataConUnique 205 -fromPhaseDataConKey = mkPreludeDataConUnique 206 -beforePhaseDataConKey = mkPreludeDataConUnique 207 - --- newtype TExp a = ... -tExpDataConKey :: Unique -tExpDataConKey = mkPreludeDataConUnique 208 - --- data Overlap = .. -overlappableDataConKey, - overlappingDataConKey, - overlapsDataConKey, - incoherentDataConKey :: Unique -overlappableDataConKey = mkPreludeDataConUnique 209 -overlappingDataConKey = mkPreludeDataConUnique 210 -overlapsDataConKey = mkPreludeDataConUnique 211 -incoherentDataConKey = mkPreludeDataConUnique 212 - -{- ********************************************************************* -* * - Id keys -* * -********************************************************************* -} - --- IdUniques available: 200-499 --- If you want to change this, make sure you check in PrelNames - -returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, - mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, - mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey, - unsafeTExpCoerceIdKey, liftTypedIdKey :: Unique -returnQIdKey = mkPreludeMiscIdUnique 200 -bindQIdKey = mkPreludeMiscIdUnique 201 -sequenceQIdKey = mkPreludeMiscIdUnique 202 -liftIdKey = mkPreludeMiscIdUnique 203 -newNameIdKey = mkPreludeMiscIdUnique 204 -mkNameIdKey = mkPreludeMiscIdUnique 205 -mkNameG_vIdKey = mkPreludeMiscIdUnique 206 -mkNameG_dIdKey = mkPreludeMiscIdUnique 207 -mkNameG_tcIdKey = mkPreludeMiscIdUnique 208 -mkNameLIdKey = mkPreludeMiscIdUnique 209 -mkNameSIdKey = mkPreludeMiscIdUnique 210 -unTypeIdKey = mkPreludeMiscIdUnique 211 -unTypeQIdKey = mkPreludeMiscIdUnique 212 -unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213 -liftTypedIdKey = mkPreludeMiscIdUnique 214 - - --- data Lit = ... -charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey, - floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey, - charPrimLIdKey:: Unique -charLIdKey = mkPreludeMiscIdUnique 220 -stringLIdKey = mkPreludeMiscIdUnique 221 -integerLIdKey = mkPreludeMiscIdUnique 222 -intPrimLIdKey = mkPreludeMiscIdUnique 223 -wordPrimLIdKey = mkPreludeMiscIdUnique 224 -floatPrimLIdKey = mkPreludeMiscIdUnique 225 -doublePrimLIdKey = mkPreludeMiscIdUnique 226 -rationalLIdKey = mkPreludeMiscIdUnique 227 -stringPrimLIdKey = mkPreludeMiscIdUnique 228 -charPrimLIdKey = mkPreludeMiscIdUnique 229 - -liftStringIdKey :: Unique -liftStringIdKey = mkPreludeMiscIdUnique 230 - --- data Pat = ... -litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey, - infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, - listPIdKey, sigPIdKey, viewPIdKey :: Unique -litPIdKey = mkPreludeMiscIdUnique 240 -varPIdKey = mkPreludeMiscIdUnique 241 -tupPIdKey = mkPreludeMiscIdUnique 242 -unboxedTupPIdKey = mkPreludeMiscIdUnique 243 -unboxedSumPIdKey = mkPreludeMiscIdUnique 244 -conPIdKey = mkPreludeMiscIdUnique 245 -infixPIdKey = mkPreludeMiscIdUnique 246 -tildePIdKey = mkPreludeMiscIdUnique 247 -bangPIdKey = mkPreludeMiscIdUnique 248 -asPIdKey = mkPreludeMiscIdUnique 249 -wildPIdKey = mkPreludeMiscIdUnique 250 -recPIdKey = mkPreludeMiscIdUnique 251 -listPIdKey = mkPreludeMiscIdUnique 252 -sigPIdKey = mkPreludeMiscIdUnique 253 -viewPIdKey = mkPreludeMiscIdUnique 254 - --- type FieldPat = ... -fieldPatIdKey :: Unique -fieldPatIdKey = mkPreludeMiscIdUnique 260 - --- data Match = ... -matchIdKey :: Unique -matchIdKey = mkPreludeMiscIdUnique 261 - --- data Clause = ... -clauseIdKey :: Unique -clauseIdKey = mkPreludeMiscIdUnique 262 - - --- data Exp = ... -varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey, - infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, - tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey, - letEIdKey, caseEIdKey, doEIdKey, compEIdKey, - fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, - listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey, - unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey :: Unique -varEIdKey = mkPreludeMiscIdUnique 270 -conEIdKey = mkPreludeMiscIdUnique 271 -litEIdKey = mkPreludeMiscIdUnique 272 -appEIdKey = mkPreludeMiscIdUnique 273 -appTypeEIdKey = mkPreludeMiscIdUnique 274 -infixEIdKey = mkPreludeMiscIdUnique 275 -infixAppIdKey = mkPreludeMiscIdUnique 276 -sectionLIdKey = mkPreludeMiscIdUnique 277 -sectionRIdKey = mkPreludeMiscIdUnique 278 -lamEIdKey = mkPreludeMiscIdUnique 279 -lamCaseEIdKey = mkPreludeMiscIdUnique 280 -tupEIdKey = mkPreludeMiscIdUnique 281 -unboxedTupEIdKey = mkPreludeMiscIdUnique 282 -unboxedSumEIdKey = mkPreludeMiscIdUnique 283 -condEIdKey = mkPreludeMiscIdUnique 284 -multiIfEIdKey = mkPreludeMiscIdUnique 285 -letEIdKey = mkPreludeMiscIdUnique 286 -caseEIdKey = mkPreludeMiscIdUnique 287 -doEIdKey = mkPreludeMiscIdUnique 288 -compEIdKey = mkPreludeMiscIdUnique 289 -fromEIdKey = mkPreludeMiscIdUnique 290 -fromThenEIdKey = mkPreludeMiscIdUnique 291 -fromToEIdKey = mkPreludeMiscIdUnique 292 -fromThenToEIdKey = mkPreludeMiscIdUnique 293 -listEIdKey = mkPreludeMiscIdUnique 294 -sigEIdKey = mkPreludeMiscIdUnique 295 -recConEIdKey = mkPreludeMiscIdUnique 296 -recUpdEIdKey = mkPreludeMiscIdUnique 297 -staticEIdKey = mkPreludeMiscIdUnique 298 -unboundVarEIdKey = mkPreludeMiscIdUnique 299 -labelEIdKey = mkPreludeMiscIdUnique 300 -implicitParamVarEIdKey = mkPreludeMiscIdUnique 301 -mdoEIdKey = mkPreludeMiscIdUnique 302 - --- type FieldExp = ... -fieldExpIdKey :: Unique -fieldExpIdKey = mkPreludeMiscIdUnique 305 - --- data Body = ... -guardedBIdKey, normalBIdKey :: Unique -guardedBIdKey = mkPreludeMiscIdUnique 306 -normalBIdKey = mkPreludeMiscIdUnique 307 - --- data Guard = ... -normalGEIdKey, patGEIdKey :: Unique -normalGEIdKey = mkPreludeMiscIdUnique 308 -patGEIdKey = mkPreludeMiscIdUnique 309 - --- data Stmt = ... -bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique -bindSIdKey = mkPreludeMiscIdUnique 310 -letSIdKey = mkPreludeMiscIdUnique 311 -noBindSIdKey = mkPreludeMiscIdUnique 312 -parSIdKey = mkPreludeMiscIdUnique 313 -recSIdKey = mkPreludeMiscIdUnique 314 - --- data Dec = ... -funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, - instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, - pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, - pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey, - openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey, - newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey, - infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey, - patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey, - kiSigDIdKey :: Unique -funDIdKey = mkPreludeMiscIdUnique 320 -valDIdKey = mkPreludeMiscIdUnique 321 -dataDIdKey = mkPreludeMiscIdUnique 322 -newtypeDIdKey = mkPreludeMiscIdUnique 323 -tySynDIdKey = mkPreludeMiscIdUnique 324 -classDIdKey = mkPreludeMiscIdUnique 325 -instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 326 -instanceDIdKey = mkPreludeMiscIdUnique 327 -sigDIdKey = mkPreludeMiscIdUnique 328 -forImpDIdKey = mkPreludeMiscIdUnique 329 -pragInlDIdKey = mkPreludeMiscIdUnique 330 -pragSpecDIdKey = mkPreludeMiscIdUnique 331 -pragSpecInlDIdKey = mkPreludeMiscIdUnique 332 -pragSpecInstDIdKey = mkPreludeMiscIdUnique 333 -pragRuleDIdKey = mkPreludeMiscIdUnique 334 -pragAnnDIdKey = mkPreludeMiscIdUnique 335 -dataFamilyDIdKey = mkPreludeMiscIdUnique 336 -openTypeFamilyDIdKey = mkPreludeMiscIdUnique 337 -dataInstDIdKey = mkPreludeMiscIdUnique 338 -newtypeInstDIdKey = mkPreludeMiscIdUnique 339 -tySynInstDIdKey = mkPreludeMiscIdUnique 340 -closedTypeFamilyDIdKey = mkPreludeMiscIdUnique 341 -infixLDIdKey = mkPreludeMiscIdUnique 342 -infixRDIdKey = mkPreludeMiscIdUnique 343 -infixNDIdKey = mkPreludeMiscIdUnique 344 -roleAnnotDIdKey = mkPreludeMiscIdUnique 345 -standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346 -defaultSigDIdKey = mkPreludeMiscIdUnique 347 -patSynDIdKey = mkPreludeMiscIdUnique 348 -patSynSigDIdKey = mkPreludeMiscIdUnique 349 -pragCompleteDIdKey = mkPreludeMiscIdUnique 350 -implicitParamBindDIdKey = mkPreludeMiscIdUnique 351 -kiSigDIdKey = mkPreludeMiscIdUnique 352 - --- type Cxt = ... -cxtIdKey :: Unique -cxtIdKey = mkPreludeMiscIdUnique 361 - --- data SourceUnpackedness = ... -noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique -noSourceUnpackednessKey = mkPreludeMiscIdUnique 362 -sourceNoUnpackKey = mkPreludeMiscIdUnique 363 -sourceUnpackKey = mkPreludeMiscIdUnique 364 - --- data SourceStrictness = ... -noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique -noSourceStrictnessKey = mkPreludeMiscIdUnique 365 -sourceLazyKey = mkPreludeMiscIdUnique 366 -sourceStrictKey = mkPreludeMiscIdUnique 367 - --- data Con = ... -normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey, - recGadtCIdKey :: Unique -normalCIdKey = mkPreludeMiscIdUnique 368 -recCIdKey = mkPreludeMiscIdUnique 369 -infixCIdKey = mkPreludeMiscIdUnique 370 -forallCIdKey = mkPreludeMiscIdUnique 371 -gadtCIdKey = mkPreludeMiscIdUnique 372 -recGadtCIdKey = mkPreludeMiscIdUnique 373 - --- data Bang = ... -bangIdKey :: Unique -bangIdKey = mkPreludeMiscIdUnique 374 - --- type BangType = ... -bangTKey :: Unique -bangTKey = mkPreludeMiscIdUnique 375 - --- type VarBangType = ... -varBangTKey :: Unique -varBangTKey = mkPreludeMiscIdUnique 376 - --- data PatSynDir = ... -unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique -unidirPatSynIdKey = mkPreludeMiscIdUnique 377 -implBidirPatSynIdKey = mkPreludeMiscIdUnique 378 -explBidirPatSynIdKey = mkPreludeMiscIdUnique 379 - --- data PatSynArgs = ... -prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique -prefixPatSynIdKey = mkPreludeMiscIdUnique 380 -infixPatSynIdKey = mkPreludeMiscIdUnique 381 -recordPatSynIdKey = mkPreludeMiscIdUnique 382 - --- data Type = ... -forallTIdKey, forallVisTIdKey, varTIdKey, conTIdKey, tupleTIdKey, - unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, - appKindTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey, - promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey, - wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique -forallTIdKey = mkPreludeMiscIdUnique 390 -forallVisTIdKey = mkPreludeMiscIdUnique 391 -varTIdKey = mkPreludeMiscIdUnique 392 -conTIdKey = mkPreludeMiscIdUnique 393 -tupleTIdKey = mkPreludeMiscIdUnique 394 -unboxedTupleTIdKey = mkPreludeMiscIdUnique 395 -unboxedSumTIdKey = mkPreludeMiscIdUnique 396 -arrowTIdKey = mkPreludeMiscIdUnique 397 -listTIdKey = mkPreludeMiscIdUnique 398 -appTIdKey = mkPreludeMiscIdUnique 399 -appKindTIdKey = mkPreludeMiscIdUnique 400 -sigTIdKey = mkPreludeMiscIdUnique 401 -equalityTIdKey = mkPreludeMiscIdUnique 402 -litTIdKey = mkPreludeMiscIdUnique 403 -promotedTIdKey = mkPreludeMiscIdUnique 404 -promotedTupleTIdKey = mkPreludeMiscIdUnique 405 -promotedNilTIdKey = mkPreludeMiscIdUnique 406 -promotedConsTIdKey = mkPreludeMiscIdUnique 407 -wildCardTIdKey = mkPreludeMiscIdUnique 408 -implicitParamTIdKey = mkPreludeMiscIdUnique 409 -infixTIdKey = mkPreludeMiscIdUnique 410 - --- data TyLit = ... -numTyLitIdKey, strTyLitIdKey :: Unique -numTyLitIdKey = mkPreludeMiscIdUnique 411 -strTyLitIdKey = mkPreludeMiscIdUnique 412 - --- data TyVarBndr = ... -plainTVIdKey, kindedTVIdKey :: Unique -plainTVIdKey = mkPreludeMiscIdUnique 413 -kindedTVIdKey = mkPreludeMiscIdUnique 414 - --- data Role = ... -nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique -nominalRIdKey = mkPreludeMiscIdUnique 415 -representationalRIdKey = mkPreludeMiscIdUnique 416 -phantomRIdKey = mkPreludeMiscIdUnique 417 -inferRIdKey = mkPreludeMiscIdUnique 418 - --- data Kind = ... -starKIdKey, constraintKIdKey :: Unique -starKIdKey = mkPreludeMiscIdUnique 425 -constraintKIdKey = mkPreludeMiscIdUnique 426 - --- data FamilyResultSig = ... -noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique -noSigIdKey = mkPreludeMiscIdUnique 427 -kindSigIdKey = mkPreludeMiscIdUnique 428 -tyVarSigIdKey = mkPreludeMiscIdUnique 429 - --- data InjectivityAnn = ... -injectivityAnnIdKey :: Unique -injectivityAnnIdKey = mkPreludeMiscIdUnique 430 - --- data Callconv = ... -cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey, - javaScriptCallIdKey :: Unique -cCallIdKey = mkPreludeMiscIdUnique 431 -stdCallIdKey = mkPreludeMiscIdUnique 432 -cApiCallIdKey = mkPreludeMiscIdUnique 433 -primCallIdKey = mkPreludeMiscIdUnique 434 -javaScriptCallIdKey = mkPreludeMiscIdUnique 435 - --- data Safety = ... -unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique -unsafeIdKey = mkPreludeMiscIdUnique 440 -safeIdKey = mkPreludeMiscIdUnique 441 -interruptibleIdKey = mkPreludeMiscIdUnique 442 - --- data FunDep = ... -funDepIdKey :: Unique -funDepIdKey = mkPreludeMiscIdUnique 445 - --- data TySynEqn = ... -tySynEqnIdKey :: Unique -tySynEqnIdKey = mkPreludeMiscIdUnique 460 - --- quasiquoting -quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique -quoteExpKey = mkPreludeMiscIdUnique 470 -quotePatKey = mkPreludeMiscIdUnique 471 -quoteDecKey = mkPreludeMiscIdUnique 472 -quoteTypeKey = mkPreludeMiscIdUnique 473 - --- data RuleBndr = ... -ruleVarIdKey, typedRuleVarIdKey :: Unique -ruleVarIdKey = mkPreludeMiscIdUnique 480 -typedRuleVarIdKey = mkPreludeMiscIdUnique 481 - --- data AnnTarget = ... -valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique -valueAnnotationIdKey = mkPreludeMiscIdUnique 490 -typeAnnotationIdKey = mkPreludeMiscIdUnique 491 -moduleAnnotationIdKey = mkPreludeMiscIdUnique 492 - --- type DerivPred = ... -derivClauseIdKey :: Unique -derivClauseIdKey = mkPreludeMiscIdUnique 493 - --- data DerivStrategy = ... -stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey, - viaStrategyIdKey :: Unique -stockStrategyIdKey = mkPreludeDataConUnique 494 -anyclassStrategyIdKey = mkPreludeDataConUnique 495 -newtypeStrategyIdKey = mkPreludeDataConUnique 496 -viaStrategyIdKey = mkPreludeDataConUnique 497 - -{- -************************************************************************ -* * - RdrNames -* * -************************************************************************ --} - -lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName -lift_RDR = nameRdrName liftName -liftTyped_RDR = nameRdrName liftTypedName -mkNameG_dRDR = nameRdrName mkNameG_dName -mkNameG_vRDR = nameRdrName mkNameG_vName - --- data Exp = ... -conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName -conE_RDR = nameRdrName conEName -litE_RDR = nameRdrName litEName -appE_RDR = nameRdrName appEName -infixApp_RDR = nameRdrName infixAppName - --- data Lit = ... -stringL_RDR, intPrimL_RDR, wordPrimL_RDR, floatPrimL_RDR, - doublePrimL_RDR, stringPrimL_RDR, charPrimL_RDR :: RdrName -stringL_RDR = nameRdrName stringLName -intPrimL_RDR = nameRdrName intPrimLName -wordPrimL_RDR = nameRdrName wordPrimLName -floatPrimL_RDR = nameRdrName floatPrimLName -doublePrimL_RDR = nameRdrName doublePrimLName -stringPrimL_RDR = nameRdrName stringPrimLName -charPrimL_RDR = nameRdrName charPrimLName diff --git a/compiler/typecheck/ClsInst.hs b/compiler/typecheck/ClsInst.hs deleted file mode 100644 --- a/compiler/typecheck/ClsInst.hs +++ /dev/null @@ -1,714 +0,0 @@ -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module ClsInst ( - matchGlobalInst, - ClsInstResult(..), - InstanceWhat(..), safeOverlap, instanceReturnsDictCon, - AssocInstInfo(..), isNotAssociated - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcEnv -import TcRnMonad -import TcType -import TcTypeable -import TcMType -import TcEvidence -import GHC.Core.Predicate -import GHC.Rename.Env( addUsedGRE ) -import GHC.Types.Name.Reader( lookupGRE_FieldLabel ) -import GHC.Core.InstEnv -import Inst( instDFunType ) -import FamInst( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst ) - -import TysWiredIn -import TysPrim( eqPrimTyCon, eqReprPrimTyCon ) -import PrelNames - -import GHC.Types.Id -import GHC.Core.Type -import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr ) - -import GHC.Types.Name ( Name, pprDefinedAt ) -import GHC.Types.Var.Env ( VarEnv ) -import GHC.Core.DataCon -import GHC.Core.TyCon -import GHC.Core.Class -import GHC.Driver.Session -import Outputable -import Util( splitAtList, fstOf3 ) -import Data.Maybe - -{- ******************************************************************* -* * - A helper for associated types within - class instance declarations -* * -**********************************************************************-} - --- | Extra information about the parent instance declaration, needed --- when type-checking associated types. The 'Class' is the enclosing --- class, the [TyVar] are the /scoped/ type variable of the instance decl. --- The @VarEnv Type@ maps class variables to their instance types. -data AssocInstInfo - = NotAssociated - | InClsInst { ai_class :: Class - , ai_tyvars :: [TyVar] -- ^ The /scoped/ tyvars of the instance - -- Why scoped? See bind_me in - -- TcValidity.checkConsistentFamInst - , ai_inst_env :: VarEnv Type -- ^ Maps /class/ tyvars to their instance types - -- See Note [Matching in the consistent-instantiation check] - } - -isNotAssociated :: AssocInstInfo -> Bool -isNotAssociated NotAssociated = True -isNotAssociated (InClsInst {}) = False - - -{- ******************************************************************* -* * - Class lookup -* * -**********************************************************************-} - --- | Indicates if Instance met the Safe Haskell overlapping instances safety --- check. --- --- See Note [Safe Haskell Overlapping Instances] in TcSimplify --- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify -type SafeOverlapping = Bool - -data ClsInstResult - = NoInstance -- Definitely no instance - - | OneInst { cir_new_theta :: [TcPredType] - , cir_mk_ev :: [EvExpr] -> EvTerm - , cir_what :: InstanceWhat } - - | NotSure -- Multiple matches and/or one or more unifiers - -data InstanceWhat - = BuiltinInstance - | BuiltinEqInstance -- A built-in "equality instance"; see the - -- TcSMonad Note [Solved dictionaries] - | LocalInstance - | TopLevInstance { iw_dfun_id :: DFunId - , iw_safe_over :: SafeOverlapping } - -instance Outputable ClsInstResult where - ppr NoInstance = text "NoInstance" - ppr NotSure = text "NotSure" - ppr (OneInst { cir_new_theta = ev - , cir_what = what }) - = text "OneInst" <+> vcat [ppr ev, ppr what] - -instance Outputable InstanceWhat where - ppr BuiltinInstance = text "a built-in 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 - -instanceReturnsDictCon :: InstanceWhat -> Bool --- See Note [Solved dictionaries] in TcSMonad -instanceReturnsDictCon (TopLevInstance {}) = True -instanceReturnsDictCon BuiltinInstance = True -instanceReturnsDictCon BuiltinEqInstance = False -instanceReturnsDictCon LocalInstance = False - -matchGlobalInst :: DynFlags - -> Bool -- True <=> caller is the short-cut solver - -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcM ClsInstResult -matchGlobalInst dflags short_cut clas tys - | cls_name == knownNatClassName - = matchKnownNat dflags short_cut clas tys - | cls_name == knownSymbolClassName - = matchKnownSymbol dflags short_cut clas tys - | isCTupleClass clas = matchCTuple clas tys - | cls_name == typeableClassName = matchTypeable clas 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 - where - cls_name = className clas - - -{- ******************************************************************** -* * - Looking in the instance environment -* * -***********************************************************************-} - - -matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult -matchInstEnv dflags short_cut_solver clas tys - = do { instEnvs <- tcGetInstEnvs - ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy] - (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys - safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps) - ; traceTc "matchInstEnv" $ - vcat [ text "goal:" <+> ppr clas <+> ppr tys - , text "matches:" <+> ppr matches - , text "unify:" <+> ppr unify ] - ; case (matches, unify, safeHaskFail) of - - -- Nothing matches - ([], [], _) - -> do { traceTc "matchClass not matching" (ppr pred) - ; return NoInstance } - - -- A single match (& no safe haskell failure) - ([(ispec, inst_tys)], [], False) - | short_cut_solver -- Called from the short-cut solver - , isOverlappable ispec - -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT - -- then don't let the short-cut solver choose it, because a - -- later instance might overlap it. #14434 is an example - -- See Note [Shortcut solving: overlap] - -> do { traceTc "matchClass: ignoring overlappable" (ppr pred) - ; return NotSure } - - | otherwise - -> do { let dfun_id = instanceDFunId ispec - ; traceTc "matchClass success" $ - vcat [text "dict" <+> ppr pred, - text "witness" <+> ppr dfun_id - <+> ppr (idType dfun_id) ] - -- Record that this dfun is needed - ; match_one (null unsafeOverlaps) 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 - _ -> do { traceTc "matchClass multiple matches, deferring choice" $ - vcat [text "dict" <+> ppr pred, - text "matches" <+> ppr matches] - ; return NotSure } } - 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 - = 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 } } } - - -{- Note [Shortcut solving: overlap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - instance {-# OVERLAPPABLE #-} C a where ... -and we are typechecking - f :: C a => a -> a - f = e -- Gives rise to [W] C a - -We don't want to solve the wanted constraint with the overlappable -instance; rather we want to use the supplied (C a)! That was the whole -point of it being overlappable! #14434 wwas an example. - -Alas even if the instance has no overlap flag, thus - instance C a where ... -there is nothing to stop it being overlapped. GHC provides no way to -declare an instance as "final" so it can't be overlapped. But really -only final instances are OK for short-cut solving. Sigh. #15135 -was a puzzling example. --} - - -{- ******************************************************************** -* * - Class lookup for CTuples -* * -***********************************************************************-} - -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 }) - -- The dfun *is* the data constructor! - where - data_con = tyConSingleDataCon (classTyCon clas) - tuple_ev = evDFunApp (dataConWrapId data_con) tys - -{- ******************************************************************** -* * - Class lookup for Literals -* * -***********************************************************************-} - -{- -Note [KnownNat & KnownSymbol and EvLit] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A part of the type-level literals implementation are the classes -"KnownNat" and "KnownSymbol", which provide a "smart" constructor for -defining singleton values. Here is the key stuff from GHC.TypeLits - - class KnownNat (n :: Nat) where - natSing :: SNat n - - newtype SNat (n :: Nat) = SNat Integer - -Conceptually, this class has infinitely many instances: - - instance KnownNat 0 where natSing = SNat 0 - instance KnownNat 1 where natSing = SNat 1 - instance KnownNat 2 where natSing = SNat 2 - ... - -In practice, we solve `KnownNat` predicates in the type-checker -(see typecheck/TcInteract.hs) 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 - a newtype for the type of the method, so using a evidence amounts - to a coercion, and - 2. Newtypes use the same representation as their definition types. - -So, the evidence for `KnownNat` is just a value of the representation type, -wrapped in two newtype constructors: one to make it into a `SNat` value, -and another to make it into a `KnownNat` dictionary. - -Also note that `natSing` and `SNat` are never actually exposed from the -library---they are just an implementation detail. Instead, users see -a more convenient function, defined in terms of `natSing`: - - natVal :: KnownNat n => proxy n -> Integer - -The reason we don't use this directly in the class is that it is simpler -and more efficient to pass around an integer rather than an entire function, -especially when the `KnowNat` evidence is packaged up in an existential. - -The story for kind `Symbol` is analogous: - * class KnownSymbol - * newtype SSymbol - * Evidence: a Core literal (e.g. mkNaturalExpr) - - -Note [Fabricating Evidence for Literals in Backpack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Let `T` be a type of kind `Nat`. When solving for a purported instance -of `KnownNat T`, ghc tries to resolve the type `T` to an integer `n`, -in which case the evidence `EvLit (EvNum n)` is generated on the -fly. It might appear that this is sufficient as users cannot define -their own instances of `KnownNat`. However, for backpack module this -would not work (see issue #15379). Consider the signature `Abstract` - -> signature Abstract where -> data T :: Nat -> instance KnownNat T - -and a module `Util` that depends on it: - -> module Util where -> import Abstract -> printT :: IO () -> printT = do print $ natVal (Proxy :: Proxy T) - -Clearly, we need to "use" the dictionary associated with `KnownNat T` -in the module `Util`, but it is too early for the compiler to produce -a real dictionary as we still have not fixed what `T` is. Only when we -mixin a concrete module - -> module Concrete where -> type T = 42 - -do we really get hold of the underlying integer. So the strategy that -we follow is the following - -1. If T is indeed available as a type alias for an integer constant, - generate the dictionary on the fly, failing which - -2. Look up the type class environment for the evidence. - -Finally actual code gets generate for Util only when a module like -Concrete gets "mixed-in" in place of the signature Abstract. As a -result all things, including the typeclass instances, in Concrete gets -reexported. So `KnownNat` gets resolved the normal way post-Backpack. - -A similar generation works for `KnownSymbol` as well - --} - -matchKnownNat :: DynFlags - -> Bool -- True <=> caller is the short-cut solver - -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcM ClsInstResult -matchKnownNat _ _ clas [ty] -- clas = KnownNat - | Just n <- isNumLitTy ty = do - et <- mkNaturalExpr n - makeLitDict clas ty et -matchKnownNat df sc clas tys = matchInstEnv df sc clas tys - -- See Note [Fabricating Evidence for Literals in Backpack] for why - -- this lookup into the instance environment is required. - -matchKnownSymbol :: DynFlags - -> Bool -- True <=> caller is the short-cut solver - -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcM ClsInstResult -matchKnownSymbol _ _ clas [ty] -- clas = KnownSymbol - | Just s <- isStrLitTy ty = do - et <- mkStringExprFS s - makeLitDict clas ty et -matchKnownSymbol df sc clas tys = matchInstEnv df sc clas tys - -- See Note [Fabricating Evidence for Literals in Backpack] for why - -- this lookup into the instance environment is required. - -makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult --- makeLitDict adds a coercion that will convert the literal into a dictionary --- of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit] --- in TcEvidence. The coercion happens in 2 steps: --- --- Integer -> SNat n -- representation of literal to singleton --- SNat n -> KnownNat n -- singleton to dictionary --- --- The process is mirrored for Symbols: --- String -> SSymbol n --- SSymbol n -> KnownSymbol n -makeLitDict clas ty et - | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty] - -- co_dict :: KnownNat n ~ SNat n - , [ meth ] <- classMethods clas - , Just tcRep <- tyConAppTyCon_maybe -- SNat - $ funResultTy -- SNat n - $ dropForAlls -- KnownNat n => SNat n - $ idType meth -- forall n. KnownNat n => SNat n - , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] - -- SNat n ~ Integer - , let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep)) - = return $ OneInst { cir_new_theta = [] - , cir_mk_ev = \_ -> ev_tm - , cir_what = BuiltinInstance } - - | otherwise - = pprPanic "makeLitDict" $ - text "Unexpected evidence for" <+> ppr (className clas) - $$ vcat (map (ppr . idType) (classMethods clas)) - -{- ******************************************************************** -* * - Class lookup for Typeable -* * -***********************************************************************-} - --- | Assumes that we've checked that this is the 'Typeable' class, --- and it was applied to the correct argument. -matchTypeable :: Class -> [Type] -> TcM ClsInstResult -matchTypeable clas [k,t] -- clas = Typeable - -- For the first two cases, See Note [No Typeable for polytypes or qualified types] - | isForAllTy k = return NoInstance -- Polytype - | isJust (tcSplitPredFunTy_maybe t) = return NoInstance -- Qualified type - - -- Now cases that do work - | k `eqType` typeNatKind = doTyLit knownNatClassName t - | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t - | tcIsConstraintKind t = doTyConApp clas t constraintKindTyCon [] - | Just (arg,ret) <- splitFunTy_maybe t = doFunTy clas t arg ret - | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] - , onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks - | Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt - -matchTypeable _ _ = return NoInstance - --- | Representation for a type @ty@ of the form @arg -> ret@. -doFunTy :: Class -> Type -> Type -> Type -> TcM ClsInstResult -doFunTy clas ty arg_ty ret_ty - = return $ OneInst { cir_new_theta = preds - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } - where - preds = map (mk_typeable_pred clas) [arg_ty, ret_ty] - mk_ev [arg_ev, ret_ev] = evTypeable ty $ - EvTypeableTrFun (EvExpr arg_ev) (EvExpr ret_ev) - mk_ev _ = panic "TcInteract.doFunTy" - - --- | Representation for type constructor applied to some kinds. --- 'onlyNamedBndrsApplied' has ensured that this application results in a type --- of monomorphic kind (e.g. all kind variables have been instantiated). -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 = BuiltinInstance } - | otherwise - = return NoInstance - where - mk_ev kinds = evTypeable ty $ EvTypeableTyCon tc (map EvExpr kinds) - --- | Representation for TyCon applications of a concrete kind. We just use the --- kind itself, but first we must make sure that we've instantiated all kind- --- polymorphism, but no more. -onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool -onlyNamedBndrsApplied tc ks - = all isNamedTyConBinder used_bndrs && - not (any isNamedTyConBinder leftover_bndrs) - where - bndrs = tyConBinders tc - (used_bndrs, leftover_bndrs) = splitAtList ks bndrs - -doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult --- Representation for an application of a type to a type-or-kind. --- This may happen when the type expression starts with a type variable. --- Example (ignoring kind parameter): --- Typeable (f Int Char) --> --- (Typeable (f Int), Typeable Char) --> --- (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps) --- Typeable f -doTyApp clas ty f tk - | isForAllTy (tcTypeKind 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 } - where - mk_ev [t1,t2] = evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2) - mk_ev _ = panic "doTyApp" - - --- Emit a `Typeable` constraint for the given type. -mk_typeable_pred :: Class -> Type -> PredType -mk_typeable_pred clas ty = mkClassPred clas [ tcTypeKind ty, ty ] - - -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal - -- we generate a sub-goal for the appropriate class. - -- See Note [Typeable for Nat and Symbol] -doTyLit :: Name -> Type -> TcM ClsInstResult -doTyLit kc t = do { kc_clas <- tcLookupClass kc - ; 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 }) } - -{- Note [Typeable (T a b c)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For type applications we always decompose using binary application, -via doTyApp, until we get to a *kind* instantiation. Example - Proxy :: forall k. k -> * - -To solve Typeable (Proxy (* -> *) Maybe) we - - First decompose with doTyApp, - to get (Typeable (Proxy (* -> *))) and Typeable Maybe - - Then solve (Typeable (Proxy (* -> *))) with doTyConApp - -If we attempt to short-cut by solving it all at once, via -doTyConApp - -(this note is sadly truncated FIXME) - - -Note [No Typeable for polytypes or qualified types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not support impredicative typeable, such as - Typeable (forall a. a->a) - Typeable (Eq a => a -> a) - Typeable (() => Int) - Typeable (((),()) => Int) - -See #9858. For forall's the case is clear: we simply don't have -a TypeRep for them. For qualified but not polymorphic types, like -(Eq a => a -> a), things are murkier. But: - - * We don't need a TypeRep for these things. TypeReps are for - monotypes only. - - * Perhaps we could treat `=>` as another type constructor for `Typeable` - purposes, and thus support things like `Eq Int => Int`, however, - at the current state of affairs this would be an odd exception as - no other class works with impredicative types. - For now we leave it off, until we have a better story for impredicativity. - - -Note [Typeable for Nat and Symbol] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have special Typeable instances for Nat and Symbol. Roughly we -have this instance, implemented here by doTyLit: - instance KnownNat n => Typeable (n :: Nat) where - typeRep = typeNatTypeRep @n -where - Data.Typeable.Internals.typeNatTypeRep :: KnownNat a => TypeRep a - -Ultimately typeNatTypeRep uses 'natSing' from KnownNat to get a -runtime value 'n'; it turns it into a string with 'show' and uses -that to whiz up a TypeRep TyCon for 'n', with mkTypeLitTyCon. -See #10348. - -Because of this rule it's inadvisable (see #15322) to have a constraint - f :: (Typeable (n :: Nat)) => blah -in a function signature; it gives rise to overlap problems just as -if you'd written - f :: Eq [a] => blah --} - -{- ******************************************************************** -* * - Class lookup for lifted equality -* * -***********************************************************************-} - --- See also Note [The equality types story] in TysPrim -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 }) - -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) - --- See also Note [The equality types story] in TysPrim -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) - - -{- ******************************************************************** -* * - Class lookup for overloaded record fields -* * -***********************************************************************-} - -{- -Note [HasField instances] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - data T y = MkT { foo :: [y] } - -and `foo` is in scope. Then GHC will automatically solve a constraint like - - HasField "foo" (T Int) b - -by emitting a new wanted - - T alpha -> [alpha] ~# T Int -> b - -and building a HasField dictionary out of the selector function `foo`, -appropriately cast. - -The HasField class is defined (in GHC.Records) thus: - - class HasField (x :: k) r a | x r -> a where - getField :: r -> a - -Since this is a one-method class, it is represented as a newtype. -Hence we can solve `HasField "foo" (T Int) b` by taking an expression -of type `T Int -> b` and casting it using the newtype coercion. -Note that - - foo :: forall y . T y -> [y] - -so the expression we construct is - - foo @alpha |> co - -where - - co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b - -is built from - - co1 :: (T alpha -> [alpha]) ~# (T Int -> b) - -which is the new wanted, and - - co2 :: (T Int -> b) ~# HasField "foo" (T Int) b - -which can be derived from the newtype coercion. - -If `foo` is not in scope, or has a higher-rank or existentially -quantified type, then the constraint is not solved automatically, but -may be solved by a user-supplied HasField instance. Similarly, if we -encounter a HasField constraint where the field is not a literal -string, or does not belong to the type, then we fall back on the -normal constraint solver behaviour. --} - --- See Note [HasField instances] -matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult -matchHasField dflags short_cut clas tys - = do { fam_inst_envs <- tcGetFamInstEnvs - ; rdr_env <- getGlobalRdrEnv - ; case tys of - -- We are matching HasField {k} x r a... - [_k_ty, x_ty, r_ty, a_ty] - -- x should be a literal string - | Just x <- isStrLitTy x_ty - -- r should be an applied type constructor - , Just (tc, args) <- tcSplitTyConApp_maybe r_ty - -- use representation tycon (if data family); it has the fields - , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args) - -- x should be a field of r - , Just fl <- lookupTyConFieldLabel x r_tc - -- the field selector should be in scope - , Just gre <- lookupGRE_FieldLabel rdr_env fl - - -> do { sel_id <- tcLookupId (flSelector fl) - ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id - - -- The first new wanted constraint equates the actual - -- type of the selector with the type (r -> a) within - -- the HasField x r a dictionary. The preds will - -- typically be empty, but if the datatype has a - -- "stupid theta" then we have to include it here. - ; let theta = mkPrimEqPred sel_ty (mkVisFunTy r_ty a_ty) : preds - - -- Use the equality proof to cast the selector Id to - -- type (r -> a), then use the newtype coercion to cast - -- it to a HasField dictionary. - mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co - where - co = mkTcSubCo (evTermCoercion (EvExpr ev1)) - `mkTcTransCo` mkTcSymCo co2 - mk_ev [] = panic "matchHasField.mk_ev" - - Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas) - tys - - tvs = mkTyVarTys (map snd tv_prs) - - -- The selector must not be "naughty" (i.e. the field - -- cannot have an existentially quantified type), and - -- it must not be higher-rank. - ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty - then do { addUsedGRE True gre - ; return OneInst { cir_new_theta = theta - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } } - else matchInstEnv dflags short_cut clas tys } - - _ -> matchInstEnv dflags short_cut clas tys } diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs deleted file mode 100644 --- a/compiler/typecheck/FamInst.hs +++ /dev/null @@ -1,1057 +0,0 @@ --- The @FamInst@ type: family instance heads - -{-# LANGUAGE CPP, GADTs, ViewPatterns #-} - -module FamInst ( - FamInstEnvs, tcGetFamInstEnvs, - checkFamInstConsistency, tcExtendLocalFamInstEnv, - tcLookupDataFamInst, tcLookupDataFamInst_maybe, - tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe, - newFamInst, - - -- * Injectivity - reportInjectivityErrors, reportConflictingInjectivityErrs - ) where - -import GhcPrelude - -import GHC.Driver.Types -import GHC.Core.FamInstEnv -import GHC.Core.InstEnv( roughMatchTcs ) -import GHC.Core.Coercion -import GHC.Core.Lint -import TcEvidence -import GHC.Iface.Load -import TcRnMonad -import GHC.Types.SrcLoc as SrcLoc -import GHC.Core.TyCon -import TcType -import GHC.Core.Coercion.Axiom -import GHC.Driver.Session -import GHC.Types.Module -import Outputable -import Util -import GHC.Types.Name.Reader -import GHC.Core.DataCon ( dataConName ) -import Maybes -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen ) -import TcMType -import GHC.Types.Name -import Panic -import GHC.Types.Var.Set -import FV -import Bag( Bag, unionBags, unitBag ) -import Control.Monad -import Data.List ( sortBy ) -import Data.List.NonEmpty ( NonEmpty(..) ) -import Data.Function ( on ) - -import qualified GHC.LanguageExtensions as LangExt - -#include "HsVersions.h" - -{- Note [The type family instance consistency story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -To preserve type safety we must ensure that for any given module, all -the type family instances used either in that module or in any module -it directly or indirectly imports are consistent. For example, consider - - module F where - type family F a - - module A where - import F( F ) - type instance F Int = Bool - f :: F Int -> Bool - f x = x - - module B where - import F( F ) - type instance F Int = Char - g :: Char -> F Int - g x = x - - module Bad where - import A( f ) - import B( g ) - bad :: Char -> Int - bad c = f (g c) - -Even though module Bad never mentions the type family F at all, by -combining the functions f and g that were type checked in contradictory -type family instance environments, the function bad is able to coerce -from one type to another. So when we type check Bad we must verify that -the type family instances defined in module A are consistent with those -defined in module B. - -How do we ensure that we maintain the necessary consistency? - -* Call a module which defines at least one type family instance a - "family instance module". This flag `mi_finsts` is recorded in the - interface file. - -* For every module we calculate the set of all of its direct and - indirect dependencies that are family instance modules. This list - `dep_finsts` is also recorded in the interface file so we can compute - this list for a module from the lists for its direct dependencies. - -* When type checking a module M we check consistency of all the type - family instances that are either provided by its `dep_finsts` or - defined in the module M itself. This is a pairwise check, i.e., for - every pair of instances we must check that they are consistent. - - - For family instances coming from `dep_finsts`, this is checked in - checkFamInstConsistency, called from tcRnImports. See Note - [Checking family instance consistency] for details on this check - (and in particular how we avoid having to do all these checks for - every module we compile). - - - That leaves checking the family instances defined in M itself - against instances defined in either M or its `dep_finsts`. This is - checked in `tcExtendLocalFamInstEnv'. - -There are four subtle points in this scheme which have not been -addressed yet. - -* We have checked consistency of the family instances *defined* by M - or its imports, but this is not by definition the same thing as the - family instances *used* by M or its imports. Specifically, we need to - ensure when we use a type family instance while compiling M that this - instance was really defined from either M or one of its imports, - rather than being an instance that we happened to know about from - reading an interface file in the course of compiling an unrelated - module. Otherwise, we'll end up with no record of the fact that M - depends on this family instance and type safety will be compromised. - See #13102. - -* It can also happen that M uses a function defined in another module - which is not transitively imported by M. Examples include the - desugaring of various overloaded constructs, and references inserted - by Template Haskell splices. If that function's definition makes use - of type family instances which are not checked against those visible - from M, type safety can again be compromised. See #13251. - -* When a module C imports a boot module B.hs-boot, we check that C's - type family instances are compatible with those visible from - B.hs-boot. However, C will eventually be linked against a different - module B.hs, which might define additional type family instances which - are inconsistent with C's. This can also lead to loss of type safety. - See #9562. - -* The call to checkFamConsistency for imported functions occurs very - early (in tcRnImports) and that causes problems if the imported - instances use type declared in the module being compiled. - See Note [Loading your own hi-boot file] in GHC.Iface.Load. --} - -{- -************************************************************************ -* * - 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 }) - = ASSERT2( tyCoVarsOfTypes lhs `subVarSet` tcv_set, text "lhs" <+> pp_ax ) - ASSERT2( lhs_kind `eqType` rhs_kind, text "kind" <+> pp_ax $$ ppr lhs_kind $$ ppr rhs_kind ) - -- We used to have an assertion that the tyvars of the RHS were bound - -- by tcv_set, but in error situations like F Int = a that isn't - -- true; a later check in checkValidFamInst rejects it - do { (subst, tvs') <- freshenTyVarBndrs tvs - ; (subst, cvs') <- freshenCoVarBndrsX subst cvs - ; dflags <- getDynFlags - ; let lhs' = substTys subst lhs - rhs' = substTy subst rhs - tcvs' = tvs' ++ cvs' - ; ifErrsM (return ()) $ -- Don't lint when there are errors, because - -- errors might mean TcTyCons. - -- See Note [Recover from validity error] in TcTyClsDecls - when (gopt Opt_DoCoreLinting dflags) $ - -- Check that the types involved in this instance are well formed. - -- Do /not/ expand type synonyms, for the reasons discussed in - -- Note [Linting type synonym applications]. - case lintTypes dflags tcvs' (rhs':lhs') of - Nothing -> pure () - Just fail_msg -> pprPanic "Core Lint error in newFamInst" $ - vcat [ fail_msg - , ppr fam_tc - , ppr subst - , ppr tvs' - , ppr cvs' - , ppr lhs' - , ppr 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 - lhs_kind = tcTypeKind (mkTyConApp fam_tc lhs) - rhs_kind = tcTypeKind rhs - tcv_set = mkVarSet (tvs ++ cvs) - pp_ax = pprCoAxiom axiom - CoAxBranch { cab_tvs = tvs - , cab_cvs = cvs - , cab_lhs = lhs - , cab_rhs = rhs } = coAxiomSingleBranch axiom - - -{- -************************************************************************ -* * - Optimised overlap checking for family instances -* * -************************************************************************ - -Note [Checking family instance consistency] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For any two family instance modules that we import directly or indirectly, we -check whether the instances in the two modules are consistent, *unless* we can -be certain that the instances of the two modules have already been checked for -consistency during the compilation of modules that we import. - -Why do we need to check? Consider - module X1 where module X2 where - data T1 data T2 - type instance F T1 b = Int type instance F a T2 = Char - f1 :: F T1 a -> Int f2 :: Char -> F a T2 - f1 x = x f2 x = x - -Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char. -Notice that neither instance is an orphan. - -How do we know which pairs of modules have already been checked? For each -module M we directly import, we look up the family instance modules that M -imports (directly or indirectly), say F1, ..., FN. For any two modules -among M, F1, ..., FN, we know that the family instances defined in those -two modules are consistent--because we checked that when we compiled M. - -For every other pair of family instance modules we import (directly or -indirectly), we check that they are consistent now. (So that we can be -certain that the modules in our `GHC.Driver.Types.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] -we need to ensure that every pair of transitive imports that define type family -instances is consistent. - -Let's define df(A) = transitive imports of A that define type family instances -+ A, if A defines type family instances - -Then for every direct import A, df(A) is already consistent. - -Let's name the current module M. - -We want to make sure that df(M) is consistent. -df(M) = df(D_1) U df(D_2) U ... U df(D_i) where D_1 .. D_i are direct imports. - -We perform the check iteratively, maintaining a set of consistent modules 'C' -and trying to add df(D_i) to it. - -The key part is how to ensure that the union C U df(D_i) is consistent. - -Let's consider two modules: A and B from C U df(D_i). -There are nine possible ways to choose A and B from C U df(D_i): - - | A in C only | A in C and B in df(D_i) | A in df(D_i) only --------------------------------------------------------------------------------- -B in C only | Already checked | Already checked | Needs to be checked - | when checking C | when checking C | --------------------------------------------------------------------------------- -B in C and | Already checked | Already checked | Already checked when -B in df(D_i) | when checking C | when checking C | checking df(D_i) --------------------------------------------------------------------------------- -B in df(D_i) | Needs to be | Already checked | Already checked when -only | checked | when checking df(D_i) | checking df(D_i) - -That means to ensure that C U df(D_i) is consistent we need to check every -module from C - df(D_i) against every module from df(D_i) - C and -every module from df(D_i) - C against every module from C - df(D_i). -But since the checks are symmetric it suffices to pick A from C - df(D_i) -and B from df(D_i) - C. - -In other words these are the modules we need to check: - [ (m1, m2) | m1 <- C, m1 not in df(D_i) - , m2 <- df(D_i), m2 not in C ] - -One final thing to note here is that if there's lot of overlap between -subsequent df(D_i)'s then we expect those set differences to be small. -That situation should be pretty common in practice, there's usually -a set of utility modules that every module imports directly or indirectly. - -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]. -checkFamInstConsistency :: [Module] -> TcM () -checkFamInstConsistency directlyImpMods - = do { (eps, hpt) <- getEpsAndHpt - ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) - ; let { -- Fetch the iface of a given module. Must succeed as - -- all directly imported modules must already have been loaded. - modIface mod = - case lookupIfaceByModule hpt (eps_PIT eps) mod of - Nothing -> panicDoc "FamInst.checkFamInstConsistency" - (ppr mod $$ pprHPT hpt) - Just iface -> iface - - -- Which family instance modules were checked for consistency - -- when we compiled `mod`? - -- Itself (if a family instance module) and its dep_finsts. - -- This is df(D_i) from - -- Note [Checking family instance optimization] - ; modConsistent :: Module -> [Module] - ; modConsistent mod = - if mi_finsts (mi_final_exts (modIface mod)) then mod:deps else deps - where - deps = dep_finsts . mi_deps . modIface $ mod - - ; hmiModule = mi_module . hm_iface - ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv - . md_fam_insts . hm_details - ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) - | hmi <- eltsHpt hpt] - - } - - ; checkMany hpt_fam_insts modConsistent directlyImpMods - } - where - -- See Note [Checking family instance optimization] - checkMany - :: ModuleEnv FamInstEnv -- home package family instances - -> (Module -> [Module]) -- given A, modules checked when A was checked - -> [Module] -- modules to process - -> TcM () - checkMany hpt_fam_insts modConsistent mods = go [] emptyModuleSet mods - where - go :: [Module] -- list of consistent modules - -> ModuleSet -- set of consistent modules, same elements as the - -- list above - -> [Module] -- modules to process - -> TcM () - go _ _ [] = return () - go consistent consistent_set (mod:mods) = do - sequence_ - [ check hpt_fam_insts m1 m2 - | m1 <- to_check_from_mod - -- loop over toCheckFromMod first, it's usually smaller, - -- it may even be empty - , m2 <- to_check_from_consistent - ] - go consistent' consistent_set' mods - where - mod_deps_consistent = modConsistent mod - mod_deps_consistent_set = mkModuleSet mod_deps_consistent - consistent' = to_check_from_mod ++ consistent - consistent_set' = - extendModuleSetList consistent_set to_check_from_mod - to_check_from_consistent = - filterOut (`elemModuleSet` mod_deps_consistent_set) consistent - to_check_from_mod = - filterOut (`elemModuleSet` consistent_set) mod_deps_consistent - -- Why don't we just minusModuleSet here? - -- We could, but doing so means one of two things: - -- - -- 1. When looping over the cartesian product we convert - -- a set into a non-deterministicly ordered list. Which - -- happens to be fine for interface file determinism - -- in this case, today, because the order only - -- determines the order of deferred checks. But such - -- invariants are hard to keep. - -- - -- 2. When looping over the cartesian product we convert - -- a set into a deterministically ordered list - this - -- adds some additional cost of sorting for every - -- direct import. - -- - -- That also explains why we need to keep both 'consistent' - -- and 'consistentSet'. - -- - -- See also Note [ModuleEnv performance and determinism]. - check hpt_fam_insts m1 m2 - = do { env1' <- getFamInsts hpt_fam_insts m1 - ; env2' <- getFamInsts hpt_fam_insts m2 - -- We're checking each element of env1 against env2. - -- The cost of that is dominated by the size of env1, because - -- for each instance in env1 we look it up in the type family - -- environment env2, and lookup is cheap. - -- The code below ensures that env1 is the smaller environment. - ; let sizeE1 = famInstEnvSize env1' - 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 - } - -getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv -getFamInsts hpt_fam_insts mod - | Just env <- lookupModuleEnv hpt_fam_insts mod = return env - | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod) - ; eps <- getEps - ; return (expectJust "checkFamInstConsistency" $ - lookupModuleEnv (eps_mod_fam_inst_env eps) mod) } - where - doc = ppr mod <+> text "is a family-instance module" - -{- -************************************************************************ -* * - Lookup -* * -************************************************************************ - --} - --- | If @co :: T ts ~ rep_ty@ then: --- --- > instNewTyCon_maybe T ts = Just (rep_ty, co) --- --- Checks for a newtype, and for being saturated --- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion -tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion) -tcInstNewTyCon_maybe = instNewTyCon_maybe - --- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if --- there is no data family to unwrap. --- Returns a Representational coercion -tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType] - -> (TyCon, [TcType], Coercion) -tcLookupDataFamInst fam_inst_envs tc tc_args - | Just (rep_tc, rep_args, co) - <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args - = (rep_tc, rep_args, co) - | otherwise - = (tc, tc_args, mkRepReflCo (mkTyConApp tc tc_args)) - -tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType] - -> Maybe (TyCon, [TcType], Coercion) --- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a) --- and returns a coercion between the two: co :: F [a] ~R FList a. -tcLookupDataFamInst_maybe fam_inst_envs tc tc_args - | isDataFamilyTyCon tc - , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args - , FamInstMatch { fim_instance = rep_fam@(FamInst { fi_axiom = ax - , fi_cvs = cvs }) - , fim_tys = rep_args - , fim_cos = rep_cos } <- match - , let rep_tc = dataFamInstRepTyCon rep_fam - co = mkUnbranchedAxInstCo Representational ax rep_args - (mkCoVarCos cvs) - = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in GHC.Core.FamInstEnv - Just (rep_tc, rep_args, co) - - | otherwise - = Nothing - --- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes, --- potentially looking through newtype /instances/. --- --- It is only used by the type inference engine (specifically, when --- solving representational equality), and hence it is careful to unwrap --- only if the relevant data constructor is in scope. That's why --- it get a GlobalRdrEnv argument. --- --- It is careful not to unwrap data/newtype instances if it can't --- continue unwrapping. Such care is necessary for proper error --- messages. --- --- It does not look through type families. --- It does not normalise arguments to a tycon. --- --- If the result is Just (rep_ty, (co, gres), rep_ty), then --- co : ty ~R rep_ty --- gres are the GREs for the data constructors that --- had to be in scope -tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs - -> GlobalRdrEnv - -> Type - -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type) -tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty --- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe - = topNormaliseTypeX stepper plus ty - where - plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion) - -> (Bag GlobalRdrElt, TcCoercion) - plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2 - , co1 `mkTransCo` co2 ) - - stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion) - stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance - - -- For newtype instances we take a double step or nothing, so that - -- we don't return the representation type of the newtype instance, - -- which would lead to terrible error messages - unwrap_newtype_instance rec_nts tc tys - | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys - = mapStepResult (\(gres, co1) -> (gres, co `mkTransCo` co1)) $ - unwrap_newtype rec_nts tc' tys' - | otherwise = NS_Done - - unwrap_newtype rec_nts tc tys - | Just con <- newTyConDataCon_maybe tc - , Just gre <- lookupGRE_Name rdr_env (dataConName con) - -- This is where we check that the - -- data constructor is in scope - = mapStepResult (\co -> (unitBag gre, co)) $ - unwrapNewTypeStepper rec_nts tc tys - - | otherwise - = NS_Done - -{- -************************************************************************ -* * - Extending the family instance environment -* * -************************************************************************ --} - --- Add new locally-defined family instances, checking consistency with --- previous locally-defined family instances as well as all instances --- available from imported modules. This requires loading all of our --- imports that define family instances (if we haven't loaded them already). -tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a - --- If we weren't actually given any instances to add, then we don't want --- to go to the bother of loading family instance module dependencies. -tcExtendLocalFamInstEnv [] thing_inside = thing_inside - --- Otherwise proceed... -tcExtendLocalFamInstEnv fam_insts thing_inside - = do { -- Load family-instance modules "below" this module, so that - -- allLocalFamInst can check for consistency with them - -- See Note [The type family instance consistency story] - loadDependentFamInstModules fam_insts - - -- Now add the instances one by one - ; env <- getGblEnv - ; (inst_env', fam_insts') <- foldlM addLocalFamInst - (tcg_fam_inst_env env, tcg_fam_insts env) - fam_insts - - ; let env' = env { tcg_fam_insts = fam_insts' - , tcg_fam_inst_env = inst_env' } - ; setGblEnv env' thing_inside - } - -loadDependentFamInstModules :: [FamInst] -> TcM () --- Load family-instance modules "below" this module, so that --- allLocalFamInst can check for consistency with them --- See Note [The type family instance consistency story] -loadDependentFamInstModules fam_insts - = do { env <- getGblEnv - ; let this_mod = tcg_mod env - imports = tcg_imports env - - want_module mod -- See Note [Home package family instances] - | mod == this_mod = False - | home_fams_only = moduleUnitId mod == moduleUnitId this_mod - | otherwise = True - home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts - - ; loadModuleInterfaces (text "Loading family-instance modules") $ - filter want_module (imp_finsts imports) } - -{- Note [Home package family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Optimization: If we're only defining type family instances -for type families *defined in the home package*, then we -only have to load interface files that belong to the home -package. The reason is that there's no recursion between -packages, so modules in other packages can't possibly define -instances for our type families. - -(Within the home package, we could import a module M that -imports us via an hs-boot file, and thereby defines an -instance of a type family defined in this module. So we can't -apply the same logic to avoid reading any interface files at -all, when we define an instances for type family defined in -the current module. --} - --- Check that the proposed new instance is OK, --- and then add it to the home inst env --- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match] --- in GHC.Core.FamInstEnv -addLocalFamInst :: (FamInstEnv,[FamInst]) - -> FamInst - -> TcM (FamInstEnv, [FamInst]) -addLocalFamInst (home_fie, my_fis) fam_inst - -- home_fie includes home package and this module - -- my_fies is just the ones from this module - = do { traceTc "addLocalFamInst" (ppr fam_inst) - - -- Unlike the case of class instances, don't override existing - -- instances in GHCi; it's unsound. See #7102. - - ; mod <- getModule - ; traceTc "alfi" (ppr mod) - - -- Fetch imported instances, so that we report - -- overlaps correctly. - -- Really we ought to only check consistency with - -- those instances which are transitively imported - -- by the current module, rather than every instance - -- we've ever seen. Fixing this is part of #13102. - ; eps <- getEps - ; let inst_envs = (eps_fam_inst_env eps, home_fie) - home_fie' = extendFamInstEnv home_fie fam_inst - - -- Check for conflicting instance decls and injectivity violations - ; ((), no_errs) <- askNoErrs $ - do { checkForConflicts inst_envs fam_inst - ; checkForInjectivityConflicts inst_envs fam_inst - ; checkInjectiveEquation fam_inst - } - - ; if no_errs then - return (home_fie', fam_inst : my_fis) - else - return (home_fie, my_fis) } - -{- -************************************************************************ -* * - Checking an instance against conflicts with an instance env -* * -************************************************************************ - -Check whether a single family instance conflicts with those in two instance -environments (one for the EPS and one for the HPT). --} - --- | Checks to make sure no two family instances overlap. -checkForConflicts :: FamInstEnvs -> FamInst -> TcM () -checkForConflicts inst_envs fam_inst - = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst - ; traceTc "checkForConflicts" $ - vcat [ ppr (map fim_instance conflicts) - , ppr fam_inst - -- , ppr inst_envs - ] - ; reportConflictInstErr fam_inst conflicts } - -checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM () - -- see Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv, check 1B1. -checkForInjectivityConflicts instEnvs famInst - | isTypeFamilyTyCon tycon -- as opposed to data family tycon - , Injective inj <- tyConInjectivityInfo tycon - = let conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst in - reportConflictingInjectivityErrs tycon conflicts (coAxiomSingleBranch (fi_axiom famInst)) - - | otherwise - = return () - - where tycon = famInstTyCon famInst - --- | Check whether a new open type family equation can be added without --- violating injectivity annotation supplied by the user. Returns True when --- this is possible and False if adding this equation would violate injectivity --- annotation. This looks only at the one equation; it does not look for --- interaction between equations. Use checkForInjectivityConflicts for that. --- Does checks (2)-(4) of Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv. -checkInjectiveEquation :: FamInst -> TcM () -checkInjectiveEquation famInst - | isTypeFamilyTyCon tycon - -- type family is injective in at least one argument - , Injective inj <- tyConInjectivityInfo tycon = do - { dflags <- getDynFlags - ; let axiom = coAxiomSingleBranch fi_ax - -- see Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv - ; reportInjectivityErrors dflags fi_ax axiom inj - } - - -- if there was no injectivity annotation or tycon does not represent a - -- type family we report no conflicts - | otherwise - = return () - - where tycon = famInstTyCon famInst - fi_ax = fi_axiom famInst - --- | Report a list of injectivity errors together with their source locations. --- Looks only at one equation; does not look for conflicts *among* equations. -reportInjectivityErrors - :: DynFlags - -> CoAxiom br -- ^ Type family for which we generate errors - -> CoAxBranch -- ^ Currently checked equation (represented by axiom) - -> [Bool] -- ^ Injectivity annotation - -> TcM () -reportInjectivityErrors dflags fi_ax axiom inj - = ASSERT2( any id inj, text "No injective type variables" ) - do let lhs = coAxBranchLHS axiom - rhs = coAxBranchRHS axiom - fam_tc = coAxiomTyCon fi_ax - (unused_inj_tvs, unused_vis, undec_inst_flag) - = unusedInjTvsInRHS dflags fam_tc lhs rhs - inj_tvs_unused = not $ isEmptyVarSet unused_inj_tvs - tf_headed = isTFHeaded rhs - bare_variables = bareTvInRHSViolated lhs rhs - wrong_bare_rhs = not $ null bare_variables - - when inj_tvs_unused $ reportUnusedInjectiveVarsErr fam_tc unused_inj_tvs - unused_vis undec_inst_flag axiom - when tf_headed $ reportTfHeadedErr fam_tc axiom - when wrong_bare_rhs $ reportBareVariableInRHSErr fam_tc bare_variables axiom - --- | Is type headed by a type family application? -isTFHeaded :: Type -> Bool --- See Note [Verifying injectivity annotation], case 3. -isTFHeaded ty | Just ty' <- coreView ty - = isTFHeaded ty' -isTFHeaded ty | (TyConApp tc args) <- ty - , isTypeFamilyTyCon tc - = args `lengthIs` tyConArity tc -isTFHeaded _ = False - - --- | If a RHS is a bare type variable return a set of LHS patterns that are not --- bare type variables. -bareTvInRHSViolated :: [Type] -> Type -> [Type] --- See Note [Verifying injectivity annotation], case 2. -bareTvInRHSViolated pats rhs | isTyVarTy rhs - = filter (not . isTyVarTy) pats -bareTvInRHSViolated _ _ = [] - ------------------------------------------------------------------- --- Checking for the coverage condition for injective type families ------------------------------------------------------------------- - -{- -Note [Coverage condition for injective type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Injective Type Families paper describes how we can tell whether -or not a type family equation upholds the injectivity condition. -Briefly, consider the following: - - type family F a b = r | r -> a -- NB: b is not injective - - type instance F ty1 ty2 = ty3 - -We need to make sure that all variables mentioned in ty1 are mentioned in ty3 --- that's how we know that knowing ty3 determines ty1. But they can't be -mentioned just anywhere in ty3: they must be in *injective* positions in ty3. -For example: - - type instance F a Int = Maybe (G a) - -This is no good, if G is not injective. However, if G is indeed injective, -then this would appear to meet our needs. There is a trap here, though: while -knowing G a does indeed determine a, trying to compute a from G a might not -terminate. This is precisely the same problem that we have with functional -dependencies and their liberal coverage condition. Here is the test case: - - type family G a = r | r -> a - type instance G [a] = [G a] - [W] G alpha ~ [alpha] - -We see that the equation given applies, because G alpha equals a list. So we -learn that alpha must be [beta] for some beta. We then have - - [W] G [beta] ~ [[beta]] - -This can reduce to - - [W] [G beta] ~ [[beta]] - -which then decomposes to - - [W] G beta ~ [beta] - -right where we started. The equation G [a] = [G a] thus is dangerous: while -it does not violate the injectivity assumption, it might throw us into a loop, -with a particularly dastardly Wanted. - -We thus do what functional dependencies do: require -XUndecidableInstances to -accept this. - -Checking the coverage condition is not terribly hard, but we also want to produce -a nice error message. A nice error message has at least two properties: - -1. If any of the variables involved are invisible or are used in an invisible context, -we want to print invisible arguments (as -fprint-explicit-kinds does). - -2. If we fail to accept the equation because we're worried about non-termination, -we want to suggest UndecidableInstances. - -To gather the right information, we can talk about the *usage* of a variable. Every -variable is used either visibly or invisibly, and it is either not used at all, -in a context where acceptance requires UndecidableInstances, or in a context that -does not require UndecidableInstances. If a variable is used both visibly and -invisibly, then we want to remember the fact that it was used invisibly: printing -out invisibles will be helpful for the user to understand what is going on. -If a variable is used where we need -XUndecidableInstances and where we don't, -we can similarly just remember the latter. - -We thus define Visibility and NeedsUndecInstFlag below. These enumerations are -*ordered*, and we used their Ord instances. We then define VarUsage, which is just a pair -of a Visibility and a NeedsUndecInstFlag. (The visibility is irrelevant when a -variable is NotPresent, but this extra slack in the representation causes no -harm.) We finally define VarUsages as a mapping from variables to VarUsage. -Its Monoid instance combines two maps, using the Semigroup instance of VarUsage -to combine elements that are represented in both maps. In this way, we can -compositionally analyze types (and portions thereof). - -To do the injectivity check: - -1. We build VarUsages that represent the LHS (rather, the portion of the LHS -that is flagged as injective); each usage on the LHS is NotPresent, because we -have not yet looked at the RHS. - -2. We also build a VarUsage for the RHS, done by injTyVarUsages. - -3. We then combine these maps. Now, every variable in the injective components of the LHS -will be mapped to its correct usage (either NotPresent or perhaps needing --XUndecidableInstances in order to be seen as injective). - -4. We look up each var used in an injective argument on the LHS in -the map, making a list of tvs that should be determined by the RHS -but aren't. - -5. We then return the set of bad variables, whether any of the bad -ones were used invisibly, and whether any bad ones need -XUndecidableInstances. -If -XUndecidableInstances is enabled, than a var that needs the flag -won't be bad, so it won't appear in this list. - -6. We use all this information to produce a nice error message, (a) switching -on -fprint-explicit-kinds if appropriate and (b) telling the user about --XUndecidableInstances if appropriate. - --} - --- | Return the set of type variables that a type family equation is --- expected to be injective in but is not. Suppose we have @type family --- F a b = r | r -> a@. Then any variables that appear free in the first --- argument to F in an equation must be fixed by that equation's RHS. --- This function returns all such variables that are not indeed fixed. --- It also returns whether any of these variables appear invisibly --- and whether -XUndecidableInstances would help. --- See Note [Coverage condition for injective type families]. -unusedInjTvsInRHS :: DynFlags - -> TyCon -- type family - -> [Type] -- LHS arguments - -> Type -- the RHS - -> ( TyVarSet - , Bool -- True <=> one or more variable is used invisibly - , Bool ) -- True <=> suggest -XUndecidableInstances --- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv. --- This function implements check (4) described there, further --- described in Note [Coverage condition for injective type families]. --- In theory (and modulo the -XUndecidableInstances wrinkle), --- instead of implementing this whole check in this way, we could --- attempt to unify equation with itself. We would reject exactly the same --- equations but this method gives us more precise error messages by returning --- precise names of variables that are not mentioned in the RHS. -unusedInjTvsInRHS dflags tycon@(tyConInjectivityInfo -> Injective inj_list) lhs rhs = - -- Note [Coverage condition for injective type families], step 5 - (bad_vars, any_invisible, suggest_undec) - where - undec_inst = xopt LangExt.UndecidableInstances dflags - - inj_lhs = filterByList inj_list lhs - lhs_vars = tyCoVarsOfTypes inj_lhs - - rhs_inj_vars = fvVarSet $ injectiveVarsOfType undec_inst rhs - - bad_vars = lhs_vars `minusVarSet` rhs_inj_vars - - any_bad = not $ isEmptyVarSet bad_vars - - invis_vars = fvVarSet $ invisibleVarsOfTypes [mkTyConApp tycon lhs, rhs] - - any_invisible = any_bad && (bad_vars `intersectsVarSet` invis_vars) - suggest_undec = any_bad && - not undec_inst && - (lhs_vars `subVarSet` fvVarSet (injectiveVarsOfType True rhs)) - --- When the type family is not injective in any arguments -unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, False, False) - ---------------------------------------- --- Producing injectivity error messages ---------------------------------------- - --- | Report error message for a pair of equations violating an injectivity --- annotation. No error message if there are no branches. -reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM () -reportConflictingInjectivityErrs _ [] _ = return () -reportConflictingInjectivityErrs fam_tc (confEqn1:_) tyfamEqn - = addErrs [buildInjectivityError fam_tc herald (confEqn1 :| [tyfamEqn])] - where - herald = text "Type family equation right-hand sides overlap; this violates" $$ - text "the family's injectivity annotation:" - --- | Injectivity error herald common to all injectivity errors. -injectivityErrorHerald :: SDoc -injectivityErrorHerald = - text "Type family equation violates the family's injectivity annotation." - - --- | Report error message for equation with injective type variables unused in --- the RHS. Note [Coverage condition for injective type families], step 6 -reportUnusedInjectiveVarsErr :: TyCon - -> TyVarSet - -> Bool -- True <=> print invisible arguments - -> Bool -- True <=> suggest -XUndecidableInstances - -> CoAxBranch - -> TcM () -reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn - = let (loc, doc) = buildInjectivityError fam_tc - (injectivityErrorHerald $$ - herald $$ - text "In the type family equation:") - (tyfamEqn :| []) - in addErrAt loc (pprWithExplicitKindsWhen has_kinds doc) - where - herald = sep [ what <+> text "variable" <> - pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort) - , text "cannot be inferred from the right-hand side." ] - $$ extra - - what | has_kinds = text "Type/kind" - | otherwise = text "Type" - - extra | undec_inst = text "Using UndecidableInstances might help" - | otherwise = empty - --- | Report error message for equation that has a type family call at the top --- level of RHS -reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM () -reportTfHeadedErr fam_tc branch - = addErrs [buildInjectivityError fam_tc - (injectivityErrorHerald $$ - text "RHS of injective type family equation cannot" <+> - text "be a type family:") - (branch :| [])] - --- | Report error message for equation that has a bare type variable in the RHS --- but LHS pattern is not a bare type variable. -reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM () -reportBareVariableInRHSErr fam_tc tys branch - = addErrs [buildInjectivityError fam_tc - (injectivityErrorHerald $$ - text "RHS of injective type family equation is a bare" <+> - text "type variable" $$ - text "but these LHS type and kind patterns are not bare" <+> - text "variables:" <+> pprQuotedList tys) - (branch :| [])] - -buildInjectivityError :: TyCon -> SDoc -> NonEmpty CoAxBranch -> (SrcSpan, SDoc) -buildInjectivityError fam_tc herald (eqn1 :| rest_eqns) - = ( coAxBranchSpan eqn1 - , hang herald - 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) ) - -reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () -reportConflictInstErr _ [] - = return () -- No conflicts -reportConflictInstErr fam_inst (match1 : _) - | FamInstMatch { fim_instance = conf_inst } <- match1 - , let sorted = sortBy (SrcLoc.leftmost_smallest `on` getSpan) [fam_inst, conf_inst] - fi1 = head sorted - span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) - = setSrcSpan span $ addErr $ - hang (text "Conflicting family instance declarations:") - 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax) - | fi <- sorted - , let ax = famInstAxiom fi ]) - where - getSpan = getSrcSpan . famInstAxiom - -- The sortBy just arranges that instances are displayed in order - -- of source location, which reduced wobbling in error messages, - -- and is better for users - -tcGetFamInstEnvs :: TcM FamInstEnvs --- Gets both the external-package inst-env --- and the home-pkg inst env (includes module being compiled) -tcGetFamInstEnvs - = do { eps <- getEps; env <- getGblEnv - ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) } diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs deleted file mode 100644 --- a/compiler/typecheck/FunDeps.hs +++ /dev/null @@ -1,678 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 2000 - - -FunDeps - functional dependencies - -It's better to read it as: "if we know these, then we're going to know these" --} - -{-# LANGUAGE CPP #-} - -module FunDeps ( - FunDepEqn(..), pprEquation, - improveFromInstEnv, improveFromAnother, - checkInstCoverage, checkFunDeps, - pprFundeps - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Types.Name -import GHC.Types.Var -import GHC.Core.Class -import GHC.Core.Predicate -import GHC.Core.Type -import TcType( transSuperClasses ) -import GHC.Core.Coercion.Axiom( TypeEqn ) -import GHC.Core.Unify -import GHC.Core.InstEnv -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Ppr( pprWithExplicitKindsWhen ) -import FV -import Outputable -import ErrUtils( Validity(..), allValid ) -import GHC.Types.SrcLoc -import Util - -import Pair ( Pair(..) ) -import Data.List ( nubBy ) -import Data.Maybe -import Data.Foldable ( fold ) - -{- -************************************************************************ -* * -\subsection{Generate equations from functional dependencies} -* * -************************************************************************ - - -Each functional dependency with one variable in the RHS is responsible -for generating a single equality. For instance: - class C a b | a -> b -The constraints ([Wanted] C Int Bool) and [Wanted] C Int alpha -will generate the following FunDepEqn - FDEqn { fd_qtvs = [] - , fd_eqs = [Pair Bool alpha] - , fd_pred1 = C Int Bool - , fd_pred2 = C Int alpha - , fd_loc = ... } -However notice that a functional dependency may have more than one variable -in the RHS which will create more than one pair of types in fd_eqs. Example: - class C a b c | a -> b c - [Wanted] C Int alpha alpha - [Wanted] C Int Bool beta -Will generate: - FDEqn { fd_qtvs = [] - , fd_eqs = [Pair Bool alpha, Pair alpha beta] - , fd_pred1 = C Int Bool - , fd_pred2 = C Int alpha - , fd_loc = ... } - -INVARIANT: Corresponding types aren't already equal -That is, there exists at least one non-identity equality in FDEqs. - -Assume: - class C a b c | a -> b c - instance C Int x x -And: [Wanted] C Int Bool alpha -We will /match/ the LHS of fundep equations, producing a matching substitution -and create equations for the RHS sides. In our last example we'd have generated: - ({x}, [fd1,fd2]) -where - fd1 = FDEq 1 Bool x - fd2 = FDEq 2 alpha x -To ``execute'' the equation, make fresh type variable for each tyvar in the set, -instantiate the two types with these fresh variables, and then unify or generate -a new constraint. In the above example we would generate a new unification -variable 'beta' for x and produce the following constraints: - [Wanted] (Bool ~ beta) - [Wanted] (alpha ~ beta) - -Notice the subtle difference between the above class declaration and: - class C a b c | a -> b, a -> c -where we would generate: - ({x},[fd1]),({x},[fd2]) -This means that the template variable would be instantiated to different -unification variables when producing the FD constraints. - -Finally, the position parameters will help us rewrite the wanted constraint ``on the spot'' --} - -data FunDepEqn loc - = FDEqn { fd_qtvs :: [TyVar] -- Instantiate these type and kind vars - -- to fresh unification vars, - -- Non-empty only for FunDepEqns arising from instance decls - - , fd_eqs :: [TypeEqn] -- Make these pairs of types equal - , fd_pred1 :: PredType -- The FunDepEqn arose from - , fd_pred2 :: PredType -- combining these two constraints - , fd_loc :: loc } - -{- -Given a bunch of predicates that must hold, such as - - C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5 - -improve figures out what extra equations must hold. -For example, if we have - - class C a b | a->b where ... - -then improve will return - - [(t1,t2), (t4,t5)] - -NOTA BENE: - - * improve does not iterate. It's possible that when we make - t1=t2, for example, that will in turn trigger a new equation. - This would happen if we also had - C t1 t7, C t2 t8 - If t1=t2, we also get t7=t8. - - improve does *not* do this extra step. It relies on the caller - doing so. - - * The equations unify types that are not already equal. So there - is no effect iff the result of improve is empty --} - -instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type --- (instFD fd tvs tys) returns fd instantiated with (tvs -> tys) -instFD (ls,rs) tvs tys - = (map lookup ls, map lookup rs) - where - env = zipVarEnv tvs tys - lookup tv = lookupVarEnv_NF env tv - -zipAndComputeFDEqs :: (Type -> Type -> Bool) -- Discard this FDEq if true - -> [Type] -> [Type] - -> [TypeEqn] --- Create a list of (Type,Type) pairs from two lists of types, --- making sure that the types are not already equal -zipAndComputeFDEqs discard (ty1:tys1) (ty2:tys2) - | discard ty1 ty2 = zipAndComputeFDEqs discard tys1 tys2 - | otherwise = Pair ty1 ty2 : zipAndComputeFDEqs discard tys1 tys2 -zipAndComputeFDEqs _ _ _ = [] - --- Improve a class constraint from another class constraint --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -improveFromAnother :: loc - -> PredType -- Template item (usually given, or inert) - -> PredType -- Workitem [that can be improved] - -> [FunDepEqn loc] --- Post: FDEqs always oriented from the other to the workitem --- Equations have empty quantified variables -improveFromAnother loc pred1 pred2 - | Just (cls1, tys1) <- getClassPredTys_maybe pred1 - , Just (cls2, tys2) <- getClassPredTys_maybe pred2 - , cls1 == cls2 - = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2, fd_loc = loc } - | let (cls_tvs, cls_fds) = classTvsFds cls1 - , fd <- cls_fds - , let (ltys1, rs1) = instFD fd cls_tvs tys1 - (ltys2, rs2) = instFD fd cls_tvs tys2 - , eqTypes ltys1 ltys2 -- The LHSs match - , let eqs = zipAndComputeFDEqs eqType rs1 rs2 - , not (null eqs) ] - -improveFromAnother _ _ _ = [] - - --- Improve a class constraint from instance declarations --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -instance Outputable (FunDepEqn a) where - ppr = pprEquation - -pprEquation :: FunDepEqn a -> SDoc -pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) - = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs), - nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2 - | Pair t1 t2 <- pairs])] - -improveFromInstEnv :: InstEnvs - -> (PredType -> SrcSpan -> loc) - -> PredType - -> [FunDepEqn loc] -- Needs to be a FunDepEqn because - -- of quantified variables --- Post: Equations oriented from the template (matching instance) to the workitem! -improveFromInstEnv inst_env mk_loc pred - | Just (cls, tys) <- ASSERT2( isClassPred pred, ppr pred ) - getClassPredTys_maybe pred - , let (cls_tvs, cls_fds) = classTvsFds cls - instances = classInstances inst_env cls - rough_tcs = roughMatchTcs tys - = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs - , fd_pred1 = p_inst, fd_pred2 = pred - , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) } - | fd <- cls_fds -- Iterate through the fundeps first, - -- because there often are none! - , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs - -- Trim the rough_tcs based on the head of the fundep. - -- Remember that instanceCantMatch treats both arguments - -- symmetrically, so it's ok to trim the rough_tcs, - -- rather than trimming each inst_tcs in turn - , ispec <- instances - , (meta_tvs, eqs) <- improveClsFD cls_tvs fd ispec - tys trimmed_tcs -- NB: orientation - , let p_inst = mkClassPred cls (is_tys ispec) - ] -improveFromInstEnv _ _ _ = [] - - -improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class - -> ClsInst -- An instance template - -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate - -> [([TyCoVar], [TypeEqn])] -- Empty or singleton - -improveClsFD clas_tvs fd - (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst }) - tys_actual rough_tcs_actual - --- Compare instance {a,b} C sx sp sy sq --- with wanted [W] C tx tp ty tq --- for fundep (x,y -> p,q) from class (C x p y q) --- If (sx,sy) unifies with (tx,ty), take the subst S - --- 'qtvs' are the quantified type variables, the ones which can be instantiated --- to make the types match. For example, given --- class C a b | a->b where ... --- instance C (Maybe x) (Tree x) where .. --- --- and a wanted constraint of form (C (Maybe t1) t2), --- then we will call checkClsFD with --- --- is_qtvs = {x}, is_tys = [Maybe x, Tree x] --- tys_actual = [Maybe t1, t2] --- --- We can instantiate x to t1, and then we want to force --- (Tree x) [t1/x] ~ t2 - - | instanceCantMatch rough_tcs_inst rough_tcs_actual - = [] -- Filter out ones that can't possibly match, - - | otherwise - = ASSERT2( equalLength tys_inst tys_actual && - equalLength tys_inst clas_tvs - , ppr tys_inst <+> ppr tys_actual ) - - case tcMatchTyKis ltys1 ltys2 of - Nothing -> [] - Just subst | isJust (tcMatchTyKisX subst rtys1 rtys2) - -- Don't include any equations that already hold. - -- Reason: then we know if any actual improvement has happened, - -- in which case we need to iterate the solver - -- In making this check we must taking account of the fact that any - -- qtvs that aren't already instantiated can be instantiated to anything - -- at all - -- NB: We can't do this 'is-useful-equation' check element-wise - -- because of: - -- class C a b c | a -> b c - -- instance C Int x x - -- [Wanted] C Int alpha Int - -- We would get that x -> alpha (isJust) and x -> Int (isJust) - -- so we would produce no FDs, which is clearly wrong. - -> [] - - | null fdeqs - -> [] - - | otherwise - -> -- pprTrace "iproveClsFD" (vcat - -- [ text "is_tvs =" <+> ppr qtvs - -- , text "tys_inst =" <+> ppr tys_inst - -- , text "tys_actual =" <+> ppr tys_actual - -- , text "ltys1 =" <+> ppr ltys1 - -- , text "ltys2 =" <+> ppr ltys2 - -- , text "subst =" <+> ppr subst ]) $ - [(meta_tvs, fdeqs)] - -- We could avoid this substTy stuff by producing the eqn - -- (qtvs, ls1++rs1, ls2++rs2) - -- which will re-do the ls1/ls2 unification when the equation is - -- executed. What we're doing instead is recording the partial - -- work of the ls1/ls2 unification leaving a smaller unification problem - where - rtys1' = map (substTyUnchecked subst) rtys1 - - fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2 - -- Don't discard anything! - -- We could discard equal types but it's an overkill to call - -- eqType again, since we know for sure that /at least one/ - -- equation in there is useful) - - meta_tvs = [ setVarType tv (substTyUnchecked subst (varType tv)) - | tv <- qtvs, tv `notElemTCvSubst` subst ] - -- meta_tvs are the quantified type variables - -- that have not been substituted out - -- - -- Eg. class C a b | a -> b - -- instance C Int [y] - -- Given constraint C Int z - -- we generate the equation - -- ({y}, [y], z) - -- - -- But note (a) we get them from the dfun_id, so they are *in order* - -- because the kind variables may be mentioned in the - -- type variables' kinds - -- (b) we must apply 'subst' to the kinds, in case we have - -- matched out a kind variable, but not a type variable - -- whose kind mentions that kind variable! - -- #6015, #6068 - where - (ltys1, rtys1) = instFD fd clas_tvs tys_inst - (ltys2, rtys2) = instFD fd clas_tvs tys_actual - -{- -%************************************************************************ -%* * - The Coverage condition for instance declarations -* * -************************************************************************ - -Note [Coverage condition] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Example - class C a b | a -> b - instance theta => C t1 t2 - -For the coverage condition, we check - (normal) fv(t2) `subset` fv(t1) - (liberal) fv(t2) `subset` oclose(fv(t1), theta) - -The liberal version ensures the self-consistency of the instance, but -it does not guarantee termination. Example: - - class Mul a b c | a b -> c where - (.*.) :: a -> b -> c - - instance Mul Int Int Int where (.*.) = (*) - instance Mul Int Float Float where x .*. y = fromIntegral x * y - instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v - -In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]). -But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) ) - -But it is a mistake to accept the instance because then this defn: - f = \ b x y -> if b then x .*. [y] else y -makes instance inference go into a loop, because it requires the constraint - Mul a [b] b --} - -checkInstCoverage :: Bool -- Be liberal - -> Class -> [PredType] -> [Type] - -> Validity --- "be_liberal" flag says whether to use "liberal" coverage of --- See Note [Coverage Condition] below --- --- Return values --- Nothing => no problems --- Just msg => coverage problem described by msg - -checkInstCoverage be_liberal clas theta inst_taus - = allValid (map fundep_ok fds) - where - (tyvars, fds) = classTvsFds clas - fundep_ok fd - | and (isEmptyVarSet <$> undetermined_tvs) = IsValid - | otherwise = NotValid msg - where - (ls,rs) = instFD fd tyvars inst_taus - ls_tvs = tyCoVarsOfTypes ls - rs_tvs = splitVisVarsOfTypes rs - - undetermined_tvs | be_liberal = liberal_undet_tvs - | otherwise = conserv_undet_tvs - - closed_ls_tvs = oclose theta ls_tvs - liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs - conserv_undet_tvs = (`minusVarSet` ls_tvs) <$> rs_tvs - - undet_set = fold undetermined_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 "oclose" <+> ppr (oclose 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] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a fundep (a::k) -> b -Then if 'a' is instantiated to (x y), where x:k2->*, y:k2, -then fixing x really fixes k2 as well, and so k2 should be added to -the lhs tyvars in the fundep check. - -Example (#8391), using liberal coverage - data Foo a = ... -- Foo :: forall k. k -> * - class Bar a b | a -> b - instance Bar a (Foo a) - - In the instance decl, (a:k) does fix (Foo k a), but only if we notice - that (a:k) fixes k. #10109 is another example. - -Here is a more subtle example, from HList-0.4.0.0 (#10564) - - class HasFieldM (l :: k) r (v :: Maybe *) - | l r -> v where ... - class HasFieldM1 (b :: Maybe [*]) (l :: k) r v - | b l r -> v where ... - class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) - | e1 l -> r - - data Label :: k -> * - type family LabelsOf (a :: [*]) :: * - - instance (HMemberM (Label {k} (l::k)) (LabelsOf xs) b, - HasFieldM1 b l (r xs) v) - => HasFieldM l (r xs) v where - -Is the instance OK? Does {l,r,xs} determine v? Well: - - * From the instance constraint HMemberM (Label k l) (LabelsOf xs) b, - plus the fundep "| el l -> r" in class HMameberM, - we get {l,k,xs} -> b - - * Note the 'k'!! We must call closeOverKinds on the seed set - ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b - fundep won't fire. This was the reason for #10564. - - * So starting from seeds {l,r,xs,k} we do oclose to get - first {l,r,xs,k,b}, via the HMemberM constraint, and then - {l,r,xs,k,b,v}, via the HasFieldM1 constraint. - - * And that fixes v. - -However, we must closeOverKinds whenever augmenting the seed set -in oclose! Consider #10109: - - data Succ a -- Succ :: forall k. k -> * - class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab - instance (Add a b ab) => Add (Succ {k1} (a :: k1)) - b - (Succ {k3} (ab :: k3}) - -We start with seed set {a:k1,b:k2} and closeOverKinds to {a,k1,b,k2}. -Now use the fundep to extend to {a,k1,b,k2,ab}. But we need to -closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all -the variables free in (Succ {k3} ab). - -Bottom line: - * closeOverKinds on initial seeds (done automatically - by tyCoVarsOfTypes in checkInstCoverage) - * and closeOverKinds whenever extending those seeds (in oclose) - -Note [The liberal coverage condition] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(oclose preds tvs) closes the set of type variables tvs, -wrt functional dependencies in preds. The result is a superset -of the argument set. For example, if we have - class C a b | a->b where ... -then - oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z} -because if we know x and y then that fixes z. - -We also use equality predicates in the predicates; if we have an -assumption `t1 ~ t2`, then we use the fact that if we know `t1` we -also know `t2` and the other way. - eg oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x} - -oclose is used (only) when checking the coverage condition for -an instance declaration - -Note [Equality superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - class (a ~ [b]) => C a b - -Remember from Note [The equality types story] in TysPrim, that - * (a ~~ b) is a superclass of (a ~ b) - * (a ~# b) is a superclass of (a ~~ b) - -So when oclose expands superclasses we'll get a (a ~# [b]) superclass. -But that's an EqPred not a ClassPred, and we jolly well do want to -account for the mutual functional dependencies implied by (t1 ~# t2). -Hence the EqPred handling in oclose. See #10778. - -Note [Care with type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#12803) - class C x y | x -> y - type family F a b - type family G c d = r | r -> d - -Now consider - oclose (C (F a b) (G c d)) {a,b} - -Knowing {a,b} fixes (F a b) regardless of the injectivity of F. -But knowing (G c d) fixes only {d}, because G is only injective -in its second parameter. - -Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds. --} - -oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet --- See Note [The liberal coverage condition] -oclose preds fixed_tvs - | null tv_fds = fixed_tvs -- Fast escape hatch for common case. - | otherwise = fixVarSet extend fixed_tvs - where - extend fixed_tvs = foldl' add fixed_tvs tv_fds - where - add fixed_tvs (ls,rs) - | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs - | otherwise = fixed_tvs - -- closeOverKinds: see Note [Closing over kinds in coverage] - - tv_fds :: [(TyCoVarSet,TyCoVarSet)] - tv_fds = [ (tyCoVarsOfTypes ls, fvVarSet $ injectiveVarsOfTypes True rs) - -- See Note [Care with type functions] - | pred <- preds - , pred' <- pred : transSuperClasses pred - -- Look for fundeps in superclasses too - , (ls, rs) <- determined pred' ] - - determined :: PredType -> [([Type],[Type])] - determined pred - = case classifyPredType pred of - EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])] - -- See Note [Equality superclasses] - ClassPred cls tys -> [ instFD fd cls_tvs tys - | let (cls_tvs, cls_fds) = classTvsFds cls - , fd <- cls_fds ] - _ -> [] - - -{- ********************************************************************* -* * - Check that a new instance decl is OK wrt fundeps -* * -************************************************************************ - -Here is the bad case: - class C a b | a->b where ... - instance C Int Bool where ... - instance C Int Char where ... - -The point is that a->b, so Int in the first parameter must uniquely -determine the second. In general, given the same class decl, and given - - instance C s1 s2 where ... - instance C t1 t2 where ... - -Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2). - -Matters are a little more complicated if there are free variables in -the s2/t2. - - class D a b c | a -> b - instance D a b => D [(a,a)] [b] Int - instance D a b => D [a] [b] Bool - -The instance decls don't overlap, because the third parameter keeps -them separate. But we want to make sure that given any constraint - D s1 s2 s3 -if s1 matches - -Note [Bogus consistency check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In checkFunDeps we check that a new ClsInst is consistent with all the -ClsInsts in the environment. - -The bogus aspect is discussed in #10675. Currently it if the two -types are *contradicatory*, using (isNothing . tcUnifyTys). But all -the papers say we should check if the two types are *equal* thus - not (substTys subst rtys1 `eqTypes` substTys subst rtys2) -For now I'm leaving the bogus form because that's the way it has -been for years. --} - -checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst] --- The Consistency Check. --- Check whether adding DFunId would break functional-dependency constraints --- Used only for instance decls defined in the module being compiled --- Returns a list of the ClsInst in InstEnvs that are inconsistent --- with the proposed new ClsInst -checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls - , is_tys = tys1, is_tcs = rough_tcs1 }) - | null fds - = [] - | otherwise - = nubBy eq_inst $ - [ ispec | ispec <- cls_insts - , fd <- fds - , is_inconsistent fd ispec ] - where - cls_insts = classInstances inst_envs cls - (cls_tvs, fds) = classTvsFds cls - qtv_set1 = mkVarSet qtvs1 - - is_inconsistent fd (ClsInst { is_tvs = qtvs2, is_tys = tys2, is_tcs = rough_tcs2 }) - | instanceCantMatch trimmed_tcs rough_tcs2 - = False - | otherwise - = case tcUnifyTyKis bind_fn ltys1 ltys2 of - Nothing -> False - Just subst - -> isNothing $ -- Bogus legacy test (#10675) - -- See Note [Bogus consistency check] - tcUnifyTyKis bind_fn (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2) - - where - trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs1 - (ltys1, rtys1) = instFD fd cls_tvs tys1 - (ltys2, rtys2) = instFD fd cls_tvs tys2 - qtv_set2 = mkVarSet qtvs2 - bind_fn tv | tv `elemVarSet` qtv_set1 = BindMe - | tv `elemVarSet` qtv_set2 = BindMe - | otherwise = Skolem - - eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2 - -- A single instance may appear twice in the un-nubbed conflict list - -- because it may conflict with more than one fundep. E.g. - -- class C a b c | a -> b, a -> c - -- instance C Int Bool Bool - -- instance C Int Char Char - -- The second instance conflicts with the first by *both* fundeps - -trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name] --- Computing rough_tcs for a particular fundep --- class C a b c | a -> b where ... --- For each instance .... => C ta tb tc --- we want to match only on the type ta; so our --- rough-match thing must similarly be filtered. --- Hence, we Nothing-ise the tb and tc types right here --- --- Result list is same length as input list, just with more Nothings -trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs - = zipWith select clas_tvs mb_tcs - where - select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc - | otherwise = Nothing diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs deleted file mode 100644 --- a/compiler/typecheck/Inst.hs +++ /dev/null @@ -1,853 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -The @Inst@ type: dictionaries or method instances --} - -{-# LANGUAGE CPP, MultiWayIf, TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module Inst ( - deeplySkolemise, - topInstantiate, topInstantiateInferred, deeplyInstantiate, - instCall, instDFunType, instStupidTheta, instTyVarsWith, - newWanted, newWanteds, - - tcInstInvisibleTyBinders, tcInstInvisibleTyBinder, - - newOverloadedLit, mkOverLit, - - newClsInst, - tcGetInsts, tcGetInstEnvs, getOverlapFlag, - tcExtendLocalInstEnv, - instCallConstraints, newMethodFromName, - tcSyntaxName, - - -- Simple functions over evidence variables - tyCoVarsOfWC, - tyCoVarsOfCt, tyCoVarsOfCts, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp ) -import {-# SOURCE #-} TcUnify( unifyType, unifyKind ) - -import GHC.Types.Basic ( IntegralLit(..), SourceText(..) ) -import FastString -import GHC.Hs -import TcHsSyn -import TcRnMonad -import Constraint -import GHC.Core.Predicate -import TcOrigin -import TcEnv -import TcEvidence -import GHC.Core.InstEnv -import TysWiredIn ( heqDataCon, eqDataCon ) -import GHC.Core ( isOrphan ) -import FunDeps -import TcMType -import GHC.Core.Type -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr ( debugPprType ) -import TcType -import GHC.Driver.Types -import GHC.Core.Class( Class ) -import GHC.Types.Id.Make( mkDictFunId ) -import GHC.Core( Expr(..) ) -- For the Coercion constructor -import GHC.Types.Id -import GHC.Types.Name -import GHC.Types.Var ( EvVar, tyVarName, VarBndr(..) ) -import GHC.Core.DataCon -import GHC.Types.Var.Env -import PrelNames -import GHC.Types.SrcLoc as SrcLoc -import GHC.Driver.Session -import Util -import Outputable -import GHC.Types.Basic ( TypeOrKind(..) ) -import qualified GHC.LanguageExtensions as LangExt - -import Data.List ( sortBy ) -import Control.Monad( unless ) -import Data.Function ( on ) - -{- -************************************************************************ -* * - Creating and emittind constraints -* * -************************************************************************ --} - -newMethodFromName - :: CtOrigin -- ^ why do we need this? - -> Name -- ^ name of the method - -> [TcRhoType] -- ^ types with which to instantiate the class - -> TcM (HsExpr GhcTcId) --- ^ Used when 'Name' is the wired-in name for a wired-in class method, --- so the caller knows its type for sure, which should be of form --- --- > forall a. C a => --- --- 'newMethodFromName' is supposed to instantiate just the outer --- type variable and constraint - -newMethodFromName origin name ty_args - = do { id <- tcLookupId name - -- Use tcLookupId not tcLookupGlobalId; the method is almost - -- always a class op, but with -XRebindableSyntax GHC is - -- meant to find whatever thing is in scope, and that may - -- be an ordinary function. - - ; let ty = piResultTys (idType id) ty_args - (theta, _caller_knows_this) = tcSplitPhiTy ty - ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) - instCall origin ty_args theta - - ; return (mkHsWrap wrap (HsVar noExtField (noLoc id))) } - -{- -************************************************************************ -* * - Deep instantiation and skolemisation -* * -************************************************************************ - -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 --} - -deeplySkolemise :: TcSigmaType - -> TcM ( HsWrapper - , [(Name,TyVar)] -- All skolemised variables - , [EvVar] -- All "given"s - , TcRhoType ) - -deeplySkolemise ty - = go init_subst ty - where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) - - go subst ty - | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty - = do { let arg_tys' = substTys subst arg_tys - ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys' - ; (subst', tvs1) <- tcInstSkolTyVarsX 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 ( mkWpLams ids1 - <.> mkWpTyLams tvs1 - <.> mkWpLams ev_vars1 - <.> wrap - <.> mkWpEvVarApps ids1 - , tv_prs1 ++ tvs_prs2 - , ev_vars1 ++ ev_vars2 - , mkVisFunTys arg_tys' rho ) } - - | otherwise - = return (idHsWrapper, [], [], substTy subst ty) - -- substTy is a quick no-op on an empty substitution - --- | Instantiate all outer type variables --- and any context. Never looks through arrows. -topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- if topInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho (that is, wrap :: ty "->" rho) -topInstantiate = top_instantiate True - --- | Instantiate all outer 'Inferred' binders --- and any context. Never looks through arrows or specified type variables. --- Used for visible type application. -topInstantiateInferred :: CtOrigin -> TcSigmaType - -> TcM (HsWrapper, TcSigmaType) --- if topInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho -topInstantiateInferred = top_instantiate False - -top_instantiate :: Bool -- True <=> instantiate *all* variables - -- False <=> instantiate only the inferred ones - -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) -top_instantiate inst_all orig ty - | not (null binders && null theta) - = do { let (inst_bndrs, leave_bndrs) = span should_inst binders - (inst_theta, leave_theta) - | null leave_bndrs = (theta, []) - | otherwise = ([], theta) - in_scope = mkInScopeSet (tyCoVarsOfType ty) - empty_subst = mkEmptyTCvSubst in_scope - inst_tvs = binderVars inst_bndrs - ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs - ; let inst_theta' = substTheta subst inst_theta - sigma' = substTy subst (mkForAllTys leave_bndrs $ - mkPhiTy leave_theta rho) - inst_tv_tys' = mkTyVarTys inst_tvs' - - ; wrap1 <- instCall orig inst_tv_tys' inst_theta' - ; traceTc "Instantiating" - (vcat [ text "all tyvars?" <+> ppr inst_all - , text "origin" <+> pprCtOrigin orig - , text "type" <+> debugPprType ty - , text "theta" <+> ppr theta - , text "leave_bndrs" <+> ppr leave_bndrs - , text "with" <+> vcat (map debugPprType inst_tv_tys') - , text "theta:" <+> ppr inst_theta' ]) - - ; (wrap2, rho2) <- - if null leave_bndrs - - -- account for types like forall a. Num a => forall b. Ord b => ... - then top_instantiate inst_all orig sigma' - - -- but don't loop if there were any un-inst'able tyvars - else return (idHsWrapper, sigma') - - ; return (wrap2 <.> wrap1, rho2) } - - | otherwise = return (idHsWrapper, ty) - where - (binders, phi) = tcSplitForAllVarBndrs ty - (theta, rho) = tcSplitPhiTy phi - - should_inst bndr - | inst_all = True - | otherwise = binderArgFlag bndr == Inferred - -deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- Int -> forall a. a -> a ==> (\x:Int. [] x alpha) :: Int -> alpha --- In general if --- if deeplyInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho --- That is, wrap :: ty ~> rho --- --- If you don't need the HsWrapper returned from this function, consider --- using tcSplitNestedSigmaTys in TcType, which is a pure alternative that --- only computes the returned TcRhoType. - -deeplyInstantiate orig ty = - deeply_instantiate orig - (mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))) - ty - -deeply_instantiate :: CtOrigin - -> TCvSubst - -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- Internal function to deeply instantiate that builds on an existing subst. --- It extends the input substitution and applies the final substitution to --- the types on return. See #12549. - -deeply_instantiate orig subst ty - | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty - = do { (subst', tvs') <- newMetaTyVarsX subst tvs - ; let arg_tys' = substTys subst' arg_tys - theta' = substTheta subst' theta - ; ids1 <- newSysLocalIds (fsLit "di") arg_tys' - ; wrap1 <- instCall orig (mkTyVarTys tvs') theta' - ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig - , text "type" <+> ppr ty - , text "with" <+> ppr tvs' - , text "args:" <+> ppr ids1 - , text "theta:" <+> ppr theta' - , text "subst:" <+> ppr subst']) - ; (wrap2, rho2) <- deeply_instantiate orig subst' rho - ; return (mkWpLams ids1 - <.> wrap2 - <.> wrap1 - <.> mkWpEvVarApps ids1, - mkVisFunTys arg_tys' rho2) } - - | otherwise - = do { let ty' = substTy subst ty - ; traceTc "deeply_instantiate final subst" - (vcat [ text "origin:" <+> pprCtOrigin orig - , text "type:" <+> ppr ty - , text "new type:" <+> ppr ty' - , text "subst:" <+> ppr subst ]) - ; return (idHsWrapper, ty') } - - -instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst --- Use this when you want to instantiate (forall a b c. ty) with --- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might --- not yet match (perhaps because there are unsolved constraints; #14154) --- If they don't match, emit a kind-equality to promise that they will --- eventually do so, and thus make a kind-homongeneous substitution. -instTyVarsWith orig tvs tys - = go emptyTCvSubst tvs tys - where - go subst [] [] - = return subst - go subst (tv:tvs) (ty:tys) - | tv_kind `tcEqType` ty_kind - = go (extendTvSubstAndInScope subst tv ty) tvs tys - | otherwise - = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind - ; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys } - where - tv_kind = substTy subst (tyVarKind tv) - ty_kind = tcTypeKind ty - - go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys) - - -{- -************************************************************************ -* * - Instantiating a call -* * -************************************************************************ - -Note [Handling boxed equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The solver deals entirely in terms of unboxed (primitive) equality. -There should never be a boxed Wanted equality. Ever. But, what if -we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality -is boxed, so naive treatment here would emit a boxed Wanted equality. - -So we simply check for this case and make the right boxing of evidence. - --} - ----------------- -instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper --- Instantiate the constraints of a call --- (instCall o tys theta) --- (a) Makes fresh dictionaries as necessary for the constraints (theta) --- (b) Throws these dictionaries into the LIE --- (c) Returns an HsWrapper ([.] tys dicts) - -instCall orig tys theta - = do { dict_app <- instCallConstraints orig theta - ; return (dict_app <.> mkWpTyApps tys) } - ----------------- -instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper --- Instantiates the TcTheta, puts all constraints thereby generated --- into the LIE, and returns a HsWrapper to enclose the call site. - -instCallConstraints orig preds - | null preds - = return idHsWrapper - | otherwise - = do { evs <- mapM go preds - ; traceTc "instCallConstraints" (ppr evs) - ; return (mkWpEvApps evs) } - where - go :: TcPredType -> TcM EvTerm - go pred - | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1 - = do { co <- unifyType Nothing ty1 ty2 - ; return (evCoercion co) } - - -- Try short-cut #2 - | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred - , tc `hasKey` heqTyConKey - = do { co <- unifyType Nothing ty1 ty2 - ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) } - - | otherwise - = emitWanted orig pred - -instDFunType :: DFunId -> [DFunInstType] - -> TcM ( [TcType] -- instantiated argument types - , TcThetaType ) -- instantiated constraint --- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv -instDFunType dfun_id dfun_inst_tys - = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys - ; return (inst_tys, substTheta subst dfun_theta) } - where - dfun_ty = idType dfun_id - (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty)) - -- With quantified constraints, the - -- type of a dfun may not be closed - - go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType]) - go subst [] [] = return (subst, []) - go subst (tv:tvs) (Just ty : mb_tys) - = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty) - tvs - mb_tys - ; return (subst', ty : tys) } - go subst (tv:tvs) (Nothing : mb_tys) - = do { (subst', tv') <- newMetaTyVarX subst tv - ; (subst'', tys) <- go subst' tvs mb_tys - ; return (subst'', mkTyVarTy tv' : tys) } - go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys) - ----------------- -instStupidTheta :: CtOrigin -> TcThetaType -> TcM () --- Similar to instCall, but only emit the constraints in the LIE --- Used exclusively for the 'stupid theta' of a data constructor -instStupidTheta orig theta - = do { _co <- instCallConstraints orig theta -- Discard the coercion - ; return () } - - -{- ********************************************************************* -* * - Instantiating Kinds -* * -********************************************************************* -} - --- | Instantiates up to n invisible binders --- Returns the instantiating types, and body kind -tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind) - -tcInstInvisibleTyBinders 0 kind - = return ([], kind) -tcInstInvisibleTyBinders n ty - = go n empty_subst ty - where - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) - - go n subst kind - | n > 0 - , Just (bndr, body) <- tcSplitPiTy_maybe kind - , isInvisibleBinder bndr - = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr - ; (args, inner_ty) <- go (n-1) subst' body - ; return (arg:args, inner_ty) } - | otherwise - = return ([], substTy subst kind) - --- | Used only in *types* -tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType) -tcInstInvisibleTyBinder subst (Named (Bndr tv _)) - = do { (subst', tv') <- newMetaTyVarX subst tv - ; return (subst', mkTyVarTy tv') } - -tcInstInvisibleTyBinder subst (Anon af ty) - | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty) - -- Equality is the *only* constraint currently handled in types. - -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep - = ASSERT( af == InvisArg ) - do { co <- unifyKind Nothing k1 k2 - ; arg' <- mk co - ; return (subst, arg') } - - | 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 -> TcM Type - -- given a coercion proving t1 ~# t2, produce the - -- right instantiation for the TyBinder 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 (\co -> mkHEqBoxTy co k1 k2, k1, k2) - - -- Lifted homogeneous equality (~) - | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty - , tc `hasKey` eqTyConKey - = Just (\co -> mkEqBoxTy co k1 k2, k1, k2) - - | otherwise - = Nothing - --- | This takes @a ~# b@ and returns @a ~~ b@. -mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type --- monadic just for convenience with mkEqBoxTy -mkHEqBoxTy co ty1 ty2 - = return $ - mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co] - where k1 = tcTypeKind ty1 - k2 = tcTypeKind ty2 - --- | This takes @a ~# b@ and returns @a ~ b@. -mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type -mkEqBoxTy co ty1 ty2 - = return $ - mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co] - where k = tcTypeKind ty1 - -{- -************************************************************************ -* * - Literals -* * -************************************************************************ - --} - -{- -In newOverloadedLit we convert directly to an Int or Integer if we -know that's what we want. This may save some time, by not -temporarily generating overloaded literals, but it won't catch all -cases (the rest are caught in lookupInst). - --} - -newOverloadedLit :: HsOverLit GhcRn - -> ExpRhoType - -> TcM (HsOverLit GhcTcId) -newOverloadedLit - lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty - | not rebindable - -- all built-in overloaded lits are tau-types, so we can just - -- tauify the ExpType - = do { res_ty <- expTypeToType res_ty - ; dflags <- getDynFlags - ; let platform = targetPlatform dflags - ; case shortCutLit platform val res_ty of - -- Do not generate a LitInst for rebindable syntax. - -- Reason: If we do, tcSimplify will call lookupInst, which - -- will call tcSyntaxName, which does unification, - -- which tcSimplify doesn't like - Just expr -> return (lit { ol_witness = expr - , ol_ext = OverLitTc False res_ty }) - Nothing -> newNonTrivialOverloadedLit orig lit - (mkCheckExpType res_ty) } - - | otherwise - = newNonTrivialOverloadedLit orig lit res_ty - where - orig = LiteralOrigin lit -newOverloadedLit (XOverLit nec) _ = noExtCon nec - --- Does not handle things that 'shortCutLit' can handle. See also --- newOverloadedLit in TcUnify -newNonTrivialOverloadedLit :: CtOrigin - -> HsOverLit GhcRn - -> ExpRhoType - -> TcM (HsOverLit GhcTcId) -newNonTrivialOverloadedLit orig - lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name) - , ol_ext = rebindable }) res_ty - = do { hs_lit <- mkOverLit val - ; let lit_ty = hsLitType hs_lit - ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name) - [synKnownType lit_ty] res_ty $ - \_ -> return () - ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit] - ; res_ty <- readExpType res_ty - ; return (lit { ol_witness = witness - , ol_ext = OverLitTc rebindable res_ty }) } -newNonTrivialOverloadedLit _ lit _ - = pprPanic "newNonTrivialOverloadedLit" (ppr lit) - ------------- -mkOverLit ::OverLitVal -> TcM (HsLit GhcTc) -mkOverLit (HsIntegral i) - = do { integer_ty <- tcMetaTy integerTyConName - ; return (HsInteger (il_text i) - (il_value i) integer_ty) } - -mkOverLit (HsFractional r) - = do { rat_ty <- tcMetaTy rationalTyConName - ; return (HsRat noExtField r rat_ty) } - -mkOverLit (HsIsString src s) = return (HsString src s) - -{- -************************************************************************ -* * - Re-mappable syntax - - Used only for arrow syntax -- find a way to nuke this -* * -************************************************************************ - -Suppose we are doing the -XRebindableSyntax thing, and we encounter -a do-expression. We have to find (>>) in the current environment, which is -done by the rename. Then we have to check that it has the same type as -Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had -this: - - (>>) :: HB m n mn => m a -> n b -> mn b - -So the idea is to generate a local binding for (>>), thus: - - let then72 :: forall a b. m a -> m b -> m b - then72 = ...something involving the user's (>>)... - in - ...the do-expression... - -Now the do-expression can proceed using then72, which has exactly -the expected type. - -In fact tcSyntaxName just generates the RHS for then72, because we only -want an actual binding in the do-expression case. For literals, we can -just use the expression inline. --} - -tcSyntaxName :: CtOrigin - -> TcType -- ^ Type to instantiate it at - -> (Name, HsExpr GhcRn) -- ^ (Standard name, user name) - -> TcM (Name, HsExpr GhcTcId) - -- ^ (Standard name, suitable expression) --- USED ONLY FOR CmdTop (sigh) *** --- See Note [CmdSyntaxTable] in GHC.Hs.Expr - -tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm)) - | std_nm == user_nm - = do rhs <- newMethodFromName orig std_nm [ty] - return (std_nm, rhs) - -tcSyntaxName orig ty (std_nm, user_nm_expr) = do - std_id <- tcLookupId std_nm - let - -- C.f. newMethodAtLoc - ([tv], _, tau) = tcSplitSigmaTy (idType std_id) - sigma1 = substTyWith [tv] [ty] tau - -- Actually, the "tau-type" might be a sigma-type in the - -- case of locally-polymorphic methods. - - addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do - - -- Check that the user-supplied thing has the - -- same type as the standard one. - -- Tiresome jiggling because tcCheckSigma takes a located expression - span <- getSrcSpanM - expr <- tcPolyExpr (L span user_nm_expr) sigma1 - return (std_nm, unLoc expr) - -syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv - -> TcRn (TidyEnv, SDoc) -syntaxNameCtxt name orig ty tidy_env - = do { inst_loc <- getCtLocM orig (Just TypeLevel) - ; let msg = vcat [ text "When checking that" <+> quotes (ppr name) - <+> text "(needed by a syntactic construct)" - , nest 2 (text "has the required type:" - <+> ppr (tidyType tidy_env ty)) - , nest 2 (pprCtLoc inst_loc) ] - ; return (tidy_env, msg) } - -{- -************************************************************************ -* * - Instances -* * -************************************************************************ --} - -getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag --- Construct the OverlapFlag from the global module flags, --- but if the overlap_mode argument is (Just m), --- set the OverlapMode to 'm' -getOverlapFlag overlap_mode - = do { dflags <- getDynFlags - ; let overlap_ok = xopt LangExt.OverlappingInstances dflags - incoherent_ok = xopt LangExt.IncoherentInstances 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 - ; return final_oflag } - -tcGetInsts :: TcM [ClsInst] --- Gets the local class instances. -tcGetInsts = fmap tcg_insts getGblEnv - -newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType - -> Class -> [Type] -> TcM ClsInst -newClsInst overlap_mode dfun_name tvs theta clas tys - = do { (subst, tvs') <- freshenTyVarBndrs tvs - -- Be sure to freshen those type variables, - -- so they are sure not to appear in any lookup - ; let tys' = substTys subst tys - - dfun = mkDictFunId dfun_name tvs theta clas tys - -- The dfun uses the original 'tvs' because - -- (a) they don't need to be fresh - -- (b) they may be mentioned in the ib_binds field of - -- an InstInfo, and in TcEnv.pprInstInfoDetails it's - -- helpful to use the same names - - ; oflag <- getOverlapFlag overlap_mode - ; let inst = mkLocalInstance dfun oflag tvs' clas tys' - ; warnIfFlag Opt_WarnOrphans - (isOrphan (is_orphan inst)) - (instOrphWarn inst) - ; return inst } - -instOrphWarn :: ClsInst -> SDoc -instOrphWarn inst - = hang (text "Orphan instance:") 2 (pprInstanceHdr inst) - $$ text "To avoid this" - $$ nest 4 (vcat possibilities) - where - possibilities = - text "move the instance declaration to the module of the class or of the type, or" : - text "wrap the type with a newtype and declare the instance on the new type." : - [] - -tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a - -- Add new locally-defined instances -tcExtendLocalInstEnv dfuns thing_inside - = do { traceDFuns dfuns - ; env <- getGblEnv - ; (inst_env', cls_insts') <- foldlM addLocalInst - (tcg_inst_env env, tcg_insts env) - dfuns - ; let env' = env { tcg_insts = cls_insts' - , tcg_inst_env = inst_env' } - ; setGblEnv env' thing_inside } - -addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst]) --- Check that the proposed new instance is OK, --- and then add it to the home inst env --- If overwrite_inst, then we can overwrite a direct match -addLocalInst (home_ie, my_insts) ispec - = do { - -- Load imported instances, so that we report - -- duplicates correctly - - -- 'matches' are existing instance declarations that are less - -- specific than the new one - -- 'dups' are those 'matches' that are equal to the new one - ; isGHCi <- getIsGHCi - ; eps <- getEps - ; tcg_env <- getGblEnv - - -- In GHCi, we *override* any identical instances - -- that are also defined in the interactive context - -- See Note [Override identical instances in GHCi] - ; let home_ie' - | isGHCi = deleteFromInstEnv home_ie ispec - | otherwise = home_ie - - global_ie = eps_inst_env eps - inst_envs = InstEnvs { ie_global = global_ie - , ie_local = home_ie' - , ie_visible = tcVisibleOrphanMods tcg_env } - - -- Check for inconsistent functional dependencies - ; let inconsistent_ispecs = checkFunDeps inst_envs ispec - ; unless (null inconsistent_ispecs) $ - funDepErr ispec inconsistent_ispecs - - -- Check for duplicate instance decls. - ; let (_tvs, cls, tys) = instanceHead ispec - (matches, _, _) = lookupInstEnv False inst_envs cls tys - dups = filter (identicalClsInstHead ispec) (map fst matches) - ; unless (null dups) $ - dupInstErr ispec (head dups) - - ; return (extendInstEnv home_ie' ispec, ispec : my_insts) } - -{- -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 -the file (this is because the signatures go in the EPS and we -can't filter them out easily.) This is also why we cannot -place the instance in the hi file: it would show up as a duplicate, -and we don't have instance reexports anyway. - -However, you might find them useful when typechecking against -a signature: the instance is a way of indicating to GHC that -some instance exists, in case downstream code uses it. - -Implementing this is a little tricky. Consider the following -situation (sigof03): - - module A where - instance C T where ... - - module ASig where - instance C T - -When compiling ASig, A.hi is loaded, which brings its instances -into the EPS. When we process the instance declaration in ASig, -we should ignore it for the purpose of doing a duplicate check, -since it's not actually a duplicate. But don't skip the check -entirely, we still want this to fail (tcfail221): - - module ASig where - instance C T - instance C T - -Note that in some situations, the interface containing the type -class instances may not have been loaded yet at all. The usual -situation when A imports another module which provides the -instances (sigof02m): - - module A(module B) where - import B - -See also Note [Signature lazy interface loading]. We can't -rely on this, however, since sometimes we'll have spurious -type class instances in the EPS, see #9422 (sigof02dm) - -************************************************************************ -* * - Errors and tracing -* * -************************************************************************ --} - -traceDFuns :: [ClsInst] -> TcRn () -traceDFuns ispecs - = traceTc "Adding instances:" (vcat (map pp ispecs)) - where - pp ispec = hang (ppr (instanceDFunId ispec) <+> colon) - 2 (ppr ispec) - -- Print the dfun name itself too - -funDepErr :: ClsInst -> [ClsInst] -> TcRn () -funDepErr ispec ispecs - = addClsInstsErr (text "Functional dependencies conflict between instance declarations:") - (ispec : ispecs) - -dupInstErr :: ClsInst -> ClsInst -> TcRn () -dupInstErr ispec dup_ispec - = addClsInstsErr (text "Duplicate instance declarations:") - [ispec, dup_ispec] - -addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () -addClsInstsErr herald ispecs - = setSrcSpan (getSrcSpan (head sorted)) $ - addErr (hang herald 2 (pprInstances sorted)) - where - sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs - -- The sortBy just arranges that instances are displayed in order - -- of source location, which reduced wobbling in error messages, - -- and is better for users diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs deleted file mode 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ /dev/null @@ -1,71 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[TcAnnotations]{Typechecking annotations} --} - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -module TcAnnotations ( tcAnnotations, annCtxt ) where - -import GhcPrelude - -import {-# SOURCE #-} TcSplice ( runAnnotation ) -import GHC.Types.Module -import GHC.Driver.Session -import Control.Monad ( when ) - -import GHC.Hs -import GHC.Types.Name -import GHC.Types.Annotations -import TcRnMonad -import GHC.Types.SrcLoc -import Outputable -import GHC.Driver.Types - --- Some platforms don't support the interpreter, and compilation on those --- platforms shouldn't fail just due to annotations -tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation] -tcAnnotations anns = do - hsc_env <- getTopEnv - case hsc_interp hsc_env of - Just _ -> mapM tcAnnotation anns - Nothing -> warnAnns anns - -warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation] ---- No GHCI; emit a warning (not an error) and ignore. cf #4268 -warnAnns [] = return [] -warnAnns anns@(L loc _ : _) - = do { setSrcSpan loc $ addWarnTc NoReason $ - (text "Ignoring ANN annotation" <> plural anns <> comma - <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") - ; return [] } - -tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation -tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do - -- Work out what the full target of this annotation was - mod <- getModule - let target = annProvenanceToTarget mod provenance - - -- Run that annotation and construct the full Annotation data structure - setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do - -- See #10826 -- Annotations allow one to bypass Safe Haskell. - dflags <- getDynFlags - when (safeLanguageOn dflags) $ failWithTc safeHsErr - runAnnotation target expr - where - safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." - , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] -tcAnnotation (L _ (XAnnDecl nec)) = noExtCon nec - -annProvenanceToTarget :: Module -> AnnProvenance Name - -> AnnTarget Name -annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name -annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name -annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod - -annCtxt :: (OutputableBndrId p) => AnnDecl (GhcPass p) -> SDoc -annCtxt ann - = hang (text "In the annotation:") 2 (ppr ann) diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs deleted file mode 100644 --- a/compiler/typecheck/TcArrows.hs +++ /dev/null @@ -1,442 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -Typecheck arrow notation --} - -{-# LANGUAGE RankNTypes, TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcArrows ( tcProc ) where - -import GhcPrelude - -import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) - -import GHC.Hs -import TcMatches -import TcHsSyn( hsLPatType ) -import TcType -import TcMType -import TcBinds -import TcPat -import TcUnify -import TcRnMonad -import TcEnv -import TcOrigin -import TcEvidence -import GHC.Types.Id( mkLocalId ) -import Inst -import TysWiredIn -import GHC.Types.Var.Set -import TysPrim -import GHC.Types.Basic( Arity ) -import GHC.Types.SrcLoc -import Outputable -import Util - -import Control.Monad - -{- -Note [Arrow overview] -~~~~~~~~~~~~~~~~~~~~~ -Here's a summary of arrows and how they typecheck. First, here's -a cut-down syntax: - - expr ::= .... - | proc pat cmd - - cmd ::= cmd exp -- Arrow application - | \pat -> cmd -- Arrow abstraction - | (| exp cmd1 ... cmdn |) -- Arrow form, n>=0 - | ... -- If, case in the usual way - - cmd_type ::= carg_type --> type - - carg_type ::= () - | (type, carg_type) - -Note that - * The 'exp' in an arrow form can mention only - "arrow-local" variables - - * An "arrow-local" variable is bound by an enclosing - cmd binding form (eg arrow abstraction) - - * A cmd_type is here written with a funny arrow "-->", - The bit on the left is a carg_type (command argument type) - which itself is a nested tuple, finishing with () - - * The arrow-tail operator (e1 -< e2) means - (| e1 <<< arr snd |) e2 - - -************************************************************************ -* * - Proc -* * -************************************************************************ --} - -tcProc :: InPat GhcRn -> LHsCmdTop GhcRn -- proc pat -> expr - -> ExpRhoType -- Expected type of whole proc expression - -> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion) - -tcProc pat cmd exp_ty - = newArrowScope $ - do { exp_ty <- expTypeToType exp_ty -- no higher-rank stuff with arrows - ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty - ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 - ; let cmd_env = CmdEnv { cmd_arr = arr_ty } - ; (pat', cmd') <- tcPat ProcExpr pat (mkCheckExpType arg_ty) $ - tcCmdTop cmd_env cmd (unitTy, res_ty) - ; let res_co = mkTcTransCo co - (mkTcAppCo co1 (mkTcNomReflCo res_ty)) - ; return (pat', cmd', res_co) } - -{- -************************************************************************ -* * - Commands -* * -************************************************************************ --} - --- See Note [Arrow overview] -type CmdType = (CmdArgType, TcTauType) -- cmd_type -type CmdArgType = TcTauType -- carg_type, a nested tuple - -data CmdEnv - = CmdEnv { - cmd_arr :: TcType -- arrow type constructor, of kind *->*->* - } - -mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType -mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2] - ---------------------------------------- -tcCmdTop :: CmdEnv - -> LHsCmdTop GhcRn - -> CmdType - -> TcM (LHsCmdTop GhcTcId) - -tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty) - = setSrcSpan loc $ - do { cmd' <- tcCmd env cmd cmd_ty - ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names - ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') } -tcCmdTop _ (L _ (XCmdTop nec)) _ = noExtCon nec - ----------------------------------------- -tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId) - -- The main recursive function -tcCmd env (L loc cmd) res_ty - = setSrcSpan loc $ do - { cmd' <- tc_cmd env cmd res_ty - ; return (L loc cmd') } - -tc_cmd :: CmdEnv -> HsCmd GhcRn -> CmdType -> TcM (HsCmd GhcTcId) -tc_cmd env (HsCmdPar x cmd) res_ty - = do { cmd' <- tcCmd env cmd res_ty - ; return (HsCmdPar x cmd') } - -tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty - = do { (binds', body') <- tcLocalBinds binds $ - setSrcSpan body_loc $ - tc_cmd env body res_ty - ; return (HsCmdLet x (L l binds') (L body_loc body')) } - -tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) - = addErrCtxt (cmdCtxt in_cmd) $ do - (scrut', scrut_ty) <- tcInferRho scrut - matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty) - return (HsCmdCase x scrut' matches') - where - match_ctxt = MC { mc_what = CaseAlt, - mc_body = mc_body } - mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' - ; tcCmd env body (stk, res_ty') } - -tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if' - = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) - ; b1' <- tcCmd env b1 res_ty - ; b2' <- tcCmd env b2 res_ty - ; return (HsCmdIf x NoSyntaxExprTc pred' b1' b2') - } - -tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syntax for if - = do { pred_ty <- newOpenFlexiTyVarTy - -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r - -- because we're going to apply it to the environment, not - -- the return value. - ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] - ; let r_ty = mkTyVarTy r_tv - ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) - (text "Predicate type of `ifThenElse' depends on result type") - ; (pred', fun') - <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty]) - (mkCheckExpType r_ty) $ \ _ -> - tcMonoExpr pred (mkCheckExpType pred_ty) - - ; b1' <- tcCmd env b1 res_ty - ; b2' <- tcCmd env b2 res_ty - ; return (HsCmdIf x fun' pred' b1' b2') - } - -------------------------------------------- --- Arrow application --- (f -< a) or (f -<< a) --- --- D |- fun :: a t1 t2 --- D,G |- arg :: t1 --- ------------------------ --- D;G |-a fun -< arg :: stk --> t2 --- --- D,G |- fun :: a t1 t2 --- D,G |- arg :: t1 --- ------------------------ --- D;G |-a fun -<< arg :: stk --> t2 --- --- (plus -<< requires ArrowApply) - -tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { arg_ty <- newOpenFlexiTyVarTy - ; let fun_ty = mkCmdArrTy env arg_ty res_ty - ; fun' <- select_arrow_scope (tcMonoExpr fun (mkCheckExpType fun_ty)) - - ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) - - ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) } - where - -- Before type-checking f, use the environment of the enclosing - -- proc for the (-<) case. - -- Local bindings, inside the enclosing proc, are not in scope - -- inside f. In the higher-order case (-<<), they are. - -- See Note [Escaping the arrow scope] in TcRnTypes - select_arrow_scope tc = case ho_app of - HsHigherOrderApp -> tc - HsFirstOrderApp -> escapeArrowScope tc - -------------------------------------------- --- Command application --- --- D,G |- exp : t --- D;G |-a cmd : (t,stk) --> res --- ----------------------------- --- D;G |-a cmd exp : stk --> res - -tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { arg_ty <- newOpenFlexiTyVarTy - ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) - ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) - ; return (HsCmdApp x fun' arg') } - -------------------------------------------- --- Lambda --- --- D;G,x:t |-a cmd : stk --> res --- ------------------------------ --- D;G |-a (\x.cmd) : (t,stk) --> res - -tc_cmd env - (HsCmdLam x (MG { mg_alts = L l [L mtch_loc - (match@(Match { m_pats = pats, m_grhss = grhss }))], - mg_origin = origin })) - (cmd_stk, res_ty) - = addErrCtxt (pprMatchInCtxt match) $ - do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk - - -- Check the patterns, and the GRHSs inside - ; (pats', grhss') <- setSrcSpan mtch_loc $ - tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $ - tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) - - ; let match' = L mtch_loc (Match { m_ext = noExtField - , m_ctxt = LambdaExpr, m_pats = pats' - , m_grhss = grhss' }) - arg_tys = map hsLPatType pats' - cmd' = HsCmdLam x (MG { mg_alts = L l [match'] - , mg_ext = MatchGroupTc arg_tys res_ty - , mg_origin = origin }) - ; return (mkHsCmdWrap (mkWpCastN co) cmd') } - where - n_pats = length pats - match_ctxt = (LambdaExpr :: HsMatchContext GhcRn) -- Maybe KappaExpr? - pg_ctxt = PatGuard match_ctxt - - tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty - = do { (binds', grhss') <- tcLocalBinds binds $ - mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss - ; return (GRHSs x grhss' (L l binds')) } - tc_grhss (XGRHSs nec) _ _ = noExtCon nec - - tc_grhs stk_ty res_ty (GRHS x guards body) - = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ - \ res_ty -> tcCmd env body - (stk_ty, checkingExpType "tc_grhs" res_ty) - ; return (GRHS x guards' rhs') } - tc_grhs _ _ (XGRHS nec) = noExtCon nec - -------------------------------------------- --- Do notation - -tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty) - = do { co <- unifyType Nothing unitTy cmd_stk -- Expecting empty argument stack - ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty - ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) } - - ------------------------------------------------------------------ --- Arrow ``forms'' (| e c1 .. cn |) --- --- D; G |-a1 c1 : stk1 --> r1 --- ... --- D; G |-an cn : stkn --> rn --- D |- e :: forall e. a1 (e, stk1) t1 --- ... --- -> an (e, stkn) tn --- -> a (e, stk) t --- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) --- ---------------------------------------------- --- D; G |-a (| e c1 ... cn |) : stk --> t - -tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args - -- We use alphaTyVar for 'w' - ; let e_ty = mkInvForAllTy alphaTyVar $ - mkVisFunTys cmd_tys $ - mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty - ; expr' <- tcPolyExpr expr e_ty - ; return (HsCmdArrForm x expr' f fixity cmd_args') } - - where - tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType) - tc_cmd_arg cmd - = do { arr_ty <- newFlexiTyVarTy arrowTyConKind - ; stk_ty <- newFlexiTyVarTy liftedTypeKind - ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; let env' = env { cmd_arr = arr_ty } - ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) - ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } - -tc_cmd _ (XCmd nec) _ = noExtCon nec - ------------------------------------------------------------------ --- Base case for illegal commands --- This is where expressions that aren't commands get rejected - -tc_cmd _ cmd _ - = failWithTc (vcat [text "The expression", nest 2 (ppr cmd), - text "was found where an arrow command was expected"]) - - -matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType) -matchExpectedCmdArgs 0 ty - = return (mkTcNomReflCo ty, [], ty) -matchExpectedCmdArgs n ty - = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty - ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2 - ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) } - -{- -************************************************************************ -* * - Stmts -* * -************************************************************************ --} - --------------------------------- --- Mdo-notation --- The distinctive features here are --- (a) RecStmts, and --- (b) no rebindable syntax - -tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker -tcArrDoStmt env _ (LastStmt x rhs noret _) res_ty thing_inside - = do { rhs' <- tcCmd env rhs (unitTy, res_ty) - ; thing <- thing_inside (panic "tcArrDoStmt") - ; return (LastStmt x rhs' noret noSyntaxExpr, thing) } - -tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside - = do { (rhs', elt_ty) <- tc_arr_rhs env rhs - ; thing <- thing_inside res_ty - ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) } - -tcArrDoStmt env ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside - = do { (rhs', pat_ty) <- tc_arr_rhs env rhs - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - thing_inside res_ty - ; return (mkTcBindStmt pat' rhs', thing) } - -tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names - , recS_rec_ids = rec_names }) res_ty thing_inside - = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names - ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind - ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys - ; tcExtendIdEnv tup_ids $ do - { (stmts', tup_rets) - <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> - -- ToDo: res_ty not really right - zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys) - - ; thing <- thing_inside res_ty - -- NB: The rec_ids for the recursive things - -- already scope over this part. This binding may shadow - -- some of them with polymorphic things with the same Name - -- (see note [RecStmt] in GHC.Hs.Expr) - - ; let rec_ids = takeList rec_names tup_ids - ; later_ids <- tcLookupLocalIds later_names - - ; let rec_rets = takeList rec_names tup_rets - ; let ret_table = zip tup_ids tup_rets - ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j] - - ; return (emptyRecStmtId { recS_stmts = stmts' - , recS_later_ids = later_ids - , recS_rec_ids = rec_ids - , recS_ext = unitRecStmtTc - { recS_later_rets = later_rets - , recS_rec_rets = rec_rets - , recS_ret_ty = res_ty} }, thing) - }} - -tcArrDoStmt _ _ stmt _ _ - = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) - -tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType) -tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcCmd env rhs (unitTy, ty) - ; return (rhs', ty) } - -{- -************************************************************************ -* * - Helpers -* * -************************************************************************ --} - -mkPairTy :: Type -> Type -> Type -mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] - -arrowTyConKind :: Kind -- *->*->* -arrowTyConKind = mkVisFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind - -{- -************************************************************************ -* * - Errors -* * -************************************************************************ --} - -cmdCtxt :: HsCmd GhcRn -> SDoc -cmdCtxt cmd = text "In the command:" <+> ppr cmd diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs deleted file mode 100644 --- a/compiler/typecheck/TcBackpack.hs +++ /dev/null @@ -1,1010 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -module TcBackpack ( - findExtraSigImports', - findExtraSigImports, - implicitRequirements', - implicitRequirements, - checkUnitId, - tcRnCheckUnitId, - tcRnMergeSignatures, - mergeSignatures, - tcRnInstantiateSignature, - instantiateSignature, -) where - -import GhcPrelude - -import GHC.Types.Basic (defaultFixity, TypeOrKind(..)) -import GHC.Driver.Packages -import TcRnExports -import GHC.Driver.Session -import GHC.Hs -import GHC.Types.Name.Reader -import TcRnMonad -import TcTyDecls -import GHC.Core.InstEnv -import GHC.Core.FamInstEnv -import Inst -import GHC.IfaceToCore -import TcMType -import TcType -import TcSimplify -import Constraint -import TcOrigin -import GHC.Iface.Load -import GHC.Rename.Names -import ErrUtils -import GHC.Types.Id -import GHC.Types.Module -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Avail -import GHC.Types.SrcLoc -import GHC.Driver.Types -import Outputable -import GHC.Core.Type -import FastString -import GHC.Rename.Fixity ( lookupFixityRn ) -import Maybes -import TcEnv -import GHC.Types.Var -import GHC.Iface.Syntax -import PrelNames -import qualified Data.Map as Map - -import GHC.Driver.Finder -import GHC.Types.Unique.DSet -import GHC.Types.Name.Shape -import TcErrors -import TcUnify -import GHC.Iface.Rename -import Util - -import Control.Monad -import Data.List (find) - -import {-# SOURCE #-} TcRnDriver - -#include "HsVersions.h" - -fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc -fixityMisMatch real_thing real_fixity sig_fixity = - 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) - -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 - 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) - --- | Given a 'ModDetails' of an instantiated signature (note that the --- 'ModDetails' must be knot-tied consistently with the actual implementation) --- and a 'GlobalRdrEnv' constructed from the implementor of this interface, --- verify that the actual implementation actually matches the original --- interface. --- --- Note that it is already assumed that the implementation *exports* --- 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 - ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, - md_types = sig_type_env, md_exports = sig_exports } = do - traceTc "checkHsigIface" $ vcat - [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ] - mapM_ check_export (map availName sig_exports) - unless (null sig_fam_insts) $ - panic ("TcRnDriver.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 - tcg_env <- getGblEnv - setGblEnv tcg_env { tcg_inst_env = emptyInstEnv, - tcg_fam_inst_env = emptyFamInstEnv, - tcg_insts = [], - tcg_fam_insts = [] } $ do - mapM_ check_inst sig_insts - failIfErrsM - where - -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig - -- in package p that defines T; and we implement with himpl:H. Then the - -- Name is p[himpl:H]:H.T, NOT himplH:H.T. That's OK but we just - -- have to look up the right name. - sig_type_occ_env = mkOccEnv - . map (\t -> (nameOccName (getName t), t)) - $ nameEnvElts sig_type_env - dfun_names = map getName sig_insts - check_export name - -- Skip instances, we'll check them later - -- TODO: Actually this should never happen, because DFuns are - -- never exported... - | name `elem` dfun_names = return () - -- See if we can find the type directly in the hsig ModDetails - -- TODO: need to special case wired in names - | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do - -- NB: We use tcLookupImported_maybe because we want to EXCLUDE - -- tcg_env (TODO: but maybe this isn't relevant anymore). - r <- tcLookupImported_maybe name - case r of - Failed err -> addErr 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 { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) = - when (name /= name') $ do - -- See Note [Error reporting bad reexport] - -- TODO: Actually this error swizzle doesn't work - let p (L _ ie) = name `elem` ieNames ie - loc = case tcg_rn_exports tcg_env of - Just es | Just e <- find p (map fst es) - -- TODO: maybe we can be a little more - -- precise here and use the Located - -- info for the *specific* name we matched. - -> getLoc e - _ -> nameSrcSpan name - addErrAt loc - (badReexportedBootThing False name name') - -- This should actually never happen, but whatever... - | otherwise = - addErrAt (nameSrcSpan name) - (missingBootThing False name "exported by") - --- Note [Error reporting bad reexport] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- NB: You want to be a bit careful about what location you report on reexports. --- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the --- correct source location. However, if it was *reexported*, obviously the name --- is not going to have the right location. In this case, we need to grovel in --- tcg_rn_exports to figure out where the reexport came from. - - - --- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't --- assume that the implementing file actually implemented the instances (they --- may be reexported from elsewhere). Where should we look for the instances? --- We do the same as we would otherwise: consult the EPS. This isn't perfect --- (we might conclude the module exports an instance when it doesn't, see --- #9422), but we will never refuse to compile something. -check_inst :: ClsInst -> TcM () -check_inst sig_inst = do - -- TODO: This could be very well generalized to support instance - -- declarations in boot files. - tcg_env <- getGblEnv - -- 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 ty = idType (instanceDFunId sig_inst) - skol_info = InstSkol - -- Based off of tcSplitDFunTy - (tvs, theta, pred) = - case tcSplitForAllTys ty of { (tvs, rho) -> - case splitFunTys rho of { (theta, pred) -> - (tvs, theta, pred) }} - origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst - (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize - (tclvl,cts) <- pushTcLevelM $ do - wanted <- newWanted origin - (Just TypeLevel) - (substTy skol_subst pred) - givens <- forM theta $ \given -> do - loc <- getCtLocM origin (Just TypeLevel) - let given_pred = substTy skol_subst given - new_ev <- newEvVar given_pred - return CtGiven { ctev_pred = given_pred - -- Doesn't matter, make something up - , ctev_evar = new_ev - , ctev_loc = loc - } - return $ wanted : givens - unsolved <- simplifyWantedsTcM cts - - (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved - reportAllUnsolved (mkImplicWC implic) - --- | Return this list of requirement interfaces that need to be merged --- to form @mod_name@, or @[]@ if this is not a requirement. -requirementMerges :: PackageState -> ModuleName -> [IndefModule] -requirementMerges pkgstate mod_name = - fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate)) - where - -- update ComponentId cached details as they may have changed since the - -- time the ComponentId was created - fixupModule (IndefModule iud name) = IndefModule iud' name - where - iud' = iud { indefUnitIdComponentId = cid' } - cid = indefUnitIdComponentId iud - cid' = updateComponentId pkgstate cid - --- | For a module @modname@ of type 'HscSource', determine the list --- of extra "imports" of other requirements which should be considered part of --- the import of the requirement, because it transitively depends on those --- requirements by imports of modules from other packages. The situation --- is something like this: --- --- unit p where --- signature A --- signature B --- import A --- --- unit q where --- dependency p[A=,B=] --- signature A --- signature B --- --- Although q's B does not directly import A, we still have to make sure we --- process A first, because the merging process will cause B to indirectly --- import A. This function finds the TRANSITIVE closure of all such imports --- we need to make. -findExtraSigImports' :: HscEnv - -> HscSource - -> ModuleName - -> IO (UniqDSet ModuleName) -findExtraSigImports' hsc_env HsigFile modname = - fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) -> - (initIfaceLoad hsc_env - . withException - $ moduleFreeHolesPrecise (text "findExtraSigImports") - (mkModule (IndefiniteUnitId iuid) mod_name))) - where - pkgstate = pkgState (hsc_dflags hsc_env) - reqs = requirementMerges pkgstate modname - -findExtraSigImports' _ _ _ = return emptyUniqDSet - --- | 'findExtraSigImports', but in a convenient form for "GHC.Driver.Make" and --- "TcRnDriver". -findExtraSigImports :: HscEnv -> HscSource -> ModuleName - -> IO [(Maybe FastString, Located ModuleName)] -findExtraSigImports hsc_env hsc_src modname = do - extra_requirements <- findExtraSigImports' hsc_env hsc_src modname - return [ (Nothing, noLoc mod_name) - | mod_name <- uniqDSetToList extra_requirements ] - --- A version of 'implicitRequirements'' which is more friendly --- for "GHC.Driver.Make" and "TcRnDriver". -implicitRequirements :: HscEnv - -> [(Maybe FastString, Located ModuleName)] - -> IO [(Maybe FastString, Located ModuleName)] -implicitRequirements hsc_env normal_imports - = do mns <- implicitRequirements' hsc_env normal_imports - return [ (Nothing, noLoc mn) | mn <- mns ] - --- Given a list of 'import M' statements in a module, figure out --- any extra implicit requirement imports they may have. For --- example, if they 'import M' and M resolves to p[A=], then --- they actually also import the local requirement B. -implicitRequirements' :: HscEnv - -> [(Maybe FastString, Located ModuleName)] - -> IO [ModuleName] -implicitRequirements' hsc_env normal_imports - = fmap concat $ - forM normal_imports $ \(mb_pkg, L _ imp) -> do - found <- findImportedModule hsc_env imp mb_pkg - case found of - Found _ mod | thisPackage dflags /= moduleUnitId mod -> - return (uniqDSetToList (moduleFreeHoles mod)) - _ -> return [] - where dflags = hsc_dflags hsc_env - --- | Given a 'UnitId', make sure it is well typed. This is because --- unit IDs come from Cabal, which does not know if things are well-typed or --- not; a component may have been filled with implementations for the holes --- that don't actually fulfill the requirements. --- --- INVARIANT: the UnitId is NOT a InstalledUnitId -checkUnitId :: UnitId -> TcM () -checkUnitId uid = do - case splitUnitIdInsts uid of - (_, Just indef) -> - let insts = indefUnitIdInsts indef in - forM_ insts $ \(mod_name, mod) -> - -- NB: direct hole instantiations are well-typed by construction - -- (because we FORCE things to be merged in), so don't check them - when (not (isHoleModule mod)) $ do - checkUnitId (moduleUnitId mod) - _ <- mod `checkImplements` IndefModule indef mod_name - return () - _ -> return () -- if it's hashed, must be well-typed - --- | Top-level driver for signature instantiation (run when compiling --- an @hsig@ file.) -tcRnCheckUnitId :: - HscEnv -> UnitId -> - IO (Messages, Maybe ()) -tcRnCheckUnitId hsc_env uid = - withTiming dflags - (text "Check unit id" <+> ppr uid) - (const ()) $ - initTc hsc_env - HsigFile -- bogus - False - mAIN -- bogus - (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus - $ checkUnitId uid - where - dflags = hsc_dflags hsc_env - loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid) - --- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear... - --- | Top-level driver for signature merging (run after typechecking --- an @hsig@ file). -tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface - -> IO (Messages, Maybe TcGblEnv) -tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = - withTiming dflags - (text "Signature merging" <+> brackets (ppr this_mod)) - (const ()) $ - initTc hsc_env HsigFile False this_mod real_loc $ - mergeSignatures hpm orig_tcg_env iface - where - dflags = hsc_dflags hsc_env - this_mod = mi_module iface - real_loc = tcg_top_loc orig_tcg_env - -thinModIface :: [AvailInfo] -> ModIface -> ModIface -thinModIface avails iface = - iface { - mi_exports = avails, - -- mi_fixities = ..., - -- mi_warns = ..., - -- mi_anns = ..., - -- TODO: The use of nameOccName here is a bit dodgy, because - -- perhaps there might be two IfaceTopBndr that are the same - -- OccName but different Name. Requires better understanding - -- of invariants here. - mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls - -- mi_insts = ..., - -- mi_fam_insts = ..., - } - where - 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 - | a <- avails - , n <- availNames a ] - exported_decls = filter_decls exported_occs - - non_exported_occs = mkOccSet [ occName n - | (_, d) <- exported_decls - , n <- ifaceDeclNeverExportedRefs d ] - non_exported_decls = filter_decls non_exported_occs - - dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True - dfun_pred _ = False - dfun_decls = filter (dfun_pred . snd) (mi_decls iface) - --- | The list of 'Name's of *non-exported* 'IfaceDecl's which this --- 'IfaceDecl' may refer to. A non-exported 'IfaceDecl' should be kept --- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps) --- refers to it; we can't decide to keep it by looking at the exports --- of a module after thinning. Keep this synchronized with --- 'rnIfaceDecl'. -ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name] -ifaceDeclNeverExportedRefs d@IfaceFamily{} = - case ifFamFlav d of - IfaceClosedSynFamilyTyCon (Just (n, _)) - -> [n] - _ -> [] -ifaceDeclNeverExportedRefs _ = [] - - --- Note [Blank hsigs for all requirements] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- One invariant that a client of GHC must uphold is that there --- must be an hsig file for every requirement (according to --- @-this-unit-id@); this ensures that for every interface --- file (hi), there is a source file (hsig), which helps grease --- the wheels of recompilation avoidance which assumes that --- source files always exist. - -{- -inheritedSigPvpWarning :: WarningTxt -inheritedSigPvpWarning = - WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))] - where - msg = "Inherited requirements from non-signature libraries (libraries " ++ - "with modules) should not be used, as this mode of use is not " ++ - "compatible with PVP-style version bounds. Instead, copy the " ++ - "declaration to the local hsig file or move the signature to a " ++ - "library of its own and add that library as a dependency." --} - --- Note [Handling never-exported TyThings under Backpack] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will --- never be mentioned in the export list of a module (mi_avails). --- Unlike implicit TyThings (Note [Implicit TyThings]), non-exported --- TyThings DO have a standalone IfaceDecl declaration in their --- interface file. --- --- Originally, Backpack was designed under the assumption that anything --- you could declare in a module could also be exported; thus, merging --- the export lists of two signatures is just merging the declarations --- of two signatures writ small. Of course, in GHC Haskell, there are a --- few important things which are not explicitly exported but still can --- be used: in particular, dictionary functions for instances, Typeable --- TyCon bindings, and coercion axioms for type families also count. --- --- When handling these non-exported things, there two primary things --- we need to watch out for: --- --- * Signature matching/merging is done by comparing each --- of the exported entities of a signature and a module. These exported --- entities may refer to non-exported TyThings which must be tested for --- consistency. For example, an instance (ClsInst) will refer to a --- non-exported DFunId. In this case, 'checkBootDeclM' directly compares the --- embedded 'DFunId' in 'is_dfun'. --- --- For this to work at all, we must ensure that pointers in 'is_dfun' refer --- to DISTINCT 'DFunId's, even though the 'Name's (may) be the same. --- Unfortunately, this is the OPPOSITE of how we treat most other references --- to 'Name's, so this case needs to be handled specially. --- --- The details are in the documentation for 'typecheckIfacesForMerging'. --- and the Note [Resolving never-exported Names] in GHC.IfaceToCore. --- --- * When we rename modules and signatures, we use the export lists to --- decide how the declarations should be renamed. However, this --- means we don't get any guidance for how to rename non-exported --- entities. Fortunately, we only need to rename these entities --- *consistently*, so that 'typecheckIfacesForMerging' can wire them --- up as needed. --- --- The details are in Note [rnIfaceNeverExported] in 'GHC.Iface.Rename'. --- --- The root cause for all of these complications is the fact that these --- logically "implicit" entities are defined indirectly in an interface --- file. #13151 gives a proposal to make these *truly* implicit. - -merge_msg :: ModuleName -> [IndefModule] -> SDoc -merge_msg mod_name [] = - text "while checking the local signature" <+> ppr mod_name <+> - text "for consistency" -merge_msg mod_name reqs = - hang (text "while merging the signatures from" <> colon) - 2 (vcat [ bullet <+> ppr req | req <- reqs ] $$ - bullet <+> text "...and the local signature for" <+> ppr mod_name) - --- | Given a local 'ModIface', merge all inherited requirements --- 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 - (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }), - hpm_src_files = src_files }) - orig_tcg_env lcl_iface0 = setSrcSpan loc $ do - -- The lcl_iface0 is the ModIface for the local hsig - -- file, which is guaranteed to exist, see - -- Note [Blank hsigs for all requirements] - hsc_env <- getTopEnv - dflags <- getDynFlags - - -- Copy over some things from the original TcGblEnv that - -- we want to preserve - updGblEnv (\env -> env { - -- Renamed imports/declarations are often used - -- by programs that use the GHC API, e.g., Haddock. - -- These won't get filled by the merging process (since - -- we don't actually rename the parsed module again) so - -- we need to take them directly from the previous - -- typechecking. - -- - -- NB: the export declarations aren't in their final - -- form yet. We'll fill those in when we reprocess - -- the export declarations. - tcg_rn_imports = tcg_rn_imports orig_tcg_env, - tcg_rn_decls = tcg_rn_decls orig_tcg_env, - -- Annotations - tcg_ann_env = tcg_ann_env orig_tcg_env, - -- Documentation header - tcg_doc_hdr = tcg_doc_hdr orig_tcg_env - -- tcg_dus? - -- tcg_th_used = tcg_th_used orig_tcg_env, - -- tcg_th_splice_used = tcg_th_splice_used orig_tcg_env - }) $ do - tcg_env <- getGblEnv - - let outer_mod = tcg_mod tcg_env - inner_mod = tcg_semantic_mod tcg_env - mod_name = moduleName (tcg_mod tcg_env) - pkgstate = pkgState dflags - - -- STEP 1: Figure out all of the external signature interfaces - -- we are going to merge in. - let reqs = requirementMerges pkgstate mod_name - - addErrCtxt (merge_msg mod_name reqs) $ do - - -- STEP 2: Read in the RAW forms of all of these interfaces - ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) -> - let m = mkModule (IndefiniteUnitId iuid) mod_name - im = fst (splitModuleInsts m) - in fmap fst - . withException - $ findAndReadIface (text "mergeSignatures") im m False - - -- STEP 3: Get the unrenamed exports of all these interfaces, - -- thin it according to the export list, and do shaping on them. - let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as - -- This function gets run on every inherited interface, and - -- it's responsible for: - -- - -- 1. Merging the exports of the interface into @nsubst@, - -- 2. Adding these exports to the "OK to import" set (@oks@) - -- if they came from a package with no exposed modules - -- (this means we won't report a PVP error in this case), and - -- 3. Thinning the interface according to an explicit export - -- list. - -- - gen_subst (nsubst,oks,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do - let insts = indefUnitIdInsts iuid - isFromSignaturePackage = - let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid)) - pkg = getInstalledPackageDetails pkgstate inst_uid - in null (exposedModules pkg) - -- 3(a). Rename the exports according to how the dependency - -- was instantiated. The resulting export list will be accurate - -- except for exports *from the signature itself* (which may - -- be subsequently updated by exports from other signatures in - -- the merge. - as1 <- tcRnModExports insts ireq_iface - -- 3(b). Thin the interface if it comes from a signature package. - (thinned_iface, as2) <- case mb_exports of - Just (L loc _) - -- Check if the package containing this signature is - -- a signature package (i.e., does not expose any - -- modules.) If so, we can thin it. - | isFromSignaturePackage - -> setSrcSpan loc $ do - -- Suppress missing errors; they might be used to refer - -- to entities from other signatures we are merging in. - -- If an identifier truly doesn't exist in any of the - -- signatures that are merged in, we will discover this - -- when we run exports_from_avail on the final merged - -- export list. - (mb_r, msgs) <- tryTc $ do - -- Suppose that we have written in a signature: - -- signature A ( module A ) where {- empty -} - -- If I am also inheriting a signature from a - -- signature package, does 'module A' scope over - -- all of its exports? - -- - -- There are two possible interpretations: - -- - -- 1. For non self-reexports, a module reexport - -- is interpreted only in terms of the local - -- signature module, and not any of the inherited - -- ones. The reason for this is because after - -- typechecking, module exports are completely - -- erased from the interface of a file, so we - -- have no way of "interpreting" a module reexport. - -- Thus, it's only useful for the local signature - -- module (where we have a useful GlobalRdrEnv.) - -- - -- 2. On the other hand, a common idiom when - -- you want to "export everything, plus a reexport" - -- in modules is to say module A ( module A, reex ). - -- This applies to signature modules too; and in - -- particular, you probably still want the entities - -- from the inherited signatures to be preserved - -- too. - -- - -- We think it's worth making a special case for - -- self reexports to make use case (2) work. To - -- do this, we take the exports of the inherited - -- signature @as1@, and bundle them into a - -- GlobalRdrEnv where we treat them as having come - -- from the import @import A@. Thus, we will - -- pick them up if they are referenced explicitly - -- (@foo@) or even if we do a module reexport - -- (@module A@). - let ispec = ImpSpec ImpDeclSpec{ - -- NB: This needs to be mod name - -- of the local signature, not - -- the (original) module name of - -- the inherited signature, - -- because we need module - -- LocalSig (from the local - -- export list) to match it! - is_mod = mod_name, - is_as = mod_name, - is_qual = False, - is_dloc = loc - } ImpAll - rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1) - setGblEnv tcg_env { - tcg_rdr_env = rdr_env - } $ exports_from_avail mb_exports rdr_env - -- NB: tcg_imports is also empty! - emptyImportAvails - (tcg_semantic_mod tcg_env) - case mb_r of - Just (_, as2) -> return (thinModIface as2 ireq_iface, as2) - Nothing -> addMessages msgs >> failM - -- We can't think 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.) - -- (NB: This code is actually dead right now.) - let oks' | isFromSignaturePackage - = extendOccSetList oks (exportOccs as2) - | otherwise - = oks - -- 3(d). Extend the name substitution (performing shaping) - mb_r <- extend_ns nsubst as2 - case mb_r of - Left err -> failWithTc 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)) - -- Process each interface, getting the thinned interfaces as well as - -- the final, full set of exports @nsubst@ and the exports which are - -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.) - (nsubst, ok_to_use, rev_thinned_ifaces) - <- 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) - _warn_occs = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports) - warns = NoWarnings - {- - -- 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. - -- Not supported in current warning framework - warns | null warn_occs = NoWarnings - | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs - -} - setGblEnv tcg_env { - -- The top-level GlobalRdrEnv is quite interesting. It consists - -- of two components: - -- 1. First, we reuse the GlobalRdrEnv of the local signature. - -- This is very useful, because it means that if we have - -- to print a message involving some entity that the local - -- signature imported, we'll qualify it accordingly. - -- 2. Second, we need to add all of the declarations we are - -- going to merge in (as they need to be in scope for the - -- final test of the export list.) - tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env, - -- Inherit imports from the local signature, so that module - -- reexports are picked up correctly - tcg_imports = tcg_imports orig_tcg_env, - tcg_exports = exports, - tcg_dus = usesOnly (availsToNameSetWithSelectors 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 - (tcg_imports tcg_env) (tcg_semantic_mod tcg_env) - - {- -- NB: This is commented out, because warns above is disabled. - -- If you tried to explicitly export an identifier that has a warning - -- attached to it, that's probably a mistake. Warn about it. - case mb_lies of - Nothing -> return () - Just lies -> - forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) -> - setSrcSpan loc $ - unless (nameOccName n `elemOccSet` ok_to_use) $ - addWarn NoReason $ vcat [ - text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.", - parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.") - ] - -} - - failIfErrsM - - -- Save the exports - setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do - tcg_env <- getGblEnv - - -- STEP 4: Rename the interfaces - ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) -> - tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface - lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0 - let ifaces = lcl_iface : ext_ifaces - - -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env - let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) - | (occ, f) <- concatMap mi_fixities ifaces - , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ] - - -- STEP 5: Typecheck the interfaces - let type_env_var = tcg_type_env_var tcg_env - - -- typecheckIfacesForMerging does two things: - -- 1. It merges the all of the ifaces together, and typechecks the - -- result to type_env. - -- 2. It typechecks each iface individually, but with their 'Name's - -- resolving to the merged type_env from (1). - -- See typecheckIfacesForMerging for more details. - (type_env, detailss) <- initIfaceTcRn $ - typecheckIfacesForMerging inner_mod ifaces type_env_var - let infos = zip ifaces detailss - - -- Test for cycles - checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) [] - - -- NB on type_env: it contains NO dfuns. DFuns are recorded inside - -- detailss, and given a Name that doesn't correspond to anything real. See - -- also Note [Signature merging DFuns] - - -- Add the merged type_env to TcGblEnv, so that it gets serialized - -- out when we finally write out the interface. - -- - -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly, - -- rather than use tcExtendGlobalEnv (the normal method to add newly - -- defined types to TcGblEnv?) tcExtendGlobalEnv adds these - -- TyThings to 'tcg_type_env_var', which is consulted when - -- we read in interfaces to tie the knot. But *these TyThings themselves - -- come from interface*, so that would result in deadlock. Don't - -- update it! - setGblEnv tcg_env { - tcg_tcs = typeEnvTyCons type_env, - tcg_patsyns = typeEnvPatSyns type_env, - tcg_type_env = type_env, - tcg_fix_env = fix_env - } $ do - tcg_env <- getGblEnv - - -- STEP 6: Check for compatibility/merge things - tcg_env <- (\x -> foldM x tcg_env infos) - $ \tcg_env (iface, details) -> do - - let check_export name - | Just sig_thing <- lookupTypeEnv (md_types details) name - = case lookupTypeEnv type_env (getName sig_thing) of - Just thing -> checkHsigDeclM iface sig_thing thing - Nothing -> panic "mergeSignatures: check_export" - -- Oops! We're looking for this export but it's - -- not actually in the type environment of the signature's - -- ModDetails. - -- - -- NB: This case happens because the we're iterating - -- over the union of all exports, so some interfaces - -- won't have everything. Note that md_exports is nonsense - -- (it's the same as exports); maybe we should fix this - -- eventually. - | otherwise - = return () - mapM_ check_export (map availName exports) - - -- Note [Signature merging instances] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Merge instances into the global environment. The algorithm here is - -- dumb and simple: if an instance has exactly the same DFun type - -- (tested by 'memberInstEnv') as an existing instance, we drop it; - -- otherwise, we add it even, even if this would cause overlap. - -- - -- Why don't we deduplicate instances with identical heads? There's no - -- good choice if they have premises: - -- - -- instance K1 a => K (T a) - -- instance K2 a => K (T a) - -- - -- Why not eagerly error in this case? The overlapping head does not - -- necessarily mean that the instances are unimplementable: in fact, - -- they may be implemented without overlap (if, for example, the - -- implementing module has 'instance K (T a)'; both are implemented in - -- this case.) The implements test just checks that the wanteds are - -- derivable assuming the givens. - -- - -- Still, overlapping instances with hypotheses like above are going - -- to be a bad deal, because instance resolution when we're typechecking - -- against the merged signature is going to have a bad time when - -- there are overlapping heads like this: we never backtrack, so it - -- may be difficult to see that a wanted is derivable. For now, - -- we hope that we get lucky / the overlapping instances never - -- get used, but it is not a very good situation to be in. - -- - let merge_inst (insts, inst_env) inst - | memberInstEnv inst_env inst -- test DFun Type equality - = (insts, inst_env) - | otherwise - -- NB: is_dfun_name inst is still nonsense here, - -- see Note [Signature merging DFuns] - = (inst:insts, extendInstEnv inst_env inst) - (insts, inst_env) = foldl' merge_inst - (tcg_insts tcg_env, tcg_inst_env tcg_env) - (md_insts details) - -- This is a HACK to prevent calculateAvails from including imp_mod - -- in the listing. We don't want it because a module is NOT - -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 - iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } } - avails = plusImportAvails (tcg_imports tcg_env) $ - calculateAvails dflags iface' False False ImportedBySystem - return tcg_env { - tcg_inst_env = inst_env, - tcg_insts = insts, - tcg_imports = avails, - tcg_merged = - if outer_mod == mi_module iface - -- Don't add ourselves! - then tcg_merged tcg_env - else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env - } - - -- Note [Signature merging DFuns] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Once we know all of instances which will be defined by this merged - -- signature, we go through each of the DFuns and rename them with a fresh, - -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing - -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'. - -- - -- We can't do this fixup earlier, because we need a way to identify each - -- source DFun (from each of the signatures we are merging in) so that - -- when we have a ClsInst, we can pull up the correct DFun to check if - -- the types match. - -- - -- See also Note [rnIfaceNeverExported] in GHC.Iface.Rename - dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do - 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) - } - - addDependentFiles src_files - - return tcg_env - --- | Top-level driver for signature instantiation (run when compiling --- an @hsig@ file.) -tcRnInstantiateSignature :: - HscEnv -> Module -> RealSrcSpan -> - IO (Messages, Maybe TcGblEnv) -tcRnInstantiateSignature hsc_env this_mod real_loc = - withTiming dflags - (text "Signature instantiation"<+>brackets (ppr this_mod)) - (const ()) $ - initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature - where - dflags = hsc_dflags hsc_env - -exportOccs :: [AvailInfo] -> [OccName] -exportOccs = concatMap (map occName . availNames) - -impl_msg :: Module -> IndefModule -> SDoc -impl_msg impl_mod (IndefModule req_uid req_mod_name) = - text "while checking that" <+> ppr impl_mod <+> - text "implements signature" <+> ppr req_mod_name <+> - text "in" <+> ppr req_uid - --- | Check if module implements a signature. (The signature is --- always un-hashed, which is why its components are specified --- explicitly.) -checkImplements :: Module -> IndefModule -> TcRn TcGblEnv -checkImplements impl_mod req_mod@(IndefModule uid mod_name) = - addErrCtxt (impl_msg impl_mod req_mod) $ do - let insts = indefUnitIdInsts uid - - -- STEP 1: Load the implementing interface, and make a RdrEnv - -- for its exports. Also, add its 'ImportAvails' to 'tcg_imports', - -- so that we treat all orphan instances it provides as visible - -- when we verify that all instances are checked (see #12945), and so that - -- when we eventually write out the interface we record appropriate - -- dependency information. - impl_iface <- initIfaceTcRn $ - loadSysInterface (text "checkImplements 1") impl_mod - let impl_gr = mkGlobalRdrEnv - (gresFromAvails Nothing (mi_exports impl_iface)) - nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface) - - -- Load all the orphans, so the subsequent 'checkHsigIface' sees - -- all the instances it needs to - loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)") - (dep_orphs (mi_deps impl_iface)) - - dflags <- getDynFlags - let avails = calculateAvails dflags - impl_iface False{- safe -} False{- boot -} ImportedBySystem - fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) - | (occ, f) <- mi_fixities impl_iface - , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ] - updGblEnv (\tcg_env -> tcg_env { - -- Setting tcg_rdr_env to treat all exported entities from - -- the implementing module as in scope improves error messages, - -- as it reduces the amount of qualification we need. Unfortunately, - -- we still end up qualifying references to external modules - -- (see bkpfail07 for an example); we'd need to record more - -- information in ModIface to solve this. - tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr, - tcg_imports = tcg_imports tcg_env `plusImportAvails` avails, - -- This is here so that when we call 'lookupFixityRn' for something - -- directly implemented by the module, we grab the right thing - tcg_fix_env = fix_env - }) $ do - - -- STEP 2: Load the *unrenamed, uninstantiated* interface for - -- the ORIGINAL signature. We are going to eventually rename it, - -- but we must proceed slowly, because it is NOT known if the - -- instantiation is correct. - let sig_mod = mkModule (IndefiniteUnitId uid) mod_name - isig_mod = fst (splitModuleInsts sig_mod) - mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod False - isig_iface <- case mb_isig_iface of - Succeeded (iface, _) -> return iface - Failed err -> failWithTc $ - hang (text "Could not find hi interface for signature" <+> - quotes (ppr isig_mod) <> colon) 4 err - - -- 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 $ quotes (ppr occ) - <+> text "is exported by the hsig file, but not" - <+> text "exported by the implementing module" - <+> quotes (ppr impl_mod) - _ -> return () - failIfErrsM - - -- STEP 4: Now that the export is complete, rename the interface... - sig_iface <- tcRnModIface insts (Just nsubst) isig_iface - - -- STEP 5: ...and typecheck it. (Note that in both cases, the nsubst - -- lets us determine how top-level identifiers should be handled.) - sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface - - -- STEP 6: Check that it's sufficient - tcg_env <- getGblEnv - checkHsigIface tcg_env impl_gr sig_iface sig_details - - -- STEP 7: Return the updated 'TcGblEnv' with the signature exports, - -- so we write them out. - return tcg_env { - tcg_exports = mi_exports sig_iface - } - --- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite --- library to use the actual implementations of the relevant entities, --- checking that the implementation matches the signature. -instantiateSignature :: TcRn TcGblEnv -instantiateSignature = do - tcg_env <- getGblEnv - dflags <- getDynFlags - let outer_mod = tcg_mod tcg_env - inner_mod = tcg_semantic_mod tcg_env - -- TODO: setup the local RdrEnv so the error messages look a little better. - -- But this information isn't stored anywhere. Should we RETYPECHECK - -- the local one just to get the information? Hmm... - MASSERT( moduleUnitId outer_mod == thisPackage dflags ) - inner_mod `checkImplements` - IndefModule - (newIndefUnitId (thisComponentId dflags) - (thisUnitIdInsts dflags)) - (moduleName outer_mod) diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs deleted file mode 100644 --- a/compiler/typecheck/TcBinds.hs +++ /dev/null @@ -1,1732 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcBinds]{TcBinds} --} - -{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds, - tcHsBootSigs, tcPolyCheck, - chooseInferredQuantifiers, - badBootDeclErr ) where - -import GhcPrelude - -import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) -import {-# SOURCE #-} TcExpr ( tcMonoExpr ) -import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) -import GHC.Core (Tickish (..)) -import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC)) -import GHC.Driver.Session -import FastString -import GHC.Hs -import TcSigs -import TcRnMonad -import TcOrigin -import TcEnv -import TcUnify -import TcSimplify -import TcEvidence -import TcHsType -import TcPat -import TcMType -import GHC.Core.FamInstEnv( normaliseType ) -import FamInst( tcGetFamInstEnvs ) -import GHC.Core.TyCon -import TcType -import GHC.Core.Type (mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy) -import TysPrim -import TysWiredIn( mkBoxedTupleTy ) -import GHC.Types.Id -import GHC.Types.Var as Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env( TidyEnv ) -import GHC.Types.Module -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.Name.Env -import GHC.Types.SrcLoc -import Bag -import ErrUtils -import Digraph -import Maybes -import Util -import GHC.Types.Basic -import Outputable -import PrelNames( ipClassName ) -import TcValidity (checkValidType) -import GHC.Types.Unique.FM -import GHC.Types.Unique.Set -import qualified GHC.LanguageExtensions as LangExt -import GHC.Core.ConLike - -import Control.Monad -import Data.Foldable (find) - -#include "HsVersions.h" - -{- -************************************************************************ -* * -\subsection{Type-checking bindings} -* * -************************************************************************ - -@tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because -it needs to know something about the {\em usage} of the things bound, -so that it can create specialisations of them. So @tcBindsAndThen@ -takes a function which, given an extended environment, E, typechecks -the scope of the bindings returning a typechecked thing and (most -important) an LIE. It is this LIE which is then used as the basis for -specialising the things bound. - -@tcBindsAndThen@ also takes a "combiner" which glues together the -bindings and the "thing" to make a new "thing". - -The real work is done by @tcBindWithSigsAndThen@. - -Recursive and non-recursive binds are handled in essentially the same -way: because of uniques there are no scoping issues left. The only -difference is that non-recursive bindings can bind primitive values. - -Even for non-recursive binding groups we add typings for each binder -to the LVE for the following reason. When each individual binding is -checked the type of its LHS is unified with that of its RHS; and -type-checking the LHS of course requires that the binder is in scope. - -At the top-level the LIE is sure to contain nothing but constant -dictionaries, which we resolve at the module level. - -Note [Polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The game plan for polymorphic recursion in the code above is - - * Bind any variable for which we have a type signature - to an Id with a polymorphic type. Then when type-checking - the RHSs we'll make a full polymorphic call. - -This fine, but if you aren't a bit careful you end up with a horrendous -amount of partial application and (worse) a huge space leak. For example: - - f :: Eq a => [a] -> [a] - f xs = ...f... - -If we don't take care, after typechecking we get - - f = /\a -> \d::Eq a -> let f' = f a d - in - \ys:[a] -> ...f'... - -Notice the stupid construction of (f a d), which is of course -identical to the function we're executing. In this case, the -polymorphic recursion isn't being used (but that's a very common case). -This can lead to a massive space leak, from the following top-level defn -(post-typechecking) - - ff :: [Int] -> [Int] - ff = f Int dEqInt - -Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but -f' is another thunk which evaluates to the same thing... and you end -up with a chain of identical values all hung onto by the CAF ff. - - ff = f Int dEqInt - - = let f' = f Int dEqInt in \ys. ...f'... - - = let f' = let f' = f Int dEqInt in \ys. ...f'... - in \ys. ...f'... - -Etc. - -NOTE: a bit of arity analysis would push the (f a d) inside the (\ys...), -which would make the space leak go away in this case - -Solution: when typechecking the RHSs we always have in hand the -*monomorphic* Ids for each binding. So we just need to make sure that -if (Method f a d) shows up in the constraints emerging from (...f...) -we just use the monomorphic Id. We achieve this by adding monomorphic Ids -to the "givens" when simplifying constraints. That's what the "lies_avail" -is doing. - -Then we get - - f = /\a -> \d::Eq a -> letrec - fm = \ys:[a] -> ...fm... - in - fm --} - -tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] - -> TcM (TcGblEnv, TcLclEnv) --- The TcGblEnv contains the new tcg_binds and tcg_spects --- The TcLclEnv has an extended type envt for the new bindings -tcTopBinds binds sigs - = do { -- Pattern synonym bindings populate the global environment - (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $ - do { gbl <- getGblEnv - ; lcl <- getLclEnv - ; return (gbl, lcl) } - ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids - - ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs - ; traceTc "complete_matches" (ppr binds $$ ppr sigs) - ; traceTc "complete_matches" (ppr complete_matches) - - ; let { tcg_env' = tcg_env { tcg_imp_specs - = specs ++ tcg_imp_specs tcg_env - , tcg_complete_matches - = complete_matches - ++ tcg_complete_matches tcg_env } - `addTypecheckedBinds` map snd binds' } - - ; return (tcg_env', tcl_env) } - -- The top level bindings are flattened into a giant - -- implicitly-mutually-recursive LHsBinds - - --- Note [Typechecking Complete Matches] --- Much like when a user bundled a pattern synonym, the result types of --- all the constructors in the match pragma must be consistent. --- --- If we allowed pragmas with inconsistent types then it would be --- impossible to ever match every constructor in the list and so --- the pragma would be useless. - - - - - --- This is only used in `tcCompleteSig`. We fold over all the conlikes, --- this accumulator keeps track of the first `ConLike` with a concrete --- return type. After fixing the return type, all other constructors with --- a fixed return type must agree with this. --- --- The fields of `Fixed` cache the first conlike and its return type so --- that that we can compare all the other conlikes to it. The conlike is --- stored for error messages. --- --- `Nothing` in the case that the type is fixed by a type signature -data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon - -tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch] -tcCompleteSigs sigs = - let - doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch) - doOne c@(CompleteMatchSig _ _ lns mtc) - = fmap Just $ do - addErrCtxt (text "In" <+> ppr c) $ - case mtc of - Nothing -> infer_complete_match - Just tc -> check_complete_match tc - where - - checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns) - - infer_complete_match = do - (res, cls) <- checkCLTypes AcceptAny - case res of - AcceptAny -> failWithTc ambiguousError - Fixed _ tc -> return $ mkMatch cls tc - - check_complete_match tc_name = do - ty_con <- tcLookupLocatedTyCon tc_name - (_, cls) <- checkCLTypes (Fixed Nothing ty_con) - return $ mkMatch cls ty_con - - mkMatch :: [ConLike] -> TyCon -> CompleteMatch - mkMatch cls ty_con = CompleteMatch { - -- foldM is a left-fold and will have accumulated the ConLikes in - -- the reverse order. foldrM would accumulate in the correct order, - -- but would type-check the last ConLike first, which might also be - -- confusing from the user's perspective. Hence reverse here. - completeMatchConLikes = reverse (map conLikeName cls), - completeMatchTyCon = tyConName ty_con - } - doOne _ = return Nothing - - ambiguousError :: SDoc - ambiguousError = - text "A type signature must be provided for a set of polymorphic" - <+> text "pattern synonyms." - - - -- See note [Typechecking Complete Matches] - checkCLType :: (CompleteSigType, [ConLike]) -> Located Name - -> TcM (CompleteSigType, [ConLike]) - checkCLType (cst, cs) n = do - cl <- addLocM tcLookupConLike n - let (_,_,_,_,_,_, res_ty) = conLikeFullSig cl - res_ty_con = fst <$> splitTyConApp_maybe res_ty - case (cst, res_ty_con) of - (AcceptAny, Nothing) -> return (AcceptAny, cl:cs) - (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs) - (Fixed mfcl tc, Nothing) -> return (Fixed mfcl tc, cl:cs) - (Fixed mfcl tc, Just tc') -> - if tc == tc' - then return (Fixed mfcl tc, cl:cs) - else case mfcl of - Nothing -> - addErrCtxt (text "In" <+> ppr cl) $ - failWithTc typeSigErrMsg - Just cl -> failWithTc (errMsg cl) - where - typeSigErrMsg :: SDoc - typeSigErrMsg = - text "Couldn't match expected type" - <+> quotes (ppr tc) - <+> text "with" - <+> quotes (ppr tc') - - errMsg :: ConLike -> SDoc - errMsg fcl = - text "Cannot form a group of complete patterns from patterns" - <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl) - <+> text "as they match different type constructors" - <+> parens (quotes (ppr tc) - <+> text "resp." - <+> quotes (ppr tc')) - -- For some reason I haven't investigated further, the signatures come in - -- backwards wrt. declaration order. So we reverse them here, because it makes - -- a difference for incomplete match suggestions. - in mapMaybeM (addLocM doOne) (reverse sigs) -- process in declaration order - -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 -tcHsBootSigs binds sigs - = do { checkTc (null binds) badBootDeclErr - ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } - where - tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames - where - f (L _ name) - = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty - ; return (mkVanillaGlobal name sigma_ty) } - -- Notice that we make GlobalIds, not LocalIds - tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) - -badBootDeclErr :: MsgDoc -badBootDeclErr = text "Illegal declarations in an hs-boot file" - ------------------------- -tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing - -> TcM (HsLocalBinds GhcTcId, thing) - -tcLocalBinds (EmptyLocalBinds x) thing_inside - = do { thing <- thing_inside - ; return (EmptyLocalBinds x, thing) } - -tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside - = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside - ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) } -tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds" - -tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside - = do { ipClass <- tcLookupClass ipClassName - ; (given_ips, ip_binds') <- - mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds - - -- If the binding binds ?x = E, we must now - -- discharge any ?x constraints in expr_lie - -- See Note [Implicit parameter untouchables] - ; (ev_binds, result) <- checkConstraints (IPSkol ips) - [] given_ips thing_inside - - ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } - where - ips = [ip | (L _ (IPBind _ (Left (L _ ip)) _)) <- ip_binds] - - -- I wonder if we should do these one at a time - -- Consider ?x = 4 - -- ?y = ?x + 1 - tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr) - = do { ty <- newOpenFlexiTyVarTy - ; let p = mkStrLitTy $ hsIPNameFS ip - ; ip_id <- newDict ipClass [ p, ty ] - ; expr' <- tcMonoExpr expr (mkCheckExpType ty) - ; let d = toDict ipClass p ty `fmap` expr' - ; return (ip_id, (IPBind noExtField (Right ip_id) d)) } - tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind" - tc_ip_bind _ (XIPBind nec) = noExtCon nec - - -- Coerces a `t` into a dictionary for `IP "x" t`. - -- co : t -> IP "x" t - toDict ipClass x ty = mkHsWrap $ mkWpCastR $ - wrapIP $ mkClassPred ipClass [x,ty] - -tcLocalBinds (HsIPBinds _ (XHsIPBinds nec)) _ = noExtCon nec -tcLocalBinds (XHsLocalBindsLR nec) _ = noExtCon nec - -{- Note [Implicit parameter untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We add the type variables in the types of the implicit parameters -as untouchables, not so much because we really must not unify them, -but rather because we otherwise end up with constraints like this - Num alpha, Implic { wanted = alpha ~ Int } -The constraint solver solves alpha~Int by unification, but then -doesn't float that solved constraint out (it's not an unsolved -wanted). Result disaster: the (Num alpha) is again solved, this -time by defaulting. No no no. - -However [Oct 10] this is all handled automatically by the -untouchable-range idea. --} - -tcValBinds :: TopLevelFlag - -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] - -> TcM thing - -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) - -tcValBinds top_lvl binds sigs thing_inside - = do { -- Typecheck the signatures - -- It's easier to do so now, once for all the SCCs together - -- because a single signature f,g :: - -- might relate to more than one SCC - ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $ - tcTySigs sigs - - -- Extend the envt right away with all the Ids - -- declared with complete type signatures - -- Do not extend the TcBinderStack; instead - -- we extend it on a per-rhs basis in tcExtendForRhs - ; tcExtendSigIds top_lvl poly_ids $ do - { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do - { thing <- thing_inside - -- See Note [Pattern synonym builders don't yield dependencies] - -- in GHC.Rename.Binds - ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns - ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ] - ; return (extra_binds, thing) } - ; return (binds' ++ extra_binds', thing) }} - where - patsyns = getPatSynBinds binds - prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds) - ------------------------- -tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv - -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing - -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) --- Typecheck a whole lot of value bindings, --- one strongly-connected component at a time --- Here a "strongly connected component" has the straightforward --- meaning of a group of bindings that mention each other, --- ignoring type signatures (that part comes later) - -tcBindGroups _ _ _ [] thing_inside - = do { thing <- thing_inside - ; return ([], thing) } - -tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside - = do { -- See Note [Closed binder groups] - type_env <- getLclTypeEnv - ; let closed = isClosedBndrGroup type_env (snd group) - ; (group', (groups', thing)) - <- tc_group top_lvl sig_fn prag_fn group closed $ - tcBindGroups top_lvl sig_fn prag_fn groups thing_inside - ; return (group' ++ groups', thing) } - --- Note [Closed binder groups] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- A mutually recursive group is "closed" if all of the free variables of --- the bindings are closed. For example --- --- > h = \x -> let f = ...g... --- > g = ....f...x... --- > in ... --- --- Here @g@ is not closed because it mentions @x@; and hence neither is @f@ --- closed. --- --- So we need to compute closed-ness on each strongly connected components, --- before we sub-divide it based on what type signatures it has. --- - ------------------------- -tc_group :: forall thing. - TopLevelFlag -> TcSigFun -> TcPragEnv - -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing - -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) - --- Typecheck one strongly-connected component of the original program. --- We get a list of groups back, because there may --- be specialisations etc as well - -tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside - -- A single non-recursive binding - -- We want to keep non-recursive things non-recursive - -- so that we desugar unlifted bindings correctly - = do { let bind = case bagToList binds of - [bind] -> bind - [] -> panic "tc_group: empty list of binds" - _ -> panic "tc_group: NonRecursive binds is not a singleton bag" - ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed - thing_inside - ; return ( [(NonRecursive, bind')], thing) } - -tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside - = -- To maximise polymorphism, we do a new - -- strongly-connected-component analysis, this time omitting - -- any references to variables with type signatures. - -- (This used to be optional, but isn't now.) - -- See Note [Polymorphic recursion] in HsBinds. - do { traceTc "tc_group rec" (pprLHsBinds binds) - ; whenIsJust mbFirstPatSyn $ \lpat_syn -> - recursivePatSynErr (getLoc lpat_syn) binds - ; (binds1, thing) <- go sccs - ; return ([(Recursive, binds1)], thing) } - -- Rec them all together - where - mbFirstPatSyn = find (isPatSyn . unLoc) binds - isPatSyn PatSynBind{} = True - isPatSyn _ = False - - sccs :: [SCC (LHsBind GhcRn)] - sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds) - - go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, thing) - go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc - ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn - closed ids1 $ - go sccs - ; return (binds1 `unionBags` binds2, thing) } - go [] = do { thing <- thing_inside; return (emptyBag, thing) } - - tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind] - tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds - - tc_sub_group rec_tc binds = - tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds - -recursivePatSynErr :: - OutputableBndrId p => - SrcSpan -- ^ The location of the first pattern synonym binding - -- (for error reporting) - -> LHsBinds (GhcPass p) - -> TcM a -recursivePatSynErr loc binds - = failAt loc $ - hang (text "Recursive pattern synonym definition with following bindings:") - 2 (vcat $ map pprLBind . bagToList $ binds) - where - pprLoc loc = parens (text "defined at" <+> ppr loc) - pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) - <+> pprLoc loc - -tc_single :: forall thing. - TopLevelFlag -> TcSigFun -> TcPragEnv - -> LHsBind GhcRn -> IsGroupClosed -> TcM thing - -> TcM (LHsBinds GhcTcId, thing) -tc_single _top_lvl sig_fn _prag_fn - (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name })) - _ thing_inside - = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) - ; thing <- setGblEnv tcg_env thing_inside - ; return (aux_binds, thing) - } - -tc_single top_lvl sig_fn prag_fn lbind closed thing_inside - = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn - NonRecursive NonRecursive - closed - [lbind] - ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside - ; return (binds1, thing) } - ------------------------- -type BKey = Int -- Just number off the bindings - -mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)] --- See Note [Polymorphic recursion] in HsBinds. -mkEdges sig_fn binds - = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)), - Just key <- [lookupNameEnv key_map n], no_sig n ] - | (bind, key) <- keyd_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 Digraph. - where - bind_fvs (FunBind { fun_ext = fvs }) = fvs - bind_fvs (PatBind { pat_ext = fvs }) = fvs - bind_fvs _ = emptyNameSet - - no_sig :: Name -> Bool - no_sig n = not (hasCompleteSig sig_fn n) - - keyd_binds = bagToList binds `zip` [0::BKey ..] - - key_map :: NameEnv BKey -- Which binding it comes from - key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds - , bndr <- collectHsBindBinders bind ] - ------------------------- -tcPolyBinds :: TcSigFun -> TcPragEnv - -> RecFlag -- Whether the group is really recursive - -> RecFlag -- Whether it's recursive after breaking - -- dependencies based on type signatures - -> IsGroupClosed -- Whether the group is closed - -> [LHsBind GhcRn] -- None are PatSynBind - -> TcM (LHsBinds GhcTcId, [TcId]) - --- Typechecks a single bunch of values bindings all together, --- and generalises them. The bunch may be only part of a recursive --- group, because we use type signatures to maximise polymorphism --- --- Returns a list because the input may be a single non-recursive binding, --- in which case the dependency order of the resulting bindings is --- important. --- --- Knows nothing about the scope of the bindings --- None of the bindings are pattern synonyms - -tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list - = setSrcSpan loc $ - recoverM (recoveryCode binder_names sig_fn) $ do - -- Set up main recover; take advantage of any type sigs - - { traceTc "------------------------------------------------" Outputable.empty - ; traceTc "Bindings for {" (ppr binder_names) - ; dflags <- getDynFlags - ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn - ; traceTc "Generalisation plan" (ppr plan) - ; result@(_, poly_ids) <- case plan of - NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list - InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list - CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind - - ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group - , vcat [ppr id <+> ppr (idType id) | id <- poly_ids] - ]) - - ; return result } - where - binder_names = collectHsBindListBinders bind_list - loc = foldr1 combineSrcSpans (map getLoc bind_list) - -- The mbinds have been dependency analysed and - -- may no longer be adjacent; so find the narrowest - -- span that includes them all - --------------- --- If typechecking the binds fails, then return with each --- signature-less binder given type (forall a.a), to minimise --- subsequent error messages -recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTcId, [Id]) -recoveryCode binder_names sig_fn - = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) - ; let poly_ids = map mk_dummy binder_names - ; return (emptyBag, poly_ids) } - where - mk_dummy name - | Just sig <- sig_fn name - , Just poly_id <- completeSigPolyId_maybe sig - = poly_id - | otherwise - = mkLocalId name forall_a_a - -forall_a_a :: TcType --- At one point I had (forall r (a :: TYPE r). a), but of course --- that type is ill-formed: its mentions 'r' which escapes r's scope. --- Another alternative would be (forall (a :: TYPE kappa). a), where --- kappa is a unification variable. But I don't think we need that --- complication here. I'm going to just use (forall (a::*). a). --- See #15276 -forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy - -{- ********************************************************************* -* * - tcPolyNoGen -* * -********************************************************************* -} - -tcPolyNoGen -- No generalisation whatsoever - :: RecFlag -- Whether it's recursive after breaking - -- dependencies based on type signatures - -> TcPragEnv -> TcSigFun - -> [LHsBind GhcRn] - -> TcM (LHsBinds GhcTcId, [TcId]) - -tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list - = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn - (LetGblBndr prag_fn) - bind_list - ; mono_ids' <- mapM tc_mono_info mono_infos - ; return (binds', mono_ids') } - where - tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id }) - = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name) - ; return mono_id } - -- NB: tcPrags generates error messages for - -- specialisation pragmas for non-overloaded sigs - -- Indeed that is why we call it here! - -- So we can safely ignore _specs - - -{- ********************************************************************* -* * - tcPolyCheck -* * -********************************************************************* -} - -tcPolyCheck :: TcPragEnv - -> TcIdSigInfo -- Must be a complete signature - -> LHsBind GhcRn -- Must be a FunBind - -> TcM (LHsBinds GhcTcId, [TcId]) --- There is just one binding, --- it is a FunBind --- it has a complete type signature, -tcPolyCheck prag_fn - (CompleteSig { sig_bndr = poly_id - , sig_ctxt = ctxt - , sig_loc = sig_loc }) - (L loc (FunBind { fun_id = (L nm_loc name) - , fun_matches = matches })) - = setSrcSpan sig_loc $ - do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) - ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id - -- See Note [Instantiate sig with fresh variables] - - ; mono_name <- newNameAt (nameOccName name) nm_loc - ; ev_vars <- newEvVars theta - ; let mono_id = mkLocalId mono_name tau - skol_info = SigSkol ctxt (idType poly_id) tv_prs - skol_tvs = map snd tv_prs - - ; (ev_binds, (co_fn, matches')) - <- checkConstraints skol_info skol_tvs ev_vars $ - tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ - tcExtendNameTyVarEnv tv_prs $ - setSrcSpan loc $ - tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau) - - ; let prag_sigs = lookupPragEnv prag_fn name - ; spec_prags <- tcSpecPrags poly_id prag_sigs - ; poly_id <- addInlinePrags poly_id prag_sigs - - ; mod <- getModule - ; tick <- funBindTicks nm_loc mono_id mod prag_sigs - ; let bind' = FunBind { fun_id = L nm_loc mono_id - , fun_matches = matches' - , fun_ext = co_fn - , fun_tick = tick } - - export = ABE { abe_ext = noExtField - , abe_wrap = idHsWrapper - , abe_poly = poly_id - , abe_mono = mono_id - , abe_prags = SpecPrags spec_prags } - - abs_bind = L loc $ - AbsBinds { abs_ext = noExtField - , abs_tvs = skol_tvs - , abs_ev_vars = ev_vars - , abs_ev_binds = [ev_binds] - , abs_exports = [export] - , abs_binds = unitBag (L loc bind') - , abs_sig = True } - - ; return (unitBag abs_bind, [poly_id]) } - -tcPolyCheck _prag_fn sig bind - = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind) - -funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] - -> TcM [Tickish TcId] -funBindTicks loc fun_id mod sigs - | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ] - -- this can only be a singleton list, as duplicate pragmas are rejected - -- by the renamer - , let cc_str - | Just cc_str <- mb_cc_str - = sl_fs $ unLoc cc_str - | otherwise - = getOccFS (Var.varName fun_id) - cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str - = do - flavour <- DeclCC <$> getCCIndexM cc_name - let cc = mkUserCC cc_name mod loc flavour - return [ProfNote cc True True] - | otherwise - = return [] - -{- Note [Instantiate sig with fresh variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's vital to instantiate a type signature with fresh variables. -For example: - type T = forall a. [a] -> [a] - f :: T; - f = g where { g :: T; g = } - - We must not use the same 'a' from the defn of T at both places!! -(Instantiation is only necessary because of type synonyms. Otherwise, -it's all cool; each signature has distinct type variables from the renamer.) --} - - -{- ********************************************************************* -* * - tcPolyInfer -* * -********************************************************************* -} - -tcPolyInfer - :: RecFlag -- Whether it's recursive after breaking - -- dependencies based on type signatures - -> TcPragEnv -> TcSigFun - -> Bool -- True <=> apply the monomorphism restriction - -> [LHsBind GhcRn] - -> TcM (LHsBinds GhcTcId, [TcId]) -tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list - = do { (tclvl, wanted, (binds', mono_infos)) - <- pushLevelAndCaptureConstraints $ - tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list - - ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info)) - | info <- mono_infos ] - sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ] - infer_mode = if mono then ApplyMR else NoRestrictions - - ; mapM_ (checkOverloadedSig mono) sigs - - ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted) - ; (qtvs, givens, ev_binds, residual, insoluble) - <- simplifyInfer tclvl infer_mode sigs name_taus wanted - ; emitConstraints residual - - ; let inferred_theta = map evVarPred givens - ; exports <- checkNoErrs $ - mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos - - ; loc <- getSrcSpanM - ; let poly_ids = map abe_poly exports - abs_bind = L loc $ - AbsBinds { abs_ext = noExtField - , abs_tvs = qtvs - , abs_ev_vars = givens, abs_ev_binds = [ev_binds] - , abs_exports = exports, abs_binds = binds' - , abs_sig = False } - - ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids)) - ; return (unitBag abs_bind, poly_ids) } - -- poly_ids are guaranteed zonked by mkExport - --------------- -mkExport :: TcPragEnv - -> Bool -- True <=> there was an insoluble type error - -- when typechecking the bindings - -> [TyVar] -> TcThetaType -- Both already zonked - -> MonoBindInfo - -> TcM (ABExport GhcTc) --- Only called for generalisation plan InferGen, not by CheckGen or NoGen --- --- mkExport generates exports with --- zonked type variables, --- zonked poly_ids --- The former is just because no further unifications will change --- the quantified type variables, so we can fix their final form --- right now. --- The latter is needed because the poly_ids are used to extend the --- type environment; see the invariant on TcEnv.tcExtendIdEnv - --- Pre-condition: the qtvs and theta are already zonked - -mkExport prag_fn insoluble qtvs theta - mono_info@(MBI { mbi_poly_name = poly_name - , mbi_sig = mb_sig - , mbi_mono_id = mono_id }) - = do { mono_ty <- zonkTcType (idType mono_id) - ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty - - -- NB: poly_id has a zonked type - ; poly_id <- addInlinePrags poly_id prag_sigs - ; spec_prags <- tcSpecPrags poly_id prag_sigs - -- tcPrags requires a zonked poly_id - - -- See Note [Impedance matching] - -- NB: we have already done checkValidType, including an ambiguity check, - -- on the type; either when we checked the sig or in mkInferredPolyId - ; let poly_ty = idType poly_id - sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty - -- This type is just going into tcSubType, - -- so Inferred vs. Specified doesn't matter - - ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility - 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 addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $ - tcSubType_NC sig_ctxt sel_poly_ty poly_ty - - ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures - ; when warn_missing_sigs $ - localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig - - ; return (ABE { abe_ext = noExtField - , abe_wrap = wrap - -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty) - , abe_poly = poly_id - , abe_mono = mono_id - , abe_prags = SpecPrags spec_prags }) } - where - prag_sigs = lookupPragEnv prag_fn poly_name - sig_ctxt = InfSigCtxt poly_name - -mkInferredPolyId :: Bool -- True <=> there was an insoluble error when - -- checking the binding group for this Id - -> [TyVar] -> TcThetaType - -> Name -> Maybe TcIdSigInst -> TcType - -> TcM TcId -mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty - | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst - , CompleteSig { sig_bndr = poly_id } <- sig - = return poly_id - - | otherwise -- Either no type sig or partial type sig - = checkNoErrs $ -- The checkNoErrs ensures that if the type is ambiguous - -- we don't carry on to the impedance matching, and generate - -- a duplicate ambiguity error. There is a similar - -- checkNoErrs for complete type signatures too. - do { fam_envs <- tcGetFamInstEnvs - ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty - -- Unification may not have normalised the type, - -- (see Note [Lazy flattening] in TcFlatten) so do it - -- here to make it as uncomplicated as possible. - -- Example: f :: [F Int] -> Bool - -- should be rewritten to f :: [Char] -> Bool, if possible - -- - -- We can discard the coercion _co, because we'll reconstruct - -- it in the call to tcSubType below - - ; (binders, theta') <- chooseInferredQuantifiers inferred_theta - (tyCoVarsOfType mono_ty') qtvs mb_sig_inst - - ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty') - - ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta' - , ppr inferred_poly_ty]) - ; unless insoluble $ - addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $ - 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. - - ; return (mkLocalId poly_name inferred_poly_ty) } - - -chooseInferredQuantifiers :: TcThetaType -- inferred - -> TcTyVarSet -- tvs free in tau type - -> [TcTyVar] -- inferred quantified tvs - -> Maybe TcIdSigInst - -> TcM ([TyVarBinder], TcThetaType) -chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing - = -- No type signature (partial or complete) for this binder, - do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs) - -- Include kind variables! #7916 - my_theta = pickCapturedPreds free_tvs inferred_theta - binders = [ mkTyVarBinder Inferred tv - | tv <- qtvs - , tv `elemVarSet` free_tvs ] - ; return (binders, my_theta) } - -chooseInferredQuantifiers inferred_theta tau_tvs qtvs - (Just (TISI { sig_inst_sig = sig -- Always PartialSig - , sig_inst_wcx = wcx - , sig_inst_theta = annotated_theta - , sig_inst_skols = annotated_tvs })) - = -- Choose quantifiers for a partial type signature - do { psig_qtv_prs <- zonkTyVarTyVarPairs annotated_tvs - - -- Check whether the quantified variables of the - -- partial signature have been unified together - -- See Note [Quantified variables in partial type signatures] - ; mapM_ report_dup_tyvar_tv_err (findDupTyVarTvs psig_qtv_prs) - - -- Check whether a quantified variable of the partial type - -- signature is not actually quantified. How can that happen? - -- See Note [Quantification and partial signatures] Wrinkle 4 - -- in TcSimplify - ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs - , not (tv `elem` qtvs) ] - - ; let psig_qtvs = mkVarSet (map snd psig_qtv_prs) - - ; annotated_theta <- zonkTcTypes annotated_theta - ; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx - - ; let keep_me = free_tvs `unionVarSet` psig_qtvs - final_qtvs = [ mkTyVarBinder vis tv - | tv <- qtvs -- Pulling from qtvs maintains original order - , tv `elemVarSet` keep_me - , let vis | tv `elemVarSet` psig_qtvs = Specified - | otherwise = Inferred ] - - ; return (final_qtvs, my_theta) } - where - report_dup_tyvar_tv_err (n1,n2) - | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig - = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1) - <+> text "with" <+> quotes (ppr n2)) - 2 (hang (text "both bound by the partial type signature:") - 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) - - | otherwise -- Can't happen; by now we know it's a partial sig - = pprPanic "report_tyvar_tv_err" (ppr sig) - - report_mono_sig_tv_err n - | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig - = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n)) - 2 (hang (text "bound by the partial type signature:") - 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) - | otherwise -- Can't happen; by now we know it's a partial sig - = pprPanic "report_mono_sig_tv_err" (ppr sig) - - choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType - -> TcM (VarSet, TcThetaType) - choose_psig_context _ annotated_theta Nothing - = do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta - `unionVarSet` tau_tvs) - ; return (free_tvs, annotated_theta) } - - choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty) - = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs) - -- growThetaVars just like the no-type-sig case - -- Omitting this caused #12844 - seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there - `unionVarSet` tau_tvs -- by the user - - ; let keep_me = psig_qtvs `unionVarSet` free_tvs - my_theta = pickCapturedPreds keep_me inferred_theta - - -- Fill in the extra-constraints wildcard hole with inferred_theta, - -- so that the Hole constraint we have already emitted - -- (in tcHsPartialSigType) can report what filled it in. - -- NB: my_theta already includes all the annotated constraints - ; let inferred_diff = [ pred - | pred <- my_theta - , all (not . (`eqType` pred)) annotated_theta ] - ; ctuple <- mk_ctuple inferred_diff - - ; case tcGetCastedTyVar_maybe wc_var_ty of - -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it - -- comes from the checkExpectedKind in TcHsType.tcAnonWildCardOcc. So, to - -- make the kinds work out, we reverse the cast here. - Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co) - Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty) - - ; traceTc "completeTheta" $ - vcat [ ppr sig - , ppr annotated_theta, ppr inferred_theta - , ppr inferred_diff ] - ; return (free_tvs, my_theta) } - - mk_ctuple preds = return (mkBoxedTupleTy preds) - -- Hack alert! See TcHsType: - -- Note [Extra-constraint holes in partial type signatures] - - -mk_impedance_match_msg :: MonoBindInfo - -> TcType -> TcType - -> TidyEnv -> TcM (TidyEnv, SDoc) --- This is a rare but rather awkward error messages -mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig }) - inf_ty sig_ty tidy_env - = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty - ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty - ; let msg = vcat [ text "When checking that the inferred type" - , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty - , text "is as general as its" <+> what <+> text "signature" - , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ] - ; return (tidy_env2, msg) } - where - what = case mb_sig of - Nothing -> text "inferred" - Just sig | isPartialSig sig -> text "(partial)" - | otherwise -> empty - - -mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (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" - , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ] - ; return (tidy_env1, msg) } - - --- | Warn the user about polymorphic local binders that lack type signatures. -localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM () -localSigWarn flag id mb_sig - | Just _ <- mb_sig = return () - | not (isSigmaTy (idType id)) = return () - | otherwise = warnMissingSignatures flag msg id - where - msg = text "Polymorphic local binding with no type signature:" - -warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM () -warnMissingSignatures flag msg id - = do { env0 <- tcInitTidyEnv - ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) - ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) } - where - mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ] - -checkOverloadedSig :: Bool -> TcIdSigInst -> 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 monomorphism_restriction_applies sig - | not (null (sig_inst_theta sig)) - , monomorphism_restriction_applies - , let orig_sig = sig_inst_sig sig - = setSrcSpan (sig_loc orig_sig) $ - failWith $ - hang (text "Overloaded signature conflicts with monomorphism restriction") - 2 (ppr orig_sig) - | otherwise - = return () - -{- Note [Partial type signatures and generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If /any/ of the signatures in the group is a partial type signature - f :: _ -> Int -then we *always* use the InferGen plan, and hence tcPolyInfer. -We do this even for a local binding with -XMonoLocalBinds, when -we normally use NoGen. - -Reasons: - * The TcSigInfo for 'f' has a unification variable for the '_', - whose TcLevel is one level deeper than the current level. - (See pushTcLevelM in tcTySig.) But NoGen doesn't increase - the TcLevel like InferGen, so we lose the level invariant. - - * The signature might be f :: forall a. _ -> a - so it really is polymorphic. It's not clear what it would - mean to use NoGen on this, and indeed the ASSERT in tcLhs, - in the (Just sig) case, checks that if there is a signature - then we are using LetLclBndr, and hence a nested AbsBinds with - increased TcLevel - -It might be possible to fix these difficulties somehow, but there -doesn't seem much point. Indeed, adding a partial type signature is a -way to get per-binding inferred generalisation. - -We apply the MR if /all/ of the partial signatures lack a context. -In particular (#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 - -Note [Quantified variables in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall a. a -> a -> _ - f x y = g x y - g :: forall b. b -> b -> _ - g x y = [x, y] - -Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b' -together, which is fine. So we bind 'a' and 'b' to TyVarTvs, which can then -unify with each other. - -But now consider: - f :: forall a b. a -> b -> _ - f x y = [x, y] - -We want to get an error from this, because 'a' and 'b' get unified. -So we make a test, one per partial signature, to check that the -explicitly-quantified type variables have not been unified together. -#14449 showed this up. - - -Note [Validity of inferred types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to check inferred type for validity, in case it uses language -extensions that are not turned on. The principle is that if the user -simply adds the inferred type to the program source, it'll compile fine. -See #8883. - -Examples that might fail: - - the type might be ambiguous - - - an inferred theta that requires type equalities e.g. (F a ~ G b) - or multi-parameter type classes - - an inferred type that includes unboxed tuples - - -Note [Impedance matching] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f 0 x = x - f n x = g [] (not x) - - g [] y = f 10 y - g _ y = f 9 y - -After typechecking we'll get - f_mono_ty :: a -> Bool -> Bool - g_mono_ty :: [b] -> Bool -> Bool -with constraints - (Eq a, Num a) - -Note that f is polymorphic in 'a' and g in 'b'; and these are not linked. -The types we really want for f and g are - f :: forall a. (Eq a, Num a) => a -> Bool -> Bool - g :: forall b. [b] -> Bool -> Bool - -We can get these by "impedance matching": - tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool) - tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono) - - f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f - g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g - -Suppose the shared quantified tyvars are qtvs and constraints theta. -Then we want to check that - 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. - -It also cleverly does an ambiguity check; for example, rejecting - f :: F a -> F a -where F is a non-injective type function. --} - - -{- -Note [SPECIALISE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~ -There is no point in a SPECIALISE pragma for a non-overloaded function: - reverse :: [a] -> [a] - {-# SPECIALISE reverse :: [Int] -> [Int] #-} - -But SPECIALISE INLINE *can* make sense for GADTS: - data Arr e where - ArrInt :: !Int -> ByteArray# -> Arr Int - ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2) - - (!:) :: Arr e -> Int -> e - {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-} - {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-} - (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i) - (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i) - -When (!:) is specialised it becomes non-recursive, and can usefully -be inlined. Scary! So we only warn for SPECIALISE *without* INLINE -for a non-overloaded function. - -************************************************************************ -* * - tcMonoBinds -* * -************************************************************************ - -@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. -The signatures have been dealt with already. --} - -data MonoBindInfo = MBI { mbi_poly_name :: Name - , mbi_sig :: Maybe TcIdSigInst - , mbi_mono_id :: TcId } - -tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes - -- i.e. the binders are mentioned in their RHSs, and - -- we are not rescued by a type signature - -> TcSigFun -> LetBndrSpec - -> [LHsBind GhcRn] - -> TcM (LHsBinds GhcTcId, [MonoBindInfo]) -tcMonoBinds is_rec sig_fn no_gen - [ L b_loc (FunBind { fun_id = L nm_loc name - , fun_matches = matches })] - -- Single function binding, - | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS - , Nothing <- sig_fn name -- ...with no type signature - = -- Note [Single function non-recursive binding special-case] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- In this very special case we infer the type of the - -- right hand side first (it may have a higher-rank type) - -- and *then* make the monomorphic Id for the LHS - -- e.g. f = \(x::forall a. a->a) -> - -- We want to infer a higher-rank type for f - setSrcSpan b_loc $ - do { ((co_fn, matches'), rhs_ty) - <- tcInferInst $ \ exp_ty -> - -- tcInferInst: see TcUnify, - -- Note [Deep instantiation of InferResult] in TcUnify - tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $ - -- We extend the error context even for a non-recursive - -- function so that in type error messages we show the - -- type of the thing whose rhs we are type checking - tcMatchesFun (L nm_loc name) matches exp_ty - - ; mono_id <- newLetBndr no_gen name rhs_ty - ; return (unitBag $ L b_loc $ - FunBind { fun_id = L nm_loc mono_id, - fun_matches = matches', - fun_ext = co_fn, fun_tick = [] }, - [MBI { mbi_poly_name = name - , mbi_sig = Nothing - , mbi_mono_id = mono_id }]) } - -tcMonoBinds _ sig_fn no_gen binds - = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds - - -- Bring the monomorphic Ids, into scope for the RHSs - ; let mono_infos = getMonoBindInfo tc_binds - rhs_id_env = [ (name, mono_id) - | MBI { mbi_poly_name = name - , mbi_sig = mb_sig - , mbi_mono_id = mono_id } <- mono_infos - , case mb_sig of - Just sig -> isPartialSig sig - Nothing -> True ] - -- A monomorphic binding for each term variable that lacks - -- a complete type sig. (Ones with a sig are already in scope.) - - ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) - | (n,id) <- rhs_id_env] - ; binds' <- tcExtendRecIds rhs_id_env $ - mapM (wrapLocM tcRhs) tc_binds - - ; return (listToBag binds', mono_infos) } - - ------------------------- --- tcLhs typechecks the LHS of the bindings, to construct the environment in which --- we typecheck the RHSs. Basically what we are doing is this: for each binder: --- if there's a signature for it, use the instantiated signature type --- otherwise invent a type variable --- You see that quite directly in the FunBind case. --- --- But there's a complication for pattern bindings: --- data T = MkT (forall a. a->a) --- MkT f = e --- Here we can guess a type variable for the entire LHS (which will be refined to T) --- but we want to get (f::forall a. a->a) as the RHS environment. --- The simplest way to do this is to typecheck the pattern, and then look up the --- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing --- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't - -data TcMonoBind -- Half completed; LHS done, RHS not done - = TcFunBind MonoBindInfo SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn)) - | TcPatBind [MonoBindInfo] (LPat GhcTcId) (GRHSs GhcRn (LHsExpr GhcRn)) - TcSigmaType - -tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind --- Only called with plan InferGen (LetBndrSpec = LetLclBndr) --- or NoGen (LetBndrSpec = LetGblBndr) --- CheckGen is used only for functions with a complete type signature, --- and tcPolyCheck doesn't use tcMonoBinds at all - -tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name - , fun_matches = matches }) - | Just (TcIdSig sig) <- sig_fn name - = -- There is a type signature. - -- It must be partial; if complete we'd be in tcPolyCheck! - -- e.g. f :: _ -> _ - -- f x = ...g... - -- Just g = ...f... - -- Hence always typechecked with InferGen - do { mono_info <- tcLhsSigId no_gen (name, sig) - ; return (TcFunBind mono_info nm_loc matches) } - - | otherwise -- No type signature - = do { mono_ty <- newOpenFlexiTyVarTy - ; mono_id <- newLetBndr no_gen name mono_ty - ; let mono_info = MBI { mbi_poly_name = name - , mbi_sig = Nothing - , mbi_mono_id = mono_id } - ; return (TcFunBind mono_info nm_loc matches) } - -tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) - = -- See Note [Typechecking pattern bindings] - do { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names - - ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $ - [ (mbi_poly_name mbi, mbi_mono_id mbi) - | mbi <- sig_mbis ] - - -- See Note [Existentials in pattern bindings] - ; ((pat', nosig_mbis), pat_ty) - <- addErrCtxt (patMonoBindsCtxt pat grhss) $ - tcInferNoInst $ \ exp_ty -> - tcLetPat inst_sig_fun no_gen pat exp_ty $ - mapM lookup_info nosig_names - - ; let mbis = sig_mbis ++ nosig_mbis - - ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id) - | mbi <- mbis, let id = mbi_mono_id mbi ] - $$ ppr no_gen) - - ; return (TcPatBind mbis pat' grhss pat_ty) } - where - bndr_names = collectPatBinders pat - (nosig_names, sig_names) = partitionWith find_sig bndr_names - - find_sig :: Name -> Either Name (Name, TcIdSigInfo) - find_sig name = case sig_fn name of - Just (TcIdSig sig) -> Right (name, sig) - _ -> Left name - - -- After typechecking the pattern, look up the binder - -- names that lack a signature, which the pattern has brought - -- into scope. - lookup_info :: Name -> TcM MonoBindInfo - lookup_info name - = do { mono_id <- tcLookupId name - ; return (MBI { mbi_poly_name = name - , mbi_sig = Nothing - , mbi_mono_id = mono_id }) } - -tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) - -- AbsBind, VarBind impossible - -------------------- -tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo -tcLhsSigId no_gen (name, sig) - = do { inst_sig <- tcInstSig sig - ; mono_id <- newSigLetBndr no_gen name inst_sig - ; return (MBI { mbi_poly_name = name - , mbi_sig = Just inst_sig - , mbi_mono_id = mono_id }) } - ------------- -newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId -newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig }) - | CompleteSig { sig_bndr = poly_id } <- id_sig - = addInlinePrags poly_id (lookupPragEnv prags name) -newSigLetBndr no_gen name (TISI { sig_inst_tau = tau }) - = newLetBndr no_gen name tau - -------------------- -tcRhs :: TcMonoBind -> TcM (HsBind GhcTcId) -tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) - loc matches) - = tcExtendIdBinderStackForRhs [info] $ - tcExtendTyVarEnvForRhs mb_sig $ - do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) - ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id)) - matches (mkCheckExpType $ idType mono_id) - ; return ( FunBind { fun_id = L loc mono_id - , fun_matches = matches' - , fun_ext = co_fn - , fun_tick = [] } ) } - -tcRhs (TcPatBind infos pat' grhss pat_ty) - = -- When we are doing pattern bindings we *don't* bring any scoped - -- type variables into scope unlike function bindings - -- Wny not? They are not completely rigid. - -- That's why we have the special case for a single FunBind in tcMonoBinds - tcExtendIdBinderStackForRhs infos $ - do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) - ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ - tcGRHSsPat grhss pat_ty - ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' - , pat_ext = NPatBindTc emptyNameSet pat_ty - , pat_ticks = ([],[]) } )} - -tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a -tcExtendTyVarEnvForRhs Nothing thing_inside - = thing_inside -tcExtendTyVarEnvForRhs (Just sig) thing_inside - = tcExtendTyVarEnvFromSig sig thing_inside - -tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a -tcExtendTyVarEnvFromSig sig_inst thing_inside - | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst - = tcExtendNameTyVarEnv wcs $ - tcExtendNameTyVarEnv skol_prs $ - thing_inside - -tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a --- Extend the TcBinderStack for the RHS of the binding, with --- the monomorphic Id. That way, if we have, say --- f = \x -> blah --- and something goes wrong in 'blah', we get a "relevant binding" --- looking like f :: alpha -> beta --- This applies if 'f' has a type signature too: --- f :: forall a. [a] -> [a] --- f x = True --- We can't unify True with [a], and a relevant binding is f :: [a] -> [a] --- If we had the *polymorphic* version of f in the TcBinderStack, it --- would not be reported as relevant, because its type is closed -tcExtendIdBinderStackForRhs infos thing_inside - = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel - | MBI { mbi_mono_id = mono_id } <- infos ] - thing_inside - -- NotTopLevel: it's a monomorphic binding - ---------------------- -getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo] -getMonoBindInfo tc_binds - = foldr (get_info . unLoc) [] tc_binds - where - get_info (TcFunBind info _ _) rest = info : rest - get_info (TcPatBind infos _ _ _) rest = infos ++ rest - - -{- Note [Typechecking pattern bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Look at: - - typecheck/should_compile/ExPat - - #12427, typecheck/should_compile/T12427{a,b} - - data T where - MkT :: Integral a => a -> Int -> T - -and suppose t :: T. Which of these pattern bindings are ok? - - E1. let { MkT p _ = t } in - - E2. let { MkT _ q = t } in - - E3. let { MkT (toInteger -> r) _ = t } in - -* (E1) is clearly wrong because the existential 'a' escapes. - What type could 'p' possibly have? - -* (E2) is fine, despite the existential pattern, because - q::Int, and nothing escapes. - -* Even (E3) is fine. The existential pattern binds a dictionary - for (Integral a) which the view pattern can use to convert the - a-valued field to an Integer, so r :: Integer. - -An easy way to see all three is to imagine the desugaring. -For (E2) it would look like - let q = case t of MkT _ q' -> q' - in - - -We typecheck pattern bindings as follows. First tcLhs does this: - - 1. Take each type signature q :: ty, partial or complete, and - instantiate it (with tcLhsSigId) to get a MonoBindInfo. This - gives us a fresh "mono_id" qm :: instantiate(ty), where qm has - a fresh name. - - Any fresh unification variables in instantiate(ty) born here, not - deep under implications as would happen if we allocated them when - we encountered q during tcPat. - - 2. Build a little environment mapping "q" -> "qm" for those Ids - with signatures (inst_sig_fun) - - 3. Invoke tcLetPat to typecheck the pattern. - - - We pass in the current TcLevel. This is captured by - TcPat.tcLetPat, and put into the pc_lvl field of PatCtxt, in - PatEnv. - - - When tcPat finds an existential constructor, it binds fresh - type variables and dictionaries as usual, increments the TcLevel, - and emits an implication constraint. - - - When we come to a binder (TcPat.tcPatBndr), it looks it up - in the little environment (the pc_sig_fn field of PatCtxt). - - Success => There was a type signature, so just use it, - checking compatibility with the expected type. - - Failure => No type signature. - Infer case: (happens only outside any constructor pattern) - use a unification variable - at the outer level pc_lvl - - Check case: use promoteTcType to promote the type - to the outer level pc_lvl. This is the - place where we emit a constraint that'll blow - up if existential capture takes place - - Result: the type of the binder is always at pc_lvl. This is - crucial. - - 4. Throughout, when we are making up an Id for the pattern-bound variables - (newLetBndr), we have two cases: - - - If we are generalising (generalisation plan is InferGen or - CheckGen), then the let_bndr_spec will be LetLclBndr. In that case - we want to bind a cloned, local version of the variable, with the - type given by the pattern context, *not* by the signature (even if - there is one; see #7268). The mkExport part of the - generalisation step will do the checking and impedance matching - against the signature. - - - If for some some reason we are not generalising (plan = NoGen), the - LetBndrSpec will be LetGblBndr. In that case we must bind the - global version of the Id, and do so with precisely the type given - in the signature. (Then we unify with the type from the pattern - context type.) - - -And that's it! The implication constraints check for the skolem -escape. It's quite simple and neat, and more expressive than before -e.g. GHC 8.0 rejects (E2) and (E3). - -Example for (E1), starting at level 1. We generate - p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta) -The (a~beta) can't float (because of the 'a'), nor be solved (because -beta is untouchable.) - -Example for (E2), we generate - q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta) -The beta is untouchable, but floats out of the constraint and can -be solved absolutely fine. - - -************************************************************************ -* * - Generalisation -* * -********************************************************************* -} - -data GeneralisationPlan - = NoGen -- No generalisation, no AbsBinds - - | InferGen -- Implicit generalisation; there is an AbsBinds - Bool -- True <=> apply the MR; generalise only unconstrained type vars - - | CheckGen (LHsBind GhcRn) TcIdSigInfo - -- One FunBind with a signature - -- Explicit generalisation - --- A consequence of the no-AbsBinds choice (NoGen) is that there is --- no "polymorphic Id" and "monmomorphic Id"; there is just the one - -instance Outputable GeneralisationPlan where - ppr NoGen = text "NoGen" - ppr (InferGen b) = text "InferGen" <+> ppr b - ppr (CheckGen _ s) = text "CheckGen" <+> ppr s - -decideGeneralisationPlan - :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun - -> GeneralisationPlan -decideGeneralisationPlan dflags lbinds closed sig_fn - | has_partial_sigs = InferGen (and partial_sig_mrs) - | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig - | do_not_generalise closed = NoGen - | otherwise = InferGen mono_restriction - where - binds = map unLoc lbinds - - partial_sig_mrs :: [Bool] - -- One for each partial signature (so empty => no partial sigs) - -- The Bool is True if the signature has no constraint context - -- so we should apply the MR - -- See Note [Partial type signatures and generalisation] - partial_sig_mrs - = [ null theta - | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) - <- mapMaybe sig_fn (collectHsBindListBinders lbinds) - , let (_, L _ theta, _) = splitLHsSigmaTyInvis (hsSigWcType hs_ty) ] - - has_partial_sigs = not (null partial_sig_mrs) - - mono_restriction = xopt LangExt.MonomorphismRestriction dflags - && any restricted binds - - do_not_generalise (IsGroupClosed _ True) = False - -- The 'True' means that all of the group's - -- free vars have ClosedTypeId=True; so we can ignore - -- -XMonoLocalBinds, and generalise anyway - do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags - - -- With OutsideIn, all nested bindings are monomorphic - -- except a single function binding with a signature - one_funbind_with_sig - | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds - , Just (TcIdSig sig) <- sig_fn (unLoc v) - = Just (lbind, sig) - | otherwise - = Nothing - - -- The Haskell 98 monomorphism restriction - 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) - - restricted_match mg = matchGroupArity mg == 0 - -- No args => like a pattern binding - -- Some args => a function binding - - no_sig n = not (hasCompleteSig sig_fn n) - -isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed -isClosedBndrGroup type_env binds - = IsGroupClosed fv_env type_closed - where - type_closed = allUFM (nameSetAll is_closed_type_id) fv_env - - fv_env :: NameEnv NameSet - fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds - - bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)] - bindFvs (FunBind { fun_id = L _ f - , fun_ext = fvs }) - = let open_fvs = get_open_fvs fvs - in [(f, open_fvs)] - bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs }) - = let open_fvs = get_open_fvs fvs - in [(b, open_fvs) | b <- collectPatBinders pat] - bindFvs _ - = [] - - get_open_fvs fvs = filterNameSet (not . is_closed) fvs - - is_closed :: Name -> ClosedTypeId - is_closed name - | Just thing <- lookupNameEnv type_env name - = case thing of - AGlobal {} -> True - ATcId { tct_info = ClosedLet } -> True - _ -> False - - | otherwise - = True -- The free-var set for a top level binding mentions - - - is_closed_type_id :: Name -> Bool - -- We're already removed Global and ClosedLet Ids - is_closed_type_id name - | Just thing <- lookupNameEnv type_env name - = case thing of - ATcId { tct_info = NonClosedLet _ cl } -> cl - ATcId { tct_info = NotLetBound } -> False - ATyVar {} -> False - -- In-scope type variables are not closed! - _ -> pprPanic "is_closed_id" (ppr name) - - | otherwise - = True -- The free-var set for a top level binding mentions - -- imported things too, so that we can report unused imports - -- These won't be in the local type env. - -- Ditto class method etc from the current module - - -{- ********************************************************************* -* * - Error contexts and messages -* * -********************************************************************* -} - --- This one is called on LHS, when pat and grhss are both Name --- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: (OutputableBndrId p, Outputable body) - => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc -patMonoBindsCtxt pat grhss - = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs deleted file mode 100644 --- a/compiler/typecheck/TcCanonical.hs +++ /dev/null @@ -1,2542 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -module TcCanonical( - canonicalize, - unifyDerived, - makeSuperClasses, maybeSym, - StopOrContinue(..), stopWith, continueWith, - solveCallStack -- For TcSimplify - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Constraint -import GHC.Core.Predicate -import TcOrigin -import TcUnify( swapOverTyVars, metaTyVarUpdateOK, MetaTyVarUpdateResult(..) ) -import TcType -import GHC.Core.Type -import TcFlatten -import TcSMonad -import TcEvidence -import TcEvTerm -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking -import GHC.Core.Coercion -import GHC.Core -import GHC.Types.Id( idType, mkTemplateLocals ) -import GHC.Core.FamInstEnv ( FamInstEnvs ) -import FamInst ( tcTopNormaliseNewTypeTF_maybe ) -import GHC.Types.Var -import GHC.Types.Var.Env( mkInScopeSet ) -import GHC.Types.Var.Set( delVarSetList ) -import GHC.Types.Name.Occurrence ( OccName ) -import Outputable -import GHC.Driver.Session( DynFlags ) -import GHC.Types.Name.Set -import GHC.Types.Name.Reader -import GHC.Hs.Types( HsIPName(..) ) - -import Pair -import Util -import Bag -import MonadUtils -import Control.Monad -import Data.Maybe ( isJust ) -import Data.List ( zip4 ) -import GHC.Types.Basic - -import Data.Bifunctor ( bimap ) -import Data.Foldable ( traverse_ ) - -{- -************************************************************************ -* * -* 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 (except for CHoleCans, arising from holes). 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 flattened and then decomposed into one of several forms -(see type Ct in TcRnTypes). - -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" #-} - 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 OtherCIS ev - ForAllPred tvs theta p -> do traceTcS "canEvNC:forall" (ppr pred) - canForAllNC ev tvs theta p - where - pred = ctEvPred ev - -canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc })) - = canForAll ev pend_sc - -canonicalize (CIrredCan { cc_ev = ev, cc_status = status }) - | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev) - = -- For insolubles (all of which are equalities, do /not/ flatten 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 - canEqNC ev eq_rel ty1 ty2 - - | otherwise - = canIrred status ev - -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 (CTyEqCan { cc_ev = ev - , cc_tyvar = tv - , cc_rhs = xi - , cc_eq_rel = eq_rel }) - = {-# SCC "canEqLeafTyVarEq" #-} - canEqNC ev eq_rel (mkTyVarTy tv) xi - -- NB: Don't use canEqTyVar because that expects flattened types, - -- and tv and xi may not be flat w.r.t. an updated inert set - -canonicalize (CFunEqCan { cc_ev = ev - , cc_fun = fn - , cc_tyargs = xis1 - , cc_fsk = fsk }) - = {-# SCC "canEqLeafFunEq" #-} - canCFunEqCan ev fn xis1 fsk - -canonicalize (CHoleCan { cc_ev = ev, cc_occ = occ, cc_hole = hole }) - = canHole ev occ hole - -{- -************************************************************************ -* * -* 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 } - - | isWanted ev - , Just ip_name <- isCallStackPred cls tys - , OccurrenceOf func <- ctLocOrigin loc - -- 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 TcEvidence - -- and Note [Solving CallStack constraints] in TcSMonad - = 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] - - ; new_ev <- newWantedEvVarNC new_loc pred - - -- Then we solve the wanted by pushing the call-site - -- onto the newly emitted CallStack - ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev) - ; solveCallStack ev ev_cs - - ; canClass new_ev cls tys False } - - | otherwise - = canClass ev cls tys (has_scs cls) - - where - has_scs cls = not (null (classSCTheta cls)) - loc = ctEvLoc ev - pred = ctEvPred ev - -solveCallStack :: CtEvidence -> EvCallStack -> TcS () --- Also called from TcSimplify 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 - ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys ) - do { (xis, cos, _kind_co) <- flattenArgsNom ev cls_tc tys - ; MASSERT( isTcReflCo _kind_co ) - ; let co = mkTcTyConAppCo Nominal cls_tc cos - xi = mkClassPred cls xis - mk_ct new_ev = CDictCan { cc_ev = new_ev - , cc_tyargs = xis - , cc_class = cls - , cc_pend_sc = pend_sc } - ; mb <- rewriteEvidence ev xi co - ; 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], and deriveds [WD], [D], 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 [D] (C Int beta) constraint. It's derived because - we don't actually have to cough up any evidence for it; it's only there - to generate fundep equalities. - -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 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 Constraint) - try harder: take both the Givens and Wanteds, and expand - superclasses again. See the calls to expandSuperClasses in - TcSimplify.simpl_loop and solveWanteds. - - This may succeed in generating (a finite number of) extra Givens, - and extra Deriveds. 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 TcSimplify.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 -XNoRecursiveSuperClasses - 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 -TcInteract. 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 TcInteract. - -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 [D] 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 - [D] F a ~ beta - Now we get [D] beta ~ b, and can solve that. - - -- Example (tcfail138) - class L a b | a -> b - class (G a, L a b) => C a b - - instance C a b' => G (Maybe a) - instance C a b => C (Maybe a) a - instance L (Maybe a) a - - When solving the superclasses of the (C (Maybe a) a) instance, we get - [G] C a b, and hance by superclasses, [G] G a, [G] L a b - [W] G (Maybe a) - Use the instance decl to get - [W] C a beta - Generate its derived superclass - [D] L a beta. Now using fundeps, combine with [G] L a b to get - [D] beta ~ b - which is what we want. - -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 - [D] RealOf e ~ fuv - [D] 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. - -Mind you, now that Wanteds cannot rewrite Derived, I think this particular -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 superclasses story] --- See Note [The superclass story] --- The loop-breaking here follows Note [Expanding superclasses] in 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 })) - = ASSERT2( 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 (mk_given_loc loc)) $ - classSCSelIds cls - where - dict_ids = mkTemplateLocals theta - size = sizeTypes tys - - do_one_given given_loc sel_id - | isUnliftedType sc_pred - , not (null tvs && null theta) - = -- See Note [Equality superclasses in quantified constraints] - return [] - | otherwise - = do { given_ev <- newGivenEvVar given_loc $ - mk_given_desc sel_id sc_pred - ; mk_superclasses rec_clss given_ev tvs theta sc_pred } - where - sc_pred = funResultTy (piResultTys (idType 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) = splitForAllTys sc_pred - (sc_theta, sc_inner_pred) = splitFunTys sc_rho - - all_tvs = tvs `chkAppend` sc_tvs - all_theta = theta `chkAppend` 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 - - mk_given_loc loc - | isCTupleClass cls - = loc -- For tuple predicates, just take them apart, without - -- adding their (large) size into the chain. When we - -- get down to a base predicate, we'll include its size. - -- #10335 - - | GivenOrigin skol_info <- ctLocOrigin loc - -- See Note [Solving superclass constraints] in TcInstDcls - -- for explantation of this transformation for givens - = case skol_info of - InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) } - InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) } - _ -> loc - - | otherwise -- Probably doesn't happen, since this function - = loc -- is only used for Givens, but does no harm - -mk_strict_superclasses rec_clss ev tvs theta cls tys - | all noFreeVarsOfType tys - = return [] -- Wanteds with no variables yield no deriveds. - -- See Note [Improvement from Ground Wanteds] - - | otherwise -- Wanted/Derived case, just add Derived superclasses - -- that can lead to improvement. - = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta ) - concatMapM do_one_derived (immSuperClasses cls tys) - where - loc = ctEvLoc ev - - do_one_derived sc_pred - = do { sc_ev <- newDerivedNC loc 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 [D] C Bool Int? No! The only point of -emitting superclass constraints for W/D 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 -TcInteract.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 TcInteract.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 :: CtIrredStatus -> CtEvidence -> TcS (StopOrContinue Ct) --- Precondition: ty not a tuple and no other evidence form -canIrred status ev - = do { let pred = ctEvPred ev - ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred) - ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred - ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> - do { -- Re-classify, in case flattening has improved its shape - ; case classifyPredType (ctEvPred new_ev) of - ClassPred cls tys -> canClassNC new_ev cls tys - EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2 - _ -> continueWith $ - mkIrredCt status new_ev } } - -canHole :: CtEvidence -> OccName -> HoleSort -> TcS (StopOrContinue Ct) -canHole ev occ hole_sort - = do { let pred = ctEvPred ev - ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred - ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> - do { updInertIrreds (`snocCts` (CHoleCan { cc_ev = new_ev - , cc_occ = occ - , cc_hole = hole_sort })) - ; stopWith new_ev "Emit insoluble hole" } } - - -{- ********************************************************************* -* * -* Quantified predicates -* * -********************************************************************* -} - -{- 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 - - * TcSMonad.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 - TcInteract.matchInstEnv, use the InstEnv from inert_insts - so that we include the local Given forall-constraints - in the lookup. (See TcSMonad.getInstEnvs.) - - * TcCanonical.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 TcSMonad.kick_out_rewritable - -Note that a quantified constraint is never /inferred/ -(by TcSimplify.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 - -- Do not bother with type-family reductions; we can't - -- do them under a forall anyway (c.f. Flatten.flatten_one - -- on a forall type) - let pred = ctEvPred ev - ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred - ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> - - do { -- Now decompose into its pieces and solve it - -- (It takes a lot less code to flatten 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 tvs theta pred pend_sc - | CtWanted { ctev_dest = dest } <- ev - = -- See Note [Solving a Wanted forall-constraint] - do { let skol_info = QuantCtxtSkol - empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs - ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs - ; given_ev_vars <- mapM newEvVar (substTheta subst theta) - - ; (lvl, (w_id, wanteds)) - <- pushLevelNoWorkList (ppr skol_info) $ - do { wanted_ev <- newWantedEvVarNC loc $ - substTy subst pred - ; return ( ctEvEvId wanted_ev - , unitBag (mkNonCanonical wanted_ev)) } - - ; ev_binds <- emitImplicationTcS lvl 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" } - - | isGiven ev -- See Note [Solving a Given forall-constraint] - = do { addInertForAll qci - ; stopWith ev "Given forall-constraint" } - - | otherwise - = do { traceTcS "discarding derived forall-constraint" (ppr ev) - ; stopWith ev "Derived forall-constraint" } - where - loc = ctEvLoc ev - 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. - -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 flattening but similar after flattening. -However, we don't just want to jump in and flatten right away, because -this might be wasted effort. So, after looking for similarities and failing, -we flatten and then try again. Of course, we don't want to loop, so we -track whether or not we've already flattened. - -It is conceivable to do a better job at tracking whether or not a type -is flattened, but this is left as future work. (Mar '15) - - -Note [FunTy and decomposing tycon applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When can_eq_nc' attempts to decompose a tycon application we haven't yet 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. tcRepSplitTyConApp_maybe panics in the event -that it sees such a type as it cannot determine the RuntimeReps which the (->) -is applied to. Consequently, it is vital that we instead use -tcRepSplitTyConApp_maybe', which simply returns Nothing in such a case. - -When this happens can_eq_nc' will fail to decompose, zonk, and try again. -Zonking should fill the variable k, meaning that decomposition will succeed the -second time around. --} - -canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct) -canEqNC ev eq_rel ty1 ty2 - = do { result <- zonk_eq_types ty1 ty2 - ; case result of - Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2 - Right ty -> canEqReflexive ev eq_rel ty } - -can_eq_nc - :: Bool -- True => both types are flat - -> 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) -can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - = do { traceTcS "can_eq_nc" $ - vcat [ ppr flat, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ] - ; rdr_env <- getGlobalRdrEnvTcS - ; fam_insts <- getFamInstEnvs - ; can_eq_nc' flat rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 } - -can_eq_nc' - :: Bool -- True => both input types are flattened - -> 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) - --- Expand synonyms first; see Note [Type synonyms and canonicalization] -can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - | Just ty1' <- tcView ty1 = can_eq_nc' flat rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2 - | Just ty2' <- tcView ty2 = can_eq_nc' flat 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 flat because the zonk_eq_types check in canEqNC takes --- care of the non-flat 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' _flat 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' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2 - | not (isTyVarTy ty2) -- See (3) in Note [Equalities with incompatible kinds] - = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 -can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _ - | not (isTyVarTy ty1) -- See (3) in Note [Equalities with incompatible kinds] - = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1 - --- NB: pattern match on True: we want only flat types sent to canEqTyVar. --- See also Note [No top-level newtypes on RHS of representational equalities] -can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2 - = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2 -can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2 - = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1 - ----------------------- --- Otherwise try to decompose ----------------------- - --- Literals -can_eq_nc' _flat _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" } - --- Try to decompose type constructor applications --- Including FunTy (s -> t) -can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _ - --- See Note [FunTy and decomposing type constructor applications]. - | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1 - , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2 - , not (isTypeFamilyTyCon tc1) - , not (isTypeFamilyTyCon tc2) - = canTyConApp ev eq_rel tc1 tys1 tc2 tys2 - -can_eq_nc' _flat _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 flat types -can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _ - | NomEq <- eq_rel - , Just (t2, s2) <- tcSplitAppTy_maybe ty2 - = can_eq_app ev t1 s1 t2 s2 -can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _ - | NomEq <- eq_rel - , Just (t1, s1) <- tcSplitAppTy_maybe ty1 - = can_eq_app ev t1 s1 t2 s2 - --- No similarity in type structure detected. Flatten and try again. -can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 - = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1 - ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2 - ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 - ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } - --- We've flattened 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 OtherCIS ev) - NomEq -> continueWith (mkIrredCt InsolubleCIS ev) } - -- No need to call canEqFailure/canEqHardFailure because they - -- flatten, and the types involved here are already flat - -{- 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 } <- ev - = do { let free_tvs = tyCoVarsOfTypes [s1,s2] - (bndrs1, phi1) = tcSplitForAllVarBndrs s1 - (bndrs2, phi2) = tcSplitForAllVarBndrs s2 - ; if not (equalLength bndrs1 bndrs2) - then do { traceTcS "Forall failure" $ - vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 - , ppr (map binderArgFlag bndrs1) - , ppr (map binderArgFlag bndrs2) ] - ; canEqHardFailure ev s1 s2 } - else - do { traceTcS "Creating implication for polytype equality" $ ppr ev - ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs - ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $ - binderVars bndrs1 - - ; let skol_info = UnifyForAllSkol phi1 - phi1' = substTy subst1 phi1 - - -- Unify the kinds, extend the substitution - go :: [TcTyVar] -> TCvSubst -> [TyVarBinder] - -> TcS (TcCoercion, Cts) - go (skol_tv:skol_tvs) subst (bndr2:bndrs2) - = do { let tv2 = binderVar bndr2 - ; (kind_co, wanteds1) <- unify loc 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 ( mkTcForAllCo skol_tv kind_co co - , wanteds1 `unionBags` wanteds2 ) } - - -- Done: unify phi1 ~ phi2 - go [] subst bndrs2 - = ASSERT( null bndrs2 ) - unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2) - - go _ _ _ = panic "cna_eq_nc_forall" -- case (s:ss) [] - - empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1) - - ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ - go skol_tvs empty_subst2 bndrs2 - ; emitTvImplicationTcS lvl 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 -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts) - -- This version returns the wanted constraint rather - -- than putting it in the work list - unify loc role ty1 ty2 - | ty1 `tcEqType` ty2 - = return (mkTcReflCo role ty1, emptyBag) - | otherwise - = do { (wanted, co) <- newWantedEq loc 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 --- flattening, 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 ty1 ty2 - | Just (arg1, res1) <- split1 - , Just (arg2, res2) <- split2 - = do { res_a <- go arg1 arg2 - ; res_b <- go res1 res2 - ; return $ combine_rev mkVisFunTy res_b res_a - } - | isJust split1 || isJust split2 - = bale_out ty1 ty2 - where - split1 = tcSplitFunTy_maybe ty1 - split2 = tcSplitFunTy_maybe ty2 - - go ty1 ty2 - | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1 - , Just (tc2, tys2) <- repSplitTyConApp_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) <- tcRepSplitAppTy_maybe ty1 - , Just (ty2a, ty2b) <- tcRepSplitAppTy_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 flattening. 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) - -{- See Note [Unwrap newtypes first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - newtype N m a = MkN (m a) -Then 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. - -Bottom line: unwrap newtypes before decomposing them! -c.f. #9123 comment:52,53 for a compelling example. - -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 when unwrapping newtypes. - -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 flattener 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.) --} - ------------------------- --- | 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, co), ty1') ty2 ps_ty2 - = do { traceTcS "can_eq_newtype_nc" $ - vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ] - - -- check for blowing our stack: - -- See Note [Newtypes can blow the stack] - ; checkReductionDepth (ctEvLoc ev) ty1 - - -- Next, we record uses of newtype constructors, since coercing - -- through newtypes is tantamount to using their constructors. - ; addUsedGREs gre_list - -- If a newtype constructor was imported, don't warn about not - -- importing it... - ; traverse_ keepAlive $ map gre_name 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 TcRnTypes. - - ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2 - (mkTcSymCo co) (mkTcReflCo Representational ps_ty2) - ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 } - where - gre_list = bagToList gres - ---------- --- ^ Decompose a type application. --- All input types must be flat. 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 equality], note {4} -can_eq_app ev s1 t1 s2 t2 - | CtDerived {} <- ev - = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2] - ; stopWith ev "Decomposed [D] AppTy" } - | CtWanted { ctev_dest = dest } <- ev - = do { co_s <- unifyWanted loc Nominal s1 s2 - ; let arg_loc - | isNextArgVisible s1 = loc - | otherwise = updateCtLocOrigin loc toInvisibleOrigin - ; co_t <- unifyWanted 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 = mkTcCoVarCo evar - co_s = mkTcLRCo CLeft co - co_t = mkTcLRCo 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 = tcTypeKind s1 - s2k = tcTypeKind 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 flat? - -> CtEvidence - -> EqRel - -> SwapFlag - -> TcType -> Coercion -- LHS (res. RHS), ty1 |> co1 - -> TcType -> TcType -- RHS (res. LHS), ty2 both normal and pretty - -> TcS (StopOrContinue Ct) -canEqCast flat 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 ev swapped ty1 ps_ty2 - (mkTcGReflRightCo role ty1 co1) - (mkTcReflCo role ps_ty2) - ; can_eq_nc flat 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 TyConApps] -canTyConApp ev eq_rel tc1 tys1 tc2 tys2 - | tc1 == tc2 - , tys1 `equalLength` tys2 - = do { inerts <- getTcSInerts - ; if can_decompose inerts - then do { traceTcS "canTyConApp" - (ppr ev $$ ppr eq_rel $$ ppr tc1 $$ ppr tys1 $$ ppr tys2) - ; canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2 - ; stopWith ev "Decomposed TyConApp" } - else canEqFailure ev eq_rel ty1 ty2 } - - -- See Note [Skolem abstract data] (at tyConSkolem) - | tyConSkolem tc1 || tyConSkolem tc2 - = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2) - ; continueWith (mkIrredCt OtherCIS 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 - ty1 = mkTyConApp tc1 tys1 - ty2 = mkTyConApp tc2 tys2 - - loc = ctEvLoc ev - pred = ctEvPred ev - - -- See Note [Decomposing equality] - can_decompose inerts - = isInjectiveTyCon tc1 (eqRelRole eq_rel) - || (ctEvFlavour ev /= Given && isEmptyBag (matchableGivens loc pred inerts)) - -{- -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 [Decomposing equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have a constraint (of any flavour and role) that looks like -T tys1 ~ T tys2, what can we conclude about tys1 and tys2? The answer, -of course, is "it depends". This Note spells it all out. - -In this Note, "decomposition" refers to taking the constraint - [fl] (T tys1 ~X T tys2) -(for some flavour fl and some role X) and replacing it with - [fls'] (tys1 ~Xs' tys2) -where that notation indicates a list of new constraints, where the -new constraints may have different flavours and different roles. - -The key property to consider is injectivity. When decomposing a Given the -decomposition is sound if and only if T is injective in all of its type -arguments. When decomposing a Wanted, the decomposition is sound (assuming the -correct roles in the produced equality constraints), but it may be a guess -- -that is, an unforced decision by the constraint solver. Decomposing Wanteds -over injective TyCons does not entail guessing. But sometimes we want to -decompose a Wanted even when the TyCon involved is not injective! (See below.) - -So, in broad strokes, we want this rule: - -(*) Decompose a constraint (T tys1 ~X T tys2) if and only if T is injective -at role X. - -Pursuing the details requires exploring three axes: -* Flavour: Given vs. Derived vs. Wanted -* Role: Nominal vs. Representational -* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable - -(So a type variable isn't a TyCon, but it's convenient to put the AppTy case -in the same table.) - -Right away, we can say that Derived behaves just as Wanted for the purposes -of decomposition. The difference between Derived and Wanted is the handling of -evidence. Since decomposition in these cases isn't a matter of soundness but of -guessing, we want the same behavior regardless of evidence. - -Here is a table (discussion following) detailing where decomposition of - (T s1 ... sn) ~r (T t1 .. tn) -is allowed. The first four lines (Data types ... type family) refer -to TyConApps with various TyCons T; the last line is for AppTy, where -there is presumably a type variable at the head, so it's actually - (s s1 ... sn) ~r (t t1 .. tn) - -NOMINAL GIVEN WANTED - -Datatype YES YES -Newtype YES YES -Data family YES YES -Type family YES, in injective args{1} YES, in injective args{1} -Type variable YES YES - -REPRESENTATIONAL GIVEN WANTED - -Datatype YES YES -Newtype NO{2} MAYBE{2} -Data family NO{3} MAYBE{3} -Type family NO NO -Type variable NO{4} NO{4} - -{1}: Type families can be injective in some, but not all, of their arguments, -so we want to do partial decomposition. This is quite different than the way -other decomposition is done, where the decomposed equalities replace the original -one. We thus proceed much like we do with superclasses: emitting new Givens -when "decomposing" a partially-injective type family Given and new Deriveds -when "decomposing" a partially-injective type family Wanted. (As of the time of -writing, 13 June 2015, the implementation of injective type families has not -been merged, but it should be soon. Please delete this parenthetical if the -implementation is indeed merged.) - -{2}: See Note [Decomposing newtypes at representational role] - -{3}: Because of the possibility of newtype instances, we must treat -data families like newtypes. See also Note [Decomposing newtypes at -representational role]. See #10534 and test case -typecheck/should_fail/T10534. - -{4}: Because type variables can stand in for newtypes, we conservatively do not -decompose AppTys over representational equality. - -In the implementation of can_eq_nc and friends, we don't directly pattern -match using lines like in the tables above, as those tables don't cover -all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity, -boiling the tables above down to rule (*). The exceptions to rule (*) are for -injective type families, which are handled separately from other decompositions, -and the MAYBE entries above. - -Note [Decomposing newtypes at representational role] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This note discusses the 'newtype' line in the REPRESENTATIONAL table -in Note [Decomposing equality]. (At nominal role, newtypes are fully -decomposable.) - -Here is a representative example of why representational equality over -newtypes is tricky: - - 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 - -If we have [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. Here's another example. - - 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: - * Unwrap newtypes before attempting to decompose them. - This is done in can_eq_nc'. - -It all comes from the fact that newtypes aren't necessarily injective -w.r.t. representational equality. - -Furthermore, as explained in Note [NthCo and newtypes] in GHC.Core.TyCo.Rep, we can't use -NthCo on representational coercions over newtypes. NthCo comes into play -only when decomposing givens. - -Conclusion: - * Do not decompose [G] N s ~R N t - -Is it sensible to decompose *Wanted* constraints over newtypes? Yes! -It's the only way we could ever prove (IO Int ~R IO Age), recalling -that IO is a newtype. - -However we must be careful. Consider - - type role Nt representational - - [G] Nt a ~R Nt b (1) - [W] NT alpha ~R Nt b (2) - [W] alpha ~ a (3) - -If we focus on (3) first, we'll substitute in (2), and now it's -identical to the given (1), so we succeed. But if we focus on (2) -first, and decompose it, we'll get (alpha ~R b), which is not soluble. -This is exactly like the question of overlapping Givens for class -constraints: see Note [Instance and Given overlap] in TcInteract. - -Conclusion: - * Decompose [W] N s ~R N t iff there no given constraint that could - later solve it. - --} - -canDecomposableTyConAppOK :: CtEvidence -> EqRel - -> TyCon -> [TcType] -> [TcType] - -> TcS () --- Precondition: tys1 and tys2 are the same length, hence "OK" -canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 - = ASSERT( tys1 `equalLength` tys2 ) - case ev of - CtDerived {} - -> unifyDeriveds loc tc_roles tys1 tys2 - - 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 - -> do { cos <- zipWith4M unifyWanted 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 $ mkNthCo r i ev_co ) - | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] - , r /= Phantom - , not (isCoercionTy ty1) && not (isCoercionTy ty2) ] - ; emitWorkNC given_evs } - where - loc = ctEvLoc ev - role = eqRelRole eq_rel - - -- infinite, as tyConRolesX returns an infinite tail of Nominal - tc_roles = tyConRolesX 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 | isVisibleTyConBinder bndr - = updateCtLocOrigin new_loc0 toInvisibleOrigin - | otherwise - = new_loc0 ] - ++ repeat loc - --- | 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 { (xi1, co1) <- flatten FM_FlattenAll ev ty1 - ; (xi2, co2) <- flatten FM_FlattenAll ev ty2 - -- We must flatten 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 ty1, ppr ty2, ppr xi1, ppr xi2 ] - ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 - ; continueWith (mkIrredCt OtherCIS 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 { (s1, co1) <- flatten FM_SubstOnly ev ty1 - ; (s2, co2) <- flatten FM_SubstOnly ev ty2 - ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2 - ; continueWith (mkIrredCt InsolubleCIS new_ev) } - -{- -Note [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 decomopose 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 canDecomposableTyCon is a fast-path decomposition that uses -unifyWanted etc to short-cut that work. - -Note [Canonicalising type applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (s1 t1) ~ ty2, how should we proceed? -The simple things is to see if ty2 is of form (s2 t2), and -decompose. By this time s1 and s2 can't be saturated type -function applications, because those have been dealt with -by an earlier equation in can_eq_nc, so it is always sound to -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 flattens 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 TcSMonad. -And if we don't do this there is a bad danger that -TcSimplify.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 [Combining insoluble constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As this point we have an insoluble constraint, like Int~Bool. - - * If it is Wanted, delete it from the cache, so that subsequent - Int~Bool constraints give rise to separate error messages - - * But if it is Derived, DO NOT delete from cache. A class constraint - may get kicked out of the inert set, and then have its functional - dependency Derived constraints generated a second time. In that - case we don't want to get two (or more) error messages by - generating two (or more) insoluble fundep constraints from the same - class constraint. - -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 canEqTyVar sees [W] a ~R a, after b is flattened -and the Id newtype is unwrapped. This is assured by requiring only flat -types in canEqTyVar *and* having the newtype-unwrapping check above -the tyvar check in can_eq_nc. - -Note [Occurs check error] -~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an occurs check error, are we necessarily hosed? Say our -tyvar is tv1 and the type it appears in is xi2. Because xi2 is function -free, then if we're computing w.r.t. nominal equality, then, yes, we're -hosed. Nothing good can come from (a ~ [a]). If we're computing w.r.t. -representational equality, this is a little subtler. Once again, (a ~R [a]) -is a bad thing, but (a ~R N a) for a newtype N might be just fine. This -means also that (a ~ b a) might be fine, because `b` might become a newtype. - -So, we must check: does tv1 appear in xi2 under any type constructor -that is generative w.r.t. representational equality? That's what -isInsolubleOccursCheck does. - -See also #10715, which induced this addition. - -Note [canCFunEqCan] -~~~~~~~~~~~~~~~~~~~ -Flattening the arguments to a type family can change the kind of the type -family application. As an easy example, consider (Any k) where (k ~ Type) -is in the inert set. The original (Any k :: k) becomes (Any Type :: Type). -The problem here is that the fsk in the CFunEqCan will have the old kind. - -The solution is to come up with a new fsk/fmv of the right kind. For -givens, this is easy: just introduce a new fsk and update the flat-cache -with the new one. For wanteds, we want to solve the old one if favor of -the new one, so we use dischargeFmv. This also kicks out constraints -from the inert set; this behavior is correct, as the kind-change may -allow more constraints to be solved. - -We use `isTcReflexiveCo`, to ensure that we only use the hetero-kinded case -if we really need to. Of course `flattenArgsNom` should return `Refl` -whenever possible, but #15577 was an infinite loop because even -though the coercion was homo-kinded, `kind_co` was not `Refl`, so we -made a new (identical) CFunEqCan, and then the entire process repeated. --} - -canCFunEqCan :: CtEvidence - -> TyCon -> [TcType] -- LHS - -> TcTyVar -- RHS - -> TcS (StopOrContinue Ct) --- ^ Canonicalise a CFunEqCan. We know that --- the arg types are already flat, --- and the RHS is a fsk, which we must *not* substitute. --- So just substitute in the LHS -canCFunEqCan ev fn tys fsk - = do { (tys', cos, kind_co) <- flattenArgsNom ev fn tys - -- cos :: tys' ~ tys - - ; let lhs_co = mkTcTyConAppCo Nominal fn cos - -- :: F tys' ~ F tys - new_lhs = mkTyConApp fn tys' - - flav = ctEvFlavour ev - ; (ev', fsk') - <- if isTcReflexiveCo kind_co -- See Note [canCFunEqCan] - then do { traceTcS "canCFunEqCan: refl" (ppr new_lhs) - ; let fsk_ty = mkTyVarTy fsk - ; ev' <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty - lhs_co (mkTcNomReflCo fsk_ty) - ; return (ev', fsk) } - else do { traceTcS "canCFunEqCan: non-refl" $ - vcat [ text "Kind co:" <+> ppr kind_co - , text "RHS:" <+> ppr fsk <+> dcolon <+> ppr (tyVarKind fsk) - , text "LHS:" <+> hang (ppr (mkTyConApp fn tys)) - 2 (dcolon <+> ppr (tcTypeKind (mkTyConApp fn tys))) - , text "New LHS" <+> hang (ppr new_lhs) - 2 (dcolon <+> ppr (tcTypeKind new_lhs)) ] - ; (ev', new_co, new_fsk) - <- newFlattenSkolem flav (ctEvLoc ev) fn tys' - ; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co - -- sym lhs_co :: F tys ~ F tys' - -- new_co :: F tys' ~ new_fsk - -- co :: F tys ~ (new_fsk |> kind_co) - co = mkTcSymCo lhs_co `mkTcTransCo` - mkTcCoherenceRightCo Nominal - (mkTyVarTy new_fsk) - kind_co - new_co - - ; traceTcS "Discharging fmv/fsk due to hetero flattening" (ppr ev) - ; dischargeFunEq ev fsk co xi - ; return (ev', new_fsk) } - - ; extendFlatCache fn tys' (ctEvCoercion ev', mkTyVarTy fsk', ctEvFlavour ev') - ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn - , cc_tyargs = tys', cc_fsk = fsk' }) } - ---------------------- -canEqTyVar :: CtEvidence -- ev :: lhs ~ rhs - -> EqRel -> SwapFlag - -> TcTyVar -- tv1 - -> TcType -- lhs: pretty lhs, already flat - -> TcType -> TcType -- rhs: already flat - -> TcS (StopOrContinue Ct) -canEqTyVar ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2 - | k1 `tcEqType` k2 - = canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2 - - | otherwise - = canEqTyVarHetero ev eq_rel swapped tv1 ps_xi1 k1 xi2 ps_xi2 k2 - - where - k1 = tyVarKind tv1 - k2 = tcTypeKind xi2 - -canEqTyVarHetero :: CtEvidence -- :: (tv1 :: ki1) ~ (xi2 :: ki2) - -> EqRel -> SwapFlag - -> TcTyVar -> TcType -- tv1, pretty tv1 - -> TcKind -- ki1 - -> TcType -> TcType -- xi2, pretty xi2 :: ki2 - -> TcKind -- ki2 - -> TcS (StopOrContinue Ct) -canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2 - -- See Note [Equalities with incompatible kinds] - = do { kind_co <- emit_kind_co -- :: ki2 ~N ki1 - - ; let -- kind_co :: (ki2 :: *) ~N (ki1 :: *) (whether swapped or not) - -- co1 :: kind(tv1) ~N ki1 - rhs' = xi2 `mkCastTy` kind_co -- :: ki1 - ps_rhs' = ps_xi2 `mkCastTy` kind_co -- :: ki1 - rhs_co = mkTcGReflLeftCo role xi2 kind_co - -- rhs_co :: (xi2 |> kind_co) ~ xi2 - - lhs' = mkTyVarTy tv1 -- same as old lhs - lhs_co = mkTcReflCo role lhs' - - ; traceTcS "Hetero equality gives rise to kind equality" - (ppr kind_co <+> dcolon <+> sep [ ppr ki2, text "~#", ppr ki1 ]) - ; type_ev <- rewriteEqEvidence ev swapped lhs' rhs' lhs_co rhs_co - - -- rewriteEqEvidence carries out the swap, so we're NotSwapped any more - ; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' } - where - emit_kind_co :: TcS CoercionN - emit_kind_co - | CtGiven { ctev_evar = evar } <- ev - = do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar) -- :: k2 ~ k1 - ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co) - ; emitWorkNC [kind_ev] - ; return (ctEvCoercion kind_ev) } - - | otherwise - = unifyWanted kind_loc Nominal ki2 ki1 - - loc = ctev_loc ev - role = eqRelRole eq_rel - kind_loc = mkKindLoc (mkTyVarTy tv1) xi2 loc - kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki2 ki1 - - maybe_sym = case swapped of - IsSwapped -> id -- if the input is swapped, then we already - -- will have k2 ~ k1 - NotSwapped -> mkTcSymCo - --- guaranteed that tcTypeKind lhs == tcTypeKind rhs -canEqTyVarHomo :: CtEvidence - -> EqRel -> SwapFlag - -> TcTyVar -- lhs: tv1 - -> TcType -- pretty lhs, flat - -> TcType -> TcType -- rhs, flat - -> TcS (StopOrContinue Ct) -canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 _ - | Just (tv2, _) <- tcGetCastedTyVar_maybe xi2 - , tv1 == tv2 - = canEqReflexive ev eq_rel (mkTyVarTy tv1) - -- we don't need to check co because it must be reflexive - - -- this guarantees (TyEq:TV) - | Just (tv2, co2) <- tcGetCastedTyVar_maybe xi2 - , swapOverTyVars tv1 tv2 - = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped) - ; let role = eqRelRole eq_rel - sym_co2 = mkTcSymCo co2 - ty1 = mkTyVarTy tv1 - new_lhs = ty1 `mkCastTy` sym_co2 - lhs_co = mkTcGReflLeftCo role ty1 sym_co2 - - new_rhs = mkTyVarTy tv2 - rhs_co = mkTcGReflRightCo role new_rhs co2 - - ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co - - ; dflags <- getDynFlags - ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_xi1 `mkCastTy` sym_co2) } - -canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_xi2 - = do { dflags <- getDynFlags - ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_xi2 } - --- The RHS here is either not a casted tyvar, or it's a tyvar but we want --- to rewrite the LHS to the RHS (as per swapOverTyVars) -canEqTyVar2 :: DynFlags - -> CtEvidence -- lhs ~ rhs (or, if swapped, orhs ~ olhs) - -> EqRel - -> SwapFlag - -> TcTyVar -- lhs = tv, flat - -> TcType -- rhs, flat - -> TcS (StopOrContinue Ct) --- LHS is an inert type variable, --- and RHS is fully rewritten, but with type synonyms --- preserved as much as possible --- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K) --- the "flat" requirement guarantees (TyEq:AFF) --- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqTyVarHomo -canEqTyVar2 dflags ev eq_rel swapped tv1 rhs - -- this next line checks also for coercion holes; see - -- Note [Equalities with incompatible kinds] - | MTVU_OK rhs' <- mtvu -- No occurs check - -- Must do the occurs check even on tyvar/tyvar - -- equalities, in case have x ~ (y :: ..x...) - -- #12593 - -- guarantees (TyEq:OC), (TyEq:F), and (TyEq:H) - = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2 - ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1 - , cc_rhs = rhs', cc_eq_rel = eq_rel }) } - - | otherwise -- For some reason (occurs check, or forall) we can't unify - -- We must not use it for further rewriting! - = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs) - ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2 - ; let status | isInsolubleOccursCheck eq_rel tv1 rhs - = InsolubleCIS - -- If we have a ~ [a], it is not canonical, and in particular - -- we don't want to rewrite existing inerts with it, otherwise - -- we'd risk divergence in the constraint solver - - | MTVU_HoleBlocker <- mtvu - = BlockedCIS - -- This is the case detailed in - -- Note [Equalities with incompatible kinds] - - | otherwise - = OtherCIS - -- A representational equality with an occurs-check problem isn't - -- insoluble! For example: - -- a ~R b a - -- We might learn that b is the newtype Id. - -- But, the occurs-check certainly prevents the equality from being - -- canonical, and we might loop if we were to use it in rewriting. - - ; continueWith (mkIrredCt status new_ev) } - where - mtvu = metaTyVarUpdateOK dflags tv1 rhs - - role = eqRelRole eq_rel - - lhs = mkTyVarTy tv1 - - rewrite_co1 = mkTcReflCo role lhs - rewrite_co2 = mkTcReflCo role rhs - --- | 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 $ - mkTcReflCo (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) - -we go to - - [noDerived X] co :: k2 ~ k1 - [X] (tv :: k1) ~ ((rhs |> co) :: k1) - -where - - noDerived G = G - noDerived _ = W - -Wrinkles: - - (1) The noDerived step is because Derived equalities have no evidence. - And yet we absolutely need evidence to be able to proceed here. - Given evidence will use the KindCo coercion; Wanted evidence will - be a coercion hole. Even a Derived hetero equality begets a Wanted - kind equality. - - (2) Though it would be sound to do so, we must not mark the rewritten Wanted - [W] (tv :: k1) ~ ((rhs |> co) :: k1) - as canonical in the inert set. In particular, we must not unify tv. - If we did, the Wanted becomes a Given (effectively), and then can - rewrite other Wanteds. But that's bad: See Note [Wanteds to not rewrite Wanteds] - in Constraint. The problem is about poor error messages. See #11198 for - tales of destruction. - - So, we have an invariant on CTyEqCan (TyEq:H) that the RHS does not have - any coercion holes. This is checked in metaTyVarUpdateOK. We also - must be sure to kick out any constraints that mention coercion holes - when those holes get filled in. - - (2a) We don't want to do this for CoercionHoles that witness - CFunEqCans (that are produced by the flattener), as these will disappear - once we unflatten. So we remember in the CoercionHole structure - whether the presence of the hole should block substitution or not. - A bit gross, this. - - (2b) We must now absolutely make sure to kick out any constraints that - mention a newly-filled-in coercion hole. This is done in - kickOutAfterFillingCoercionHole. - - (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the - algorithm detailed here, producing [W] co :: k2 ~ k1, and adding - [W] (a :: k1) ~ ((rhs |> 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 (2b). - But now, during canonicalization, we see the cast - and remove it, in canEqCast. By the time we get into canEqTyVar, 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 tyvar. 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'. - - (4) Reporting an error for a constraint that is blocked only because - of wrinkle (2) is hard: what would we say to users? And we don't - really need to report, because if a constraint is blocked, then - there is unsolved wanted blocking it; that unsolved wanted will - be reported. We thus push such errors to the bottom of the queue - in the error-reporting code; they should never be printed. - - (4a) It would seem possible to do this filtering just based on the - presence of a blocking coercion hole. However, this is no good, - as it suppresses e.g. no-instance-found errors. We thus record - a CtIrredStatus in CIrredCan and filter based on this status. - This happened in T14584. An alternative approach is to expressly - look for *equalities* with blocking coercion holes, but actually - recording the blockage in a status field seems nicer. - - (4b) The error message might be printed with -fdefer-type-errors, - so it still must exist. This is the only reason why there is - a message at all. Otherwise, we could simply do nothing. - -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 canEqTyVar. - --} - -{- -************************************************************************ -* * - 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 :: CtEvidence -- old evidence - -> TcPredType -- new predicate - -> TcCoercion -- 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/derived 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 - or Derived 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. - -qThe flattener preserves type synonyms, so they should appear in new_pred -as well as in old_pred; that is important for good error messages. - -} - - -rewriteEvidence old_ev@(CtDerived {}) new_pred _co - = -- If derived, don't even look at the coercion. - -- This is very important, DO NOT re-order the equations for - -- rewriteEvidence to put the isTcReflCo test first! - -- Why? Because for *Derived* constraints, c, the coercion, which - -- was produced by flattening, may contain suspended calls to - -- (ctEvExpr c), which fails for Derived constraints. - -- (Getting this wrong caused #7384.) - continueWith (old_ev { ctev_pred = new_pred }) - -rewriteEvidence old_ev new_pred co - | isTcReflCo co -- See Note [Rewriting with Refl] - = continueWith (old_ev { ctev_pred = new_pred }) - -rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co - = do { new_ev <- newGivenEvVar loc (new_pred, new_tm) - ; continueWith new_ev } - where - -- mkEvCast optimises ReflCo - new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational - (ctEvRole ev) - (mkTcSymCo co)) - -rewriteEvidence ev@(CtWanted { ctev_dest = dest - , ctev_nosh = si - , ctev_loc = loc }) new_pred co - = do { mb_new_ev <- newWanted_SI si loc new_pred - -- The "_SI" variant ensures that we make a new Wanted - -- with the same shadow-info as the existing one - -- with the same shadow-info as the existing one (#16735) - ; MASSERT( tcCoercionRole co == ctEvRole ev ) - ; setWantedEvTerm dest - (mkEvCast (getEvExpr mb_new_ev) - (tcDowngradeRole Representational (ctEvRole ev) co)) - ; case mb_new_ev of - Fresh new_ev -> continueWith new_ev - Cached _ -> stopWith ev "Cached wanted" } - - -rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) - -- or orhs ~ olhs (swapped) - -> SwapFlag - -> TcType -> TcType -- New predicate nlhs ~ nrhs - -> TcCoercion -- lhs_co, of type :: nlhs ~ olhs - -> TcCoercion -- rhs_co, of type :: nrhs ~ orhs - -> TcS CtEvidence -- Of type nlhs ~ nrhs --- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co) --- we generate --- If not swapped --- g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co --- If 'swapped' --- g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co --- --- For (Wanted w) we do the dual thing. --- New w1 : nlhs ~ nrhs --- If not swapped --- w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co --- If swapped --- w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co --- --- It's all a form of rewwriteEvidence, specialised for equalities -rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co - | CtDerived {} <- old_ev -- Don't force the evidence for a Derived - = return (old_ev { ctev_pred = new_pred }) - - | NotSwapped <- swapped - , isTcReflCo lhs_co -- See Note [Rewriting with Refl] - , isTcReflCo rhs_co - = return (old_ev { ctev_pred = new_pred }) - - | CtGiven { ctev_evar = old_evar } <- old_ev - = do { let new_tm = evCoercion (lhs_co - `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar) - `mkTcTransCo` mkTcSymCo rhs_co) - ; newGivenEvVar loc' (new_pred, new_tm) } - - | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev - = case dest of - HoleDest hole -> - do { (new_ev, hole_co) <- newWantedEq_SI (ch_blocker hole) si loc' - (ctEvRole old_ev) nlhs nrhs - -- The "_SI" variant ensures that we make a new Wanted - -- with the same shadow-info as the existing one (#16735) - ; let co = maybeSym swapped $ - mkSymCo lhs_co - `mkTransCo` hole_co - `mkTransCo` rhs_co - ; setWantedEq dest co - ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co]) - ; return new_ev } - - _ -> panic "rewriteEqEvidence" - -#if __GLASGOW_HASKELL__ <= 810 - | otherwise - = panic "rewriteEvidence" -#endif - where - new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs - - -- equality is like a type class. Bumping the depth is necessary because - -- of recursive newtypes, where "reducing" a newtype can actually make - -- it bigger. See Note [Newtypes can blow the stack]. - loc = ctEvLoc old_ev - loc' = bumpCtLocDepth loc - -{- Note [unifyWanted and unifyDerived] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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. -Similar remarks apply for Derived. - -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 :: 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 and unifyDerived] --- The returned coercion's role matches the input parameter -unifyWanted loc Phantom ty1 ty2 - = do { kind_co <- unifyWanted loc Nominal (tcTypeKind ty1) (tcTypeKind ty2) - ; return (mkPhantomCo kind_co ty1 ty2) } - -unifyWanted loc role orig_ty1 orig_ty2 - = go orig_ty1 orig_ty2 - where - go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 - go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - - go (FunTy _ s1 t1) (FunTy _ s2 t2) - = do { co_s <- unifyWanted loc role s1 s2 - ; co_t <- unifyWanted loc role t1 t2 - ; return (mkFunCo role 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 loc) - (tyConRolesX 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 (mkTcReflCo role ty1) - -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) - | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2 - -unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS () --- See Note [unifyWanted and unifyDerived] -unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2 - -unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS () --- See Note [unifyWanted and unifyDerived] -unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2 - -unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS () --- Create new Derived and put it in the work list --- Should do nothing if the two types are equal --- See Note [unifyWanted and unifyDerived] -unify_derived _ Phantom _ _ = return () -unify_derived loc role orig_ty1 orig_ty2 - = go orig_ty1 orig_ty2 - where - go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 - go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - - go (FunTy _ s1 t1) (FunTy _ s2 t2) - = do { unify_derived loc role s1 s2 - ; unify_derived loc role t1 t2 } - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2, tys1 `equalLength` tys2 - , isInjectiveTyCon tc1 role - = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2 - 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 ty2 = bale_out ty1 ty2 - - bale_out ty1 ty2 - | ty1 `tcEqType` ty2 = return () - -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) - | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2 - -maybeSym :: SwapFlag -> TcCoercion -> TcCoercion -maybeSym IsSwapped co = mkTcSymCo co -maybeSym NotSwapped co = co diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs deleted file mode 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ /dev/null @@ -1,548 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Typechecking class declarations --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcClassDcl ( tcClassSigs, tcClassDecl2, - findMethodBind, instantiateMethod, - tcClassMinimalDef, - HsSigFun, mkHsSigFun, - badMethodErr, - instDeclCtxt1, instDeclCtxt2, instDeclCtxt3, - tcATDefault - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import TcEnv -import TcSigs -import TcEvidence ( idHsWrapper ) -import TcBinds -import TcUnify -import TcHsType -import TcMType -import GHC.Core.Type ( piResultTys ) -import GHC.Core.Predicate -import TcOrigin -import TcType -import TcRnMonad -import GHC.Driver.Phases (HscSource(..)) -import BuildTyCl( TcMethInfo ) -import GHC.Core.Class -import GHC.Core.Coercion ( pprCoAxiom ) -import GHC.Driver.Session -import FamInst -import GHC.Core.FamInstEnv -import GHC.Types.Id -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Var -import GHC.Types.Var.Env -import Outputable -import GHC.Types.SrcLoc -import GHC.Core.TyCon -import Maybes -import GHC.Types.Basic -import Bag -import FastString -import BooleanFormula -import Util - -import Control.Monad -import Data.List ( mapAccumL, partition ) - -{- -Dictionary handling -~~~~~~~~~~~~~~~~~~~ -Every class implicitly declares a new data type, corresponding to dictionaries -of that class. So, for example: - - class (D a) => C a where - op1 :: a -> a - op2 :: forall b. Ord b => a -> b -> b - -would implicitly declare - - data CDict a = CDict (D a) - (a -> a) - (forall b. Ord b => a -> b -> b) - -(We could use a record decl, but that means changing more of the existing apparatus. -One step at a time!) - -For classes with just one superclass+method, we use a newtype decl instead: - - class C a where - op :: forallb. a -> b -> b - -generates - - newtype CDict a = CDict (forall b. a -> b -> b) - -Now DictTy in Type is just a form of type synomym: - DictTy c t = TyConTy CDict `AppTy` t - -Death to "ExpandingDicts". - - -************************************************************************ -* * - Type-checking the class op signatures -* * -************************************************************************ --} - -illegalHsigDefaultMethod :: Name -> SDoc -illegalHsigDefaultMethod n = - text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file" - -tcClassSigs :: Name -- Name of the class - -> [LSig GhcRn] - -> LHsBinds GhcRn - -> TcM [TcMethInfo] -- Exactly one for each method -tcClassSigs clas sigs def_methods - = do { traceTc "tcClassSigs 1" (ppr clas) - - ; gen_dm_prs <- concatMapM (addLocM tc_gen_sig) gen_sigs - ; let gen_dm_env :: NameEnv (SrcSpan, Type) - gen_dm_env = mkNameEnv gen_dm_prs - - ; op_info <- concatMapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs - - ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ] - ; sequence_ [ failWithTc (badMethodErr clas n) - | n <- dm_bind_names, not (n `elemNameSet` op_names) ] - -- Value binding for non class-method (ie no TypeSig) - - ; tcg_env <- getGblEnv - ; if tcg_src tcg_env == HsigFile - then - -- Error if we have value bindings - -- (Generic signatures without value bindings indicate - -- that a default of this form is expected to be - -- provided.) - when (not (null def_methods)) $ - failWithTc (illegalHsigDefaultMethod clas) - else - -- Error for each generic signature without value binding - sequence_ [ failWithTc (badGenericMethod clas n) - | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] - - ; traceTc "tcClassSigs 2" (ppr clas) - ; return op_info } - where - vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs] - gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs] - dm_bind_names :: [Name] -- These ones have a value binding in the class decl - dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] - - skol_info = TyConSkol ClassFlavour clas - - tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn) - -> TcM [TcMethInfo] - tc_sig gen_dm_env (op_names, op_hs_ty) - = do { traceTc "ClsSig 1" (ppr op_names) - ; op_ty <- tcClassSigType skol_info op_names op_hs_ty - -- Class tyvars already in scope - - ; traceTc "ClsSig 2" (ppr op_names) - ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] } - where - f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty) - | nm `elem` dm_bind_names = Just VanillaDM - | otherwise = Nothing - - tc_gen_sig (op_names, gen_hs_ty) - = do { gen_op_ty <- tcClassSigType skol_info op_names gen_hs_ty - ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] } - -{- -************************************************************************ -* * - Class Declarations -* * -************************************************************************ --} - -tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration - -> TcM (LHsBinds GhcTcId) - -tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, - tcdMeths = default_binds})) - = recoverM (return emptyLHsBinds) $ - setSrcSpan (getLoc class_name) $ - do { clas <- tcLookupLocatedClass class_name - - -- We make a separate binding for each default method. - -- At one time I used a single AbsBinds for all of them, thus - -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... } - -- But that desugars into - -- ds = \d -> (..., ..., ...) - -- dm1 = \d -> case ds d of (a,b,c) -> a - -- And since ds is big, it doesn't get inlined, so we don't get good - -- default methods. Better to make separate AbsBinds for each - ; let (tyvars, _, _, op_items) = classBigSig clas - prag_fn = mkPragEnv sigs default_binds - sig_fn = mkHsSigFun sigs - clas_tyvars = snd (tcSuperSkolTyVars tyvars) - pred = mkClassPred clas (mkTyVarTys clas_tyvars) - ; this_dict <- newEvVar pred - - ; let tc_item = tcDefMeth clas clas_tyvars this_dict - default_binds sig_fn prag_fn - ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ - mapM tc_item op_items - - ; return (unionManyBags dm_binds) } - -tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) - -tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn - -> HsSigFun -> TcPragEnv -> ClassOpItem - -> TcM (LHsBinds GhcTcId) --- Generate code for default methods --- This is incompatible with Hugs, which expects a polymorphic --- default method for every class op, regardless of whether or not --- the programmer supplied an explicit default decl for the class. --- (If necessary we can fix that, but we don't have a convenient Id to hand.) - -tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing) - = do { -- No default method - mapM_ (addLocM (badDmPrag sel_id)) - (lookupPragEnv prag_fn (idName sel_id)) - ; return emptyBag } - -tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn - (sel_id, Just (dm_name, dm_spec)) - | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn - = do { -- First look up the default method; it should be there! - -- It can be the ordinary default method - -- or the generic-default method. E.g of the latter - -- class C a where - -- op :: a -> a -> Bool - -- default op :: Eq a => a -> a -> Bool - -- op x y = x==y - -- The default method we generate is - -- $gm :: (C a, Eq a) => a -> a -> Bool - -- $gm x y = x==y - - global_dm_id <- tcLookupId dm_name - ; global_dm_id <- addInlinePrags global_dm_id prags - ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc - -- Base the local_dm_name on the selector name, because - -- type errors from tcInstanceMethodBody come from here - - ; spec_prags <- discardConstraints $ - tcSpecPrags global_dm_id prags - ; warnTc NoReason - (not (null spec_prags)) - (text "Ignoring SPECIALISE pragmas on default method" - <+> quotes (ppr sel_name)) - - ; let hs_ty = hs_sig_fn sel_name - `orElse` pprPanic "tc_dm" (ppr sel_name) - -- We need the HsType so that we can bring the right - -- type variables into scope - -- - -- Eg. class C a where - -- op :: forall b. Eq b => a -> [b] -> a - -- gen_op :: a -> a - -- generic gen_op :: D a => a -> a - -- The "local_dm_ty" is precisely the type in the above - -- type signatures, ie with no "forall a. C a =>" prefix - - local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars) - - lm_bind = dm_bind { fun_id = L bind_loc local_dm_name } - -- Substitute the local_meth_name for the binder - -- NB: the binding is always a FunBind - - warn_redundant = case dm_spec of - GenericDM {} -> True - VanillaDM -> False - -- For GenericDM, warn if the user specifies a signature - -- with redundant constraints; but not for VanillaDM, where - -- the default method may well be 'error' or something - - ctxt = FunSigCtxt sel_name warn_redundant - - ; let local_dm_id = mkLocalId local_dm_name local_dm_ty - local_dm_sig = CompleteSig { sig_bndr = local_dm_id - , sig_ctxt = ctxt - , sig_loc = getLoc (hsSigType hs_ty) } - - ; (ev_binds, (tc_bind, _)) - <- checkConstraints skol_info tyvars [this_dict] $ - tcPolyCheck no_prag_fn local_dm_sig - (L bind_loc lm_bind) - - ; let export = ABE { abe_ext = noExtField - , abe_poly = global_dm_id - , abe_mono = local_dm_id - , abe_wrap = idHsWrapper - , abe_prags = IsDefaultMethod } - full_bind = AbsBinds { abs_ext = noExtField - , abs_tvs = tyvars - , abs_ev_vars = [this_dict] - , abs_exports = [export] - , abs_ev_binds = [ev_binds] - , abs_binds = tc_bind - , abs_sig = True } - - ; return (unitBag (L bind_loc full_bind)) } - - | otherwise = pprPanic "tcDefMeth" (ppr sel_id) - where - skol_info = TyConSkol ClassFlavour (getName clas) - sel_name = idName sel_id - no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; - -- they are all for meth_id - ---------------- -tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef -tcClassMinimalDef _clas sigs op_info - = case findMinimalDef sigs of - Nothing -> return defMindef - Just mindef -> do - -- Warn if the given mindef does not imply the default one - -- That is, the given mindef should at least ensure that the - -- class ops without default methods are required, since we - -- have no way to fill them in otherwise - tcg_env <- getGblEnv - -- However, only do this test when it's not an hsig file, - -- since you can't write a default implementation. - when (tcg_src tcg_env /= HsigFile) $ - whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ - (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf)) - return mindef - where - -- By default require all methods without a default implementation - defMindef :: ClassMinimalDef - defMindef = mkAnd [ noLoc (mkVar name) - | (name, _, Nothing) <- op_info ] - -instantiateMethod :: Class -> TcId -> [TcType] -> TcType --- Take a class operation, say --- op :: forall ab. C a => forall c. Ix c => (b,c) -> a --- Instantiate it at [ty1,ty2] --- Return the "local method type": --- forall c. Ix x => (ty2,c) -> ty1 -instantiateMethod clas sel_id inst_tys - = ASSERT( ok_first_pred ) local_meth_ty - where - rho_ty = piResultTys (idType sel_id) inst_tys - (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty - `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) - - ok_first_pred = case getClassPredTys_maybe first_pred of - Just (clas1, _tys) -> clas == clas1 - Nothing -> False - -- The first predicate should be of form (C a b) - -- where C is the class in question - - ---------------------------- -type HsSigFun = Name -> Maybe (LHsSigType GhcRn) - -mkHsSigFun :: [LSig GhcRn] -> HsSigFun -mkHsSigFun sigs = lookupNameEnv env - where - env = mkHsSigEnv get_classop_sig sigs - - get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn) - get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty) - get_classop_sig _ = Nothing - ---------------------------- -findMethodBind :: Name -- Selector - -> LHsBinds GhcRn -- A group of bindings - -> TcPragEnv - -> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn]) - -- Returns the binding, the binding - -- site of the method binder, and any inline or - -- specialisation pragmas -findMethodBind sel_name binds prag_fn - = foldl' mplus Nothing (mapBag f binds) - where - prags = lookupPragEnv prag_fn sel_name - - f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) - | op_name == sel_name - = Just (bind, bndr_loc, prags) - f _other = Nothing - ---------------------------- -findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef -findMinimalDef = firstJusts . map toMinimalDef - where - toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef - toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf) - toMinimalDef _ = Nothing - -{- -Note [Polymorphic methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - class Foo a where - op :: forall b. Ord b => a -> b -> b -> b - instance Foo c => Foo [c] where - op = e - -When typechecking the binding 'op = e', we'll have a meth_id for op -whose type is - op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b - -So tcPolyBinds must be capable of dealing with nested polytypes; -and so it is. See TcBinds.tcMonoBinds (with type-sig case). - -Note [Silly default-method bind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we pass the default method binding to the type checker, it must -look like op2 = e -not $dmop2 = e -otherwise the "$dm" stuff comes out error messages. But we want the -"$dm" to come out in the interface file. So we typecheck the former, -and wrap it in a let, thus - $dmop2 = let op2 = e in op2 -This makes the error messages right. - - -************************************************************************ -* * - Error messages -* * -************************************************************************ --} - -badMethodErr :: Outputable a => a -> Name -> SDoc -badMethodErr clas op - = hsep [text "Class", quotes (ppr clas), - text "does not have a method", quotes (ppr op)] - -badGenericMethod :: Outputable a => a -> Name -> SDoc -badGenericMethod clas op - = hsep [text "Class", quotes (ppr clas), - text "has a generic-default signature without a binding", quotes (ppr op)] - -{- -badGenericInstanceType :: LHsBinds Name -> SDoc -badGenericInstanceType binds - = vcat [text "Illegal type pattern in the generic bindings", - nest 2 (ppr binds)] - -missingGenericInstances :: [Name] -> SDoc -missingGenericInstances missing - = text "Missing type patterns for" <+> pprQuotedList missing - -dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc -dupGenericInsts tc_inst_infos - = vcat [text "More than one type pattern for a single generic type constructor:", - nest 2 (vcat (map ppr_inst_ty tc_inst_infos)), - text "All the type patterns for a generic type constructor must be identical" - ] - where - ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) --} -badDmPrag :: TcId -> Sig GhcRn -> TcM () -badDmPrag sel_id prag - = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method") - <+> quotes (ppr sel_id) - <+> text "lacks an accompanying binding") - -warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc -warningMinimalDefIncomplete mindef - = vcat [ text "The MINIMAL pragma does not require:" - , nest 2 (pprBooleanFormulaNice mindef) - , text "but there is no default implementation." ] - -instDeclCtxt1 :: LHsSigType GhcRn -> SDoc -instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) - -instDeclCtxt2 :: Type -> SDoc -instDeclCtxt2 dfun_ty - = instDeclCtxt3 cls tys - where - (_,_,cls,tys) = tcSplitDFunTy dfun_ty - -instDeclCtxt3 :: Class -> [Type] -> SDoc -instDeclCtxt3 cls cls_tys - = inst_decl_ctxt (ppr (mkClassPred cls cls_tys)) - -inst_decl_ctxt :: SDoc -> SDoc -inst_decl_ctxt doc = hang (text "In the instance declaration for") - 2 (quotes doc) - -tcATDefault :: SrcSpan - -> TCvSubst - -> NameSet - -> ClassATItem - -> TcM [FamInst] --- ^ Construct default instances for any associated types that --- aren't given a user definition --- Returns [] or singleton -tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) - -- User supplied instances ==> everything is OK - | tyConName fam_tc `elemNameSet` defined_ats - = return [] - - -- No user instance, have defaults ==> instantiate them - -- Example: class C a where { type F a b :: *; type F a b = () } - -- instance C [x] - -- Then we want to generate the decl: type F [x] b = () - | Just (rhs_ty, _loc) <- defs - = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst - (tyConTyVars fam_tc) - rhs' = substTyUnchecked subst' rhs_ty - tcv' = tyCoVarsOfTypesList pat_tys' - (tv', cv') = partition isTyVar tcv' - tvs' = scopedSort tv' - cvs' = scopedSort cv' - ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys' - ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs' - fam_tc pat_tys' rhs' - -- NB: no validity check. We check validity of default instances - -- in the class definition. Because type instance arguments cannot - -- be type family applications and cannot be polytypes, the - -- validity check is redundant. - - ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty - , pprCoAxiom axiom ]) - ; fam_inst <- newFamInst SynFamilyInst axiom - ; return [fam_inst] } - - -- No defaults ==> generate a warning - | otherwise -- defs = Nothing - = do { warnMissingAT (tyConName fam_tc) - ; return [] } - where - subst_tv subst tc_tv - | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv - = (subst, ty) - | otherwise - = (extendTvSubst subst tc_tv ty', ty') - where - ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv) - -warnMissingAT :: Name -> TcM () -warnMissingAT name - = do { warn <- woptM Opt_WarnMissingMethods - ; traceTc "warn" (ppr name <+> ppr warn) - ; hsc_src <- fmap tcg_src getGblEnv - -- Warn only if -Wmissing-methods AND not a signature - ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile) - (text "No explicit" <+> text "associated type" - <+> text "or default declaration for" - <+> quotes (ppr name)) } diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs deleted file mode 100644 --- a/compiler/typecheck/TcDefaults.hs +++ /dev/null @@ -1,110 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[TcDefaults]{Typechecking \tr{default} declarations} --} -{-# LANGUAGE TypeFamilies #-} - -module TcDefaults ( tcDefaults ) where - -import GhcPrelude - -import GHC.Hs -import GHC.Core.Class -import TcRnMonad -import TcEnv -import TcHsType -import TcHsSyn -import TcSimplify -import TcValidity -import TcType -import PrelNames -import GHC.Types.SrcLoc -import Outputable -import FastString -import qualified GHC.LanguageExtensions as LangExt - -tcDefaults :: [LDefaultDecl GhcRn] - -> TcM (Maybe [Type]) -- Defaulting types to heave - -- into Tc monad for later use - -- in Disambig. - -tcDefaults [] - = getDeclaredDefaultTys -- No default declaration, so get the - -- default types from the envt; - -- i.e. use the current ones - -- (the caller will put them back there) - -- It's important not to return defaultDefaultTys here (which - -- we used to do) because in a TH program, tcDefaults [] is called - -- repeatedly, once for each group of declarations between top-level - -- splices. We don't want to carefully set the default types in - -- one group, only for the next group to ignore them and install - -- defaultDefaultTys - -tcDefaults [L _ (DefaultDecl _ [])] - = return (Just []) -- Default declaration specifying no types - -tcDefaults [L locn (DefaultDecl _ mono_tys)] - = setSrcSpan locn $ - addErrCtxt defaultDeclCtxt $ - do { ovl_str <- xoptM LangExt.OverloadedStrings - ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules - ; num_class <- tcLookupClass numClassName - ; deflt_str <- if ovl_str - then mapM tcLookupClass [isStringClassName] - else return [] - ; deflt_interactive <- if ext_deflt - then mapM tcLookupClass interactiveClassNames - else return [] - ; let deflt_clss = num_class : deflt_str ++ deflt_interactive - - ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys - - ; return (Just tau_tys) } - -tcDefaults decls@(L locn (DefaultDecl _ _) : _) - = setSrcSpan locn $ - failWithTc (dupDefaultDeclErr decls) -tcDefaults (L _ (XDefaultDecl nec):_) = noExtCon nec - - -tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type -tc_default_ty deflt_clss hs_ty - = do { (ty, _kind) <- solveEqualities $ - tcLHsType hs_ty - ; ty <- zonkTcTypeToType ty -- establish Type invariants - ; checkValidType DefaultDeclCtxt ty - - -- Check that the type is an instance of at least one of the deflt_clss - ; oks <- mapM (check_instance ty) deflt_clss - ; checkTc (or oks) (badDefaultTy ty deflt_clss) - ; return ty } - -check_instance :: Type -> Class -> TcM Bool - -- Check that ty is an instance of cls - -- We only care about whether it worked or not; return a boolean -check_instance ty cls - = do { (_, success) <- discardErrs $ - askNoErrs $ - simplifyDefault [mkClassPred cls [ty]] - ; return success } - -defaultDeclCtxt :: SDoc -defaultDeclCtxt = text "When checking the types in a default declaration" - -dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc -dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things) - = hang (text "Multiple default declarations") - 2 (vcat (map pp dup_things)) - where - pp (L locn (DefaultDecl _ _)) - = text "here was another default declaration" <+> ppr locn - pp (L _ (XDefaultDecl nec)) = noExtCon nec -dupDefaultDeclErr (L _ (XDefaultDecl nec) : _) = noExtCon nec -dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" - -badDefaultTy :: Type -> [Class] -> SDoc -badDefaultTy ty deflt_clss - = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of")) - 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs deleted file mode 100644 --- a/compiler/typecheck/TcDeriv.hs +++ /dev/null @@ -1,2305 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Handles @deriving@ clauses on @data@ declarations. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcDeriv ( tcDeriving, DerivInfo(..) ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import GHC.Driver.Session - -import TcRnMonad -import FamInst -import TcOrigin -import GHC.Core.Predicate -import TcDerivInfer -import TcDerivUtils -import TcValidity( allDistinctTyVars ) -import TcClassDcl( instDeclCtxt3, tcATDefault ) -import TcEnv -import TcGenDeriv -- Deriv stuff -import TcValidity( checkValidInstHead ) -import GHC.Core.InstEnv -import Inst -import GHC.Core.FamInstEnv -import TcHsType -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr ( pprTyVars ) - -import GHC.Rename.Names ( extendGlobalRdrEnvRn ) -import GHC.Rename.Binds -import GHC.Rename.Env -import GHC.Rename.Source ( addTcgDUs ) -import GHC.Types.Avail - -import GHC.Core.Unify( tcUnifyTy ) -import GHC.Core.Class -import GHC.Core.Type -import ErrUtils -import GHC.Core.DataCon -import Maybes -import GHC.Types.Name.Reader -import GHC.Types.Name -import GHC.Types.Name.Set as NameSet -import GHC.Core.TyCon -import TcType -import GHC.Types.Var as Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import PrelNames -import GHC.Types.SrcLoc -import Util -import Outputable -import FastString -import Bag -import FV (fvVarList, unionFV, mkFVs) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Data.List (partition, find) - -{- -************************************************************************ -* * - Overview -* * -************************************************************************ - -Overall plan -~~~~~~~~~~~~ -1. Convert the decls (i.e. data/newtype deriving clauses, - plus standalone deriving) to [EarlyDerivSpec] - -2. Infer the missing contexts for the InferTheta's - -3. Add the derived bindings, generating InstInfos --} - -data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin]) - | GivenTheta (DerivSpec ThetaType) - -- InferTheta ds => the context for the instance should be inferred - -- In this case ds_theta is the list of all the sets of - -- constraints needed, such as (Eq [a], Eq a), together with a - -- suitable CtLoc to get good error messages. - -- The inference process is to reduce this to a - -- simpler form (e.g. Eq a) - -- - -- GivenTheta ds => the exact context for the instance is supplied - -- by the programmer; it is ds_theta - -- See Note [Inferring the instance context] in TcDerivInfer - -splitEarlyDerivSpec :: [EarlyDerivSpec] - -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType]) -splitEarlyDerivSpec [] = ([],[]) -splitEarlyDerivSpec (InferTheta spec : specs) = - case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs) -splitEarlyDerivSpec (GivenTheta spec : specs) = - case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs) - -instance Outputable EarlyDerivSpec where - ppr (InferTheta spec) = ppr spec <+> text "(Infer)" - ppr (GivenTheta spec) = ppr spec <+> text "(Given)" - -{- -Note [Data decl contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data (RealFloat a) => Complex a = !a :+ !a deriving( Read ) - -We will need an instance decl like: - - instance (Read a, RealFloat a) => Read (Complex a) where - ... - -The RealFloat in the context is because the read method for Complex is bound -to construct a Complex, and doing that requires that the argument type is -in RealFloat. - -But this ain't true for Show, Eq, Ord, etc, since they don't construct -a Complex; they only take them apart. - -Our approach: identify the offending classes, and add the data type -context to the instance decl. The "offending classes" are - - Read, Enum? - -FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that -pattern matching against a constructor from a data type with a context -gives rise to the constraints for that context -- or at least the thinned -version. So now all classes are "offending". - -Note [Newtype deriving] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - class C a b - instance C [a] Char - newtype T = T Char deriving( C [a] ) - -Notice the free 'a' in the deriving. We have to fill this out to - newtype T = T Char deriving( forall a. C [a] ) - -And then translate it to: - instance C [a] Char => C [a] T where ... - -Note [Unused constructors and deriving clauses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #3221. Consider - data T = T1 | T2 deriving( Show ) -Are T1 and T2 unused? Well, no: the deriving clause expands to mention -both of them. So we gather defs/uses from deriving just like anything else. - --} - --- | Stuff needed to process a datatype's `deriving` clauses -data DerivInfo = DerivInfo { di_rep_tc :: TyCon - -- ^ The data tycon for normal datatypes, - -- or the *representation* tycon for data families - , di_scoped_tvs :: ![(Name,TyVar)] - -- ^ Variables that scope over the deriving clause. - , di_clauses :: [LHsDerivingClause GhcRn] - , di_ctxt :: SDoc -- ^ error context - } - -{- - -************************************************************************ -* * -\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}} -* * -************************************************************************ --} - -tcDeriving :: [DerivInfo] -- All `deriving` clauses - -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations - -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn) -tcDeriving deriv_infos deriv_decls - = recoverM (do { g <- getGblEnv - ; return (g, emptyBag, emptyValBindsOut)}) $ - do { -- Fish the "deriving"-related information out of the TcEnv - -- And make the necessary "equations". - early_specs <- makeDerivSpecs deriv_infos deriv_decls - ; traceTc "tcDeriving" (ppr early_specs) - - ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs - ; insts1 <- mapM genInst given_specs - ; insts2 <- mapM genInst infer_specs - - ; dflags <- getDynFlags - - ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2) - ; loc <- getSrcSpanM - ; let (binds, famInsts) = genAuxBinds dflags loc - (unionManyBags deriv_stuff) - - ; let mk_inst_infos1 = map fstOf3 insts1 - ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs - - -- We must put all the derived type family instances (from both - -- infer_specs and given_specs) in the local instance environment - -- before proceeding, or else simplifyInstanceContexts might - -- get stuck if it has to reason about any of those family instances. - -- See Note [Staging of tcDeriving] - ; tcExtendLocalFamInstEnv (bagToList famInsts) $ - -- NB: only call tcExtendLocalFamInstEnv once, as it performs - -- validity checking for all of the family instances you give it. - -- If the family instances have errors, calling it twice will result - -- in duplicate error messages! - - do { - -- the stand-alone derived instances (@inst_infos1@) are used when - -- inferring the contexts for "deriving" clauses' instances - -- (@infer_specs@) - ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $ - simplifyInstanceContexts infer_specs - - ; let mk_inst_infos2 = map fstOf3 insts2 - ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs - ; let inst_infos = inst_infos1 ++ inst_infos2 - - ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds - - ; unless (isEmptyBag inst_info) $ - liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - FormatHaskell - (ddump_deriving inst_info rn_binds famInsts)) - - ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) - getGblEnv - ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs) - ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } } - where - ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn - -> Bag FamInst -- ^ Rep type family instances - -> SDoc - ddump_deriving inst_infos extra_binds repFamInsts - = hang (text "Derived class instances:") - 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) - $$ ppr extra_binds) - $$ hangP "Derived type family instances:" - (vcat (map pprRepTy (bagToList repFamInsts))) - - hangP s x = text "" $$ hang (ptext (sLit s)) 2 x - - -- Apply the suspended computations given by genInst calls. - -- See Note [Staging of tcDeriving] - apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)] - -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs] - apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds)) - --- Prints the representable type family instance -pprRepTy :: FamInst -> SDoc -pprRepTy fi@(FamInst { fi_tys = lhs }) - = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+> - equals <+> ppr rhs - where rhs = famInstRHS fi - -renameDeriv :: [InstInfo GhcPs] - -> Bag (LHsBind GhcPs, LSig GhcPs) - -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses) -renameDeriv inst_infos bagBinds - = discardWarnings $ - -- Discard warnings about unused bindings etc - setXOptM LangExt.EmptyCase $ - -- Derived decls (for empty types) can have - -- case x of {} - setXOptM LangExt.ScopedTypeVariables $ - setXOptM LangExt.KindSignatures $ - -- Derived decls (for newtype-deriving) can use ScopedTypeVariables & - -- KindSignatures - setXOptM LangExt.TypeApplications $ - -- GND/DerivingVia uses TypeApplications in generated code - -- (See Note [Newtype-deriving instances] in TcGenDeriv) - unsetXOptM LangExt.RebindableSyntax $ - -- See Note [Avoid RebindableSyntax when deriving] - setXOptM LangExt.TemplateHaskellQuotes $ - -- DeriveLift makes uses of quotes - do { - -- Bring the extra deriving stuff into scope - -- before renaming the instances themselves - ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) - ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds - ; let aux_val_binds = ValBinds noExtField aux_binds (bagToList aux_sigs) - ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds - ; let bndrs = collectHsValBinders rn_aux_lhs - ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ; - ; setEnvs envs $ - do { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs - ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos - ; return (listToBag rn_inst_infos, rn_aux, - dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } } - - where - rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars) - rn_inst_info - inst_info@(InstInfo { iSpec = inst - , iBinds = InstBindings - { ib_binds = binds - , ib_tyvars = tyvars - , ib_pragmas = sigs - , ib_extensions = exts -- Only for type-checking - , ib_derived = sa } }) - = do { (rn_binds, rn_sigs, fvs) <- rnMethodBinds False (is_cls_nm inst) - tyvars binds sigs - ; let binds' = InstBindings { ib_binds = rn_binds - , ib_tyvars = tyvars - , ib_pragmas = rn_sigs - , ib_extensions = exts - , ib_derived = sa } - ; return (inst_info { iBinds = binds' }, fvs) } - -{- -Note [Staging of tcDeriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here's a tricky corner case for deriving (adapted from #2721): - - class C a where - type T a - foo :: a -> T a - - instance C Int where - type T Int = Int - foo = id - - newtype N = N Int deriving C - -This will produce an instance something like this: - - instance C N where - type T N = T Int - foo = coerce (foo :: Int -> T Int) :: N -> T N - -We must be careful in order to typecheck this code. When determining the -context for the instance (in simplifyInstanceContexts), we need to determine -that T N and T Int have the same representation, but to do that, the T N -instance must be in the local family instance environment. Otherwise, GHC -would be unable to conclude that T Int is representationally equivalent to -T Int, and simplifyInstanceContexts would get stuck. - -Previously, tcDeriving would defer adding any derived type family instances to -the instance environment until the very end, which meant that -simplifyInstanceContexts would get called without all the type family instances -it needed in the environment in order to properly simplify instance like -the C N instance above. - -To avoid this scenario, we carefully structure the order of events in -tcDeriving. We first call genInst on the standalone derived instance specs and -the instance specs obtained from deriving clauses. Note that the return type of -genInst is a triple: - - TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name) - -The type family instances are in the BagDerivStuff. The first field of the -triple is a suspended computation which, given an instance context, produces -the rest of the instance. The fact that it is suspended is important, because -right now, we don't have ThetaTypes for the instances that use deriving clauses -(only the standalone-derived ones). - -Now we can collect the type family instances and extend the local instance -environment. At this point, it is safe to run simplifyInstanceContexts on the -deriving-clause instance specs, which gives us the ThetaTypes for the -deriving-clause instances. Now we can feed all the ThetaTypes to the -suspended computations and obtain our InstInfos, at which point -tcDeriving is done. - -An alternative design would be to split up genInst so that the -family instances are generated separately from the InstInfos. But this would -require carving up a lot of the GHC deriving internals to accommodate the -change. On the other hand, we can keep all of the InstInfo and type family -instance logic together in genInst simply by converting genInst to -continuation-returning style, so we opt for that route. - -Note [Why we don't pass rep_tc into deriveTyData] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Down in the bowels of mk_deriv_inst_tys_maybe, we need to convert the fam_tc -back into the rep_tc by means of a lookup. And yet we have the rep_tc right -here! Why look it up again? Answer: it's just easier this way. -We drop some number of arguments from the end of the datatype definition -in deriveTyData. The arguments are dropped from the fam_tc. -This action may drop a *different* number of arguments -passed to the rep_tc, depending on how many free variables, etc., the -dropped patterns have. - -Also, this technique carries over the kind substitution from deriveTyData -nicely. - -Note [Avoid RebindableSyntax when deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The RebindableSyntax extension interacts awkwardly with the derivation of -any stock class whose methods require the use of string literals. The Show -class is a simple example (see #12688): - - {-# LANGUAGE RebindableSyntax, OverloadedStrings #-} - newtype Text = Text String - fromString :: String -> Text - fromString = Text - - data Foo = Foo deriving Show - -This will generate code to the effect of: - - instance Show Foo where - showsPrec _ Foo = showString "Foo" - -But because RebindableSyntax and OverloadedStrings are enabled, the "Foo" -string literal is now of type Text, not String, which showString doesn't -accept! This causes the generated Show instance to fail to typecheck. - -To avoid this kind of scenario, we simply turn off RebindableSyntax entirely -in derived code. - -************************************************************************ -* * - From HsSyn to DerivSpec -* * -************************************************************************ - -@makeDerivSpecs@ fishes around to find the info about needed derived instances. --} - -makeDerivSpecs :: [DerivInfo] - -> [LDerivDecl GhcRn] - -> TcM [EarlyDerivSpec] -makeDerivSpecs deriv_infos deriv_decls - = do { eqns1 <- sequenceA - [ deriveClause rep_tc scoped_tvs dcs preds err_ctxt - | DerivInfo { di_rep_tc = rep_tc - , di_scoped_tvs = scoped_tvs - , di_clauses = clauses - , di_ctxt = err_ctxt } <- deriv_infos - , L _ (HsDerivingClause { deriv_clause_strategy = dcs - , deriv_clause_tys = L _ preds }) - <- clauses - ] - ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls - ; return $ concat eqns1 ++ catMaybes eqns2 } - ------------------------------------------------------------------- --- | Process the derived classes in a single @deriving@ clause. -deriveClause :: TyCon - -> [(Name, TcTyVar)] -- Scoped type variables taken from tcTyConScopedTyVars - -- See Note [Scoped tyvars in a TcTyCon] in types/TyCon - -> Maybe (LDerivStrategy GhcRn) - -> [LHsSigType GhcRn] -> SDoc - -> TcM [EarlyDerivSpec] -deriveClause rep_tc scoped_tvs mb_lderiv_strat deriv_preds err_ctxt - = addErrCtxt err_ctxt $ do - traceTc "deriveClause" $ vcat - [ text "tvs" <+> ppr tvs - , text "scoped_tvs" <+> ppr scoped_tvs - , text "tc" <+> ppr tc - , text "tys" <+> ppr tys - , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat ] - tcExtendNameTyVarEnv scoped_tvs $ do - (mb_lderiv_strat', via_tvs) <- tcDerivStrategy mb_lderiv_strat - tcExtendTyVarEnv via_tvs $ - -- Moreover, when using DerivingVia one can bind type variables in - -- the `via` type as well, so these type variables must also be - -- brought into scope. - mapMaybeM (derivePred tc tys mb_lderiv_strat' via_tvs) deriv_preds - -- After typechecking the `via` type once, we then typecheck all - -- of the classes associated with that `via` type in the - -- `deriving` clause. - -- See also Note [Don't typecheck too much in DerivingVia]. - where - tvs = tyConTyVars rep_tc - (tc, tys) = case tyConFamInstSig_maybe rep_tc of - -- data family: - Just (fam_tc, pats, _) -> (fam_tc, pats) - -- NB: deriveTyData wants the *user-specified* - -- name. See Note [Why we don't pass rep_tc into deriveTyData] - - _ -> (rep_tc, mkTyVarTys tvs) -- datatype - --- | Process a single predicate in a @deriving@ clause. --- --- This returns a 'Maybe' because the user might try to derive 'Typeable', --- which is a no-op nowadays. -derivePred :: TyCon -> [Type] -> Maybe (LDerivStrategy GhcTc) -> [TyVar] - -> LHsSigType GhcRn -> TcM (Maybe EarlyDerivSpec) -derivePred tc tys mb_lderiv_strat via_tvs deriv_pred = - -- We carefully set up uses of recoverM to minimize error message - -- cascades. See Note [Recovering from failures in deriving clauses]. - recoverM (pure Nothing) $ - setSrcSpan (getLoc (hsSigType deriv_pred)) $ do - traceTc "derivePred" $ vcat - [ text "tc" <+> ppr tc - , text "tys" <+> ppr tys - , text "deriv_pred" <+> ppr deriv_pred - , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat - , text "via_tvs" <+> ppr via_tvs ] - (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred - when (cls_arg_kinds `lengthIsNot` 1) $ - failWithTc (nonUnaryErr deriv_pred) - let [cls_arg_kind] = cls_arg_kinds - mb_deriv_strat = fmap unLoc mb_lderiv_strat - if (className cls == typeableClassName) - then do warnUselessTypeable - return Nothing - else let deriv_tvs = via_tvs ++ cls_tvs in - Just <$> deriveTyData tc tys mb_deriv_strat - deriv_tvs cls cls_tys cls_arg_kind - -{- -Note [Don't typecheck too much in DerivingVia] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example: - - data D = ... - deriving (A1 t, ..., A20 t) via T t - -GHC used to be engineered such that it would typecheck the `deriving` -clause like so: - -1. Take the first class in the clause (`A1`). -2. Typecheck the `via` type (`T t`) and bring its bound type variables - into scope (`t`). -3. Typecheck the class (`A1`). -4. Move on to the next class (`A2`) and repeat the process until all - classes have been typechecked. - -This algorithm gets the job done most of the time, but it has two notable -flaws. One flaw is that it is wasteful: it requires that `T t` be typechecked -20 different times, once for each class in the `deriving` clause. This is -unnecessary because we only need to typecheck `T t` once in order to get -access to its bound type variable. - -The other issue with this algorithm arises when there are no classes in the -`deriving` clause, like in the following example: - - data D2 = ... - deriving () via Maybe Maybe - -Because there are no classes, the algorithm above will simply do nothing. -As a consequence, GHC will completely miss the fact that `Maybe Maybe` -is ill-kinded nonsense (#16923). - -To address both of these problems, GHC now uses this algorithm instead: - -1. Typecheck the `via` type and bring its bound type variables into scope. -2. Take the first class in the `deriving` clause. -3. Typecheck the class. -4. Move on to the next class and repeat the process until all classes have been - typechecked. - -This algorithm ensures that the `via` type is always typechecked, even if there -are no classes in the `deriving` clause. Moreover, it typecheck the `via` type -/exactly/ once and no more, even if there are multiple classes in the clause. - -Note [Recovering from failures in deriving clauses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider what happens if you run this program (from #10684) without -DeriveGeneric enabled: - - data A = A deriving (Show, Generic) - data B = B A deriving (Show) - -Naturally, you'd expect GHC to give an error to the effect of: - - Can't make a derived instance of `Generic A': - You need -XDeriveGeneric to derive an instance for this class - -And *only* that error, since the other two derived Show instances appear to be -independent of this derived Generic instance. Yet GHC also used to give this -additional error on the program above: - - No instance for (Show A) - arising from the 'deriving' clause of a data type declaration - When deriving the instance for (Show B) - -This was happening because when GHC encountered any error within a single -data type's set of deriving clauses, it would call recoverM and move on -to the next data type's deriving clauses. One unfortunate consequence of -this design is that if A's derived Generic instance failed, its derived -Show instance would be skipped entirely, leading to the "No instance for -(Show A)" error cascade. - -The solution to this problem is to push through uses of recoverM to the -level of the individual derived classes in a particular data type's set of -deriving clauses. That is, if you have: - - newtype C = C D - deriving (E, F, G) - -Then instead of processing instances E through M under the scope of a single -recoverM, as in the following pseudocode: - - recoverM (pure Nothing) $ mapM derivePred [E, F, G] - -We instead use recoverM in each iteration of the loop: - - mapM (recoverM (pure Nothing) . derivePred) [E, F, G] - -And then process each class individually, under its own recoverM scope. That -way, failure to derive one class doesn't cancel out other classes in the -same set of clause-derived classes. --} - ------------------------------------------------------------------- -deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec) --- Process a single standalone deriving declaration --- e.g. deriving instance Show a => Show (T a) --- Rather like tcLocalInstDecl --- --- This returns a Maybe because the user might try to derive Typeable, which is --- a no-op nowadays. -deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode)) - = setSrcSpan loc $ - addErrCtxt (standaloneCtxt deriv_ty) $ - do { traceTc "Standalone deriving decl for" (ppr deriv_ty) - ; let ctxt = TcOrigin.InstDeclCtxt True - ; traceTc "Deriving strategy (standalone deriving)" $ - vcat [ppr mb_lderiv_strat, ppr deriv_ty] - ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat - ; (cls_tvs, deriv_ctxt, cls, inst_tys) - <- tcExtendTyVarEnv via_tvs $ - tcStandaloneDerivInstType ctxt deriv_ty - ; let mb_deriv_strat = fmap unLoc mb_lderiv_strat - tvs = via_tvs ++ cls_tvs - -- See Note [Unify kinds in deriving] - ; (tvs', deriv_ctxt', inst_tys', mb_deriv_strat') <- - case mb_deriv_strat of - -- Perform an additional unification with the kind of the `via` - -- type and the result of the previous kind unification. - Just (ViaStrategy via_ty) - -- This unification must be performed on the last element of - -- inst_tys, but we have not yet checked for this property. - -- (This is done later in expectNonNullaryClsArgs). For now, - -- simply do nothing if inst_tys is empty, since - -- expectNonNullaryClsArgs will error later if this - -- is the case. - | Just inst_ty <- lastMaybe inst_tys - -> do - let via_kind = tcTypeKind via_ty - inst_ty_kind = tcTypeKind inst_ty - mb_match = tcUnifyTy inst_ty_kind via_kind - - checkTc (isJust mb_match) - (derivingViaKindErr cls inst_ty_kind - via_ty via_kind) - - let Just kind_subst = mb_match - ki_subst_range = getTCvSubstRangeFVs kind_subst - -- See Note [Unification of two kind variables in deriving] - unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst - && not (v `elemVarSet` ki_subst_range)) - tvs - (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs - (final_deriv_ctxt, final_deriv_ctxt_tys) - = case deriv_ctxt of - InferContext wc -> (InferContext wc, []) - SupplyContext theta -> - let final_theta = substTheta subst theta - in (SupplyContext final_theta, final_theta) - final_inst_tys = substTys subst inst_tys - final_via_ty = substTy subst via_ty - -- See Note [Floating `via` type variables] - final_tvs = tyCoVarsOfTypesWellScoped $ - final_deriv_ctxt_tys ++ final_inst_tys - ++ [final_via_ty] - pure ( final_tvs, final_deriv_ctxt, final_inst_tys - , Just (ViaStrategy final_via_ty) ) - - _ -> pure (tvs, deriv_ctxt, inst_tys, mb_deriv_strat) - ; traceTc "Standalone deriving;" $ vcat - [ text "tvs':" <+> ppr tvs' - , text "mb_deriv_strat':" <+> ppr mb_deriv_strat' - , text "deriv_ctxt':" <+> ppr deriv_ctxt' - , text "cls:" <+> ppr cls - , text "inst_tys':" <+> ppr inst_tys' ] - -- C.f. TcInstDcls.tcLocalInstDecl1 - - ; if className cls == typeableClassName - then do warnUselessTypeable - return Nothing - else Just <$> mkEqnHelp (fmap unLoc overlap_mode) - tvs' cls inst_tys' - deriv_ctxt' mb_deriv_strat' } -deriveStandalone (L _ (XDerivDecl nec)) = noExtCon nec - --- Typecheck the type in a standalone deriving declaration. --- --- This may appear dense, but it's mostly huffing and puffing to recognize --- the special case of a type with an extra-constraints wildcard context, e.g., --- --- deriving instance _ => Eq (Foo a) --- --- If there is such a wildcard, we typecheck this as if we had written --- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@, --- as the 'DerivContext', where loc is the location of the wildcard used for --- error reporting. This indicates that we should infer the context as if we --- were deriving Eq via a deriving clause --- (see Note [Inferring the instance context] in TcDerivInfer). --- --- If there is no wildcard, then proceed as normal, and instead return --- @'SupplyContext' theta@, where theta is the typechecked context. --- --- Note that this will never return @'InferContext' 'Nothing'@, as that can --- only happen with @deriving@ clauses. -tcStandaloneDerivInstType - :: UserTypeCtxt -> LHsSigWcType GhcRn - -> TcM ([TyVar], DerivContext, Class, [Type]) -tcStandaloneDerivInstType ctxt - (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars - , hsib_body = deriv_ty_body })}) - | (tvs, theta, rho) <- splitLHsSigmaTyInvis deriv_ty_body - , L _ [wc_pred] <- theta - , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred - = do dfun_ty <- tcHsClsInstType ctxt $ - HsIB { hsib_ext = vars - , hsib_body - = L (getLoc deriv_ty_body) $ - HsForAllTy { hst_fvf = ForallInvis - , hst_bndrs = tvs - , hst_xforall = noExtField - , hst_body = rho }} - let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty - pure (tvs, InferContext (Just wc_span), cls, inst_tys) - | otherwise - = do dfun_ty <- tcHsClsInstType ctxt deriv_ty - let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty - pure (tvs, SupplyContext theta, cls, inst_tys) - -tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs nec)) - = noExtCon nec -tcStandaloneDerivInstType _ (XHsWildCardBndrs nec) - = noExtCon nec - -warnUselessTypeable :: TcM () -warnUselessTypeable - = do { warn <- woptM Opt_WarnDerivingTypeable - ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable) - $ text "Deriving" <+> quotes (ppr typeableClassName) <+> - text "has no effect: all types now auto-derive Typeable" } - ------------------------------------------------------------------- -deriveTyData :: TyCon -> [Type] -- LHS of data or data instance - -- Can be a data instance, hence [Type] args - -- and in that case the TyCon is the /family/ tycon - -> Maybe (DerivStrategy GhcTc) -- The optional deriving strategy - -> [TyVar] -- The type variables bound by the derived class - -> Class -- The derived class - -> [Type] -- The derived class's arguments - -> Kind -- The function argument in the derived class's kind. - -- (e.g., if `deriving Functor`, this would be - -- `Type -> Type` since - -- `Functor :: (Type -> Type) -> Constraint`) - -> TcM EarlyDerivSpec --- The deriving clause of a data or newtype declaration --- I.e. not standalone deriving -deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind - = do { -- Given data T a b c = ... deriving( C d ), - -- we want to drop type variables from T so that (C d (T a)) is well-kinded - let (arg_kinds, _) = splitFunTys cls_arg_kind - n_args_to_drop = length arg_kinds - n_args_to_keep = length tc_args - n_args_to_drop - -- See Note [tc_args and tycon arity] - (tc_args_to_keep, args_to_drop) - = splitAt n_args_to_keep tc_args - inst_ty_kind = tcTypeKind (mkTyConApp tc tc_args_to_keep) - - -- Match up the kinds, and apply the resulting kind substitution - -- to the types. See Note [Unify kinds in deriving] - -- We are assuming the tycon tyvars and the class tyvars are distinct - mb_match = tcUnifyTy inst_ty_kind cls_arg_kind - enough_args = n_args_to_keep >= 0 - - -- Check that the result really is well-kinded - ; checkTc (enough_args && isJust mb_match) - (derivingKindErr tc cls cls_tys cls_arg_kind enough_args) - - ; let -- Returns a singleton-element list if using ViaStrategy and an - -- empty list otherwise. Useful for free-variable calculations. - deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type] - deriv_strat_tys = foldMap (foldDerivStrategy [] (:[])) - - propagate_subst kind_subst tkvs' cls_tys' tc_args' mb_deriv_strat' - = (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) - where - ki_subst_range = getTCvSubstRangeFVs kind_subst - -- See Note [Unification of two kind variables in deriving] - unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst - && not (v `elemVarSet` ki_subst_range)) - tkvs' - (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs - final_tc_args = substTys subst tc_args' - final_cls_tys = substTys subst cls_tys' - final_mb_deriv_strat = fmap (mapDerivStrategy (substTy subst)) - mb_deriv_strat' - -- See Note [Floating `via` type variables] - final_tkvs = tyCoVarsOfTypesWellScoped $ - final_cls_tys ++ final_tc_args - ++ deriv_strat_tys final_mb_deriv_strat - - ; let tkvs = scopedSort $ fvVarList $ - unionFV (tyCoFVsOfTypes tc_args_to_keep) - (FV.mkFVs deriv_tvs) - Just kind_subst = mb_match - (tkvs', cls_tys', tc_args', mb_deriv_strat') - = propagate_subst kind_subst tkvs cls_tys - tc_args_to_keep mb_deriv_strat - - -- See Note [Unify kinds in deriving] - ; (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <- - case mb_deriv_strat' of - -- Perform an additional unification with the kind of the `via` - -- type and the result of the previous kind unification. - Just (ViaStrategy via_ty) -> do - let via_kind = tcTypeKind via_ty - inst_ty_kind - = tcTypeKind (mkTyConApp tc tc_args') - via_match = tcUnifyTy inst_ty_kind via_kind - - checkTc (isJust via_match) - (derivingViaKindErr cls inst_ty_kind via_ty via_kind) - - let Just via_subst = via_match - pure $ propagate_subst via_subst tkvs' cls_tys' - tc_args' mb_deriv_strat' - - _ -> pure (tkvs', cls_tys', tc_args', mb_deriv_strat') - - ; traceTc "deriveTyData 1" $ vcat - [ ppr final_mb_deriv_strat, pprTyVars deriv_tvs, ppr tc, ppr tc_args - , pprTyVars (tyCoVarsOfTypesList tc_args) - , ppr n_args_to_keep, ppr n_args_to_drop - , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match - , ppr final_tc_args, ppr final_cls_tys ] - - ; traceTc "deriveTyData 2" $ vcat - [ ppr final_tkvs ] - - ; let final_tc_app = mkTyConApp tc final_tc_args - final_cls_args = final_cls_tys ++ [final_tc_app] - ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c) - (derivingEtaErr cls final_cls_tys final_tc_app) - -- Check that - -- (a) The args to drop are all type variables; eg reject: - -- data instance T a Int = .... deriving( Monad ) - -- (b) The args to drop are all *distinct* type variables; eg reject: - -- class C (a :: * -> * -> *) where ... - -- data instance T a a = ... deriving( C ) - -- (c) The type class args, or remaining tycon args, - -- do not mention any of the dropped type variables - -- newtype T a s = ... deriving( ST s ) - -- newtype instance K a a = ... deriving( Monad ) - -- - -- It is vital that the implementation of allDistinctTyVars - -- expand any type synonyms. - -- See Note [Eta-reducing type synonyms] - - ; checkValidInstHead DerivClauseCtxt cls final_cls_args - -- Check that we aren't deriving an instance of a magical - -- type like (~) or Coercible (#14916). - - ; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_args - (InferContext Nothing) final_mb_deriv_strat - ; traceTc "deriveTyData 3" (ppr spec) - ; return spec } - - -{- Note [tc_args and tycon arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might wonder if we could use (tyConArity tc) at this point, rather -than (length tc_args). But for data families the two can differ! The -tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which -in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them -from DataFamInstTyCon: - -| DataFamInstTyCon -- See Note [Data type families] - (CoAxiom Unbranched) - TyCon -- The family TyCon - [Type] -- Argument types (mentions the tyConTyVars of this TyCon) - -- No shorter in length than the tyConTyVars of the family TyCon - -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv - -Notice that the arg tys might not be the same as the family tycon arity -(= length tyConTyVars). - -Note [Unify kinds in deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#8534) - data T a b = MkT a deriving( Functor ) - -- where Functor :: (*->*) -> Constraint - -So T :: forall k. * -> k -> *. We want to get - instance Functor (T * (a:*)) where ... -Notice the '*' argument to T. - -Moreover, as well as instantiating T's kind arguments, we may need to instantiate -C's kind args. Consider (#8865): - newtype T a b = MkT (Either a b) deriving( Category ) -where - Category :: forall k. (k -> k -> *) -> Constraint -We need to generate the instance - instance Category * (Either a) where ... -Notice the '*' argument to Category. - -So we need to - * drop arguments from (T a b) to match the number of - arrows in the (last argument of the) class; - * and then *unify* kind of the remaining type against the - expected kind, to figure out how to instantiate C's and T's - kind arguments. - -In the two examples, - * we unify kind-of( T k (a:k) ) ~ kind-of( Functor ) - i.e. (k -> *) ~ (* -> *) to find k:=*. - yielding k:=* - - * we unify kind-of( Either ) ~ kind-of( Category ) - i.e. (* -> * -> *) ~ (k -> k -> k) - yielding k:=* - -Now we get a kind substitution. We then need to: - - 1. Remove the substituted-out kind variables from the quantified kind vars - - 2. Apply the substitution to the kinds of quantified *type* vars - (and extend the substitution to reflect this change) - - 3. Apply that extended substitution to the non-dropped args (types and - kinds) of the type and class - -Forgetting step (2) caused #8893: - data V a = V [a] deriving Functor - data P (x::k->*) (a:k) = P (x a) deriving Functor - data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor - -When deriving Functor for P, we unify k to *, but we then want -an instance $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*)) -and similarly for C. Notice the modified kind of x, both at binding -and occurrence sites. - -This can lead to some surprising results when *visible* kind binder is -unified (in contrast to the above examples, in which only non-visible kind -binders were considered). Consider this example from #11732: - - data T k (a :: k) = MkT deriving Functor - -Since unification yields k:=*, this results in a generated instance of: - - instance Functor (T *) where ... - -which looks odd at first glance, since one might expect the instance head -to be of the form Functor (T k). Indeed, one could envision an alternative -generated instance of: - - instance (k ~ *) => Functor (T k) where - -But this does not typecheck by design: kind equalities are not allowed to be -bound in types, only terms. But in essence, the two instance declarations are -entirely equivalent, since even though (T k) matches any kind k, the only -possibly value for k is *, since anything else is ill-typed. As a result, we can -just as comfortably use (T *). - -Another way of thinking about is: deriving clauses often infer constraints. -For example: - - data S a = S a deriving Eq - -infers an (Eq a) constraint in the derived instance. By analogy, when we -are deriving Functor, we might infer an equality constraint (e.g., k ~ *). -The only distinction is that GHC instantiates equality constraints directly -during the deriving process. - -Another quirk of this design choice manifests when typeclasses have visible -kind parameters. Consider this code (also from #11732): - - class Cat k (cat :: k -> k -> *) where - catId :: cat a a - catComp :: cat b c -> cat a b -> cat a c - - instance Cat * (->) where - catId = id - catComp = (.) - - newtype Fun a b = Fun (a -> b) deriving (Cat k) - -Even though we requested a derived instance of the form (Cat k Fun), the -kind unification will actually generate (Cat * Fun) (i.e., the same thing as if -the user wrote deriving (Cat *)). - -What happens with DerivingVia, when you have yet another type? Consider: - - newtype Foo (a :: Type) = MkFoo (Proxy a) - deriving Functor via Proxy - -As before, we unify the kind of Foo (* -> *) with the kind of the argument to -Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind -(k -> *), which is more general than what we want. So we must additionally -unify (k -> *) with (* -> *). - -Currently, all of this unification is implemented kludgily with the pure -unifier, which is rather tiresome. #14331 lays out a plan for how this -might be made cleaner. - -Note [Unification of two kind variables in deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As a special case of the Note above, it is possible to derive an instance of -a poly-kinded typeclass for a poly-kinded datatype. For example: - - class Category (cat :: k -> k -> *) where - newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category - -This case is surprisingly tricky. To see why, let's write out what instance GHC -will attempt to derive (using -fprint-explicit-kinds syntax): - - instance Category k1 (T k2 c) where ... - -GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst) -that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to -the type variable binder for c, since its kind is (k2 -> k2 -> *). - -We used to accomplish this by doing the following: - - unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs - (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs - -Where all_tkvs contains all kind variables in the class and instance types (in -this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping, -this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped -to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new]. -This is bad, because applying that substitution yields the following instance: - - instance Category k_new (T k1 c) where ... - -In other words, keeping k1 in unmapped_tvks taints the substitution, resulting -in an ill-kinded instance (this caused #11837). - -To prevent this, we need to filter out any variable from all_tkvs which either - -1. Appears in the domain of kind_subst. notElemTCvSubst checks this. -2. Appears in the range of kind_subst. To do this, we compute the free - variable set of the range of kind_subst with getTCvSubstRangeFVs, and check - if a kind variable appears in that set. - -Note [Eta-reducing type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One can instantiate a type in a data family instance with a type synonym that -mentions other type variables: - - type Const a b = a - data family Fam (f :: * -> *) (a :: *) - newtype instance Fam f (Const a f) = Fam (f a) deriving Functor - -It is also possible to define kind synonyms, and they can mention other types in -a datatype declaration. For example, - - type Const a b = a - newtype T f (a :: Const * f) = T (f a) deriving Functor - -When deriving, we need to perform eta-reduction analysis to ensure that none of -the eta-reduced type variables are mentioned elsewhere in the declaration. But -we need to be careful, because if we don't expand through the Const type -synonym, we will mistakenly believe that f is an eta-reduced type variable and -fail to derive Functor, even though the code above is correct (see #11416, -where this was first noticed). For this reason, we expand the type synonyms in -the eta-reduced types before doing any analysis. - -Note [Floating `via` type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When generating a derived instance, it will be of the form: - - instance forall ???. C c_args (D d_args) where ... - -To fill in ???, GHC computes the free variables of `c_args` and `d_args`. -`DerivingVia` adds an extra wrinkle to this formula, since we must also -include the variables bound by the `via` type when computing the binders -used to fill in ???. This might seem strange, since if a `via` type binds -any type variables, then in almost all scenarios it will appear free in -`c_args` or `d_args`. There are certain corner cases where this does not hold, -however, such as in the following example (adapted from #15831): - - newtype Age = MkAge Int - deriving Eq via Const Int a - -In this example, the `via` type binds the type variable `a`, but `a` appears -nowhere in `Eq Age`. Nevertheless, we include it in the generated instance: - - instance forall a. Eq Age where - (==) = coerce @(Const Int a -> Const Int a -> Bool) - @(Age -> Age -> Bool) - (==) - -The use of `forall a` is certainly required here, since the `a` in -`Const Int a` would not be in scope otherwise. This instance is somewhat -strange in that nothing in the instance head `Eq Age` ever determines what `a` -will be, so any code that uses this instance will invariably instantiate `a` -to be `Any`. We refer to this property of `a` as being a "floating" `via` -type variable. Programs with floating `via` type variables are the only known -class of program in which the `via` type quantifies type variables that aren't -mentioned in the instance head in the generated instance. - -Fortunately, the choice to instantiate floating `via` type variables to `Any` -is one that is completely transparent to the user (since the instance will -work as expected regardless of what `a` is instantiated to), so we decide to -permit them. An alternative design would make programs with floating `via` -variables illegal, by requiring that every variable mentioned in the `via` type -is also mentioned in the data header or the derived class. That restriction -would require the user to pick a particular type (the choice does not matter); -for example: - - newtype Age = MkAge Int - -- deriving Eq via Const Int a -- Floating 'a' - deriving Eq via Const Int () -- Choose a=() - deriving Eq via Const Int Any -- Choose a=Any - -No expressiveness would be lost thereby, but stylistically it seems preferable -to allow a type variable to indicate "it doesn't matter". - -Note that by quantifying the `a` in `forall a. Eq Age`, we are deferring the -work of instantiating `a` to `Any` at every use site of the instance. An -alternative approach would be to generate an instance that directly defaulted -to `Any`: - - instance Eq Age where - (==) = coerce @(Const Int Any -> Const Int Any -> Bool) - @(Age -> Age -> Bool) - (==) - -We do not implement this approach since it would require a nontrivial amount -of implementation effort to substitute `Any` for the floating `via` type -variables, and since the end result isn't distinguishable from the former -instance (at least from the user's perspective), the amount of engineering -required to obtain the latter instance just isn't worth it. --} - -mkEqnHelp :: Maybe OverlapMode - -> [TyVar] - -> Class -> [Type] - -> DerivContext - -- SupplyContext => context supplied (standalone deriving) - -- InferContext => context inferred (deriving on data decl, or - -- standalone deriving decl with a wildcard) - -> Maybe (DerivStrategy GhcTc) - -> TcRn EarlyDerivSpec --- Make the EarlyDerivSpec for an instance --- forall tvs. theta => cls (tys ++ [ty]) --- where the 'theta' is optional (that's the Maybe part) --- Assumes that this declaration is well-kinded - -mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do - is_boot <- tcIsHsBootOrSig - when is_boot $ - bale_out (text "Cannot derive instances in hs-boot files" - $+$ text "Write an instance declaration instead") - runReaderT mk_eqn deriv_env - where - deriv_env = DerivEnv { denv_overlap_mode = overlap_mode - , denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = cls_args - , denv_ctxt = deriv_ctxt - , denv_strat = deriv_strat } - - bale_out msg = failWithTc $ derivingThingErr False cls cls_args deriv_strat msg - - mk_eqn :: DerivM EarlyDerivSpec - mk_eqn = do - DerivEnv { denv_inst_tys = cls_args - , denv_strat = mb_strat } <- ask - case mb_strat of - Just StockStrategy -> do - (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args - dit <- expectAlgTyConApp cls_tys inst_ty - mk_eqn_stock dit - - Just AnyclassStrategy -> mk_eqn_anyclass - - Just (ViaStrategy via_ty) -> do - (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args - mk_eqn_via cls_tys inst_ty via_ty - - Just NewtypeStrategy -> do - (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args - dit <- expectAlgTyConApp cls_tys inst_ty - unless (isNewTyCon (dit_rep_tc dit)) $ - derivingThingFailWith False gndNonNewtypeErr - mkNewTypeEqn True dit - - Nothing -> mk_eqn_no_strategy - --- @expectNonNullaryClsArgs inst_tys@ checks if @inst_tys@ is non-empty. --- If so, return @(init inst_tys, last inst_tys)@. --- Otherwise, throw an error message. --- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this --- property is important. -expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type) -expectNonNullaryClsArgs inst_tys = - maybe (derivingThingFailWith False derivingNullaryErr) pure $ - snocView inst_tys - --- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application --- of an algebraic type constructor. If so, return a 'DerivInstTys' consisting --- of @cls_tys@ and the constituent pars of @inst_ty@. --- Otherwise, throw an error message. --- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this --- property is important. -expectAlgTyConApp :: [Type] -- All but the last argument to the class in a - -- derived instance - -> Type -- The last argument to the class in a - -- derived instance - -> DerivM DerivInstTys -expectAlgTyConApp cls_tys inst_ty = do - fam_envs <- lift tcGetFamInstEnvs - case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of - Nothing -> derivingThingFailWith False $ - text "The last argument of the instance must be a" - <+> text "data or newtype application" - Just dit -> do expectNonDataFamTyCon dit - pure dit - --- @expectNonDataFamTyCon dit@ checks if @dit_rep_tc dit@ is a representation --- type constructor for a data family instance, and if not, --- throws an error message. --- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this --- property is important. -expectNonDataFamTyCon :: DerivInstTys -> DerivM () -expectNonDataFamTyCon (DerivInstTys { dit_tc = tc - , dit_tc_args = tc_args - , dit_rep_tc = rep_tc }) = - -- If it's still a data family, the lookup failed; i.e no instance exists - when (isDataFamilyTyCon rep_tc) $ - derivingThingFailWith False $ - text "No family instance for" <+> quotes (pprTypeApp tc tc_args) - -mk_deriv_inst_tys_maybe :: FamInstEnvs - -> [Type] -> Type -> Maybe DerivInstTys -mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty = - fmap lookup $ tcSplitTyConApp_maybe inst_ty - where - lookup :: (TyCon, [Type]) -> DerivInstTys - lookup (tc, tc_args) = - -- Find the instance of a data family - -- Note [Looking up family instances for deriving] - let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tc tc_args - in DerivInstTys { dit_cls_tys = cls_tys - , dit_tc = tc - , dit_tc_args = tc_args - , dit_rep_tc = rep_tc - , dit_rep_tc_args = rep_tc_args } - -{- -Note [Looking up family instances for deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcLookupFamInstExact is an auxiliary lookup wrapper which requires -that looked-up family instances exist. If called with a vanilla -tycon, the old type application is simply returned. - -If we have - data instance F () = ... deriving Eq - data instance F () = ... deriving Eq -then tcLookupFamInstExact will be confused by the two matches; -but that can't happen because tcInstDecls1 doesn't call tcDeriving -if there are any overlaps. - -There are two other things that might go wrong with the lookup. -First, we might see a standalone deriving clause - deriving Eq (F ()) -when there is no data instance F () in scope. - -Note that it's OK to have - data instance F [a] = ... - deriving Eq (F [(a,b)]) -where the match is not exact; the same holds for ordinary data types -with standalone deriving declarations. - -Note [Deriving, type families, and partial applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When there are no type families, it's quite easy: - - newtype S a = MkS [a] - -- :CoS :: S ~ [] -- Eta-reduced - - instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a) - instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S - -When type families are involved it's trickier: - - data family T a b - newtype instance T Int a = MkT [a] deriving( Eq, Monad ) - -- :RT is the representation type for (T Int a) - -- :Co:RT :: :RT ~ [] -- Eta-reduced! - -- :CoF:RT a :: T Int a ~ :RT a -- Also eta-reduced! - - instance Eq [a] => Eq (T Int a) -- easy by coercion - -- d1 :: Eq [a] - -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a)) - - instance Monad [] => Monad (T Int) -- only if we can eta reduce??? - -- d1 :: Monad [] - -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT)) - -Note the need for the eta-reduced rule axioms. After all, we can -write it out - instance Monad [] => Monad (T Int) -- only if we can eta reduce??? - return x = MkT [x] - ... etc ... - -See Note [Eta reduction for data families] in GHC.Core.FamInstEnv - -%************************************************************************ -%* * - Deriving data types -* * -************************************************************************ --} - --- Once the DerivSpecMechanism is known, we can finally produce an --- EarlyDerivSpec from it. -mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec -mk_eqn_from_mechanism mechanism - = do DerivEnv { denv_overlap_mode = overlap_mode - , denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = inst_tys - , denv_ctxt = deriv_ctxt } <- ask - doDerivInstErrorChecks1 mechanism - loc <- lift getSrcSpanM - dfun_name <- lift $ newDFunName cls inst_tys loc - case deriv_ctxt of - InferContext wildcard -> - do { (inferred_constraints, tvs', inst_tys') - <- inferConstraints mechanism - ; return $ InferTheta $ DS - { ds_loc = loc - , ds_name = dfun_name, ds_tvs = tvs' - , ds_cls = cls, ds_tys = inst_tys' - , ds_theta = inferred_constraints - , ds_overlap = overlap_mode - , ds_standalone_wildcard = wildcard - , ds_mechanism = mechanism } } - - SupplyContext theta -> - return $ GivenTheta $ DS - { ds_loc = loc - , ds_name = dfun_name, ds_tvs = tvs - , ds_cls = cls, ds_tys = inst_tys - , ds_theta = theta - , ds_overlap = overlap_mode - , ds_standalone_wildcard = Nothing - , ds_mechanism = mechanism } - -mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class - -> DerivM EarlyDerivSpec -mk_eqn_stock dit@(DerivInstTys { dit_cls_tys = cls_tys - , dit_tc = tc - , dit_rep_tc = rep_tc }) - = do DerivEnv { denv_cls = cls - , denv_ctxt = deriv_ctxt } <- ask - dflags <- getDynFlags - case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys - tc rep_tc of - CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ - DerivSpecStock { dsm_stock_dit = dit - , dsm_stock_gen_fn = gen_fn } - StockClassError msg -> derivingThingFailWith False msg - _ -> derivingThingFailWith False (nonStdErr cls) - -mk_eqn_anyclass :: DerivM EarlyDerivSpec -mk_eqn_anyclass - = do dflags <- getDynFlags - case canDeriveAnyClass dflags of - IsValid -> mk_eqn_from_mechanism DerivSpecAnyClass - NotValid msg -> derivingThingFailWith False msg - -mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class - -> Type -- The newtype's representation type - -> DerivM EarlyDerivSpec -mk_eqn_newtype dit rep_ty = - mk_eqn_from_mechanism $ DerivSpecNewtype { dsm_newtype_dit = dit - , dsm_newtype_rep_ty = rep_ty } - -mk_eqn_via :: [Type] -- All arguments to the class besides the last - -> Type -- The last argument to the class - -> Type -- The @via@ type - -> DerivM EarlyDerivSpec -mk_eqn_via cls_tys inst_ty via_ty = - mk_eqn_from_mechanism $ DerivSpecVia { dsm_via_cls_tys = cls_tys - , dsm_via_inst_ty = inst_ty - , dsm_via_ty = via_ty } - --- Derive an instance without a user-requested deriving strategy. This uses --- heuristics to determine which deriving strategy to use. --- See Note [Deriving strategies]. -mk_eqn_no_strategy :: DerivM EarlyDerivSpec -mk_eqn_no_strategy = do - DerivEnv { denv_cls = cls - , denv_inst_tys = cls_args } <- ask - fam_envs <- lift tcGetFamInstEnvs - - -- First, check if the last argument is an application of a type constructor. - -- If not, fall back to DeriveAnyClass. - if | Just (cls_tys, inst_ty) <- snocView cls_args - , Just dit <- mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty - -> if | isNewTyCon (dit_rep_tc dit) - -- We have a dedicated code path for newtypes (see the - -- documentation for mkNewTypeEqn as to why this is the case) - -> mkNewTypeEqn False dit - - | otherwise - -> do -- Otherwise, our only other options are stock or anyclass. - -- If it is stock, we must confirm that the last argument's - -- type constructor is algebraic. - -- See Note [DerivEnv and DerivSpecMechanism] in TcDerivUtils - whenIsJust (hasStockDeriving cls) $ \_ -> - expectNonDataFamTyCon dit - mk_eqn_originative 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_cls_tys = cls_tys - , dit_tc = tc - , dit_rep_tc = rep_tc }) = do - DerivEnv { denv_cls = cls - , denv_ctxt = deriv_ctxt } <- ask - dflags <- getDynFlags - - -- See Note [Deriving instances for classes themselves] - let dac_error msg - | isClassTyCon rep_tc - = quotes (ppr tc) <+> text "is a type class," - <+> text "and can only have a derived instance" - $+$ text "if DeriveAnyClass is enabled" - | otherwise - = nonStdErr cls $$ msg - - case checkOriginativeSideConditions dflags deriv_ctxt cls - cls_tys tc rep_tc of - NonDerivableClass msg -> derivingThingFailWith False (dac_error msg) - StockClassError msg -> derivingThingFailWith False msg - CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ - DerivSpecStock { dsm_stock_dit = dit - , dsm_stock_gen_fn = gen_fn } - CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass - -{- -************************************************************************ -* * - Deriving instances for newtypes -* * -************************************************************************ --} - --- Derive an instance for a newtype. We put this logic into its own function --- because --- --- (a) When no explicit deriving strategy is requested, we have special --- heuristics for newtypes to determine which deriving strategy should --- actually be used. See Note [Deriving strategies]. --- (b) We make an effort to give error messages specifically tailored to --- newtypes. -mkNewTypeEqn :: Bool -- Was this instance derived using an explicit @newtype@ - -- deriving strategy? - -> DerivInstTys -> DerivM EarlyDerivSpec -mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys - , dit_tc = tycon - , dit_rep_tc = rep_tycon - , dit_rep_tc_args = rep_tc_args }) --- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ... - = do DerivEnv { denv_cls = cls - , denv_ctxt = deriv_ctxt } <- ask - dflags <- getDynFlags - - let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags - deriveAnyClass = xopt LangExt.DeriveAnyClass dflags - - bale_out = derivingThingFailWith newtype_deriving - - non_std = nonStdErr cls - suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's" - <+> text "newtype-deriving extension" - - -- Here is the plan for newtype derivings. We see - -- newtype T a1...an = MkT (t ak+1...an) - -- deriving (.., C s1 .. sm, ...) - -- where t is a type, - -- ak+1...an is a suffix of a1..an, and are all tyvars - -- ak+1...an do not occur free in t, nor in the s1..sm - -- (C s1 ... sm) is a *partial applications* of class C - -- with the last parameter missing - -- (T a1 .. ak) matches the kind of C's last argument - -- (and hence so does t) - -- The latter kind-check has been done by deriveTyData already, - -- and tc_args are already trimmed - -- - -- We generate the instance - -- instance forall ({a1..ak} u fvs(s1..sm)). - -- C s1 .. sm t => C s1 .. sm (T a1...ak) - -- where T a1...ap is the partial application of - -- the LHS of the correct kind and p >= k - -- - -- NB: the variables below are: - -- tc_tvs = [a1, ..., an] - -- tyvars_to_keep = [a1, ..., ak] - -- rep_ty = t ak .. an - -- deriv_tvs = fvs(s1..sm) \ tc_tvs - -- tys = [s1, ..., sm] - -- rep_fn' = t - -- - -- Running example: newtype T s a = MkT (ST s a) deriving( Monad ) - -- We generate the instance - -- instance Monad (ST s) => Monad (T s) where - - nt_eta_arity = newTyConEtadArity rep_tycon - -- For newtype T a b = MkT (S a a b), the TyCon - -- machinery already eta-reduces the representation type, so - -- we know that - -- T a ~ S a a - -- That's convenient here, because we may have to apply - -- it to fewer than its original complement of arguments - - -- Note [Newtype representation] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Need newTyConRhs (*not* a recursive representation finder) - -- to get the representation type. For example - -- newtype B = MkB Int - -- newtype A = MkA B deriving( Num ) - -- We want the Num instance of B, *not* the Num instance of Int, - -- when making the Num instance of A! - rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args - - ------------------------------------------------------------------- - -- Figuring out whether we can only do this newtype-deriving thing - - -- See Note [Determining whether newtype-deriving is appropriate] - might_be_newtype_derivable - = not (non_coercible_class cls) - && eta_ok --- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes] - - -- Check that eta reduction is OK - eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity - -- The newtype can be eta-reduced to match the number - -- of type argument actually supplied - -- newtype T a b = MkT (S [a] b) deriving( Monad ) - -- Here the 'b' must be the same in the rep type (S [a] b) - -- And the [a] must not mention 'b'. That's all handled - -- by nt_eta_rity. - - cant_derive_err = ppUnless eta_ok eta_msg - eta_msg = text "cannot eta-reduce the representation type enough" - - MASSERT( cls_tys `lengthIs` (classArity cls - 1) ) - if newtype_strat - then - -- Since the user explicitly asked for GeneralizedNewtypeDeriving, - -- we don't need to perform all of the checks we normally would, - -- such as if the class being derived is known to produce ill-roled - -- coercions (e.g., Traversable), since we can just derive the - -- instance and let it error if need be. - -- See Note [Determining whether newtype-deriving is appropriate] - if eta_ok && newtype_deriving - then mk_eqn_newtype dit rep_inst_ty - else bale_out (cant_derive_err $$ - if newtype_deriving then empty else suggest_gnd) - else - if might_be_newtype_derivable - && ((newtype_deriving && not deriveAnyClass) - || std_class_via_coercible cls) - then mk_eqn_newtype dit rep_inst_ty - else case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys - tycon rep_tycon of - StockClassError msg - -- There's a particular corner case where - -- - -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are - -- both enabled at the same time - -- 2. We're deriving a particular stock derivable class - -- (such as Functor) - -- - -- and the previous cases won't catch it. This fixes the bug - -- reported in #10598. - | might_be_newtype_derivable && newtype_deriving - -> mk_eqn_newtype dit rep_inst_ty - -- Otherwise, throw an error for a stock class - | might_be_newtype_derivable && not newtype_deriving - -> bale_out (msg $$ suggest_gnd) - | otherwise - -> bale_out msg - - -- Must use newtype deriving or DeriveAnyClass - NonDerivableClass _msg - -- Too hard, even with newtype deriving - | newtype_deriving -> bale_out cant_derive_err - -- Try newtype deriving! - -- Here we suggest GeneralizedNewtypeDeriving even in cases - -- where it may not be applicable. See #9600. - | otherwise -> bale_out (non_std $$ suggest_gnd) - - -- DeriveAnyClass - CanDeriveAnyClass -> do - -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are - -- enabled, we take the diplomatic approach of defaulting to - -- DeriveAnyClass, but emitting a warning about the choice. - -- See Note [Deriving strategies] - when (newtype_deriving && deriveAnyClass) $ - lift $ whenWOptM Opt_WarnDerivingDefaults $ - addWarnTc (Reason Opt_WarnDerivingDefaults) $ sep - [ text "Both DeriveAnyClass and" - <+> text "GeneralizedNewtypeDeriving are enabled" - , text "Defaulting to the DeriveAnyClass strategy" - <+> text "for instantiating" <+> ppr cls - , text "Use DerivingStrategies to pick" - <+> text "a different strategy" - ] - mk_eqn_from_mechanism DerivSpecAnyClass - -- CanDeriveStock - CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ - DerivSpecStock { dsm_stock_dit = dit - , dsm_stock_gen_fn = gen_fn } - -{- -Note [Recursive newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Newtype deriving works fine, even if the newtype is recursive. -e.g. newtype S1 = S1 [T1 ()] - newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad ) -Remember, too, that type families are currently (conservatively) given -a recursive flag, so this also allows newtype deriving to work -for type famillies. - -We used to exclude recursive types, because we had a rather simple -minded way of generating the instance decl: - newtype A = MkA [A] - instance Eq [A] => Eq A -- Makes typechecker loop! -But now we require a simple context, so it's ok. - -Note [Determining whether newtype-deriving is appropriate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we see - newtype NT = MkNT Foo - deriving C -we have to decide how to perform the deriving. Do we do newtype deriving, -or do we do normal deriving? In general, we prefer to do newtype deriving -wherever possible. So, we try newtype deriving unless there's a glaring -reason not to. - -"Glaring reasons not to" include trying to derive a class for which a -coercion-based instance doesn't make sense. These classes are listed in -the definition of non_coercible_class. They include Show (since it must -show the name of the datatype) and Traversable (since a coercion-based -Traversable instance is ill-roled). - -However, non_coercible_class is ignored if the user explicitly requests -to derive an instance with GeneralizedNewtypeDeriving using the newtype -deriving strategy. In such a scenario, GHC will unquestioningly try to -derive the instance via coercions (even if the final generated code is -ill-roled!). See Note [Deriving strategies]. - -Note that newtype deriving might fail, even after we commit to it. This -is because the derived instance uses `coerce`, which must satisfy its -`Coercible` constraint. This is different than other deriving scenarios, -where we're sure that the resulting instance will type-check. - -Note [GND and associated type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for -classes with associated type families. A general recipe is: - - class C x y z where - type T y z x - op :: x -> [y] -> z - - newtype N a = MkN deriving( C ) - - =====> - - instance C x y => C x y (N a) where - type T y (N a) x = T y x - op = coerce (op :: x -> [y] -> ) - -However, we must watch out for three things: - -(a) The class must not contain any data families. If it did, we'd have to - generate a fresh data constructor name for the derived data family - instance, and it's not clear how to do this. - -(b) Each associated type family's type variables must mention the last type - variable of the class. As an example, you wouldn't be able to use GND to - derive an instance of this class: - - class C a b where - type T a - - But you would be able to derive an instance of this class: - - class C a b where - type T b - - The difference is that in the latter T mentions the last parameter of C - (i.e., it mentions b), but the former T does not. If you tried, e.g., - - newtype Foo x = Foo x deriving (C a) - - with the former definition of C, you'd end up with something like this: - - instance C a (Foo x) where - type T a = T ??? - - This T family instance doesn't mention the newtype (or its representation - type) at all, so we disallow such constructions with GND. - -(c) UndecidableInstances might need to be enabled. Here's a case where it is - most definitely necessary: - - class C a where - type T a - newtype Loop = Loop MkLoop deriving C - - =====> - - instance C Loop where - type T Loop = T Loop - - Obviously, T Loop would send the typechecker into a loop. Unfortunately, - you might even need UndecidableInstances even in cases where the - typechecker would be guaranteed to terminate. For example: - - instance C Int where - type C Int = Int - newtype MyInt = MyInt Int deriving C - - =====> - - instance C MyInt where - type T MyInt = T Int - - GHC's termination checker isn't sophisticated enough to conclude that the - definition of T MyInt terminates, so UndecidableInstances is required. - -(d) For the time being, we do not allow the last type variable of the class to - appear in a /kind/ of an associated type family definition. For instance: - - class C a where - type T1 a -- OK - type T2 (x :: a) -- Illegal: a appears in the kind of x - type T3 y :: a -- Illegal: a appears in the kind of (T3 y) - - The reason we disallow this is because our current approach to deriving - associated type family instances—i.e., by unwrapping the newtype's type - constructor as shown above—is ill-equipped to handle the scenario when - the last type variable appears as an implicit argument. In the worst case, - allowing the last variable to appear in a kind can result in improper Core - being generated (see #14728). - - There is hope for this feature being added some day, as one could - conceivably take a newtype axiom (which witnesses a coercion between a - newtype and its representation type) at lift that through each associated - type at the Core level. See #14728, comment:3 for a sketch of how this - might work. Until then, we disallow this featurette wholesale. - -The same criteria apply to DerivingVia. - -************************************************************************ -* * -\subsection[TcDeriv-normal-binds]{Bindings for the various classes} -* * -************************************************************************ - -After all the trouble to figure out the required context for the -derived instance declarations, all that's left is to chug along to -produce them. They will then be shoved into @tcInstDecls2@, which -will do all its usual business. - -There are lots of possibilities for code to generate. Here are -various general remarks. - -PRINCIPLES: -\begin{itemize} -\item -We want derived instances of @Eq@ and @Ord@ (both v common) to be -``you-couldn't-do-better-by-hand'' efficient. - -\item -Deriving @Show@---also pretty common--- should also be reasonable good code. - -\item -Deriving for the other classes isn't that common or that big a deal. -\end{itemize} - -PRAGMATICS: - -\begin{itemize} -\item -Deriving @Ord@ is done mostly with the 1.3 @compare@ method. - -\item -Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too. - -\item -We {\em normally} generate code only for the non-defaulted methods; -there are some exceptions for @Eq@ and (especially) @Ord@... - -\item -Sometimes we use a @_con2tag_@ function, which returns a data -constructor's numeric (@Int#@) tag. These are generated by -@gen_tag_n_con_binds@, and the heuristic for deciding if one of -these is around is given by @hasCon2TagFun@. - -The examples under the different sections below will make this -clearer. - -\item -Much less often (really just for deriving @Ix@), we use a -@_tag2con_@ function. See the examples. - -\item -We use the renamer!!! Reason: we're supposed to be -producing @LHsBinds Name@ for the methods, but that means -producing correctly-uniquified code on the fly. This is entirely -possible (the @TcM@ monad has a @UniqueSupply@), but it is painful. -So, instead, we produce @MonoBinds RdrName@ then heave 'em through -the renamer. What a great hack! -\end{itemize} --} - --- Generate the InstInfo for the required instance --- plus any auxiliary bindings required -genInst :: DerivSpec theta - -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name]) --- We must use continuation-returning style here to get the order in which we --- typecheck family instances and derived instances right. --- See Note [Staging of tcDeriving] -genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism - , ds_tys = tys, ds_cls = clas, ds_loc = loc - , ds_standalone_wildcard = wildcard }) - = do (meth_binds, meth_sigs, deriv_stuff, unusedNames) - <- set_span_and_ctxt $ - genDerivStuff mechanism loc clas tys tvs - let mk_inst_info theta = set_span_and_ctxt $ do - inst_spec <- newDerivClsInst theta spec - doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism - traceTc "newder" (ppr inst_spec) - return $ InstInfo - { iSpec = inst_spec - , iBinds = InstBindings - { ib_binds = meth_binds - , ib_tyvars = map Var.varName tvs - , ib_pragmas = meth_sigs - , ib_extensions = extensions - , ib_derived = True } } - return (mk_inst_info, deriv_stuff, unusedNames) - where - extensions :: [LangExt.Extension] - extensions - | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism - = [ - -- Both these flags are needed for higher-rank uses of coerce... - LangExt.ImpredicativeTypes, LangExt.RankNTypes - -- ...and this flag is needed to support the instance signatures - -- that bring type variables into scope. - -- See Note [Newtype-deriving instances] in TcGenDeriv - , LangExt.InstanceSigs - ] - | otherwise - = [] - - set_span_and_ctxt :: TcM a -> TcM a - set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys) - --- Checks: --- --- * All of the data constructors for a data type are in scope for a --- standalone-derived instance (for `stock` and `newtype` deriving). --- --- * All of the associated type families of a class are suitable for --- GeneralizedNewtypeDeriving or DerivingVia (for `newtype` and `via` --- deriving). -doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM () -doDerivInstErrorChecks1 mechanism = - 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 - DerivSpecAnyClass{} - -> pure () - DerivSpecVia{} - -> atf_coerce_based_error_checks - where - -- When processing a standalone deriving declaration, check that all of the - -- constructors for the data type are in scope. For instance: - -- - -- import M (T) - -- deriving stock instance Eq T - -- - -- This should be rejected, as the derived Eq instance would need to refer - -- to the constructors for T, which are not in scope. - -- - -- Note that the only strategies that require this check are `stock` and - -- `newtype`. Neither `anyclass` nor `via` require it as the code that they - -- generate does not require using data constructors. - data_cons_in_scope_check :: DerivInstTys -> DerivM () - data_cons_in_scope_check (DerivInstTys { dit_tc = tc - , dit_rep_tc = rep_tc }) = do - standalone <- isStandaloneDeriv - when standalone $ do - let bale_out msg = do err <- derivingThingErrMechanism mechanism msg - lift $ failWithTc err - - rdr_env <- lift getGlobalRdrEnv - let data_con_names = map dataConName (tyConDataCons rep_tc) - hidden_data_cons = not (isWiredIn rep_tc) && - (isAbstractTyCon rep_tc || - any not_in_scope data_con_names) - not_in_scope dc = isNothing (lookupGRE_Name rdr_env dc) - - -- Make sure to also mark the data constructors as used so that GHC won't - -- mistakenly emit -Wunused-imports warnings about them. - lift $ addUsedDataCons rdr_env rep_tc - - unless (not hidden_data_cons) $ - bale_out $ derivingHiddenErr tc - - -- Ensure that a class's associated type variables are suitable for - -- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is - -- only required for the `newtype` and `via` strategies. - -- - -- See Note [GND and associated type families] - atf_coerce_based_error_checks :: DerivM () - atf_coerce_based_error_checks = do - cls <- asks denv_cls - let bale_out msg = do err <- derivingThingErrMechanism mechanism msg - lift $ failWithTc err - - cls_tyvars = classTyVars cls - - ats_look_sensible - = -- Check (a) from Note [GND and associated type families] - no_adfs - -- Check (b) from Note [GND and associated type families] - && isNothing at_without_last_cls_tv - -- Check (d) from Note [GND and associated type families] - && isNothing at_last_cls_tv_in_kinds - - (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs - no_adfs = null adf_tcs - -- We cannot newtype-derive data family instances - - at_without_last_cls_tv - = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs - at_last_cls_tv_in_kinds - = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind) - (tyConTyVars tc) - || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs - at_last_cls_tv_in_kind kind - = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind - at_tcs = classATs cls - last_cls_tv = ASSERT( notNull cls_tyvars ) - last cls_tyvars - - cant_derive_err - = vcat [ ppUnless no_adfs adfs_msg - , maybe empty at_without_last_cls_tv_msg - at_without_last_cls_tv - , maybe empty at_last_cls_tv_in_kinds_msg - at_last_cls_tv_in_kinds - ] - adfs_msg = text "the class has associated data types" - at_without_last_cls_tv_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "is not parameterized over the last type variable") - 2 (text "of the class" <+> quotes (ppr cls)) - at_last_cls_tv_in_kinds_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "contains the last type variable") - 2 (text "of the class" <+> quotes (ppr cls) - <+> text "in a kind, which is not (yet) allowed") - unless ats_look_sensible $ bale_out cant_derive_err - -doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan - -> DerivSpecMechanism -> TcM () -doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism - = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst) - ; dflags <- getDynFlags - ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures - ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures - - -- Error if PartialTypeSignatures isn't enabled when a user tries - -- to write @deriving instance _ => Eq (Foo a)@. Or, if that - -- extension is enabled, give a warning if -Wpartial-type-signatures - -- is enabled. - ; case wildcard of - Nothing -> pure () - Just span -> setSrcSpan span $ do - checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion) - warnTc (Reason Opt_WarnPartialTypeSignatures) - wpartial_sigs partial_sig_msg - - -- Check for Generic instances that are derived with an exotic - -- deriving strategy like DAC - -- See Note [Deriving strategies] - ; when (exotic_mechanism && className clas `elem` genericClassNames) $ - do { failIfTc (safeLanguageOn dflags) gen_inst_err - ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } } - where - exotic_mechanism = not $ isDerivSpecStock mechanism - - partial_sig_msg = text "Found type wildcard" <+> quotes (char '_') - <+> text "standing for" <+> quotes (pprTheta theta) - - pts_suggestion - = text "To use the inferred type, enable PartialTypeSignatures" - - gen_inst_err = text "Generic instances can only be derived in" - <+> text "Safe Haskell using the stock strategy." - -derivingThingFailWith :: Bool -- If True, add a snippet about how not even - -- GeneralizedNewtypeDeriving would make this - -- declaration work. This only kicks in when - -- an explicit deriving strategy is not given. - -> SDoc -- The error message - -> DerivM a -derivingThingFailWith newtype_deriving msg = do - err <- derivingThingErrM newtype_deriving msg - lift $ failWithTc err - -genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class - -> [Type] -> [TyVar] - -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]) -genDerivStuff mechanism loc clas inst_tys tyvars - = case mechanism of - -- See Note [Bindings for Generalised Newtype Deriving] - DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty} - -> gen_newtype_or_via rhs_ty - - -- Try a stock deriver - DerivSpecStock { dsm_stock_dit = DerivInstTys{dit_rep_tc = rep_tc} - , dsm_stock_gen_fn = gen_fn } - -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys - pure (binds, [], faminsts, field_names) - - -- Try DeriveAnyClass - DerivSpecAnyClass -> do - let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) - mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env - dflags <- getDynFlags - tyfam_insts <- - -- canDeriveAnyClass should ensure that this code can't be reached - -- unless -XDeriveAnyClass is enabled. - ASSERT2( isValid (canDeriveAnyClass dflags) - , ppr "genDerivStuff: bad derived class" <+> ppr clas ) - mapM (tcATDefault loc mini_subst emptyNameSet) - (classATItems clas) - return ( emptyBag, [] -- No method bindings are needed... - , listToBag (map DerivFamInst (concat tyfam_insts)) - -- ...but we may need to generate binding for associated type - -- family default instances. - -- See Note [DeriveAnyClass and default family instances] - , [] ) - - -- Try DerivingVia - DerivSpecVia{dsm_via_ty = via_ty} - -> gen_newtype_or_via via_ty - where - gen_newtype_or_via ty = do - (binds, sigs, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty - return (binds, sigs, faminsts, []) - -{- -Note [Bindings for Generalised Newtype Deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - class Eq a => C a where - f :: a -> a - newtype N a = MkN [a] deriving( C ) - instance Eq (N a) where ... - -The 'deriving C' clause generates, in effect - instance (C [a], Eq a) => C (N a) where - f = coerce (f :: [a] -> [a]) - -This generates a cast for each method, but allows the superclasse to -be worked out in the usual way. In this case the superclass (Eq (N -a)) will be solved by the explicit Eq (N a) instance. We do *not* -create the superclasses by casting the superclass dictionaries for the -representation type. - -See the paper "Safe zero-cost coercions for Haskell". - -Note [DeriveAnyClass and default family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When a class has a associated type family with a default instance, e.g.: - - class C a where - type T a - type T a = Char - -then there are a couple of scenarios in which a user would expect T a to -default to Char. One is when an instance declaration for C is given without -an implementation for T: - - instance C Int - -Another scenario in which this can occur is when the -XDeriveAnyClass extension -is used: - - data Example = Example deriving (C, Generic) - -In the latter case, we must take care to check if C has any associated type -families with default instances, because -XDeriveAnyClass will never provide -an implementation for them. We "fill in" the default instances using the -tcATDefault function from TcClassDcl (which is also used in TcInstDcls to -handle the empty instance declaration case). - -Note [Deriving strategies] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC has a notion of deriving strategies, which allow the user to explicitly -request which approach to use when deriving an instance (enabled with the --XDerivingStrategies language extension). For more information, refer to the -original issue (#10598) or the associated wiki page: -https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies - -A deriving strategy can be specified in a deriving clause: - - newtype Foo = MkFoo Bar - deriving newtype C - -Or in a standalone deriving declaration: - - deriving anyclass instance C Foo - --XDerivingStrategies also allows the use of multiple deriving clauses per data -declaration so that a user can derive some instance with one deriving strategy -and other instances with another deriving strategy. For example: - - newtype Baz = Baz Quux - deriving (Eq, Ord) - deriving stock (Read, Show) - deriving newtype (Num, Floating) - deriving anyclass C - -Currently, the deriving strategies are: - -* stock: Have GHC implement a "standard" instance for a data type, if possible - (e.g., Eq, Ord, Generic, Data, Functor, etc.) - -* anyclass: Use -XDeriveAnyClass - -* newtype: Use -XGeneralizedNewtypeDeriving - -* via: Use -XDerivingVia - -The latter two strategies (newtype and via) are referred to as the -"coerce-based" strategies, since they generate code that relies on the `coerce` -function. See, for instance, TcDerivInfer.inferConstraintsCoerceBased. - -The former two strategies (stock and anyclass), in contrast, are -referred to as the "originative" strategies, since they create "original" -instances instead of "reusing" old instances (by way of `coerce`). -See, for instance, TcDerivUtils.checkOriginativeSideConditions. - -If an explicit deriving strategy is not given, GHC has an algorithm it uses to -determine which strategy it will actually use. The algorithm is quite long, -so it lives in the Haskell wiki at -https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies -("The deriving strategy resolution algorithm" section). - -Internally, GHC uses the DerivStrategy datatype to denote a user-requested -deriving strategy, and it uses the DerivSpecMechanism datatype to denote what -GHC will use to derive the instance after taking the above steps. In other -words, GHC will always settle on a DerivSpecMechnism, even if the user did not -ask for a particular DerivStrategy (using the algorithm linked to above). - -Note [Deriving instances for classes themselves] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Much of the code in TcDeriv assumes that deriving only works on data types. -But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly -reasonable to do something like this: - - {-# LANGUAGE DeriveAnyClass #-} - class C1 (a :: Constraint) where - class C2 where - deriving instance C1 C2 - -- This is equivalent to `instance C1 C2` - -If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock -deriving), we throw a special error message indicating that DeriveAnyClass is -the only way to go. We don't bother throwing this error if an explicit 'stock' -or 'newtype' keyword is used, since both options have their own perfectly -sensible error messages in the case of the above code (as C1 isn't a stock -derivable class, and C2 isn't a newtype). - -************************************************************************ -* * -\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?} -* * -************************************************************************ --} - -nonUnaryErr :: LHsSigType GhcRn -> SDoc -nonUnaryErr ct = quotes (ppr ct) - <+> text "is not a unary constraint, as expected by a deriving clause" - -nonStdErr :: Class -> SDoc -nonStdErr cls = - quotes (ppr cls) - <+> text "is not a stock derivable class (Eq, Show, etc.)" - -gndNonNewtypeErr :: SDoc -gndNonNewtypeErr = - text "GeneralizedNewtypeDeriving cannot be used on non-newtypes" - -derivingNullaryErr :: MsgDoc -derivingNullaryErr = text "Cannot derive instances for nullary classes" - -derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc -derivingKindErr tc cls cls_tys cls_kind enough_args - = sep [ hang (text "Cannot derive well-kinded instance of form" - <+> quotes (pprClassPred cls cls_tys - <+> parens (ppr tc <+> text "..."))) - 2 gen1_suggestion - , nest 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind)) - ] - where - gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args - = text "(Perhaps you intended to use PolyKinds)" - | otherwise = Outputable.empty - -derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc -derivingViaKindErr cls cls_kind via_ty via_kind - = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) - 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind) <> char ',' - $+$ text "but" <+> quotes (pprType via_ty) - <+> text "has kind" <+> quotes (pprKind via_kind)) - -derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc -derivingEtaErr cls cls_tys inst_ty - = sep [text "Cannot eta-reduce to an instance of form", - nest 2 (text "instance (...) =>" - <+> pprClassPred cls (cls_tys ++ [inst_ty]))] - -derivingThingErr :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -derivingThingErr newtype_deriving cls cls_args mb_strat why - = derivingThingErr' newtype_deriving cls cls_args mb_strat - (maybe empty derivStrategyName mb_strat) why - -derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc -derivingThingErrM newtype_deriving why - = do DerivEnv { denv_cls = cls - , denv_inst_tys = cls_args - , denv_strat = mb_strat } <- ask - pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why - -derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc -derivingThingErrMechanism mechanism why - = do DerivEnv { denv_cls = cls - , denv_inst_tys = cls_args - , denv_strat = mb_strat } <- ask - pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_args mb_strat - (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why - -derivingThingErr' :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc -derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why - = sep [(hang (text "Can't make a derived instance of") - 2 (quotes (ppr pred) <+> via_mechanism) - $$ nest 2 extra) <> colon, - nest 2 why] - where - strat_used = isJust mb_strat - extra | not strat_used, newtype_deriving - = text "(even with cunning GeneralizedNewtypeDeriving)" - | otherwise = empty - pred = mkClassPred cls cls_args - via_mechanism | strat_used - = text "with the" <+> strat_msg <+> text "strategy" - | otherwise - = empty - -derivingHiddenErr :: TyCon -> SDoc -derivingHiddenErr tc - = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope")) - 2 (text "so you cannot derive an instance for it") - -standaloneCtxt :: LHsSigWcType GhcRn -> SDoc -standaloneCtxt ty = hang (text "In the stand-alone deriving instance for") - 2 (quotes (ppr ty)) diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs deleted file mode 100644 --- a/compiler/typecheck/TcDerivInfer.hs +++ /dev/null @@ -1,1071 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Functions for inferring (and simplifying) the context for derived instances. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} - -module TcDerivInfer (inferConstraints, simplifyInstanceContexts) where - -#include "HsVersions.h" - -import GhcPrelude - -import Bag -import GHC.Types.Basic -import GHC.Core.Class -import GHC.Core.DataCon -import ErrUtils -import Inst -import Outputable -import Pair -import PrelNames -import TcDerivUtils -import TcEnv -import TcGenDeriv -import TcGenFunctor -import TcGenGenerics -import TcMType -import TcRnMonad -import TcOrigin -import Constraint -import GHC.Core.Predicate -import TcType -import GHC.Core.TyCon -import GHC.Core.TyCo.Ppr (pprTyVars) -import GHC.Core.Type -import TcSimplify -import TcValidity (validDerivPred) -import TcUnify (buildImplicationFor, checkConstraints) -import TysWiredIn (typeToTypeKind) -import GHC.Core.Unify (tcUnifyTy) -import Util -import GHC.Types.Var -import GHC.Types.Var.Set - -import Control.Monad -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ask) -import Data.List (sortBy) -import Data.Maybe - ----------------------- - -inferConstraints :: DerivSpecMechanism - -> DerivM ([ThetaOrigin], [TyVar], [TcType]) --- inferConstraints figures out the constraints needed for the --- instance declaration generated by a 'deriving' clause on a --- data type declaration. It also returns the new in-scope type --- variables and instance types, in case they were changed due to --- the presence of functor-like constraints. --- See Note [Inferring the instance context] - --- e.g. inferConstraints --- C Int (T [a]) -- Class and inst_tys --- :RTList a -- Rep tycon and its arg tys --- where T [a] ~R :RTList a --- --- Generate a sufficiently large set of constraints that typechecking the --- generated method definitions should succeed. This set will be simplified --- before being used in the instance declaration -inferConstraints mechanism - = do { DerivEnv { denv_tvs = tvs - , denv_cls = main_cls - , denv_inst_tys = inst_tys } <- ask - ; wildcard <- isStandaloneWildcardDeriv - ; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType]) - infer_constraints = - case mechanism of - DerivSpecStock{dsm_stock_dit = dit} - -> inferConstraintsStock dit - DerivSpecAnyClass - -> infer_constraints_simple inferConstraintsAnyclass - DerivSpecNewtype { dsm_newtype_dit = - DerivInstTys{dit_cls_tys = cls_tys} - , dsm_newtype_rep_ty = rep_ty } - -> infer_constraints_simple $ - inferConstraintsCoerceBased cls_tys rep_ty - DerivSpecVia { dsm_via_cls_tys = cls_tys - , dsm_via_ty = via_ty } - -> infer_constraints_simple $ - inferConstraintsCoerceBased cls_tys via_ty - - -- Most deriving strategies do not need to do anything special to - -- the type variables and arguments to the class in the derived - -- instance, so they can pass through unchanged. The exception to - -- this rule is stock deriving. See - -- Note [Inferring the instance context]. - infer_constraints_simple - :: DerivM [ThetaOrigin] - -> DerivM ([ThetaOrigin], [TyVar], [TcType]) - infer_constraints_simple infer_thetas = do - thetas <- infer_thetas - pure (thetas, tvs, inst_tys) - - -- Constraints arising from superclasses - -- See Note [Superclasses of derived instance] - cls_tvs = classTyVars main_cls - sc_constraints = ASSERT2( equalLength cls_tvs inst_tys - , ppr main_cls <+> ppr inst_tys ) - [ mkThetaOrigin (mkDerivOrigin wildcard) - TypeLevel [] [] [] $ - substTheta cls_subst (classSCTheta main_cls) ] - cls_subst = ASSERT( equalLength cls_tvs inst_tys ) - zipTvSubst cls_tvs inst_tys - - ; (inferred_constraints, tvs', inst_tys') <- infer_constraints - ; lift $ traceTc "inferConstraints" $ vcat - [ ppr main_cls <+> ppr inst_tys' - , ppr inferred_constraints - ] - ; return ( sc_constraints ++ inferred_constraints - , tvs', inst_tys' ) } - --- | Like 'inferConstraints', but used only in the case of the @stock@ deriving --- strategy. The constraints are inferred by inspecting the fields of each data --- constructor. In this example: --- --- > data Foo = MkFoo Int Char deriving Show --- --- We would infer the following constraints ('ThetaOrigin's): --- --- > (Show Int, Show Char) --- --- Note that this function also returns the type variables ('TyVar's) and --- class arguments ('TcType's) for the resulting instance. This is because --- when deriving 'Functor'-like classes, we must sometimes perform kind --- substitutions to ensure the resulting instance is well kinded, which may --- affect the type variables and class arguments. In this example: --- --- > newtype Compose (f :: k -> Type) (g :: Type -> k) (a :: Type) = --- > Compose (f (g a)) deriving stock Functor --- --- We must unify @k@ with @Type@ in order for the resulting 'Functor' instance --- to be well kinded, so we return @[]@/@[Type, f, g]@ for the --- 'TyVar's/'TcType's, /not/ @[k]@/@[k, f, g]@. --- See Note [Inferring the instance context]. -inferConstraintsStock :: DerivInstTys - -> DerivM ([ThetaOrigin], [TyVar], [TcType]) -inferConstraintsStock (DerivInstTys { dit_cls_tys = cls_tys - , dit_tc = tc - , dit_tc_args = tc_args - , dit_rep_tc = rep_tc - , dit_rep_tc_args = rep_tc_args }) - = do DerivEnv { denv_tvs = tvs - , denv_cls = main_cls - , denv_inst_tys = inst_tys } <- ask - wildcard <- isStandaloneWildcardDeriv - - let inst_ty = mkTyConApp tc tc_args - tc_binders = tyConBinders rep_tc - choose_level bndr - | isNamedTyConBinder bndr = KindLevel - | otherwise = TypeLevel - t_or_ks = map choose_level tc_binders ++ repeat TypeLevel - -- want to report *kind* errors when possible - - -- Constraints arising from the arguments of each constructor - con_arg_constraints - :: (CtOrigin -> TypeOrKind - -> Type - -> [([PredOrigin], Maybe TCvSubst)]) - -> ([ThetaOrigin], [TyVar], [TcType]) - con_arg_constraints get_arg_constraints - = let (predss, mbSubsts) = unzip - [ preds_and_mbSubst - | data_con <- tyConDataCons rep_tc - , (arg_n, arg_t_or_k, arg_ty) - <- zip3 [1..] t_or_ks $ - dataConInstOrigArgTys data_con all_rep_tc_args - -- No constraints for unlifted types - -- See Note [Deriving and unboxed types] - , not (isUnliftedType arg_ty) - , let orig = DerivOriginDC data_con arg_n wildcard - , preds_and_mbSubst - <- get_arg_constraints orig arg_t_or_k arg_ty - ] - preds = concat predss - -- If the constraints require a subtype to be of kind - -- (* -> *) (which is the case for functor-like - -- constraints), then we explicitly unify the subtype's - -- kinds with (* -> *). - -- See Note [Inferring the instance context] - subst = foldl' composeTCvSubst - emptyTCvSubst (catMaybes mbSubsts) - unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst - && not (v `isInScope` subst)) tvs - (subst', _) = substTyVarBndrs subst unmapped_tvs - preds' = map (substPredOrigin subst') preds - inst_tys' = substTys subst' inst_tys - tvs' = tyCoVarsOfTypesWellScoped inst_tys' - in ([mkThetaOriginFromPreds preds'], tvs', inst_tys') - - is_generic = main_cls `hasKey` genClassKey - is_generic1 = main_cls `hasKey` gen1ClassKey - -- is_functor_like: see Note [Inferring the instance context] - is_functor_like = tcTypeKind inst_ty `tcEqKind` typeToTypeKind - || is_generic1 - - get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type - -> [([PredOrigin], Maybe TCvSubst)] - get_gen1_constraints functor_cls orig t_or_k ty - = mk_functor_like_constraints orig t_or_k functor_cls $ - get_gen1_constrained_tys last_tv ty - - get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type - -> [([PredOrigin], Maybe TCvSubst)] - get_std_constrained_tys orig t_or_k ty - | is_functor_like - = mk_functor_like_constraints orig t_or_k main_cls $ - deepSubtypesContaining last_tv ty - | otherwise - = [( [mk_cls_pred orig t_or_k main_cls ty] - , Nothing )] - - mk_functor_like_constraints :: CtOrigin -> TypeOrKind - -> Class -> [Type] - -> [([PredOrigin], Maybe TCvSubst)] - -- 'cls' is usually main_cls (Functor or Traversable etc), but if - -- main_cls = Generic1, then 'cls' can be Functor; see - -- get_gen1_constraints - -- - -- For each type, generate two constraints, - -- [cls ty, kind(ty) ~ (*->*)], and a kind substitution that results - -- from unifying kind(ty) with * -> *. If the unification is - -- successful, it will ensure that the resulting instance is well - -- kinded. If not, the second constraint will result in an error - -- message which points out the kind mismatch. - -- See Note [Inferring the instance context] - mk_functor_like_constraints orig t_or_k cls - = map $ \ty -> let ki = tcTypeKind ty in - ( [ mk_cls_pred orig t_or_k cls ty - , mkPredOrigin orig KindLevel - (mkPrimEqPred ki typeToTypeKind) ] - , tcUnifyTy ki typeToTypeKind - ) - - rep_tc_tvs = tyConTyVars rep_tc - last_tv = last rep_tc_tvs - -- When we first gather up the constraints to solve, most of them - -- contain rep_tc_tvs, i.e., the type variables from the derived - -- datatype's type constructor. We don't want these type variables - -- to appear in the final instance declaration, so we must - -- substitute each type variable with its counterpart in the derived - -- instance. rep_tc_args lists each of these counterpart types in - -- the same order as the type variables. - all_rep_tc_args - = rep_tc_args ++ map mkTyVarTy - (drop (length rep_tc_args) rep_tc_tvs) - - -- Stupid constraints - stupid_constraints - = [ mkThetaOrigin deriv_origin TypeLevel [] [] [] $ - substTheta tc_subst (tyConStupidTheta rep_tc) ] - tc_subst = -- See the comment with all_rep_tc_args for an - -- explanation of this assertion - ASSERT( equalLength rep_tc_tvs all_rep_tc_args ) - zipTvSubst rep_tc_tvs all_rep_tc_args - - -- Extra Data constraints - -- The Data class (only) requires that for - -- instance (...) => Data (T t1 t2) - -- IF t1:*, t2:* - -- THEN (Data t1, Data t2) are among the (...) constraints - -- Reason: when the IF holds, we generate a method - -- dataCast2 f = gcast2 f - -- and we need the Data constraints to typecheck the method - extra_constraints = [mkThetaOriginFromPreds constrs] - where - constrs - | main_cls `hasKey` dataClassKey - , all (isLiftedTypeKind . tcTypeKind) rep_tc_args - = [ mk_cls_pred deriv_origin t_or_k main_cls ty - | (t_or_k, ty) <- zip t_or_ks rep_tc_args] - | otherwise - = [] - - mk_cls_pred orig t_or_k cls ty - -- Don't forget to apply to cls_tys' too - = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty])) - cls_tys' | is_generic1 = [] - -- In the awkward Generic1 case, cls_tys' should be - -- empty, since we are applying the class Functor. - - | otherwise = cls_tys - - deriv_origin = mkDerivOrigin wildcard - - if -- Generic constraints are easy - | is_generic - -> return ([], tvs, inst_tys) - - -- Generic1 needs Functor - -- See Note [Getting base classes] - | is_generic1 - -> ASSERT( rep_tc_tvs `lengthExceeds` 0 ) - -- Generic1 has a single kind variable - ASSERT( cls_tys `lengthIs` 1 ) - do { functorClass <- lift $ tcLookupClass functorClassName - ; pure $ con_arg_constraints - $ get_gen1_constraints functorClass } - - -- The others are a bit more complicated - | otherwise - -> -- See the comment with all_rep_tc_args for an explanation of - -- this assertion - ASSERT2( equalLength rep_tc_tvs all_rep_tc_args - , ppr main_cls <+> ppr rep_tc - $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args ) - do { let (arg_constraints, tvs', inst_tys') - = con_arg_constraints get_std_constrained_tys - ; lift $ traceTc "inferConstraintsStock" $ vcat - [ ppr main_cls <+> ppr inst_tys' - , ppr arg_constraints - ] - ; return ( stupid_constraints ++ extra_constraints - ++ arg_constraints - , tvs', inst_tys') } - --- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@, --- which gathers its constraints based on the type signatures of the class's --- methods instead of the types of the data constructor's field. --- --- See Note [Gathering and simplifying constraints for DeriveAnyClass] --- for an explanation of how these constraints are used to determine the --- derived instance context. -inferConstraintsAnyclass :: DerivM [ThetaOrigin] -inferConstraintsAnyclass - = do { DerivEnv { denv_cls = cls - , denv_inst_tys = inst_tys } <- ask - ; wildcard <- isStandaloneWildcardDeriv - - ; let gen_dms = [ (sel_id, dm_ty) - | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ] - - cls_tvs = classTyVars cls - - do_one_meth :: (Id, Type) -> TcM ThetaOrigin - -- (Id,Type) are the selector Id and the generic default method type - -- NB: the latter is /not/ quantified over the class variables - -- See Note [Gathering and simplifying constraints for DeriveAnyClass] - do_one_meth (sel_id, gen_dm_ty) - = do { let (sel_tvs, _cls_pred, meth_ty) - = tcSplitMethodTy (varType sel_id) - meth_ty' = substTyWith sel_tvs inst_tys meth_ty - (meth_tvs, meth_theta, meth_tau) - = tcSplitNestedSigmaTys meth_ty' - - gen_dm_ty' = substTyWith cls_tvs inst_tys gen_dm_ty - (dm_tvs, dm_theta, dm_tau) - = tcSplitNestedSigmaTys gen_dm_ty' - tau_eq = mkPrimEqPred meth_tau dm_tau - ; return (mkThetaOrigin (mkDerivOrigin wildcard) TypeLevel - meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) } - - ; theta_origins <- lift $ mapM do_one_meth gen_dms - ; return theta_origins } - --- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and --- @DerivingVia@. Since both strategies generate code involving 'coerce', the --- inferred constraints set up the scaffolding needed to typecheck those uses --- of 'coerce'. In this example: --- --- > newtype Age = MkAge Int deriving newtype Num --- --- We would infer the following constraints ('ThetaOrigin's): --- --- > (Num Int, Coercible Age Int) -inferConstraintsCoerceBased :: [Type] -> Type - -> DerivM [ThetaOrigin] -inferConstraintsCoerceBased cls_tys rep_ty = do - DerivEnv { denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = inst_tys } <- ask - sa_wildcard <- isStandaloneWildcardDeriv - let -- The following functions are polymorphic over the representation - -- type, since we might either give it the underlying type of a - -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type - -- (for DerivingVia). - rep_tys ty = cls_tys ++ [ty] - rep_pred ty = mkClassPred cls (rep_tys ty) - rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty) - -- rep_pred is the representation dictionary, from where - -- we are going to get all the methods for the final - -- dictionary - deriv_origin = mkDerivOrigin sa_wildcard - - -- Next we collect constraints for the class methods - -- If there are no methods, we don't need any constraints - -- Otherwise we need (C rep_ty), for the representation methods, - -- and constraints to coerce each individual method - meth_preds :: Type -> [PredOrigin] - meth_preds ty - | null meths = [] -- No methods => no constraints - -- (#12814) - | otherwise = rep_pred_o ty : coercible_constraints ty - meths = classMethods cls - coercible_constraints ty - = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard) - TypeLevel (mkReprPrimEqPred t1 t2) - | meth <- meths - , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs - inst_tys ty meth ] - - all_thetas :: Type -> [ThetaOrigin] - all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty] - - pure (all_thetas rep_ty) - -{- Note [Inferring the instance context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are two sorts of 'deriving', as represented by the two constructors -for DerivContext: - - * InferContext mb_wildcard: This can either be: - - The deriving clause for a data type. - (e.g, data T a = T1 a deriving( Eq )) - In this case, mb_wildcard = Nothing. - - A standalone declaration with an extra-constraints wildcard - (e.g., deriving instance _ => Eq (Foo a)) - In this case, mb_wildcard = Just loc, where loc is the location - of the extra-constraints wildcard. - - Here we must infer an instance context, - and generate instance declaration - instance Eq a => Eq (T a) where ... - - * SupplyContext theta: standalone deriving - deriving instance Eq a => Eq (T a) - Here we only need to fill in the bindings; - the instance context (theta) is user-supplied - -For the InferContext case, we must figure out the -instance context (inferConstraintsStock). Suppose we are inferring -the instance context for - C t1 .. tn (T s1 .. sm) -There are two cases - - * (T s1 .. sm) :: * (the normal case) - Then we behave like Eq and guess (C t1 .. tn t) - for each data constructor arg of type t. More - details below. - - * (T s1 .. sm) :: * -> * (the functor-like case) - Then we behave like Functor. - -In both cases we produce a bunch of un-simplified constraints -and them simplify them in simplifyInstanceContexts; see -Note [Simplifying the instance context]. - -In the functor-like case, we may need to unify some kind variables with * in -order for the generated instance to be well-kinded. An example from -#10524: - - newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) - = Compose (f (g a)) deriving Functor - -Earlier in the deriving pipeline, GHC unifies the kind of Compose f g -(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this -alone isn't enough, since k2 wasn't unified with *: - - instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) => - Functor (Compose f g) where ... - -The two Functor constraints are ill-kinded. To ensure this doesn't happen, we: - - 1. Collect all of a datatype's subtypes which require functor-like - constraints. - 2. For each subtype, create a substitution by unifying the subtype's kind - with (* -> *). - 3. Compose all the substitutions into one, then apply that substitution to - all of the in-scope type variables and the instance types. - -Note [Getting base classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Functor and Typeable are defined in package 'base', and that is not available -when compiling 'ghc-prim'. So we must be careful that 'deriving' for stuff in -ghc-prim does not use Functor or Typeable implicitly via these lookups. - -Note [Deriving and unboxed types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have some special hacks to support things like - data T = MkT Int# deriving ( Show ) - -Specifically, we use TcGenDeriv.box to box the Int# into an Int -(which we know how to show), and append a '#'. Parentheses are not required -for unboxed values (`MkT -3#` is a valid expression). - -Note [Superclasses of derived instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, a derived instance decl needs the superclasses of the derived -class too. So if we have - data T a = ...deriving( Ord ) -then the initial context for Ord (T a) should include Eq (T a). Often this is -redundant; we'll also generate an Ord constraint for each constructor argument, -and that will probably generate enough constraints to make the Eq (T a) constraint -be satisfied too. But not always; consider: - - data S a = S - instance Eq (S a) - instance Ord (S a) - - data T a = MkT (S a) deriving( Ord ) - instance Num a => Eq (T a) - -The derived instance for (Ord (T a)) must have a (Num a) constraint! -Similarly consider: - data T a = MkT deriving( Data ) -Here there *is* no argument field, but we must nevertheless generate -a context for the Data instances: - instance Typeable a => Data (T a) where ... - - -************************************************************************ -* * - Finding the fixed point of deriving equations -* * -************************************************************************ - -Note [Simplifying the instance context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T a b = C1 (Foo a) (Bar b) - | C2 Int (T b a) - | C3 (T a a) - deriving (Eq) - -We want to come up with an instance declaration of the form - - instance (Ping a, Pong b, ...) => Eq (T a b) where - x == y = ... - -It is pretty easy, albeit tedious, to fill in the code "...". The -trick is to figure out what the context for the instance decl is, -namely Ping, Pong and friends. - -Let's call the context reqd for the T instance of class C at types -(a,b, ...) C (T a b). Thus: - - Eq (T a b) = (Ping a, Pong b, ...) - -Now we can get a (recursive) equation from the data decl. This part -is done by inferConstraintsStock. - - Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 - u Eq (T b a) u Eq Int -- From C2 - u Eq (T a a) -- From C3 - - -Foo and Bar may have explicit instances for Eq, in which case we can -just substitute for them. Alternatively, either or both may have -their Eq instances given by deriving clauses, in which case they -form part of the system of equations. - -Now all we need do is simplify and solve the equations, iterating to -find the least fixpoint. This is done by simplifyInstanceConstraints. -Notice that the order of the arguments can -switch around, as here in the recursive calls to T. - -Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b. - -We start with: - - Eq (T a b) = {} -- The empty set - -Next iteration: - Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 - u Eq (T b a) u Eq Int -- From C2 - u Eq (T a a) -- From C3 - - After simplification: - = Eq a u Ping b u {} u {} u {} - = Eq a u Ping b - -Next iteration: - - Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 - u Eq (T b a) u Eq Int -- From C2 - u Eq (T a a) -- From C3 - - After simplification: - = Eq a u Ping b - u (Eq b u Ping a) - u (Eq a u Ping a) - - = Eq a u Ping b u Eq b u Ping a - -The next iteration gives the same result, so this is the fixpoint. We -need to make a canonical form of the RHS to ensure convergence. We do -this by simplifying the RHS to a form in which - - - the classes constrain only tyvars - - the list is sorted by tyvar (major key) and then class (minor key) - - no duplicates, of course - -Note [Deterministic simplifyInstanceContexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting -with nonDetCmpType puts the returned lists in a nondeterministic order. -If we were to return them, we'd get class constraints in -nondeterministic order. - -Consider: - - data ADT a b = Z a b deriving Eq - -The generated code could be either: - - instance (Eq a, Eq b) => Eq (Z a b) where - -Or: - - instance (Eq b, Eq a) => Eq (Z a b) where - -To prevent the order from being nondeterministic we only -canonicalize when comparing and return them in the same order as -simplifyDeriv returned them. -See also Note [nonDetCmpType nondeterminism] --} - - -simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]] - -> TcM [DerivSpec ThetaType] --- Used only for deriving clauses or standalone deriving with an --- extra-constraints wildcard (InferContext) --- See Note [Simplifying the instance context] - -simplifyInstanceContexts [] = return [] - -simplifyInstanceContexts infer_specs - = do { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs) - ; iterate_deriv 1 initial_solutions } - where - ------------------------------------------------------------------ - -- The initial solutions for the equations claim that each - -- instance has an empty context; this solution is certainly - -- in canonical form. - initial_solutions :: [ThetaType] - initial_solutions = [ [] | _ <- infer_specs ] - - ------------------------------------------------------------------ - -- iterate_deriv calculates the next batch of solutions, - -- compares it with the current one; finishes if they are the - -- same, otherwise recurses with the new solutions. - -- It fails if any iteration fails - iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType] - iterate_deriv n current_solns - | n > 20 -- Looks as if we are in an infinite loop - -- This can happen if we have -XUndecidableInstances - -- (See TcSimplify.tcSimplifyDeriv.) - = pprPanic "solveDerivEqns: probable loop" - (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns) - | otherwise - = do { -- Extend the inst info from the explicit instance decls - -- with the current set of solutions, and simplify each RHS - inst_specs <- zipWithM newDerivClsInst current_solns infer_specs - ; new_solns <- checkNoErrs $ - extendLocalInstEnv inst_specs $ - mapM gen_soln infer_specs - - ; if (current_solns `eqSolution` new_solns) then - return [ spec { ds_theta = soln } - | (spec, soln) <- zip infer_specs current_solns ] - else - iterate_deriv (n+1) new_solns } - - eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b) - -- Canonicalise for comparison - -- See Note [Deterministic simplifyInstanceContexts] - canSolution = map (sortBy nonDetCmpType) - ------------------------------------------------------------------ - gen_soln :: DerivSpec [ThetaOrigin] -> TcM ThetaType - gen_soln (DS { ds_loc = loc, ds_tvs = tyvars - , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) - = setSrcSpan loc $ - addErrCtxt (derivInstCtxt the_pred) $ - do { theta <- simplifyDeriv the_pred tyvars deriv_rhs - -- checkValidInstance tyvars theta clas inst_tys - -- Not necessary; see Note [Exotic derived instance contexts] - - ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta) - -- Claim: the result instance declaration is guaranteed valid - -- Hence no need to call: - -- checkValidInstance tyvars theta clas inst_tys - ; return theta } - where - the_pred = mkClassPred clas inst_tys - -derivInstCtxt :: PredType -> MsgDoc -derivInstCtxt pred - = text "When deriving the instance for" <+> parens (ppr pred) - -{- -*********************************************************************************** -* * -* Simplify derived constraints -* * -*********************************************************************************** --} - --- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much --- as possible. Fail if not possible. -simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are - -- deriving. Only used for SkolemInfo. - -> [TyVar] -- ^ The tyvars bound by @inst_ty@. - -> [ThetaOrigin] -- ^ Given and wanted constraints - -> TcM ThetaType -- ^ Needed constraints (after simplification), - -- i.e. @['PredType']@. -simplifyDeriv pred tvs thetas - = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize - -- The constraint solving machinery - -- expects *TcTyVars* not TyVars. - -- We use *non-overlappable* (vanilla) skolems - -- See Note [Overlap and deriving] - - ; let skol_set = mkVarSet tvs_skols - skol_info = DerivSkol pred - doc = text "deriving" <+> parens (ppr pred) - - mk_given_ev :: PredType -> TcM EvVar - mk_given_ev given = - let given_pred = substTy skol_subst given - in newEvVar given_pred - - emit_wanted_constraints :: [TyVar] -> [PredOrigin] -> TcM () - emit_wanted_constraints metas_to_be preds - = do { -- We instantiate metas_to_be with fresh meta type - -- variables. Currently, these can only be type variables - -- quantified in generic default type signatures. - -- See Note [Gathering and simplifying constraints for - -- DeriveAnyClass] - (meta_subst, _meta_tvs) <- newMetaTyVars metas_to_be - - -- Now make a constraint for each of the instantiated predicates - ; let wanted_subst = skol_subst `unionTCvSubst` meta_subst - mk_wanted_ct (PredOrigin wanted orig t_or_k) - = do { ev <- newWanted orig (Just t_or_k) $ - substTyUnchecked wanted_subst wanted - ; return (mkNonCanonical ev) } - ; cts <- mapM mk_wanted_ct preds - - -- And emit them into the monad - ; emitSimples (listToCts cts) } - - -- Create the implications we need to solve. For stock and newtype - -- deriving, these implication constraints will be simple class - -- constraints like (C a, Ord b). - -- But with DeriveAnyClass, we make an implication constraint. - -- See Note [Gathering and simplifying constraints for DeriveAnyClass] - mk_wanteds :: ThetaOrigin -> TcM WantedConstraints - mk_wanteds (ThetaOrigin { to_anyclass_skols = ac_skols - , to_anyclass_metas = ac_metas - , to_anyclass_givens = ac_givens - , to_wanted_origins = preds }) - = do { ac_given_evs <- mapM mk_given_ev ac_givens - ; (_, wanteds) - <- captureConstraints $ - checkConstraints skol_info ac_skols ac_given_evs $ - -- The checkConstraints bumps the TcLevel, and - -- wraps the wanted constraints in an implication, - -- when (but only when) necessary - emit_wanted_constraints ac_metas preds - ; pure wanteds } - - -- See [STEP DAC BUILD] - -- Generate the implication constraints, one for each method, to solve - -- with the skolemized variables. Start "one level down" because - -- we are going to wrap the result in an implication with tvs_skols, - -- in step [DAC RESIDUAL] - ; (tc_lvl, wanteds) <- pushTcLevelM $ - mapM mk_wanteds thetas - - ; traceTc "simplifyDeriv inputs" $ - vcat [ pprTyVars tvs $$ ppr thetas $$ ppr wanteds, doc ] - - -- See [STEP DAC SOLVE] - -- Simplify the constraints, starting at the same level at which - -- they are generated (c.f. the call to runTcSWithEvBinds in - -- simplifyInfer) - ; solved_wanteds <- setTcLevel tc_lvl $ - runTcSDeriveds $ - solveWantedsAndDrop $ - unionsWC wanteds - - -- It's not yet zonked! Obviously zonk it before peering at it - ; solved_wanteds <- zonkWC solved_wanteds - - -- See [STEP DAC HOIST] - -- Split the resulting constraints into bad and good constraints, - -- building an @unsolved :: WantedConstraints@ representing all - -- the constraints we can't just shunt to the predicates. - -- See Note [Exotic derived instance contexts] - ; let residual_simple = approximateWC True solved_wanteds - (bad, good) = partitionBagWith get_good residual_simple - - get_good :: Ct -> Either Ct PredType - get_good ct | validDerivPred skol_set p - , isWantedCt ct - = Right p - -- TODO: This is wrong - -- NB re 'isWantedCt': residual_wanted may contain - -- unsolved CtDerived and we stick them into the - -- bad set so that reportUnsolved may decide what - -- to do with them - | otherwise - = Left ct - where p = ctPred ct - - ; traceTc "simplifyDeriv outputs" $ - vcat [ ppr tvs_skols, ppr residual_simple, ppr good, ppr bad ] - - -- Return the good unsolved constraints (unskolemizing on the way out.) - ; let min_theta = mkMinimalBySCs id (bagToList good) - -- An important property of mkMinimalBySCs (used above) is that in - -- addition to removing constraints that are made redundant by - -- superclass relationships, it also removes _duplicate_ - -- constraints. - -- See Note [Gathering and simplifying constraints for - -- DeriveAnyClass] - subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs - -- The reverse substitution (sigh) - - -- See [STEP DAC RESIDUAL] - ; min_theta_vars <- mapM newEvVar min_theta - ; (leftover_implic, _) - <- buildImplicationFor tc_lvl skol_info tvs_skols - 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. - ; simplifyTopImplic leftover_implic - - ; return (substTheta subst_skol min_theta) } - -{- -Note [Overlap and deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider some overlapping instances: - instance Show a => Show [a] where .. - instance Show [Char] where ... - -Now a data type with deriving: - data T a = MkT [a] deriving( Show ) - -We want to get the derived instance - instance Show [a] => Show (T a) where... -and NOT - instance Show a => Show (T a) where... -so that the (Show (T Char)) instance does the Right Thing - -It's very like the situation when we're inferring the type -of a function - f x = show [x] -and we want to infer - f :: Show [a] => a -> String - -BOTTOM LINE: use vanilla, non-overlappable skolems when inferring - the context for the derived instance. - Hence tcInstSkolTyVars not tcInstSuperSkolTyVars - -Note [Gathering and simplifying constraints for DeriveAnyClass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -DeriveAnyClass works quite differently from stock and newtype deriving in -the way it gathers and simplifies constraints to be used in a derived -instance's context. Stock and newtype deriving gather constraints by looking -at the data constructors of the data type for which we are deriving an -instance. But DeriveAnyClass doesn't need to know about a data type's -definition at all! - -To see why, consider this example of DeriveAnyClass: - - class Foo a where - bar :: forall b. Ix b => a -> b -> String - default bar :: (Show a, Ix c) => a -> c -> String - bar x y = show x ++ show (range (y,y)) - - baz :: Eq a => a -> a -> Bool - default baz :: (Ord a, Show a) => a -> a -> Bool - baz x y = compare x y == EQ - -Because 'bar' and 'baz' have default signatures, this generates a top-level -definition for these generic default methods - - $gdm_bar :: forall a. Foo a - => forall c. (Show a, Ix c) - => a -> c -> String - $gdm_bar x y = show x ++ show (range (y,y)) - -(and similarly for baz). Now consider a 'deriving' clause - data Maybe s = ... deriving Foo - -This derives an instance of the form: - instance (CX) => Foo (Maybe s) where - bar = $gdm_bar - baz = $gdm_baz - -Now it is GHC's job to fill in a suitable instance context (CX). If -GHC were typechecking the binding - bar = $gdm bar -it would - * skolemise the expected type of bar - * instantiate the type of $gdm_bar with meta-type variables - * build an implication constraint - -[STEP DAC BUILD] -So that's what we do. We build the constraint (call it C1) - - forall[2] b. Ix b => (Show (Maybe s), Ix cc, - Maybe s -> b -> String - ~ Maybe s -> cc -> String) - -Here: -* The level of this forall constraint is forall[2], because we are later - going to wrap it in a forall[1] in [STEP DAC RESIDUAL] - -* The 'b' comes from the quantified type variable in the expected type - of bar (i.e., 'to_anyclass_skols' in 'ThetaOrigin'). The 'cc' is a unification - variable that comes from instantiating the quantified type variable 'c' in - $gdm_bar's type (i.e., 'to_anyclass_metas' in 'ThetaOrigin). - -* The (Ix b) constraint comes from the context of bar's type - (i.e., 'to_wanted_givens' in 'ThetaOrigin'). The (Show (Maybe s)) and (Ix cc) - constraints come from the context of $gdm_bar's type - (i.e., 'to_anyclass_givens' in 'ThetaOrigin'). - -* The equality constraint (Maybe s -> b -> String) ~ (Maybe s -> cc -> String) - comes from marrying up the instantiated type of $gdm_bar with the specified - type of bar. Notice that the type variables from the instance, 's' in this - case, are global to this constraint. - -Note that it is vital that we instantiate the `c` in $gdm_bar's type with a new -unification variable for each iteration of simplifyDeriv. If we re-use the same -unification variable across multiple iterations, then bad things can happen, -such as #14933. - -Similarly for 'baz', giving the constraint C2 - - forall[2]. Eq (Maybe s) => (Ord a, Show a, - Maybe s -> Maybe s -> Bool - ~ Maybe s -> Maybe s -> Bool) - -In this case baz has no local quantification, so the implication -constraint has no local skolems and there are no unification -variables. - -[STEP DAC SOLVE] -We can combine these two implication constraints into a single -constraint (C1, C2), and simplify, unifying cc:=b, to get: - - forall[2] b. Ix b => Show a - /\ - forall[2]. Eq (Maybe s) => (Ord a, Show a) - -[STEP DAC HOIST] -Let's call that (C1', C2'). Now we need to hoist the unsolved -constraints out of the implications to become our candidate for -(CX). That is done by approximateWC, which will return: - - (Show a, Ord a, Show a) - -Now we can use mkMinimalBySCs to remove superclasses and duplicates, giving - - (Show a, Ord a) - -And that's what GHC uses for CX. - -[STEP DAC RESIDUAL] -In this case we have solved all the leftover constraints, but what if -we don't? Simple! We just form the final residual constraint - - forall[1] s. CX => (C1',C2') - -and simplify that. In simple cases it'll succeed easily, because CX -literally contains the constraints in C1', C2', but if there is anything -more complicated it will be reported in a civilised way. - -Note [Error reporting for deriving clauses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A surprisingly tricky aspect of deriving to get right is reporting sensible -error messages. In particular, if simplifyDeriv reaches a constraint that it -cannot solve, which might include: - -1. Insoluble constraints -2. "Exotic" constraints (See Note [Exotic derived instance contexts]) - -Then we report an error immediately in simplifyDeriv. - -Another possible choice is to punt and let another part of the typechecker -(e.g., simplifyInstanceContexts) catch the errors. But this tends to lead -to worse error messages, so we do it directly in simplifyDeriv. - -simplifyDeriv checks for errors in a clever way. If the deriving machinery -infers the context (Foo a)--that is, if this instance is to be generated: - - instance Foo a => ... - -Then we form an implication of the form: - - forall a. Foo a => - -And pass it to the simplifier. If the context (Foo a) is enough to discharge -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/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs deleted file mode 100644 --- a/compiler/typecheck/TcDerivUtils.hs +++ /dev/null @@ -1,1112 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Error-checking and other utilities for @deriving@ clauses or declarations. --} - -{-# LANGUAGE TypeFamilies #-} - -module TcDerivUtils ( - DerivM, DerivEnv(..), - DerivSpec(..), pprDerivSpec, DerivInstTys(..), - DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock, - isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia, - DerivContext(..), OriginativeDerivStatus(..), - isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin, - PredOrigin(..), ThetaOrigin(..), mkPredOrigin, - mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin, - checkOriginativeSideConditions, hasStockDeriving, - canDeriveAnyClass, - std_class_via_coercible, non_coercible_class, - newDerivClsInst, extendLocalInstEnv - ) where - -import GhcPrelude - -import Bag -import GHC.Types.Basic -import GHC.Core.Class -import GHC.Core.DataCon -import GHC.Driver.Session -import ErrUtils -import GHC.Driver.Types (lookupFixity, mi_fix) -import GHC.Hs -import Inst -import GHC.Core.InstEnv -import GHC.Iface.Load (loadInterfaceForName) -import GHC.Types.Module (getModule) -import GHC.Types.Name -import Outputable -import PrelNames -import GHC.Types.SrcLoc -import TcGenDeriv -import TcGenFunctor -import TcGenGenerics -import TcOrigin -import TcRnMonad -import TcType -import THNames (liftClassKey) -import GHC.Core.TyCon -import GHC.Core.TyCo.Ppr (pprSourceTyCon) -import GHC.Core.Type -import Util -import GHC.Types.Var.Set - -import Control.Monad.Trans.Reader -import Data.Maybe -import qualified GHC.LanguageExtensions as LangExt -import ListSetOps (assocMaybe) - --- | To avoid having to manually plumb everything in 'DerivEnv' throughout --- various functions in @TcDeriv@ and @TcDerivInfer@, we use 'DerivM', which --- is a simple reader around 'TcRn'. -type DerivM = ReaderT DerivEnv TcRn - --- | Is GHC processing a standalone deriving declaration? -isStandaloneDeriv :: DerivM Bool -isStandaloneDeriv = asks (go . denv_ctxt) - where - go :: DerivContext -> Bool - go (InferContext wildcard) = isJust wildcard - go (SupplyContext {}) = True - --- | Is GHC processing a standalone deriving declaration with an --- extra-constraints wildcard as the context? --- (e.g., @deriving instance _ => Eq (Foo a)@) -isStandaloneWildcardDeriv :: DerivM Bool -isStandaloneWildcardDeriv = asks (go . denv_ctxt) - where - go :: DerivContext -> Bool - go (InferContext wildcard) = isJust wildcard - go (SupplyContext {}) = False - --- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True', --- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting. -mkDerivOrigin :: Bool -> CtOrigin -mkDerivOrigin standalone_wildcard - | standalone_wildcard = StandAloneDerivOrigin - | otherwise = DerivClauseOrigin - --- | Contains all of the information known about a derived instance when --- determining what its @EarlyDerivSpec@ should be. --- See @Note [DerivEnv and DerivSpecMechanism]@. -data DerivEnv = DerivEnv - { denv_overlap_mode :: Maybe OverlapMode - -- ^ Is this an overlapping instance? - , denv_tvs :: [TyVar] - -- ^ Universally quantified type variables in the instance - , denv_cls :: Class - -- ^ Class for which we need to derive an instance - , denv_inst_tys :: [Type] - -- ^ All arguments to to 'denv_cls' in the derived instance. - , denv_ctxt :: DerivContext - -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the - -- context of the instance). - -- 'InferContext' for @deriving@ clauses, or for standalone deriving that - -- uses a wildcard constraint. - -- See @Note [Inferring the instance context]@. - , denv_strat :: Maybe (DerivStrategy GhcTc) - -- ^ 'Just' if user requests a particular deriving strategy. - -- Otherwise, 'Nothing'. - } - -instance Outputable DerivEnv where - ppr (DerivEnv { denv_overlap_mode = overlap_mode - , denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = inst_tys - , denv_ctxt = ctxt - , denv_strat = mb_strat }) - = hang (text "DerivEnv") - 2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode - , text "denv_tvs" <+> ppr tvs - , text "denv_cls" <+> ppr cls - , text "denv_inst_tys" <+> ppr inst_tys - , text "denv_ctxt" <+> ppr ctxt - , text "denv_strat" <+> ppr mb_strat ]) - -data DerivSpec theta = DS { ds_loc :: SrcSpan - , ds_name :: Name -- DFun name - , ds_tvs :: [TyVar] - , ds_theta :: theta - , ds_cls :: Class - , ds_tys :: [Type] - , ds_overlap :: Maybe OverlapMode - , ds_standalone_wildcard :: Maybe SrcSpan - -- See Note [Inferring the instance context] - -- in TcDerivInfer - , ds_mechanism :: DerivSpecMechanism } - -- This spec implies a dfun declaration of the form - -- df :: forall tvs. theta => C tys - -- The Name is the name for the DFun we'll build - -- The tyvars bind all the variables in the theta - - -- the theta is either the given and final theta, in standalone deriving, - -- or the not-yet-simplified list of constraints together with their origin - - -- ds_mechanism specifies the means by which GHC derives the instance. - -- See Note [Deriving strategies] in TcDeriv - -{- -Example: - - newtype instance T [a] = MkT (Tree a) deriving( C s ) -==> - axiom T [a] = :RTList a - axiom :RTList a = Tree a - - DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]] - , ds_mechanism = DerivSpecNewtype (Tree a) } --} - -pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc -pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c, - ds_tys = tys, ds_theta = rhs, - ds_standalone_wildcard = wildcard, ds_mechanism = mech }) - = hang (text "DerivSpec") - 2 (vcat [ text "ds_loc =" <+> ppr l - , text "ds_name =" <+> ppr n - , text "ds_tvs =" <+> ppr tvs - , text "ds_cls =" <+> ppr c - , text "ds_tys =" <+> ppr tys - , text "ds_theta =" <+> ppr rhs - , text "ds_standalone_wildcard =" <+> ppr wildcard - , text "ds_mechanism =" <+> ppr mech ]) - -instance Outputable theta => Outputable (DerivSpec theta) where - ppr = pprDerivSpec - --- | Information about the arguments to the class in a stock- or --- newtype-derived instance. --- See @Note [DerivEnv and DerivSpecMechanism]@. -data DerivInstTys = DerivInstTys - { dit_cls_tys :: [Type] - -- ^ Other arguments to the class except the last - , dit_tc :: TyCon - -- ^ Type constructor for which the instance is requested - -- (last arguments to the type class) - , dit_tc_args :: [Type] - -- ^ Arguments to the type constructor - , dit_rep_tc :: TyCon - -- ^ The representation tycon for 'dit_tc' - -- (for data family instances). Otherwise the same as 'dit_tc'. - , dit_rep_tc_args :: [Type] - -- ^ The representation types for 'dit_tc_args' - -- (for data family instances). Otherwise the same as 'dit_tc_args'. - } - -instance Outputable DerivInstTys where - ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args - , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args }) - = hang (text "DITTyConHead") - 2 (vcat [ text "dit_cls_tys" <+> ppr cls_tys - , text "dit_tc" <+> ppr tc - , text "dit_tc_args" <+> ppr tc_args - , text "dit_rep_tc" <+> ppr rep_tc - , text "dit_rep_tc_args" <+> ppr rep_tc_args ]) - --- | What action to take in order to derive a class instance. --- See @Note [DerivEnv and DerivSpecMechanism]@, as well as --- @Note [Deriving strategies]@ in "TcDeriv". -data DerivSpecMechanism - -- | \"Standard\" classes - = DerivSpecStock - { dsm_stock_dit :: DerivInstTys - -- ^ Information about the arguments to the class in the derived - -- instance, including what type constructor the last argument is - -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. - , dsm_stock_gen_fn :: - SrcSpan -> TyCon - -> [Type] - -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]) - -- ^ This function returns three things: - -- - -- 1. @LHsBinds GhcPs@: The derived instance's function bindings - -- (e.g., @compare (T x) (T y) = compare x y@) - -- - -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived - -- instance. As examples, derived 'Generic' instances require - -- associated type family instances, and derived 'Eq' and 'Ord' - -- instances require top-level @con2tag@ functions. - -- See @Note [Auxiliary binders]@ in "TcGenDeriv". - -- - -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be - -- suppressed. This is used to suppress unused warnings for record - -- selectors when deriving 'Read', 'Show', or 'Generic'. - -- See @Note [Deriving and unused record selectors]@. - } - - -- | @GeneralizedNewtypeDeriving@ - | DerivSpecNewtype - { dsm_newtype_dit :: DerivInstTys - -- ^ Information about the arguments to the class in the derived - -- instance, including what type constructor the last argument is - -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. - , dsm_newtype_rep_ty :: Type - -- ^ The newtype rep type. - } - - -- | @DeriveAnyClass@ - | DerivSpecAnyClass - - -- | @DerivingVia@ - | DerivSpecVia - { dsm_via_cls_tys :: [Type] - -- ^ All arguments to the class besides the last one. - , dsm_via_inst_ty :: Type - -- ^ The last argument to the class. - , dsm_via_ty :: Type - -- ^ The @via@ type - } - --- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'. -derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc -derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy -derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy -derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy -derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t - -isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia - :: DerivSpecMechanism -> Bool -isDerivSpecStock (DerivSpecStock{}) = True -isDerivSpecStock _ = False - -isDerivSpecNewtype (DerivSpecNewtype{}) = True -isDerivSpecNewtype _ = False - -isDerivSpecAnyClass DerivSpecAnyClass = True -isDerivSpecAnyClass _ = False - -isDerivSpecVia (DerivSpecVia{}) = True -isDerivSpecVia _ = False - -instance Outputable DerivSpecMechanism where - ppr (DerivSpecStock{dsm_stock_dit = dit}) - = hang (text "DerivSpecStock") - 2 (vcat [ text "dsm_stock_dit" <+> ppr dit ]) - ppr (DerivSpecNewtype { dsm_newtype_dit = dit, dsm_newtype_rep_ty = rep_ty }) - = hang (text "DerivSpecNewtype") - 2 (vcat [ text "dsm_newtype_dit" <+> ppr dit - , text "dsm_newtype_rep_ty" <+> ppr rep_ty ]) - ppr DerivSpecAnyClass = text "DerivSpecAnyClass" - ppr (DerivSpecVia { dsm_via_cls_tys = cls_tys, dsm_via_inst_ty = inst_ty - , dsm_via_ty = via_ty }) - = hang (text "DerivSpecVia") - 2 (vcat [ text "dsm_via_cls_tys" <+> ppr cls_tys - , text "dsm_via_inst_ty" <+> ppr inst_ty - , text "dsm_via_ty" <+> ppr via_ty ]) - -{- -Note [DerivEnv and DerivSpecMechanism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -DerivEnv contains all of the bits and pieces that are common to every -deriving strategy. (See Note [Deriving strategies] in TcDeriv.) Some deriving -strategies impose stricter requirements on the types involved in the derived -instance than others, and these differences are factored out into the -DerivSpecMechanism type. Suppose that the derived instance looks like this: - - instance ... => C arg_1 ... arg_n - -Each deriving strategy imposes restrictions on arg_1 through arg_n as follows: - -* stock (DerivSpecStock): - - Stock deriving requires that: - - - n must be a positive number. This is checked by - TcDeriv.expectNonNullaryClsArgs - - arg_n must be an application of an algebraic type constructor. Here, - "algebraic type constructor" means: - - + An ordinary data type constructor, or - + A data family type constructor such that the arguments it is applied to - give rise to a data family instance. - - This is checked by TcDeriv.expectAlgTyConApp. - - This extra structure is witnessed by the DerivInstTys data type, which stores - arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor - (dit_tc), and its arguments (dit_tc_args). If dit_tc is an ordinary data type - constructor, then dit_rep_tc/dit_rep_tc_args are the same as - dit_tc/dit_tc_args. If dit_tc is a data family type constructor, then - dit_rep_tc is the representation type constructor for the data family - instance, and dit_rep_tc_args are the arguments to the representation type - constructor in the corresponding instance. - -* newtype (DerivSpecNewtype): - - Newtype deriving imposes the same DerivInstTys requirements as stock - deriving. This is necessary because we need to know what the underlying type - that the newtype wraps is, and this information can only be learned by - knowing dit_rep_tc. - -* anyclass (DerivSpecAnyclass): - - DeriveAnyClass is the most permissive deriving strategy of all, as it - essentially imposes no requirements on the derived instance. This is because - DeriveAnyClass simply derives an empty instance, so it does not need any - particular knowledge about the types involved. It can do several things - that stock/newtype deriving cannot do (#13154): - - - n can be 0. That is, one is allowed to anyclass-derive an instance with - no arguments to the class, such as in this example: - - class C - deriving anyclass instance C - - - One can derive an instance for a type that is not headed by a type - constructor, such as in the following example: - - class C (n :: Nat) - deriving instance C 0 - deriving instance C 1 - ... - - - One can derive an instance for a data family with no data family instances, - such as in the following example: - - data family Foo a - class C a - deriving anyclass instance C (Foo a) - -* via (DerivSpecVia): - - Like newtype deriving, DerivingVia requires that n must be a positive number. - This is because when one derives something like this: - - deriving via Foo instance C Bar - - Then the generated code must specifically mention Bar. However, in - contrast with newtype deriving, DerivingVia does *not* require Bar to be - an application of an algebraic type constructor. This is because the - generated code simply defers to invoking `coerce`, which does not need to - know anything in particular about Bar (besides that it is representationally - equal to Foo). This allows DerivingVia to do some things that are not - possible with newtype deriving, such as deriving instances for data families - without data instances (#13154): - - data family Foo a - newtype ByBar a = ByBar a - class Baz a where ... - instance Baz (ByBar a) where ... - deriving via ByBar (Foo a) instance Baz (Foo a) --} - --- | Whether GHC is processing a @deriving@ clause or a standalone deriving --- declaration. -data DerivContext - = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either: - -- - -- * A @deriving@ clause (in which case - -- @mb_wildcard@ is 'Nothing'). - -- - -- * A standalone deriving declaration with - -- an extra-constraints wildcard as the - -- context (in which case @mb_wildcard@ is - -- @'Just' loc@, where @loc@ is the location - -- of the wildcard. - -- - -- GHC should infer the context. - - | SupplyContext ThetaType -- ^ @'SupplyContext' theta@ is a standalone - -- deriving declaration, where @theta@ is the - -- context supplied by the user. - -instance Outputable DerivContext where - ppr (InferContext standalone) = text "InferContext" <+> ppr standalone - ppr (SupplyContext theta) = text "SupplyContext" <+> ppr theta - --- | Records whether a particular class can be derived by way of an --- /originative/ deriving strategy (i.e., @stock@ or @anyclass@). --- --- See @Note [Deriving strategies]@ in "TcDeriv". -data OriginativeDerivStatus - = CanDeriveStock -- Stock class, can derive - (SrcSpan -> TyCon -> [Type] - -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) - | StockClassError SDoc -- Stock class, but can't do it - | CanDeriveAnyClass -- See Note [Deriving any class] - | NonDerivableClass SDoc -- Cannot derive with either stock or anyclass - --- A stock class is one either defined in the Haskell report or for which GHC --- otherwise knows how to generate code for (possibly requiring the use of a --- language extension), such as Eq, Ord, Ix, Data, Generic, etc.) - --- | A 'PredType' annotated with the origin of the constraint 'CtOrigin', --- and whether or the constraint deals in types or kinds. -data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind - --- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') to --- simplify when inferring a derived instance's context. These are used in all --- deriving strategies, but in the particular case of @DeriveAnyClass@, we --- need extra information. In particular, we need: --- --- * 'to_anyclass_skols', the list of type variables bound by a class method's --- regular type signature, which should be rigid. --- --- * 'to_anyclass_metas', the list of type variables bound by a class method's --- default type signature. These can be unified as necessary. --- --- * 'to_anyclass_givens', the list of constraints from a class method's --- regular type signature, which can be used to help solve constraints --- in the 'to_wanted_origins'. --- --- (Note that 'to_wanted_origins' will likely contain type variables from the --- derived type class or data type, neither of which will appear in --- 'to_anyclass_skols' or 'to_anyclass_metas'.) --- --- For all other deriving strategies, it is always the case that --- 'to_anyclass_skols', 'to_anyclass_metas', and 'to_anyclass_givens' are --- empty. --- --- Here is an example to illustrate this: --- --- @ --- class Foo a where --- bar :: forall b. Ix b => a -> b -> String --- default bar :: forall y. (Show a, Ix y) => a -> y -> String --- bar x y = show x ++ show (range (y, y)) --- --- baz :: Eq a => a -> a -> Bool --- default baz :: Ord a => a -> a -> Bool --- baz x y = compare x y == EQ --- --- data Quux q = Quux deriving anyclass Foo --- @ --- --- Then it would generate two 'ThetaOrigin's, one for each method: --- --- @ --- [ ThetaOrigin { to_anyclass_skols = [b] --- , to_anyclass_metas = [y] --- , to_anyclass_givens = [Ix b] --- , to_wanted_origins = [ Show (Quux q), Ix y --- , (Quux q -> b -> String) ~ --- (Quux q -> y -> String) --- ] } --- , ThetaOrigin { to_anyclass_skols = [] --- , to_anyclass_metas = [] --- , to_anyclass_givens = [Eq (Quux q)] --- , to_wanted_origins = [ Ord (Quux q) --- , (Quux q -> Quux q -> Bool) ~ --- (Quux q -> Quux q -> Bool) --- ] } --- ] --- @ --- --- (Note that the type variable @q@ is bound by the data type @Quux@, and thus --- it appears in neither 'to_anyclass_skols' nor 'to_anyclass_metas'.) --- --- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@ --- in "TcDerivInfer" for an explanation of how 'to_wanted_origins' are --- determined in @DeriveAnyClass@, as well as how 'to_anyclass_skols', --- 'to_anyclass_metas', and 'to_anyclass_givens' are used. -data ThetaOrigin - = ThetaOrigin { to_anyclass_skols :: [TyVar] - , to_anyclass_metas :: [TyVar] - , to_anyclass_givens :: ThetaType - , to_wanted_origins :: [PredOrigin] } - -instance Outputable PredOrigin where - ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging - -instance Outputable ThetaOrigin where - ppr (ThetaOrigin { to_anyclass_skols = ac_skols - , to_anyclass_metas = ac_metas - , to_anyclass_givens = ac_givens - , to_wanted_origins = wanted_origins }) - = hang (text "ThetaOrigin") - 2 (vcat [ text "to_anyclass_skols =" <+> ppr ac_skols - , text "to_anyclass_metas =" <+> ppr ac_metas - , text "to_anyclass_givens =" <+> ppr ac_givens - , text "to_wanted_origins =" <+> ppr wanted_origins ]) - -mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin -mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k - -mkThetaOrigin :: CtOrigin -> TypeOrKind - -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType - -> ThetaOrigin -mkThetaOrigin origin t_or_k skols metas givens - = ThetaOrigin skols metas givens . map (mkPredOrigin origin t_or_k) - --- A common case where the ThetaOrigin only contains wanted constraints, with --- no givens or locally scoped type variables. -mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin -mkThetaOriginFromPreds = ThetaOrigin [] [] [] - -substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin -substPredOrigin subst (PredOrigin pred origin t_or_k) - = PredOrigin (substTy subst pred) origin t_or_k - -{- -************************************************************************ -* * - Class deriving diagnostics -* * -************************************************************************ - -Only certain blessed classes can be used in a deriving clause (without the -assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes -are listed below in the definition of hasStockDeriving. The stockSideConditions -function determines the criteria that needs to be met in order for a particular -stock class to be able to be derived successfully. - -A class might be able to be used in a deriving clause if -XDeriveAnyClass -is willing to support it. The canDeriveAnyClass function checks if this is the -case. --} - -hasStockDeriving - :: Class -> Maybe (SrcSpan - -> TyCon - -> [Type] - -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) -hasStockDeriving clas - = assocMaybe gen_list (getUnique clas) - where - gen_list - :: [(Unique, SrcSpan - -> TyCon - -> [Type] - -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))] - gen_list = [ (eqClassKey, simpleM gen_Eq_binds) - , (ordClassKey, simpleM gen_Ord_binds) - , (enumClassKey, simpleM gen_Enum_binds) - , (boundedClassKey, simple gen_Bounded_binds) - , (ixClassKey, simpleM gen_Ix_binds) - , (showClassKey, read_or_show gen_Show_binds) - , (readClassKey, read_or_show gen_Read_binds) - , (dataClassKey, simpleM gen_Data_binds) - , (functorClassKey, simple gen_Functor_binds) - , (foldableClassKey, simple gen_Foldable_binds) - , (traversableClassKey, simple gen_Traversable_binds) - , (liftClassKey, simple gen_Lift_binds) - , (genClassKey, generic (gen_Generic_binds Gen0)) - , (gen1ClassKey, generic (gen_Generic_binds Gen1)) ] - - simple gen_fn loc tc _ - = let (binds, deriv_stuff) = gen_fn loc tc - in return (binds, deriv_stuff, []) - - simpleM gen_fn loc tc _ - = do { (binds, deriv_stuff) <- gen_fn loc tc - ; return (binds, deriv_stuff, []) } - - read_or_show gen_fn loc tc _ - = do { fix_env <- getDataConFixityFun tc - ; let (binds, deriv_stuff) = gen_fn fix_env loc tc - field_names = all_field_names tc - ; return (binds, deriv_stuff, field_names) } - - generic gen_fn _ tc inst_tys - = do { (binds, faminst) <- gen_fn tc inst_tys - ; let field_names = all_field_names tc - ; return (binds, unitBag (DerivFamInst faminst), field_names) } - - -- See Note [Deriving and unused record selectors] - all_field_names = map flSelector . concatMap dataConFieldLabels - . tyConDataCons - -{- -Note [Deriving and unused record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (see #13919): - - module Main (main) where - - data Foo = MkFoo {bar :: String} deriving Show - - main :: IO () - main = print (Foo "hello") - -Strictly speaking, the record selector `bar` is unused in this module, since -neither `main` nor the derived `Show` instance for `Foo` mention `bar`. -However, the behavior of `main` is affected by the presence of `bar`, since -it will print different output depending on whether `MkFoo` is defined using -record selectors or not. Therefore, we do not to issue a -"Defined but not used: ‘bar’" warning for this module, since removing `bar` -changes the program's behavior. This is the reason behind the [Name] part of -the return type of `hasStockDeriving`—it tracks all of the record selector -`Name`s for which -Wunused-binds should be suppressed. - -Currently, the only three stock derived classes that require this are Read, -Show, and Generic, as their derived code all depend on the record selectors -of the derived data type's constructors. - -See also Note [Newtype deriving and unused constructors] in TcDeriv for -another example of a similar trick. --} - -getDataConFixityFun :: TyCon -> TcM (Name -> Fixity) --- If the TyCon is locally defined, we want the local fixity env; --- but if it is imported (which happens for standalone deriving) --- we need to get the fixity env from the interface file --- c.f. GHC.Rename.Env.lookupFixity, and #9830 -getDataConFixityFun tc - = do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod name - then do { fix_env <- getFixityEnv - ; return (lookupFixity fix_env) } - else do { iface <- loadInterfaceForName doc name - -- Should already be loaded! - ; return (mi_fix iface . nameOccName) } } - where - name = tyConName tc - doc = text "Data con fixities for" <+> ppr name - ------------------------------------------------------------------- --- Check side conditions that dis-allow derivability for the originative --- deriving strategies (stock and anyclass). --- See Note [Deriving strategies] in TcDeriv for an explanation of what --- "originative" means. --- --- This is *apart* from the coerce-based strategies, newtype and via. --- --- Here we get the representation tycon in case of family instances as it has --- the data constructors - but we need to be careful to fall back to the --- family tycon (with indexes) in error messages. - -checkOriginativeSideConditions - :: DynFlags -> DerivContext -> Class -> [TcType] - -> TyCon -> TyCon - -> OriginativeDerivStatus -checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc - -- First, check if stock deriving is possible... - | Just cond <- stockSideConditions deriv_ctxt cls - = case (cond dflags tc rep_tc) of - NotValid err -> StockClassError err -- Class-specific error - IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys) - -- All stock derivable classes are unary in the sense that - -- there should be not types in cls_tys (i.e., no type args - -- other than last). Note that cls_types can contain - -- invisible types as well (e.g., for Generic1, which is - -- poly-kinded), so make sure those are not counted. - , Just gen_fn <- hasStockDeriving cls - -> CanDeriveStock gen_fn - | otherwise -> StockClassError (classArgsErr cls cls_tys) - -- e.g. deriving( Eq s ) - - -- ...if not, try falling back on DeriveAnyClass. - | NotValid err <- canDeriveAnyClass dflags - = NonDerivableClass err -- Neither anyclass nor stock work - - | otherwise - = CanDeriveAnyClass -- DeriveAnyClass should work - -classArgsErr :: Class -> [Type] -> SDoc -classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class" - --- Side conditions (whether the datatype must have at least one constructor, --- required language extensions, etc.) for using GHC's stock deriving --- mechanism on certain classes (as opposed to classes that require --- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a --- class for which stock deriving isn't possible. -stockSideConditions :: DerivContext -> Class -> Maybe Condition -stockSideConditions deriv_ctxt cls - | 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 - -- Vanilla data constructors, at least one, and monotype arguments - cond_vanilla = cond_stdOK deriv_ctxt True - -- Vanilla data constructors but allow no data cons or polytype arguments - -canDeriveAnyClass :: DynFlags -> Validity --- IsValid: we can (try to) derive it via an empty instance declaration --- NotValid s: we can't, reason s -canDeriveAnyClass dflags - | not (xopt LangExt.DeriveAnyClass dflags) - = NotValid (text "Try enabling DeriveAnyClass") - | otherwise - = IsValid -- OK! - -type Condition - = DynFlags - - -> TyCon -- ^ The data type's 'TyCon'. For data families, this is the - -- family 'TyCon'. - - -> TyCon -- ^ For data families, this is the representation 'TyCon'. - -- Otherwise, this is the same as the other 'TyCon' argument. - - -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is - -- possible. Otherwise, it's @'NotValid' err@, where @err@ - -- explains what went wrong. - -orCond :: Condition -> Condition -> Condition -orCond c1 c2 dflags tc rep_tc - = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of - (IsValid, _) -> IsValid -- c1 succeeds - (_, IsValid) -> IsValid -- c21 succeeds - (NotValid x, NotValid y) -> NotValid (x $$ text " or" $$ y) - -- Both fail - -andCond :: Condition -> Condition -> Condition -andCond c1 c2 dflags tc rep_tc - = c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc - --- | Some common validity checks shared among stock derivable classes. One --- check that absolutely must hold is that if an instance @C (T a)@ is being --- derived, then @T@ must be a tycon for a data type or a newtype. The --- remaining checks are only performed if using a @deriving@ clause (i.e., --- they're ignored if using @StandaloneDeriving@): --- --- 1. The data type must have at least one constructor (this check is ignored --- if using @EmptyDataDeriving@). --- --- 2. The data type cannot have any GADT constructors. --- --- 3. The data type cannot have any constructors with existentially quantified --- type variables. --- --- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@). --- --- 5. The data type cannot have fields with higher-rank types. -cond_stdOK - :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a - -- user-supplied context, 'InferContext' if not. - -- If it is the former, we relax some of the validity checks - -- we would otherwise perform (i.e., "just go for it"). - - -> Bool -- ^ 'True' <=> allow higher rank arguments and empty data - -- types (with no data constructors) even in the absence of - -- the -XEmptyDataDeriving extension. - - -> Condition -cond_stdOK deriv_ctxt permissive dflags tc rep_tc - = valid_ADT `andValid` valid_misc - where - valid_ADT, valid_misc :: Validity - valid_ADT - | isAlgTyCon tc || isDataFamilyTyCon tc - = IsValid - | otherwise - -- Complain about functions, primitive types, and other tycons that - -- stock deriving can't handle. - = NotValid $ text "The last argument of the instance must be a" - <+> text "data or newtype application" - - valid_misc - = case deriv_ctxt of - SupplyContext _ -> IsValid - -- Don't check these conservative conditions for - -- standalone deriving; just generate the code - -- and let the typechecker handle the result - InferContext wildcard - | null data_cons -- 1. - , not permissive - -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid` - NotValid (no_cons_why rep_tc $$ empty_data_suggestion) - | not (null con_whys) - -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard) - | otherwise - -> IsValid - - empty_data_suggestion = - text "Use EmptyDataDeriving to enable deriving for empty data types" - possible_fix_suggestion wildcard - = case wildcard of - Just _ -> - text "Possible fix: fill in the wildcard constraint yourself" - Nothing -> - text "Possible fix: use a standalone deriving declaration instead" - data_cons = tyConDataCons rep_tc - con_whys = getInvalids (map check_con data_cons) - - check_con :: DataCon -> Validity - check_con con - | not (null eq_spec) -- 2. - = bad "is a GADT" - | not (null ex_tvs) -- 3. - = bad "has existential type variables in its type" - | not (null theta) -- 4. - = bad "has constraints in its type" - | not (permissive || all isTauTy (dataConOrigArgTys con)) -- 5. - = bad "has a higher-rank type" - | otherwise - = IsValid - where - (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con - bad msg = NotValid (badCon con (text msg)) - -no_cons_why :: TyCon -> SDoc -no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> - text "must have at least one data constructor" - -cond_RepresentableOk :: Condition -cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc - -cond_Representable1Ok :: Condition -cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc - -cond_enumOrProduct :: Class -> Condition -cond_enumOrProduct cls = cond_isEnumeration `orCond` - (cond_isProduct `andCond` cond_args cls) - -cond_args :: Class -> Condition --- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types --- by generating specialised code. For others (eg 'Data') we don't. --- For even others (eg 'Lift'), unlifted types aren't even a special --- consideration! -cond_args cls _ _ rep_tc - = case bad_args of - [] -> IsValid - (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls)) - 2 (text "for type" <+> quotes (ppr ty))) - where - bad_args = [ arg_ty | con <- tyConDataCons rep_tc - , arg_ty <- dataConOrigArgTys con - , isLiftedType_maybe arg_ty /= Just True - , not (ok_ty arg_ty) ] - - cls_key = classKey cls - ok_ty arg_ty - | cls_key == eqClassKey = check_in arg_ty ordOpTbl - | cls_key == ordClassKey = check_in arg_ty ordOpTbl - | cls_key == showClassKey = check_in arg_ty boxConTbl - | cls_key == liftClassKey = True -- Lift is levity-polymorphic - | otherwise = False -- Read, Ix etc - - check_in :: Type -> [(Type,a)] -> Bool - check_in arg_ty tbl = any (eqType arg_ty . fst) tbl - - -cond_isEnumeration :: Condition -cond_isEnumeration _ _ rep_tc - | isEnumerationTyCon rep_tc = IsValid - | otherwise = NotValid why - where - why = sep [ quotes (pprSourceTyCon rep_tc) <+> - text "must be an enumeration type" - , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ] - -- See Note [Enumeration types] in GHC.Core.TyCon - -cond_isProduct :: Condition -cond_isProduct _ _ rep_tc - | isProductTyCon rep_tc = IsValid - | otherwise = NotValid why - where - why = quotes (pprSourceTyCon rep_tc) <+> - text "must have precisely one constructor" - -cond_functorOK :: Bool -> Bool -> Condition --- OK for Functor/Foldable/Traversable class --- Currently: (a) at least one argument --- (b) don't use argument contravariantly --- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) --- (d) optionally: don't use function types --- (e) no "stupid context" on data type -cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc - | null tc_tvs - = NotValid (text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters") - - | not (null bad_stupid_theta) - = NotValid (text "Data type" <+> quotes (ppr rep_tc) - <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) - - | otherwise - = allValid (map check_con data_cons) - where - tc_tvs = tyConTyVars rep_tc - last_tv = last tc_tvs - bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc) - is_bad pred = last_tv `elemVarSet` exactTyCoVarsOfType pred - -- See Note [Check that the type variable is truly universal] - - data_cons = tyConDataCons rep_tc - check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con) - - check_universal :: DataCon -> Validity - check_universal con - | allowExQuantifiedLastTyVar - = IsValid -- See Note [DeriveFoldable with ExistentialQuantification] - -- in TcGenFunctor - | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) - , tv `elem` dataConUnivTyVars con - , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con)) - = IsValid -- See Note [Check that the type variable is truly universal] - | otherwise - = NotValid (badCon con existential) - - ft_check :: DataCon -> FFoldType Validity - ft_check con = FT { ft_triv = IsValid, ft_var = IsValid - , ft_co_var = NotValid (badCon con covariant) - , ft_fun = \x y -> if allowFunctions then x `andValid` y - else NotValid (badCon con functions) - , ft_tup = \_ xs -> allValid xs - , ft_ty_app = \_ _ x -> x - , ft_bad_app = NotValid (badCon con wrong_arg) - , ft_forall = \_ x -> x } - - existential = text "must be truly polymorphic in the last argument of the data type" - covariant = text "must not use the type variable in a function argument" - functions = text "must not contain function types" - wrong_arg = text "must use the type variable only as the last argument of a data type" - -checkFlag :: LangExt.Extension -> Condition -checkFlag flag dflags _ _ - | xopt flag dflags = IsValid - | otherwise = NotValid why - where - why = text "You need " <> text flag_str - <+> text "to derive an instance for this class" - flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of - [s] -> s - other -> pprPanic "checkFlag" (ppr other) - -std_class_via_coercible :: Class -> Bool --- These standard classes can be derived for a newtype --- using the coercible trick *even if no -XGeneralizedNewtypeDeriving --- because giving so gives the same results as generating the boilerplate -std_class_via_coercible clas - = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] - -- Not Read/Show because they respect the type - -- Not Enum, because newtypes are never in Enum - - -non_coercible_class :: Class -> Bool --- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift --- by Coercible, even with -XGeneralizedNewtypeDeriving --- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived --- instance behave differently if there's a non-lawful Applicative out there. --- Besides, with roles, Coercible-deriving Traversable is ill-roled. -non_coercible_class cls - = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey - , genClassKey, gen1ClassKey, typeableClassKey - , traversableClassKey, liftClassKey ]) - -badCon :: DataCon -> SDoc -> SDoc -badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg - ------------------------------------------------------------------- - -newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst -newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode - , ds_tvs = tvs, ds_cls = clas, ds_tys = tys }) - = newClsInst overlap_mode dfun_name tvs theta clas tys - -extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a --- Add new locally-defined instances; don't bother to check --- for functional dependency errors -- that'll happen in TcInstDcls -extendLocalInstEnv dfuns thing_inside - = do { env <- getGblEnv - ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns - env' = env { tcg_inst_env = inst_env' } - ; setGblEnv env' thing_inside } - -{- -Note [Deriving any class] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Classic uses of a deriving clause, or a standalone-deriving declaration, are -for: - * a stock class like Eq or Show, for which GHC knows how to generate - the instance code - * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving - -The DeriveAnyClass extension adds a third way to derive instances, based on -empty instance declarations. - -The canonical use case is in combination with GHC.Generics and default method -signatures. These allow us to have instance declarations being empty, but still -useful, e.g. - - data T a = ...blah..blah... deriving( Generic ) - instance C a => C (T a) -- No 'where' clause - -where C is some "random" user-defined class. - -This boilerplate code can be replaced by the more compact - - data T a = ...blah..blah... deriving( Generic, C ) - -if DeriveAnyClass is enabled. - -This is not restricted to Generics; any class can be derived, simply giving -rise to an empty instance. - -See Note [Gathering and simplifying constraints for DeriveAnyClass] in -TcDerivInfer for an explanation hof how the instance context is inferred for -DeriveAnyClass. - -Note [Check that the type variable is truly universal] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For Functor and Traversable instances, we must check that the *last argument* -of the type constructor is used truly universally quantified. Example - - data T a b where - T1 :: a -> b -> T a b -- Fine! Vanilla H-98 - T2 :: b -> c -> T a b -- Fine! Existential c, but we can still map over 'b' - T3 :: b -> T Int b -- Fine! Constraint 'a', but 'b' is still polymorphic - T4 :: Ord b => b -> T a b -- No! 'b' is constrained - T5 :: b -> T b b -- No! 'b' is constrained - T6 :: T a (b,b) -- No! 'b' is constrained - -Notice that only the first of these constructors is vanilla H-98. We only -need to take care about the last argument (b in this case). See #8678. -Eg. for T1-T3 we can write - - fmap f (T1 a b) = T1 a (f b) - fmap f (T2 b c) = T2 (f b) c - fmap f (T3 x) = T3 (f x) - -We need not perform these checks for Foldable instances, however, since -functions in Foldable can only consume existentially quantified type variables, -rather than produce them (as is the case in Functor and Traversable functions.) -As a result, T can have a derived Foldable instance: - - foldr f z (T1 a b) = f b z - foldr f z (T2 b c) = f b z - foldr f z (T3 x) = f x z - foldr f z (T4 x) = f x z - foldr f z (T5 x) = f x z - foldr _ z T6 = z - -See Note [DeriveFoldable with ExistentialQuantification] in TcGenFunctor. - -For Functor and Traversable, we must take care not to let type synonyms -unfairly reject a type for not being truly universally quantified. An -example of this is: - - type C (a :: Constraint) b = a - data T a b = C (Show a) b => MkT b - -Here, the existential context (C (Show a) b) does technically mention the last -type variable b. But this is OK, because expanding the type synonym C would -give us the context (Show a), which doesn't mention b. Therefore, we must make -sure to expand type synonyms before performing this check. Not doing so led to -#13813. --} diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs deleted file mode 100644 --- a/compiler/typecheck/TcEnv.hs +++ /dev/null @@ -1,1110 +0,0 @@ --- (c) The University of Glasgow 2006 -{-# LANGUAGE CPP, FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an - -- orphan -{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] - -- in module GHC.Hs.Extension -{-# LANGUAGE TypeFamilies #-} - -module TcEnv( - TyThing(..), TcTyThing(..), TcId, - - -- Instance environment, and InstInfo type - InstInfo(..), iDFunId, pprInstInfoDetails, - simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, - InstBindings(..), - - -- Global environment - tcExtendGlobalEnv, tcExtendTyConEnv, - tcExtendGlobalEnvImplicit, setGlobalTypeEnv, - tcExtendGlobalValEnv, - tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly, - tcLookupTyCon, tcLookupClass, - tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, - tcLookupLocatedGlobalId, tcLookupLocatedTyCon, - tcLookupLocatedClass, tcLookupAxiom, - lookupGlobal, ioLookupDataCon, - addTypecheckedBinds, - - -- Local environment - tcExtendKindEnv, tcExtendKindEnvList, - tcExtendTyVarEnv, tcExtendNameTyVarEnv, - tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds, - tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, - tcExtendBinderStack, tcExtendLocalTypeEnv, - isTypeClosedLetBndr, - - tcLookup, tcLookupLocated, tcLookupLocalIds, - tcLookupId, tcLookupIdMaybe, tcLookupTyVar, - tcLookupTcTyCon, - tcLookupLcl_maybe, - getInLocalScope, - wrongThingErr, pprBinders, - - tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders, - getTypeSigNames, - tcExtendRecEnv, -- For knot-tying - - -- Tidying - tcInitTidyEnv, tcInitOpenTidyEnv, - - -- Instances - tcLookupInstance, tcGetInstEnvs, - - -- Rules - tcExtendRules, - - -- Defaults - tcGetDefaultTys, - - -- Template Haskell stuff - checkWellStaged, tcMetaTy, thLevel, - topIdLvl, isBrackStage, - - -- New Ids - newDFunName, newFamInstTyConName, - newFamInstAxiomName, - mkStableIdFromString, mkStableIdFromName, - mkWrapperName - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import GHC.Iface.Env -import TcRnMonad -import TcMType -import TcType -import GHC.Iface.Load -import PrelNames -import TysWiredIn -import GHC.Types.Id -import GHC.Types.Var -import GHC.Types.Name.Reader -import GHC.Core.InstEnv -import GHC.Core.DataCon ( DataCon ) -import GHC.Core.PatSyn ( PatSyn ) -import GHC.Core.ConLike -import GHC.Core.TyCon -import GHC.Core.Type -import GHC.Core.Coercion.Axiom -import GHC.Core.Class -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.Name.Env -import GHC.Types.Var.Env -import GHC.Driver.Types -import GHC.Driver.Session -import GHC.Types.SrcLoc -import GHC.Types.Basic hiding( SuccessFlag(..) ) -import GHC.Types.Module -import Outputable -import Encoding -import FastString -import Bag -import ListSetOps -import ErrUtils -import Maybes( MaybeErr(..), orElse ) -import qualified GHC.LanguageExtensions as LangExt -import Util ( HasDebugCallStack ) - -import Data.IORef -import Data.List (intercalate) -import Control.Monad - -{- ********************************************************************* -* * - An IO interface to looking up globals -* * -********************************************************************* -} - -lookupGlobal :: HscEnv -> Name -> IO TyThing --- A variant of lookupGlobal_maybe for the clients which are not --- interested in recovering from lookup failure and accept panic. -lookupGlobal hsc_env name - = do { - mb_thing <- lookupGlobal_maybe hsc_env name - ; case mb_thing of - Succeeded thing -> return thing - Failed msg -> pprPanic "lookupGlobal" msg - } - -lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) --- This may look up an Id that one one has previously looked up. --- If so, we are going to read its interface file, and add its bindings --- to the ExternalPackageTable. -lookupGlobal_maybe hsc_env name - = do { -- Try local envt - let mod = icInteractiveModule (hsc_IC hsc_env) - dflags = hsc_dflags hsc_env - tcg_semantic_mod = canonicalizeModuleIfHome dflags 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 - } - -lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) --- Returns (Failed err) if we can't find the interface file for the thing -lookupImported_maybe hsc_env name - = do { mb_thing <- lookupTypeHscEnv hsc_env name - ; case mb_thing of - Just thing -> return (Succeeded thing) - Nothing -> importDecl_maybe hsc_env name - } - -importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) -importDecl_maybe hsc_env name - | Just thing <- wiredInNameTyThing_maybe name - = do { when (needWiredInHomeIface thing) - (initIfaceLoad hsc_env (loadWiredInHomeIface name)) - -- See Note [Loading instances for wired-in things] - ; return (Succeeded thing) } - | 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 MsgDoc 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 - -- Do not add the code for record-selector bindings - -- when compiling hs-boot files - | otherwise = tcg_env { tcg_binds = foldr unionBags - (tcg_binds tcg_env) - binds } - -{- -************************************************************************ -* * -* tcLookupGlobal * -* * -************************************************************************ - -Using the Located versions (eg. tcLookupLocatedGlobal) is preferred, -unless you know that the SrcSpan in the monad is already set to the -span of the Name. --} - - -tcLookupLocatedGlobal :: Located Name -> TcM TyThing --- c.f. GHC.IfaceToCore.tcIfaceGlobal -tcLookupLocatedGlobal name - = addLocM tcLookupGlobal name - -tcLookupGlobal :: Name -> TcM TyThing --- The Name is almost always an ExternalName, but not always --- In GHCi, we may make command-line bindings (ghci> let x = True) --- that bind a GlobalId, but with an InternalName -tcLookupGlobal name - = do { -- Try local envt - env <- getGblEnv - ; case lookupNameEnv (tcg_type_env env) name of { - Just thing -> return thing ; - Nothing -> - - -- Should it have been in the local envt? - -- (NB: use semantic mod here, since names never use - -- identity module, see Note [Identity versus semantic module].) - if nameIsLocalOrFrom (tcg_semantic_mod env) name - then notFound name -- Internal names can happen in GHCi - else - - -- Try home package table and external package table - do { mb_thing <- tcLookupImported_maybe name - ; case mb_thing of - Succeeded thing -> return thing - Failed msg -> failWithTc msg - }}} - --- Look up only in this module's global env't. Don't look in imports, etc. --- Panic if it's not there. -tcLookupGlobalOnly :: Name -> TcM TyThing -tcLookupGlobalOnly name - = do { env <- getGblEnv - ; return $ case lookupNameEnv (tcg_type_env env) name of - Just thing -> thing - Nothing -> pprPanic "tcLookupGlobalOnly" (ppr name) } - -tcLookupDataCon :: Name -> TcM DataCon -tcLookupDataCon name = do - thing <- tcLookupGlobal name - case thing of - AConLike (RealDataCon con) -> return con - _ -> wrongThingErr "data constructor" (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 - -tcLookupConLike :: Name -> TcM ConLike -tcLookupConLike name = do - thing <- tcLookupGlobal name - case thing of - AConLike cl -> return cl - _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name - -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 - -tcLookupTyCon :: Name -> TcM TyCon -tcLookupTyCon name = do - thing <- tcLookupGlobal name - case thing of - ATyCon tc -> return tc - _ -> wrongThingErr "type constructor" (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 - -tcLookupLocatedGlobalId :: Located Name -> TcM Id -tcLookupLocatedGlobalId = addLocM tcLookupId - -tcLookupLocatedClass :: Located Name -> TcM Class -tcLookupLocatedClass = addLocM tcLookupClass - -tcLookupLocatedTyCon :: Located Name -> TcM TyCon -tcLookupLocatedTyCon = addLocM tcLookupTyCon - --- Find the instance that exactly matches a type class application. The class arguments must be precisely --- the same as in the instance declaration (modulo renaming & casts). --- -tcLookupInstance :: Class -> [Type] -> TcM ClsInst -tcLookupInstance cls tys - = do { instEnv <- tcGetInstEnvs - ; case lookupUniqueInstEnv instEnv cls tys of - Left err -> failWithTc $ text "Couldn't match instance:" <+> err - Right (inst, tys) - | uniqueTyVars tys -> return inst - | otherwise -> failWithTc errNotExact - } - where - errNotExact = text "Not an exact match (i.e., some variables get instantiated)" - - uniqueTyVars tys = all isTyVarTy tys - && hasNoDups (map (getTyVar "tcLookupInstance") tys) - -tcGetInstEnvs :: TcM InstEnvs --- Gets both the external-package inst-env --- and the home-pkg inst env (includes module being compiled) -tcGetInstEnvs = do { eps <- getEps - ; env <- getGblEnv - ; return (InstEnvs { ie_global = eps_inst_env eps - , ie_local = tcg_inst_env env - , ie_visible = tcVisibleOrphanMods env }) } - -instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where - lookupThing = tcLookupGlobal - -{- -************************************************************************ -* * - Extending the global environment -* * -************************************************************************ --} - -setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv --- Use this to update the global type env --- It updates both * the normal tcg_type_env field --- * the tcg_type_env_var field seen by interface files -setGlobalTypeEnv tcg_env new_type_env - = do { -- Sync the type-envt variable seen by interface files - writeMutVar (tcg_type_env_var tcg_env) new_type_env - ; return (tcg_env { tcg_type_env = new_type_env }) } - - -tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r - -- Just extend the global environment with some TyThings - -- Do not extend tcg_tcs, tcg_patsyns etc -tcExtendGlobalEnvImplicit things thing_inside - = do { tcg_env <- getGblEnv - ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things - ; tcg_env' <- setGlobalTypeEnv tcg_env ge' - ; setGblEnv tcg_env' thing_inside } - -tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r - -- Given a mixture of Ids, TyCons, Classes, all defined in the - -- module being compiled, extend the global environment -tcExtendGlobalEnv things thing_inside - = do { env <- getGblEnv - ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env, - tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env } - ; setGblEnv env' $ - tcExtendGlobalEnvImplicit things thing_inside - } - -tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r - -- Given a mixture of Ids, TyCons, Classes, all defined in the - -- module being compiled, extend the global environment -tcExtendTyConEnv tycons thing_inside - = do { env <- getGblEnv - ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env } - ; setGblEnv env' $ - tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside - } - -tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a - -- Same deal as tcExtendGlobalEnv, but for Ids -tcExtendGlobalValEnv ids thing_inside - = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside - -tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r --- Extend the global environments for the type/class knot tying game --- Just like tcExtendGlobalEnv, except the argument is a list of pairs -tcExtendRecEnv gbl_stuff thing_inside - = do { tcg_env <- getGblEnv - ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff - tcg_env' = tcg_env { tcg_type_env = ge' } - -- No need for setGlobalTypeEnv (which side-effects the - -- tcg_type_env_var); tcExtendRecEnv is used just - -- when kind-check a group of type/class decls. It would - -- in any case be wrong for an interface-file decl to end up - -- with a TcTyCon in it! - ; setGblEnv tcg_env' thing_inside } - -{- -************************************************************************ -* * -\subsection{The local environment} -* * -************************************************************************ --} - -tcLookupLocated :: Located Name -> TcM TcTyThing -tcLookupLocated = addLocM tcLookup - -tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) -tcLookupLcl_maybe name - = do { local_env <- getLclTypeEnv - ; return (lookupNameEnv local_env name) } - -tcLookup :: Name -> TcM TcTyThing -tcLookup name = do - local_env <- getLclTypeEnv - case lookupNameEnv local_env name of - Just thing -> return thing - Nothing -> AGlobal <$> tcLookupGlobal name - -tcLookupTyVar :: Name -> TcM TcTyVar -tcLookupTyVar name - = do { thing <- tcLookup name - ; case thing of - ATyVar _ tv -> return tv - _ -> pprPanic "tcLookupTyVar" (ppr name) } - -tcLookupId :: Name -> TcM Id --- Used when we aren't interested in the binding level, nor refinement. --- The "no refinement" part means that we return the un-refined Id regardless --- --- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId) -tcLookupId name = do - thing <- tcLookupIdMaybe name - case thing of - Just id -> return id - _ -> pprPanic "tcLookupId" (ppr name) - -tcLookupIdMaybe :: Name -> TcM (Maybe Id) -tcLookupIdMaybe name - = do { thing <- tcLookup name - ; case thing of - ATcId { tct_id = id} -> return $ Just id - AGlobal (AnId id) -> return $ Just id - _ -> return Nothing } - -tcLookupLocalIds :: [Name] -> TcM [TcId] --- We expect the variables to all be bound, and all at --- the same level as the lookup. Only used in one place... -tcLookupLocalIds ns - = do { env <- getLclEnv - ; return (map (lookup (tcl_env env)) ns) } - where - lookup lenv name - = case lookupNameEnv lenv name of - Just (ATcId { tct_id = id }) -> id - _ -> pprPanic "tcLookupLocalIds" (ppr name) - --- inferInitialKind has made a suitably-shaped kind for the type or class --- Look it up in the local environment. This is used only for tycons --- that we're currently type-checking, so we're sure to find a TcTyCon. -tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon -tcLookupTcTyCon name = do - thing <- tcLookup name - case thing of - ATcTyCon tc -> return tc - _ -> pprPanic "tcLookupTcTyCon" (ppr name) - -getInLocalScope :: TcM (Name -> Bool) -getInLocalScope = do { lcl_env <- getLclTypeEnv - ; return (`elemNameEnv` lcl_env) } - -tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r --- Used only during kind checking, for TcThings that are --- ATcTyCon or APromotionErr --- 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 } - where - upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things } - -tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r --- A variant of tcExtendKindEvnList -tcExtendKindEnv extra_env thing_inside - = do { traceTc "tcExtendKindEnv" (ppr extra_env) - ; updLclEnv upd_env thing_inside } - where - upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env } - ------------------------ --- Scoped type and kind variables -tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r -tcExtendTyVarEnv tvs thing_inside - = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside - -tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r -tcExtendNameTyVarEnv binds thing_inside - -- this should be used only for explicitly mentioned scoped variables. - -- thus, no coercion variables - = do { tc_extend_local_env NotTopLevel - [(name, ATyVar name tv) | (name, tv) <- binds] $ - tcExtendBinderStack tv_binds $ - thing_inside } - where - tv_binds :: [TcBinder] - tv_binds = [TcTvBndr name tv | (name,tv) <- binds] - -isTypeClosedLetBndr :: Id -> Bool --- See Note [Bindings with closed types] in TcRnTypes -isTypeClosedLetBndr = noFreeVarsOfType . idType - -tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a --- Used for binding the recursive uses of Ids in a binding --- both top-level value bindings and nested let/where-bindings --- Does not extend the TcBinderStack -tcExtendRecIds pairs thing_inside - = tc_extend_local_env NotTopLevel - [ (name, ATcId { tct_id = let_id - , tct_info = NonClosedLet emptyNameSet False }) - | (name, let_id) <- pairs ] $ - thing_inside - -tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a --- Used for binding the Ids that have a complete user type signature --- Does not extend the TcBinderStack -tcExtendSigIds top_lvl sig_ids thing_inside - = tc_extend_local_env top_lvl - [ (idName id, ATcId { tct_id = id - , tct_info = info }) - | id <- sig_ids - , let closed = isTypeClosedLetBndr id - info = NonClosedLet emptyNameSet closed ] - thing_inside - - -tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed - -> [TcId] -> TcM a -> TcM a --- Used for both top-level value bindings and nested let/where-bindings --- Adds to the TcBinderStack too -tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed) - ids thing_inside - = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $ - tc_extend_local_env top_lvl - [ (idName id, ATcId { tct_id = id - , tct_info = mk_tct_info id }) - | id <- ids ] - thing_inside - where - mk_tct_info id - | type_closed && isEmptyNameSet rhs_fvs = ClosedLet - | otherwise = NonClosedLet rhs_fvs type_closed - where - name = idName id - rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet - type_closed = isTypeClosedLetBndr id && - (fv_type_closed || hasCompleteSig sig_fn name) - -tcExtendIdEnv :: [TcId] -> TcM a -> TcM a --- For lambda-bound and case-bound Ids --- Extends the TcBinderStack as well -tcExtendIdEnv ids thing_inside - = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside - -tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a --- Exactly like tcExtendIdEnv2, but for a single (name,id) pair -tcExtendIdEnv1 name id thing_inside - = tcExtendIdEnv2 [(name,id)] thing_inside - -tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a -tcExtendIdEnv2 names_w_ids thing_inside - = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel - | (_,mono_id) <- names_w_ids ] $ - tc_extend_local_env NotTopLevel - [ (name, ATcId { tct_id = id - , tct_info = NotLetBound }) - | (name,id) <- names_w_ids] - thing_inside - -tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a -tc_extend_local_env top_lvl extra_env thing_inside --- Precondition: the argument list extra_env has TcTyThings --- that ATcId or ATyVar, but nothing else --- --- Invariant: the ATcIds are fully zonked. Reasons: --- (a) The kinds of the forall'd type variables are defaulted --- (see Kind.defaultKind, done in skolemiseQuantifiedTyVar) --- (b) There are no via-Indirect occurrences of the bound variables --- in the types, because instantiation does not look through such things --- (c) The call to tyCoVarsOfTypes is ok without looking through refs - --- The second argument of type TyVarSet is a set of type variables --- 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) - ; env0 <- getLclEnv - ; let env1 = tcExtendLocalTypeEnv env0 extra_env - ; stage <- getStage - ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1 - ; setLclEnv env2 thing_inside } - where - extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv - -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously - -- Reason for extending LocalRdrEnv: after running a TH splice we need - -- to do renaming. - extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env - , tcl_th_bndrs = th_bndrs }) - = env { tcl_rdr = extendLocalRdrEnvList rdr_env - [ n | (n, _) <- pairs, isInternalName n ] - -- The LocalRdrEnv contains only non-top-level names - -- (GlobalRdrEnv handles the top level) - , tcl_th_bndrs = extendNameEnvList th_bndrs -- We only track Ids in tcl_th_bndrs - [(n, thlvl) | (n, ATcId {}) <- pairs] } - -tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv -tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things - = lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things } - -{- ********************************************************************* -* * - The TcBinderStack -* * -********************************************************************* -} - -tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a -tcExtendBinderStack bndrs thing_inside - = do { traceTc "tcExtendBinderStack" (ppr bndrs) - ; updLclEnv (\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 <- zonkTcTyVarToTyVar 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 -* * -********************************************************************* -} - -tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a --- See Note [AFamDataCon: not promoting data family constructors] -tcAddDataFamConPlaceholders inst_decls thing_inside - = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE) - | lid <- inst_decls, con <- get_cons lid ] - thing_inside - -- Note [AFamDataCon: not promoting data family constructors] - where - -- get_cons extracts the *constructor* bindings of the declaration - get_cons :: LInstDecl GhcRn -> [Name] - get_cons (L _ (TyFamInstD {})) = [] - get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid - get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } })) - = concatMap (get_fi_cons . unLoc) fids - get_cons (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec - get_cons (L _ (XInstDecl nec)) = noExtCon nec - - get_fi_cons :: DataFamInstDecl GhcRn -> [Name] - get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}}) - = map unLoc $ concatMap (getConNames . unLoc) cons - get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_rhs = XHsDataDefn nec }}}) - = noExtCon nec - get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn nec))) = noExtCon nec - get_fi_cons (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec - - -tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a --- See Note [Don't promote pattern synonyms] -tcAddPatSynPlaceholders pat_syns thing_inside - = tcExtendKindEnvList [ (name, APromotionErr PatSynPE) - | PSB{ psb_id = L _ name } <- pat_syns ] - thing_inside - -getTypeSigNames :: [LSig GhcRn] -> NameSet --- Get the names that have a user type sig -getTypeSigNames sigs - = foldr get_type_sig emptyNameSet sigs - where - get_type_sig :: LSig GhcRn -> NameSet -> NameSet - get_type_sig sig ns = - case sig of - L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names) - L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names) - _ -> ns - - -{- Note [AFamDataCon: not promoting data family constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family T a - data instance T Int = MkT - data Proxy (a :: k) - data S = MkS (Proxy 'MkT) - -Is it ok to use the promoted data family instance constructor 'MkT' in -the data declaration for S (where both declarations live in the same module)? -No, we don't allow this. It *might* make sense, but at least it would mean that -we'd have to interleave typechecking instances and data types, whereas at -present we do data types *then* instances. - -So to check for this we put in the TcLclEnv a binding for all the family -constructors, bound to AFamDataCon, so that if we trip over 'MkT' when -type checking 'S' we'll produce a decent error message. - -#12088 describes this limitation. Of course, when MkT and S live in -different modules then all is well. - -Note [Don't promote pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We never promote pattern synonyms. - -Consider this (#11265): - pattern A = True - instance Eq A -We want a civilised error message from the occurrence of 'A' -in the instance, yet 'A' really has not yet been type checked. - -Similarly (#9161) - {-# LANGUAGE PatternSynonyms, DataKinds #-} - pattern A = () - b :: A - b = undefined -Here, the type signature for b mentions A. But A is a pattern -synonym, which is typechecked as part of a group of bindings (for very -good reasons; a view pattern in the RHS may mention a value binding). -It is entirely reasonable to reject this, but to do so we need A to be -in the kind environment when kind-checking the signature for B. - -Hence tcAddPatSynPlaceholers adds a binding - A -> APromotionErr PatSynPE -to the environment. Then TcHsType.tcTyVar will find A in the kind -environment, and will give a 'wrongThingErr' as a result. But the -lookup of A won't fail. - - -************************************************************************ -* * -\subsection{Rules} -* * -************************************************************************ --} - -tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a - -- Just pop the new rules into the EPS and envt resp - -- All the rules come from an interface file, not source - -- Nevertheless, some may be for this module, if we read - -- its interface instead of its source code -tcExtendRules lcl_rules thing_inside - = do { env <- getGblEnv - ; let - env' = env { tcg_rules = lcl_rules ++ tcg_rules env } - ; setGblEnv env' thing_inside } - -{- -************************************************************************ -* * - Meta level -* * -************************************************************************ --} - -checkWellStaged :: SDoc -- What the stage check is for - -> ThLevel -- Binding level (increases inside brackets) - -> ThLevel -- Use stage - -> TcM () -- Fail if badly staged, adding an error -checkWellStaged pp_thing bind_lvl use_lvl - | use_lvl >= bind_lvl -- OK! Used later than bound - = return () -- E.g. \x -> [| $(f x) |] - - | bind_lvl == outerLevel -- GHC restriction on top level splices - = stageRestrictionError pp_thing - - | otherwise -- Badly staged - = failWithTc $ -- E.g. \x -> $(f x) - 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 $ - 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"])] - -topIdLvl :: Id -> ThLevel --- Globals may either be imported, or may be from an earlier "chunk" --- (separated by declaration splices) of this module. The former --- *can* be used inside a top-level splice, but the latter cannot. --- Hence we give the former impLevel, but the latter topLevel --- E.g. this is bad: --- x = [| foo |] --- $( f x ) --- By the time we are processing the $(f x), the binding for "x" --- will be in the global env, not the local one. -topIdLvl id | isLocalId id = outerLevel - | otherwise = impLevel - -tcMetaTy :: Name -> TcM Type --- Given the name of a Template Haskell data type, --- return the type --- E.g. given the name "Expr" return the type "Expr" -tcMetaTy tc_name = do - t <- tcLookupTyCon tc_name - return (mkTyConTy t) - -isBrackStage :: ThStage -> Bool -isBrackStage (Brack {}) = True -isBrackStage _other = False - -{- -************************************************************************ -* * - getDefaultTys -* * -************************************************************************ --} - -tcGetDefaultTys :: TcM ([Type], -- Default types - (Bool, -- True <=> Use overloaded strings - Bool)) -- True <=> Use extended defaulting rules -tcGetDefaultTys - = do { dflags <- getDynFlags - ; let ovl_strings = xopt LangExt.OverloadedStrings dflags - extended_defaults = xopt LangExt.ExtendedDefaultRules dflags - -- See also #1974 - flags = (ovl_strings, extended_defaults) - - ; mb_defaults <- getDeclaredDefaultTys - ; case mb_defaults of { - Just tys -> return (tys, flags) ; - -- User-supplied defaults - Nothing -> do - - -- No use-supplied default - -- Use [Integer, Double], plus modifications - { integer_ty <- tcMetaTy integerTyConName - ; list_ty <- tcMetaTy listTyConName - ; checkWiredInTyCon doubleTyCon - ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty] - -- Note [Extended defaults] - ++ [integer_ty, doubleTy] - ++ opt_deflt ovl_strings [stringTy] - ; return (deflt_tys, flags) } } } - where - opt_deflt True xs = xs - opt_deflt False _ = [] - -{- -Note [Extended defaults] -~~~~~~~~~~~~~~~~~~~~~ -In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we -try when defaulting. This has very little real impact, except in the following case. -Consider: - Text.Printf.printf "hello" -This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't -want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to -default the 'a' to (), rather than to Integer (which is what would otherwise happen; -and then GHCi doesn't attempt to print the (). So in interactive mode, we add -() to the list of defaulting types. See #1200. - -Additionally, the list type [] is added as a default specialization for -Traversable and Foldable. As such the default default list now has types of -varying kinds, e.g. ([] :: * -> *) and (Integer :: *). - -************************************************************************ -* * -\subsection{The InstInfo type} -* * -************************************************************************ - -The InstInfo type summarises the information in an instance declaration - - instance c => k (t tvs) where b - -It is used just for *local* instance decls (not ones from interface files). -But local instance decls includes - - derived ones - - generic ones -as well as explicit user written ones. --} - -data InstInfo a - = InstInfo - { iSpec :: ClsInst -- Includes the dfun id - , iBinds :: InstBindings a - } - -iDFunId :: InstInfo a -> DFunId -iDFunId info = instanceDFunId (iSpec info) - -data InstBindings a - = InstBindings - { ib_tyvars :: [Name] -- Names of the tyvars from the instance head - -- that are lexically in scope in the bindings - -- Must correspond 1-1 with the forall'd tyvars - -- of the dfun Id. When typechecking, we are - -- going to extend the typechecker's envt with - -- ib_tyvars -> dfun_forall_tyvars - - , ib_binds :: LHsBinds a -- Bindings for the instance methods - - , ib_pragmas :: [LSig a] -- User pragmas recorded for generating - -- specialised instances - - , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should - -- be enabled when type-checking - -- this instance; needed for - -- GeneralizedNewtypeDeriving - - , ib_derived :: Bool - -- True <=> This code was generated by GHC from a deriving clause - -- or standalone deriving declaration - -- Used only to improve error messages - } - -instance (OutputableBndrId a) - => Outputable (InstInfo (GhcPass a)) where - ppr = pprInstInfoDetails - -pprInstInfoDetails :: (OutputableBndrId a) - => InstInfo (GhcPass a) -> SDoc -pprInstInfoDetails info - = hang (pprInstanceHdr (iSpec info) <+> text "where") - 2 (details (iBinds info)) - where - details (InstBindings { ib_pragmas = p, ib_binds = b }) = - pprDeclList (pprLHsBindsForUser b p) - -simpleInstInfoClsTy :: InstInfo a -> (Class, Type) -simpleInstInfoClsTy info = case instanceHead (iSpec info) of - (_, cls, [ty]) -> (cls, ty) - _ -> panic "simpleInstInfoClsTy" - -simpleInstInfoTy :: InstInfo a -> Type -simpleInstInfoTy info = snd (simpleInstInfoClsTy info) - -simpleInstInfoTyCon :: InstInfo a -> TyCon - -- Gets the type constructor for a simple instance declaration, - -- i.e. one of the form instance (...) => C (T a b c) where ... -simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) - --- | Make a name for the dict fun for an instance decl. It's an *external* --- name, like other top-level names, and hence must be made with --- newGlobalBinder. -newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name -newDFunName clas tys loc - = do { is_boot <- tcIsHsBootOrSig - ; mod <- getModule - ; let info_string = occNameString (getOccName clas) ++ - concatMap (occNameString.getDFunTyKey) tys - ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) - ; newGlobalBinder mod dfun_occ loc } - -newFamInstTyConName :: Located Name -> [Type] -> TcM Name -newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys] - -newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name -newFamInstAxiomName (L loc name) branches - = mk_fam_inst_name mkInstTyCoOcc loc name branches - -mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name -mk_fam_inst_name adaptOcc loc tc_name tyss - = do { mod <- getModule - ; let info_string = occNameString (getOccName tc_name) ++ - intercalate "|" ty_strings - ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string) - ; newGlobalBinder mod (adaptOcc occ) loc } - where - ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss - -{- -Stable names used for foreign exports and annotations. -For stable names, the name must be unique (see #1533). If the -same thing has several stable Ids based on it, the -top-level bindings generated must not have the same name. -Hence we create an External name (doesn't change), and we -append a Unique to the string right here. --} - -mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId -mkStableIdFromString str sig_ty loc occ_wrapper = do - uniq <- newUnique - mod <- getModule - name <- mkWrapperName "stable" str - let occ = mkVarOccFS name :: OccName - gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name - id = mkExportedVanillaId gnm sig_ty :: Id - return id - -mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId -mkStableIdFromName nm = mkStableIdFromString (getOccString nm) - -mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m) - => String -> String -> m FastString -mkWrapperName what nameBase - = do dflags <- getDynFlags - thisMod <- getModule - let -- Note [Generating fresh names for ccall wrapper] - wrapperRef = nextWrapperNum dflags - pkg = unitIdString (moduleUnitId thisMod) - mod = moduleNameString (moduleName thisMod) - wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env -> - let num = lookupWithDefaultModuleEnv mod_env 0 thisMod - mod_env' = extendModuleEnv mod_env thisMod (num+1) - in (mod_env', num) - let components = [what, show wrapperNum, pkg, mod, nameBase] - return $ mkFastString $ zEncodeString $ intercalate ":" components - -{- -Note [Generating fresh names for FFI wrappers] - -We used to use a unique, rather than nextWrapperNum, to distinguish -between FFI wrapper functions. However, the wrapper names that we -generate are external names. This means that if a call to them ends up -in an unfolding, then we can't alpha-rename them, and thus if the -unique randomly changes from one compile to another then we get a -spurious ABI change (#4012). - -The wrapper counter has to be per-module, not global, so that the number we end -up using is not dependent on the modules compiled before the current one. --} - -{- -************************************************************************ -* * -\subsection{Errors} -* * -************************************************************************ --} - -pprBinders :: [Name] -> SDoc --- Used in error messages --- Use quotes for a single one; they look a bit "busy" for several -pprBinders [bndr] = quotes (ppr bndr) -pprBinders bndrs = pprWithCommas ppr bndrs - -notFound :: Name -> TcM TyThing -notFound name - = do { lcl_env <- getLclEnv - ; let stage = tcl_th_ctxt 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)) - _ -> failWithTc $ - 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)] - -- 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; - -- so let's just not print it! Getting a loop here is - -- very unhelpful, because it hides one compiler bug with another - } - -wrongThingErr :: String -> TcTyThing -> Name -> TcM a --- It's important that this only calls pprTcTyThingCategory, which in --- turn does not look at the details of the TcTyThing. --- See Note [Placeholder PatSyn kinds] in TcBinds -wrongThingErr expected thing name - = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> - text "used as a" <+> text expected) - -{- Note [Out of scope might be a staging error] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - x = 3 - data T = MkT $(foo x) - -where 'foo' is imported from somewhere. - -This is really a staging error, because we can't run code involving 'x'. -But in fact the type checker processes types first, so 'x' won't even be -in the type envt when we look for it in $(foo x). So inside splices we -report something missing from the type env as a staging error. -See #5752 and #5795. --} diff --git a/compiler/typecheck/TcEnv.hs-boot b/compiler/typecheck/TcEnv.hs-boot deleted file mode 100644 --- a/compiler/typecheck/TcEnv.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -module TcEnv where - -import TcRnTypes( TcM ) -import GHC.Types.Var.Env( TidyEnv ) - --- Annoyingly, there's a recursion between tcInitTidyEnv --- (which does zonking and hence needs TcMType) and --- addErrTc etc which live in TcRnMonad. Rats. -tcInitTidyEnv :: TcM TidyEnv - diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs deleted file mode 100644 --- a/compiler/typecheck/TcErrors.hs +++ /dev/null @@ -1,2981 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE LambdaCase #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcErrors( - reportUnsolved, reportAllUnsolved, warnAllUnsolved, - warnDefaulting, - - solverDepthErrorTcS - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnTypes -import TcRnMonad -import Constraint -import GHC.Core.Predicate -import TcMType -import TcUnify( occCheckForErrors, MetaTyVarUpdateResult(..) ) -import TcEnv( tcInitTidyEnv ) -import TcType -import TcOrigin -import GHC.Rename.Unbound ( unknownNameSuggestions ) -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE ) -import GHC.Core.Unify ( tcMatchTys ) -import GHC.Types.Module -import FamInst -import GHC.Core.FamInstEnv ( flattenTys ) -import Inst -import GHC.Core.InstEnv -import GHC.Core.TyCon -import GHC.Core.Class -import GHC.Core.DataCon -import TcEvidence -import TcEvTerm -import GHC.Hs.Binds ( PatSynBind(..) ) -import GHC.Types.Name -import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual ) -import PrelNames ( typeableClassName ) -import GHC.Types.Id -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Types.Name.Set -import Bag -import ErrUtils ( ErrMsg, errDoc, pprLocErrMsg ) -import GHC.Types.Basic -import GHC.Core.ConLike ( ConLike(..)) -import Util -import FastString -import Outputable -import GHC.Types.SrcLoc -import GHC.Driver.Session -import ListSetOps ( equivClasses ) -import Maybes -import qualified GHC.LanguageExtensions as LangExt -import FV ( fvVarList, unionFV ) - -import Control.Monad ( when ) -import Data.Foldable ( toList ) -import Data.List ( partition, mapAccumL, nub, sortBy, unfoldr ) - -import {-# SOURCE #-} TcHoleErrors ( findValidHoleFits ) - --- import Data.Semigroup ( Semigroup ) -import qualified Data.Semigroup as Semigroup - - -{- -************************************************************************ -* * -\section{Errors and contexts} -* * -************************************************************************ - -ToDo: for these error messages, should we note the location as coming -from the insts, or just whatever seems to be around in the monad just -now? - -Note [Deferring coercion errors to runtime] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -While developing, sometimes it is desirable to allow compilation to succeed even -if there are type errors in the code. Consider the following case: - - module Main where - - a :: Int - a = 'a' - - main = print "b" - -Even though `a` is ill-typed, it is not used in the end, so if all that we're -interested in is `main` it is handy to be able to ignore the problems in `a`. - -Since we treat type equalities as evidence, this is relatively simple. Whenever -we run into a type mismatch in TcUnify, we normally just emit an error. But it -is always safe to defer the mismatch to the main constraint solver. If we do -that, `a` will get transformed into - - co :: Int ~ Char - co = ... - - a :: Int - a = 'a' `cast` co - -The constraint solver would realize that `co` is an insoluble constraint, and -emit an error with `reportUnsolved`. But we can also replace the right-hand side -of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program -to compile, and it will run fine unless we evaluate `a`. This is what -`deferErrorsToRuntime` does. - -It does this by keeping track of which errors correspond to which coercion -in TcErrors. TcErrors.reportTidyWanteds does not print the errors -and does not fail if -fdefer-type-errors is on, so that we can continue -compilation. The errors are turned into warnings in `reportUnsolved`. --} - --- | Report unsolved goals as errors or warnings. We may also turn some into --- deferred run-time errors if `-fdefer-type-errors` is on. -reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) -reportUnsolved wanted - = do { binds_var <- newTcEvBinds - ; defer_errors <- goptM Opt_DeferTypeErrors - ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283 - ; let type_errors | not defer_errors = TypeError - | warn_errors = TypeWarn (Reason Opt_WarnDeferredTypeErrors) - | otherwise = TypeDefer - - ; defer_holes <- goptM Opt_DeferTypedHoles - ; warn_holes <- woptM Opt_WarnTypedHoles - ; let expr_holes | not defer_holes = HoleError - | warn_holes = HoleWarn - | otherwise = HoleDefer - - ; partial_sigs <- xoptM LangExt.PartialTypeSignatures - ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures - ; let type_holes | not partial_sigs = HoleError - | warn_partial_sigs = HoleWarn - | otherwise = HoleDefer - - ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables - ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables - ; let out_of_scope_holes | not defer_out_of_scope = HoleError - | warn_out_of_scope = HoleWarn - | otherwise = HoleDefer - - ; report_unsolved type_errors expr_holes - type_holes out_of_scope_holes - binds_var wanted - - ; ev_binds <- getTcEvBindsMap binds_var - ; return (evBindMapBinds ev_binds)} - --- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on --- However, do not make any evidence bindings, because we don't --- have any convenient place to put them. --- NB: Type-level holes are OK, because there are no bindings. --- See Note [Deferring coercion errors to runtime] --- Used by solveEqualities for kind equalities --- (see Note [Fail fast on kind errors] in TcSimplify) --- and for simplifyDefault. -reportAllUnsolved :: WantedConstraints -> TcM () -reportAllUnsolved wanted - = do { ev_binds <- newNoTcEvBinds - - ; partial_sigs <- xoptM LangExt.PartialTypeSignatures - ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures - ; let type_holes | not partial_sigs = HoleError - | warn_partial_sigs = HoleWarn - | otherwise = HoleDefer - - ; report_unsolved TypeError HoleError type_holes HoleError - ev_binds wanted } - --- | Report all unsolved goals as warnings (but without deferring any errors to --- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in --- TcSimplify -warnAllUnsolved :: WantedConstraints -> TcM () -warnAllUnsolved wanted - = do { ev_binds <- newTcEvBinds - ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn - ev_binds wanted } - --- | Report unsolved goals as errors or warnings. -report_unsolved :: TypeErrorChoice -- Deferred type errors - -> HoleChoice -- Expression holes - -> HoleChoice -- Type holes - -> HoleChoice -- Out of scope holes - -> EvBindsVar -- cec_binds - -> WantedConstraints -> TcM () -report_unsolved type_errors expr_holes - type_holes out_of_scope_holes binds_var wanted - | isEmptyWC wanted - = return () - | otherwise - = do { traceTc "reportUnsolved {" $ - vcat [ text "type errors:" <+> ppr type_errors - , text "expr holes:" <+> ppr expr_holes - , text "type holes:" <+> ppr type_holes - , text "scope holes:" <+> ppr out_of_scope_holes ] - ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) - - ; wanted <- zonkWC wanted -- Zonk to reveal all information - -- If we are deferring we are going to need /all/ evidence around, - -- including the evidence produced by unflattening (zonkWC) - ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs - free_tvs = tyCoVarsOfWCList wanted - - ; traceTc "reportUnsolved (after zonking):" $ - vcat [ text "Free tyvars:" <+> pprTyVars free_tvs - , text "Tidy env:" <+> ppr tidy_env - , text "Wanted:" <+> ppr wanted ] - - ; warn_redundant <- woptM Opt_WarnRedundantConstraints - ; let err_ctxt = CEC { cec_encl = [] - , cec_tidy = tidy_env - , cec_defer_type_errors = type_errors - , cec_expr_holes = expr_holes - , cec_type_holes = type_holes - , cec_out_of_scope_holes = out_of_scope_holes - , cec_suppress = insolubleWC wanted - -- See Note [Suppressing error messages] - -- Suppress low-priority errors if there - -- are insoluble errors anywhere; - -- See #15539 and c.f. setting ic_status - -- in TcSimplify.setImplicationStatus - , cec_warn_redundant = warn_redundant - , cec_binds = binds_var } - - ; tc_lvl <- getTcLevel - ; reportWanteds err_ctxt tc_lvl wanted - ; traceTc "reportUnsolved }" empty } - --------------------------------------------- --- Internal functions --------------------------------------------- - --- | An error Report collects messages categorised by their importance. --- See Note [Error report] for details. -data Report - = Report { report_important :: [SDoc] - , report_relevant_bindings :: [SDoc] - , report_valid_hole_fits :: [SDoc] - } - -instance Outputable Report where -- Debugging only - ppr (Report { report_important = imp - , report_relevant_bindings = rel - , report_valid_hole_fits = val }) - = vcat [ text "important:" <+> vcat imp - , text "relevant:" <+> vcat rel - , text "valid:" <+> vcat val ] - -{- Note [Error report] -The idea is that error msgs are divided into three parts: the main msg, the -context block (\"In the second argument of ...\"), and the relevant bindings -block, which are displayed in that order, with a mark to divide them. The -idea is that the main msg ('report_important') varies depending on the error -in question, but context and relevant bindings are always the same, which -should simplify visual parsing. - -The context is added when the Report is passed off to 'mkErrorReport'. -Unfortunately, unlike the context, the relevant bindings are added in -multiple places so they have to be in the Report. --} - -instance Semigroup Report where - Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2) - -instance Monoid Report where - mempty = Report [] [] [] - mappend = (Semigroup.<>) - --- | Put a doc into the important msgs block. -important :: SDoc -> Report -important doc = mempty { report_important = [doc] } - --- | Put a doc into the relevant bindings block. -relevant_bindings :: SDoc -> Report -relevant_bindings doc = mempty { report_relevant_bindings = [doc] } - --- | Put a doc into the valid hole fits block. -valid_hole_fits :: SDoc -> Report -valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] } - -data TypeErrorChoice -- What to do for type errors found by the type checker - = TypeError -- A type error aborts compilation with an error message - | TypeWarn WarnReason - -- A type error is deferred to runtime, plus a compile-time warning - -- The WarnReason should usually be (Reason Opt_WarnDeferredTypeErrors) - -- but it isn't for the Safe Haskell Overlapping Instances warnings - -- see warnAllUnsolved - | TypeDefer -- A type error is deferred to runtime; no error or warning at compile time - -data HoleChoice - = HoleError -- A hole is a compile-time error - | HoleWarn -- Defer to runtime, emit a compile-time warning - | HoleDefer -- Defer to runtime, no warning - -instance Outputable HoleChoice where - ppr HoleError = text "HoleError" - ppr HoleWarn = text "HoleWarn" - ppr HoleDefer = text "HoleDefer" - -instance Outputable TypeErrorChoice where - ppr TypeError = text "TypeError" - ppr (TypeWarn reason) = text "TypeWarn" <+> ppr reason - ppr TypeDefer = text "TypeDefer" - -data ReportErrCtxt - = CEC { cec_encl :: [Implication] -- Enclosing implications - -- (innermost first) - -- ic_skols and givens are tidied, rest are not - , cec_tidy :: TidyEnv - - , cec_binds :: EvBindsVar -- Make some errors (depending on cec_defer) - -- into warnings, and emit evidence bindings - -- into 'cec_binds' for unsolved constraints - - , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime - - -- cec_expr_holes is a union of: - -- cec_type_holes - a set of typed holes: '_', '_a', '_foo' - -- cec_out_of_scope_holes - a set of variables which are - -- out of scope: 'x', 'y', 'bar' - , cec_expr_holes :: HoleChoice -- Holes in expressions - , cec_type_holes :: HoleChoice -- Holes in types - , cec_out_of_scope_holes :: HoleChoice -- Out of scope holes - - , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints - - , cec_suppress :: Bool -- True <=> More important errors have occurred, - -- so create bindings if need be, but - -- don't issue any more errors/warnings - -- See Note [Suppressing error messages] - } - -instance Outputable ReportErrCtxt where - ppr (CEC { cec_binds = bvar - , cec_defer_type_errors = dte - , cec_expr_holes = eh - , cec_type_holes = th - , cec_out_of_scope_holes = osh - , cec_warn_redundant = wr - , cec_suppress = sup }) - = text "CEC" <+> braces (vcat - [ text "cec_binds" <+> equals <+> ppr bvar - , text "cec_defer_type_errors" <+> equals <+> ppr dte - , text "cec_expr_holes" <+> equals <+> ppr eh - , text "cec_type_holes" <+> equals <+> ppr th - , text "cec_out_of_scope_holes" <+> equals <+> ppr osh - , text "cec_warn_redundant" <+> equals <+> ppr wr - , text "cec_suppress" <+> equals <+> ppr sup ]) - --- | Returns True <=> the ReportErrCtxt indicates that something is deferred -deferringAnyBindings :: ReportErrCtxt -> Bool - -- Don't check cec_type_holes, as these don't cause bindings to be deferred -deferringAnyBindings (CEC { cec_defer_type_errors = TypeError - , cec_expr_holes = HoleError - , cec_out_of_scope_holes = HoleError }) = False -deferringAnyBindings _ = True - --- | Transforms a 'ReportErrCtxt' into one that does not defer any bindings --- at all. -noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt -noDeferredBindings ctxt = ctxt { cec_defer_type_errors = TypeError - , cec_expr_holes = HoleError - , cec_out_of_scope_holes = HoleError } - -{- Note [Suppressing error messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The cec_suppress flag says "don't report any errors". Instead, just create -evidence bindings (as usual). It's used when more important errors have occurred. - -Specifically (see reportWanteds) - * If there are insoluble Givens, then we are in unreachable code and all bets - are off. So don't report any further errors. - * If there are any insolubles (eg Int~Bool), here or in a nested implication, - then suppress errors from the simple constraints here. Sometimes the - simple-constraint errors are a knock-on effect of the insolubles. - -This suppression behaviour is controlled by the Bool flag in -ReportErrorSpec, as used in reportWanteds. - -But we need to take care: flags can turn errors into warnings, and we -don't want those warnings to suppress subsequent errors (including -suppressing the essential addTcEvBind for them: #15152). So in -tryReporter we use askNoErrs to see if any error messages were -/actually/ produced; if not, we don't switch on suppression. - -A consequence is that warnings never suppress warnings, so turning an -error into a warning may allow subsequent warnings to appear that were -previously suppressed. (e.g. partial-sigs/should_fail/T14584) --} - -reportImplic :: ReportErrCtxt -> Implication -> TcM () -reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope - , ic_given = given - , ic_wanted = wanted, ic_binds = evb - , ic_status = status, ic_info = info - , ic_tclvl = tc_lvl }) - | BracketSkol <- info - , not insoluble - = return () -- For Template Haskell brackets report only - -- definite errors. The whole thing will be re-checked - -- later when we plug it in, and meanwhile there may - -- certainly be un-satisfied constraints - - | otherwise - = do { traceTc "reportImplic" (ppr implic') - ; reportWanteds ctxt' tc_lvl wanted - ; when (cec_warn_redundant ctxt) $ - warnRedundantConstraints ctxt' tcl_env info' dead_givens - ; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs } - where - tcl_env = ic_env implic - insoluble = isInsolubleStatus status - (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs - info' = tidySkolemInfo env1 info - implic' = implic { ic_skols = tvs' - , ic_given = map (tidyEvVar env1) given - , ic_info = info' } - ctxt1 | CoEvBindsVar{} <- evb = noDeferredBindings ctxt - | otherwise = ctxt - -- If we go inside an implication that has no term - -- evidence (e.g. unifying under a forall), we can't defer - -- type errors. You could imagine using the /enclosing/ - -- bindings (in cec_binds), but that may not have enough stuff - -- in scope for the bindings to be well typed. So we just - -- switch off deferred type errors altogether. See #14605. - - ctxt' = ctxt1 { cec_tidy = env1 - , cec_encl = implic' : cec_encl ctxt - - , cec_suppress = insoluble || cec_suppress ctxt - -- Suppress inessential errors if there - -- are insolubles anywhere in the - -- tree rooted here, or we've come across - -- a suppress-worthy constraint higher up (#11541) - - , cec_binds = evb } - - dead_givens = case status of - IC_Solved { ics_dead = dead } -> dead - _ -> [] - - bad_telescope = case status of - IC_BadTelescope -> True - _ -> False - -warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM () --- See Note [Tracking redundant constraints] in TcSimplify -warnRedundantConstraints ctxt env info ev_vars - | null redundant_evs - = return () - - | SigSkol {} <- info - = setLclEnv env $ -- We want to add "In the type signature for f" - -- to the error context, which is a bit tiresome - addErrCtxt (text "In" <+> ppr info) $ - do { env <- getLclEnv - ; msg <- mkErrorReport ctxt env (important doc) - ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } - - | 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 - = do { msg <- mkErrorReport ctxt env (important doc) - ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } - where - doc = text "Redundant constraint" <> plural redundant_evs <> colon - <+> pprEvVarTheta redundant_evs - - redundant_evs = - filterOut is_type_error $ - case info of -- See Note [Redundant constraints in instance decls] - InstSkol -> filterOut (improving . idType) ev_vars - _ -> ev_vars - - -- See #15232 - is_type_error = isJust . userTypeError_maybe . idType - - improving pred -- (transSuperClasses p) does not include p - = any isImprovementPred (pred : transSuperClasses pred) - -reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TcTyVar] -> TcM () -reportBadTelescope ctxt env (Just telescope) skols - = do { msg <- mkErrorReport ctxt env (important doc) - ; reportError msg } - where - doc = hang (text "These kind and type variables:" <+> telescope $$ - text "are out of dependency order. Perhaps try this ordering:") - 2 (pprTyVars sorted_tvs) - - sorted_tvs = scopedSort skols - -reportBadTelescope _ _ Nothing skols - = pprPanic "reportBadTelescope" (ppr skols) - -{- Note [Redundant constraints in instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For instance declarations, 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.. --} - -reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () -reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics }) - = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples - , text "Suppress =" <+> ppr (cec_suppress ctxt)]) - ; traceTc "rw2" (ppr tidy_cts) - - -- First deal with things that are utterly wrong - -- Like Int ~ Bool (incl nullary TyCons) - -- or Int ~ t a (AppTy on one side) - -- These /ones/ are not suppressed by the incoming context - ; let ctxt_for_insols = ctxt { cec_suppress = False } - ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts - - -- Now all the other constraints. We suppress errors here if - -- any of the first batch failed, or if the enclosing context - -- says to suppress - ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } - ; (_, leftovers) <- tryReporters ctxt2 report2 cts1 - ; MASSERT2( null leftovers, ppr leftovers ) - - -- All the Derived ones have been filtered out of simples - -- by the constraint solver. This is ok; we don't want - -- to report unsolved Derived goals as errors - -- See Note [Do not report derived but soluble errors] - - ; mapBagM_ (reportImplic ctxt2) implics } - -- NB ctxt2: don't suppress inner insolubles if there's only a - -- wanted insoluble here; but do suppress inner insolubles - -- if there's a *given* insoluble here (= inaccessible code) - where - env = cec_tidy ctxt - tidy_cts = bagToList (mapBag (tidyCt env) simples) - - -- report1: ones that should *not* be suppressed by - -- an insoluble somewhere else in the tree - -- It's crucial that anything that is considered insoluble - -- (see TcRnTypes.insolubleCt) is caught here, otherwise - -- we might suppress its error message, and proceed on past - -- type checking to get a Lint error later - report1 = [ ("Out of scope", unblocked is_out_of_scope, True, mkHoleReporter tidy_cts) - , ("Holes", unblocked is_hole, False, mkHoleReporter tidy_cts) - , ("custom_error", unblocked is_user_type_error, True, mkUserTypeErrorReporter) - - , given_eq_spec - , ("insoluble2", unblocked utterly_wrong, True, mkGroupReporter mkEqErr) - , ("skolem eq1", unblocked very_wrong, True, mkSkolReporter) - , ("skolem eq2", unblocked skolem_eq, True, mkSkolReporter) - , ("non-tv eq", unblocked non_tv_eq, True, mkSkolReporter) - - -- The only remaining equalities are alpha ~ ty, - -- 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 TcCanonical - , ("Homo eqs", unblocked is_homo_equality, True, mkGroupReporter mkEqErr) - , ("Other eqs", unblocked is_equality, True, mkGroupReporter mkEqErr) - , ("Blocked eqs", is_equality, False, mkSuppressReporter mkBlockedEqErr)] - - -- report2: we suppress these if there are insolubles elsewhere in the tree - report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr) - , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) - , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] - - -- also checks to make sure the constraint isn't BlockedCIS - -- See TcCanonical Note [Equalities with incompatible kinds], (4) - unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool - unblocked _ (CIrredCan { cc_status = BlockedCIS }) _ = False - unblocked checker ct pred = checker ct pred - - -- rigid_nom_eq, rigid_nom_tv_eq, - is_hole, is_dict, - is_equality, is_ip, is_irred :: Ct -> Pred -> Bool - - is_given_eq ct pred - | EqPred {} <- pred = arisesFromGivens ct - | otherwise = False - -- I think all given residuals are equalities - - -- Things like (Int ~N Bool) - utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2 - utterly_wrong _ _ = False - - -- Things like (a ~N Int) - very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2 - very_wrong _ _ = False - - -- Things like (a ~N b) or (a ~N F Bool) - skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1 - skolem_eq _ _ = False - - -- Things like (F a ~N Int) - non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1) - non_tv_eq _ _ = False - - is_out_of_scope ct _ = isOutOfScopeCt ct - is_hole ct _ = isHoleCt ct - - is_user_type_error ct _ = isUserTypeErrorCt ct - - is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2 - is_homo_equality _ _ = False - - is_equality _ (EqPred {}) = True - is_equality _ _ = False - - is_dict _ (ClassPred {}) = True - is_dict _ _ = False - - is_ip _ (ClassPred cls _) = isIPClass cls - is_ip _ _ = False - - is_irred _ (IrredPred {}) = True - is_irred _ _ = False - - given_eq_spec -- See Note [Given errors] - | has_gadt_match (cec_encl ctxt) - = ("insoluble1a", is_given_eq, True, mkGivenErrorReporter) - | otherwise - = ("insoluble1b", is_given_eq, False, ignoreErrorReporter) - -- False means don't suppress subsequent errors - -- Reason: we don't report all given errors - -- (see mkGivenErrorReporter), and we should only suppress - -- subsequent errors if we actually report this one! - -- #13446 is an example - - -- See Note [Given errors] - has_gadt_match [] = False - has_gadt_match (implic : implics) - | PatSkol {} <- ic_info implic - , not (ic_no_eqs implic) - , ic_warn_inaccessible implic - -- Don't bother doing this if -Winaccessible-code isn't enabled. - -- See Note [Avoid -Winaccessible-code when deriving] in TcInstDcls. - = True - | otherwise - = has_gadt_match implics - ---------------- -isSkolemTy :: TcLevel -> Type -> Bool --- The type is a skolem tyvar -isSkolemTy tc_lvl ty - | Just tv <- getTyVar_maybe ty - = isSkolemTyVar tv - || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv) - -- The last case is for touchable TyVarTvs - -- we postpone untouchables to a latter test (too obscure) - - | otherwise - = False - -isTyFun_maybe :: Type -> Maybe TyCon -isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of - Just (tc,_) | isTypeFamilyTyCon tc -> Just tc - _ -> Nothing - --------------------------------------------- --- Reporters --------------------------------------------- - -type Reporter - = ReportErrCtxt -> [Ct] -> TcM () -type ReporterSpec - = ( String -- Name - , Ct -> Pred -> Bool -- Pick these ones - , Bool -- True <=> suppress subsequent reporters - , Reporter) -- The reporter itself - -mkSkolReporter :: Reporter --- Suppress duplicates with either the same LHS, or same location -mkSkolReporter ctxt cts - = mapM_ (reportGroup mkEqErr ctxt) (group cts) - where - group [] = [] - group (ct:cts) = (ct : yeses) : group noes - where - (yeses, noes) = partition (group_with ct) cts - - group_with ct1 ct2 - | EQ <- cmp_loc ct1 ct2 = True - | eq_lhs_type ct1 ct2 = True - | otherwise = False - -mkHoleReporter :: [Ct] -> Reporter --- Reports errors one at a time -mkHoleReporter tidy_simples ctxt - = mapM_ $ \ct -> do { err <- mkHoleError tidy_simples ctxt ct - ; maybeReportHoleError ctxt ct err - ; maybeAddDeferredHoleBinding ctxt err ct } - -mkUserTypeErrorReporter :: Reporter -mkUserTypeErrorReporter ctxt - = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct - ; maybeReportError ctxt err - ; addDeferredBinding ctxt err ct } - -mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg -mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct - $ important - $ pprUserTypeErrorTy - $ case getUserTypeErrorMsg ct of - Just msg -> msg - Nothing -> pprPanic "mkUserTypeError" (ppr ct) - - -mkGivenErrorReporter :: Reporter --- See Note [Given errors] -mkGivenErrorReporter ctxt cts - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; dflags <- getDynFlags - ; let (implic:_) = cec_encl ctxt - -- Always non-empty when mkGivenErrorReporter is called - ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic)) - -- For given constraints we overwrite the env (and hence src-loc) - -- with one from the immediately-enclosing implication. - -- See Note [Inaccessible code] - - inaccessible_msg = hang (text "Inaccessible code in") - 2 (ppr (ic_info implic)) - report = important inaccessible_msg `mappend` - relevant_bindings binds_msg - - ; err <- mkEqErr_help dflags ctxt report ct' - Nothing ty1 ty2 - - ; traceTc "mkGivenErrorReporter" (ppr ct) - ; reportWarning (Reason Opt_WarnInaccessibleCode) err } - where - (ct : _ ) = cts -- Never empty - (ty1, ty2) = getEqPredTys (ctPred ct) - -ignoreErrorReporter :: Reporter --- Discard Given errors that don't come from --- a pattern match; maybe we should warn instead? -ignoreErrorReporter ctxt cts - = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt)) - ; return () } - - -{- Note [Given errors] -~~~~~~~~~~~~~~~~~~~~~~ -Given constraints represent things for which we have (or will have) -evidence, so they aren't errors. But if a Given constraint is -insoluble, this code is inaccessible, and we might want to at least -warn about that. A classic case is - - data T a where - T1 :: T Int - T2 :: T a - T3 :: T Bool - - f :: T Int -> Bool - f T1 = ... - f T2 = ... - f T3 = ... -- We want to report this case as inaccessible - -We'd like to point out that the T3 match is inaccessible. It -will have a Given constraint [G] Int ~ Bool. - -But we don't want to report ALL insoluble Given constraints. See Trac -#12466 for a long discussion. For example, if we aren't careful -we'll complain about - f :: ((Int ~ Bool) => a -> a) -> Int -which arguably is OK. It's more debatable for - g :: (Int ~ Bool) => Int -> Int -but it's tricky to distinguish these cases so we don't report -either. - -The bottom line is this: has_gadt_match looks for an enclosing -pattern match which binds some equality constraints. If we -find one, we report the insoluble Given. --} - -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) - -- 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 cts - = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) - --- Like mkGroupReporter, but doesn't actually print error messages -mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter -mkSuppressReporter mk_err ctxt cts - = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) - -eq_lhs_type :: Ct -> Ct -> Bool -eq_lhs_type ct1 ct2 - = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of - (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) -> - (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2) - _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2) - -cmp_loc :: Ct -> Ct -> Ordering -cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2) - -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter -reportGroup mk_err ctxt cts = - ASSERT( not (null cts)) - do { err <- mk_err ctxt cts - ; traceTc "About to maybeReportErr" $ - vcat [ text "Constraint:" <+> ppr cts - , text "cec_suppress =" <+> ppr (cec_suppress ctxt) - , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ] - ; maybeReportError ctxt err - -- But see Note [Always warn with -fdefer-type-errors] - ; traceTc "reportGroup" (ppr cts) - ; mapM_ (addDeferredBinding ctxt err) cts } - -- Add deferred bindings for all - -- Redundant if we are going to abort compilation, - -- but that's hard to know for sure, and if we don't - -- abort, we need bindings for all (e.g. #12156) - --- like reportGroup, but does not actually report messages. It still adds --- -fdefer-type-errors bindings, though. -suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter -suppressGroup mk_err ctxt cts - = do { err <- mk_err ctxt cts - ; traceTc "Suppressing errors for" (ppr cts) - ; mapM_ (addDeferredBinding ctxt err) cts } - -maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM () --- Unlike maybeReportError, these "hole" errors are --- /not/ suppressed by cec_suppress. We want to see them! -maybeReportHoleError ctxt ct err - -- When -XPartialTypeSignatures is on, warnings (instead of errors) are - -- generated for holes in partial type signatures. - -- Unless -fwarn-partial-type-signatures is not on, - -- in which case the messages are discarded. - | isTypeHoleCt ct - = -- For partial type signatures, generate warnings only, and do that - -- only if -fwarn-partial-type-signatures is on - case cec_type_holes ctxt of - HoleError -> reportError err - HoleWarn -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err - HoleDefer -> return () - - -- Always report an error for out-of-scope variables - -- Unless -fdefer-out-of-scope-variables is on, - -- in which case the messages are discarded. - -- See #12170, #12406 - | isOutOfScopeCt ct - = -- If deferring, report a warning only if -Wout-of-scope-variables is on - case cec_out_of_scope_holes ctxt of - HoleError -> reportError err - HoleWarn -> - reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err - HoleDefer -> return () - - -- Otherwise this is a typed hole in an expression, - -- but not for an out-of-scope variable - | otherwise - = -- If deferring, report a warning only if -Wtyped-holes is on - case cec_expr_holes ctxt of - HoleError -> reportError err - HoleWarn -> reportWarning (Reason Opt_WarnTypedHoles) err - HoleDefer -> return () - -maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM () --- Report the error and/or make a deferred binding for it -maybeReportError ctxt err - | cec_suppress ctxt -- Some worse error has occurred; - = return () -- so suppress this error/warning - - | otherwise - = case cec_defer_type_errors ctxt of - TypeDefer -> return () - TypeWarn reason -> reportWarning reason err - TypeError -> reportError err - -addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () --- See Note [Deferring coercion errors to runtime] -addDeferredBinding ctxt err ct - | deferringAnyBindings ctxt - , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct - -- Only add deferred bindings for Wanted constraints - = do { dflags <- getDynFlags - ; let err_msg = pprLocErrMsg err - err_fs = mkFastString $ showSDoc dflags $ - err_msg $$ text "(deferred type error)" - err_tm = evDelayedError pred err_fs - ev_binds_var = cec_binds ctxt - - ; case dest of - EvVarDest evar - -> addTcEvBind ev_binds_var $ mkWantedEvBind evar 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 - ; fillCoercionHole hole (mkTcCoVarCo co_var) }} - - | otherwise -- Do not set any evidence for Given/Derived - = return () - -maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () -maybeAddDeferredHoleBinding ctxt err ct - | isExprHoleCt ct - = addDeferredBinding ctxt err ct -- Only add bindings for holes in expressions - | otherwise -- not for holes in partial type signatures - = return () - -tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) --- Use the first reporter in the list whose predicate says True -tryReporters ctxt reporters cts - = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts - ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts) - ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts - ; traceTc "tryReporters }" (ppr cts') - ; return (ctxt', cts') } - where - go ctxt [] vis_cts invis_cts - = return (ctxt, vis_cts ++ invis_cts) - - go ctxt (r : rs) vis_cts invis_cts - -- always look at *visible* Origins before invisible ones - -- this is the whole point of isVisibleOrigin - = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts - ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts - ; go ctxt'' rs vis_cts' invis_cts' } - -- Carry on with the rest, because we must make - -- deferred bindings for them if we have -fdefer-type-errors - -- But suppress their error messages - -tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct]) -tryReporter ctxt (str, keep_me, suppress_after, reporter) cts - | null yeses - = return (ctxt, cts) - | otherwise - = 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] - ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt } - ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after) - ; return (ctxt', nos) } - where - (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts - - -pprArising :: CtOrigin -> SDoc --- Used for the main, top-level error message --- We've done special processing for TypeEq, KindEq, Given -pprArising (TypeEqOrigin {}) = empty -pprArising (KindEqOrigin {}) = empty -pprArising (GivenOrigin {}) = empty -pprArising orig = pprCtOrigin orig - --- Add the "arising from..." part to a message about bunch of dicts -addArising :: CtOrigin -> SDoc -> SDoc -addArising orig msg = hang msg 2 (pprArising orig) - -pprWithArising :: [Ct] -> (CtLoc, SDoc) --- Print something like --- (Eq a) arising from a use of x at y --- (Show a) arising from a use of p at q --- Also return a location for the error message --- Works for Wanted/Derived only -pprWithArising [] - = panic "pprWithArising" -pprWithArising (ct:cts) - | null cts - = (loc, addArising (ctLocOrigin loc) - (pprTheta [ctPred ct])) - | otherwise - = (loc, vcat (map ppr_one (ct:cts))) - where - loc = ctLoc ct - ppr_one ct' = hang (parens (pprType (ctPred ct'))) - 2 (pprCtLoc (ctLoc ct')) - -mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg -mkErrorMsgFromCt ctxt ct report - = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report - -mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg -mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs) - = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) - ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing) - (errDoc important [context] (relevant_bindings ++ valid_subs)) - } - -type UserGiven = Implication - -getUserGivens :: ReportErrCtxt -> [UserGiven] --- One item for each enclosing implication -getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics - -getUserGivensFromImplics :: [Implication] -> [UserGiven] -getUserGivensFromImplics implics - = reverse (filterOut (null . ic_given) implics) - -{- Note [Always warn with -fdefer-type-errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When -fdefer-type-errors is on we warn about *all* type errors, even -if cec_suppress is on. This can lead to a lot more warnings than you -would get errors without -fdefer-type-errors, but if we suppress any of -them you might get a runtime error that wasn't warned about at compile -time. - -This is an easy design choice to change; just flip the order of the -first two equations for maybeReportError - -To be consistent, we should also report multiple warnings from a single -location in mkGroupReporter, when -fdefer-type-errors is on. But that -is perhaps a bit *over*-consistent! Again, an easy choice to change. - -With #10283, you can now opt out of deferred type error warnings. - -Note [Deferred errors for coercion holes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we need to defer a type error where the destination for the evidence -is a coercion hole. We can't just put the error in the hole, because we can't -make an erroneous coercion. (Remember that coercions are erased for runtime.) -Instead, we invent a new EvVar, bind it to an error and then make a coercion -from that EvVar, filling the hole with that coercion. Because coercions' -types are unlifted, the error is guaranteed to be hit before we get to the -coercion. - -Note [Do not report derived but soluble errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wc_simples include Derived constraints that have not been solved, -but are not insoluble (in that case they'd be reported by 'report1'). -We do not want to report these as errors: - -* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have - an unsolved [D] Eq a, and we do not want to report that; it's just noise. - -* Functional dependencies. For givens, consider - class C a b | a -> b - data T a where - MkT :: C a d => [d] -> T a - f :: C a b => T a -> F Int - f (MkT xs) = length xs - Then we get a [D] b~d. But there *is* a legitimate call to - f, namely f (MkT [True]) :: T Bool, in which b=d. So we should - not reject the program. - - For wanteds, something similar - data T a where - MkT :: C Int b => a -> b -> T a - g :: C Int c => c -> () - f :: T a -> () - f (MkT x y) = g x - Here we get [G] C Int b, [W] C Int a, hence [D] a~b. - But again f (MkT True True) is a legitimate call. - -(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose -derived superclasses between iterations of the solver.) - -For functional dependencies, here is a real example, -stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs - - class C a b | a -> b - g :: C a b => a -> b -> () - f :: C a b => a -> b -> () - f xa xb = - let loop = g xa - in loop xb - -We will first try to infer a type for loop, and we will succeed: - C a b' => b' -> () -Subsequently, we will type check (loop xb) and all is good. But, -recall that we have to solve a final implication constraint: - C a b => (C a b' => .... cts from body of loop .... )) -And now we have a problem as we will generate an equality b ~ b' and fail to -solve it. - - -************************************************************************ -* * - Irreducible predicate errors -* * -************************************************************************ --} - -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkIrredErr ctxt cts - = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let orig = ctOrigin ct1 - msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig) - ; mkErrorMsgFromCt ctxt ct1 $ - important msg `mappend` relevant_bindings binds_msg } - where - (ct1:_) = cts - ----------------- -mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg -mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort }) - | isOutOfScopeCt ct -- Out of scope variables, like 'a', where 'a' isn't bound - -- Suggest possible in-scope variables in the message - = do { dflags <- getDynFlags - ; rdr_env <- getGlobalRdrEnv - ; imp_info <- getImports - ; curr_mod <- getModule - ; hpt <- getHpt - ; mkErrDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing) $ - errDoc [out_of_scope_msg] [] - [unknownNameSuggestions dflags hpt curr_mod rdr_env - (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)] } - - | otherwise -- Explicit holes, like "_" or "_f" - = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct - -- The 'False' means "don't filter the bindings"; see Trac #8191 - - ; show_hole_constraints <- goptM Opt_ShowHoleConstraints - ; let constraints_msg - | isExprHoleCt ct, show_hole_constraints - = givenConstraintsMsg ctxt - | otherwise - = empty - - ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits - ; (ctxt, sub_msg) <- if show_valid_hole_fits - then validHoleFits ctxt tidy_simples ct - else return (ctxt, empty) - - ; mkErrorMsgFromCt ctxt ct $ - important hole_msg `mappend` - relevant_bindings (binds_msg $$ constraints_msg) `mappend` - valid_hole_fits sub_msg } - - where - ct_loc = ctLoc ct - lcl_env = ctLocEnv ct_loc - hole_ty = ctEvPred (ctEvidence ct) - hole_kind = tcTypeKind hole_ty - tyvars = tyCoVarsOfTypeList hole_ty - boring_type = isTyVarTy hole_ty - - out_of_scope_msg -- Print v :: ty only if the type has structure - | boring_type = hang herald 2 (ppr occ) - | otherwise = hang herald 2 pp_with_type - - pp_with_type = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) - herald | isDataOcc occ = text "Data constructor not in scope:" - | otherwise = text "Variable not in scope:" - - hole_msg = case hole_sort of - ExprHole -> vcat [ hang (text "Found hole:") - 2 pp_with_type - , tyvars_msg, expr_hole_hint ] - TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ)) - 2 (text "standing for" <+> quotes pp_hole_type_with_kind) - , tyvars_msg, type_hole_hint ] - - pp_hole_type_with_kind - | isLiftedTypeKind hole_kind - || isCoVarType hole_ty -- Don't print the kind of unlifted - -- equalities (#15039) - = pprType hole_ty - | otherwise - = pprType hole_ty <+> dcolon <+> pprKind hole_kind - - tyvars_msg = ppUnless (null tyvars) $ - text "Where:" <+> (vcat (map loc_msg other_tvs) - $$ pprSkols ctxt skol_tvs) - where - (skol_tvs, other_tvs) = partition is_skol tyvars - is_skol tv = isTcTyVar tv && isSkolemTyVar tv - -- Coercion variables can be free in the - -- hole, via kind casts - - type_hole_hint - | HoleError <- cec_type_holes ctxt - = text "To use the inferred type, enable PartialTypeSignatures" - | otherwise - = empty - - expr_hole_hint -- Give hint for, say, f x = _x - | lengthFS (occNameFS occ) > 1 -- Don't give this hint for plain "_" - = text "Or perhaps" <+> quotes (ppr occ) - <+> text "is mis-spelled, or not in scope" - | otherwise - = empty - - loc_msg tv - | isTyVar tv - = case tcTyVarDetails tv of - MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" - _ -> empty -- Skolems dealt with already - | otherwise -- A coercion variable can be free in the hole type - = ppWhenOption sdocPrintExplicitCoercions $ - quotes (ppr tv) <+> text "is a coercion variable" - -mkHoleError _ _ ct = pprPanic "mkHoleError" (ppr ct) - --- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module --- imports -validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the - -- implications and the tidy environment - -> [Ct] -- Unsolved simple constraints - -> Ct -- The hole constraint. - -> TcM (ReportErrCtxt, SDoc) -- We return the new context - -- with a possibly updated - -- tidy environment, and - -- the message. -validHoleFits ctxt@(CEC {cec_encl = implics - , cec_tidy = lcl_env}) simps ct - = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps ct - ; return (ctxt {cec_tidy = tidy_env}, msg) } - --- See Note [Constraints include ...] -givenConstraintsMsg :: ReportErrCtxt -> SDoc -givenConstraintsMsg ctxt = - let constraints :: [(Type, RealSrcSpan)] - constraints = - do { implic@Implic{ ic_given = given } <- cec_encl ctxt - ; constraint <- given - ; return (varType constraint, tcl_loc (ic_env implic)) } - - pprConstraint (constraint, loc) = - ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) - - in ppUnless (null constraints) $ - hang (text "Constraints include") - 2 (vcat $ map pprConstraint constraints) - ----------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkIPErr ctxt cts - = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let orig = ctOrigin ct1 - preds = map ctPred cts - givens = getUserGivens ctxt - msg | null givens - = addArising orig $ - sep [ text "Unbound implicit parameter" <> plural cts - , nest 2 (pprParendTheta preds) ] - | otherwise - = couldNotDeduce givens (preds, orig) - - ; mkErrorMsgFromCt ctxt ct1 $ - important msg `mappend` relevant_bindings binds_msg } - where - (ct1:_) = cts - -{- -Note [Constraints include ...] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'givenConstraintsMsg' returns the "Constraints include ..." message enabled by --fshow-hole-constraints. For example, the following hole: - - foo :: (Eq a, Show a) => a -> String - foo x = _ - -would generate the message: - - Constraints include - Eq a (from foo.hs:1:1-36) - Show a (from foo.hs:1:1-36) - -Constraints are displayed in order from innermost (closest to the hole) to -outermost. There's currently no filtering or elimination of duplicates. - -************************************************************************ -* * - Equality errors -* * -************************************************************************ - -Note [Inaccessible code] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a where - T1 :: T a - T2 :: T Bool - - f :: (a ~ Int) => T a -> Int - f T1 = 3 - f T2 = 4 -- Unreachable code - -Here the second equation is unreachable. The original constraint -(a~Int) from the signature gets rewritten by the pattern-match to -(Bool~Int), so the danger is that we report the error as coming from -the *signature* (#7293). So, for Given errors we replace the -env (and hence src-loc) on its CtLoc with that from the immediately -enclosing implication. - -Note [Error messages for untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#9109) - data G a where { GBool :: G Bool } - foo x = case x of GBool -> True - -Here we can't solve (t ~ Bool), where t is the untouchable result -meta-var 't', because of the (a ~ Bool) from the pattern match. -So we infer the type - f :: forall a t. G a -> t -making the meta-var 't' into a skolem. So when we come to report -the unsolved (t ~ Bool), t won't look like an untouchable meta-var -any more. So we don't assert that it is. --} - --- Don't have multiple equality errors from the same location --- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct -mkEqErr _ [] = panic "mkEqErr" - -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg -mkEqErr1 ctxt ct -- Wanted or derived; - -- givens handled in mkGivenErrorReporter - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; rdr_env <- getGlobalRdrEnv - ; fam_envs <- tcGetFamInstEnvs - ; exp_syns <- goptM Opt_PrintExpandedSynonyms - ; let (keep_going, is_oriented, wanted_msg) - = mk_wanted_extra (ctLoc ct) exp_syns - coercible_msg = case ctEqRel ct of - NomEq -> empty - ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 - ; dflags <- getDynFlags - ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct) $$ ppr keep_going) - ; let report = mconcat [important wanted_msg, important coercible_msg, - relevant_bindings binds_msg] - ; if keep_going - then mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2 - else mkErrorMsgFromCt ctxt ct report } - where - (ty1, ty2) = getEqPredTys (ctPred ct) - - -- If the types in the error message are the same as the types - -- we are unifying, don't add the extra expected/actual message - mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc) - mk_wanted_extra loc expandSyns - = case ctLocOrigin loc of - orig@TypeEqOrigin {} -> mkExpectedActualMsg ty1 ty2 orig - t_or_k expandSyns - where - t_or_k = ctLocTypeOrKind_maybe loc - - KindEqOrigin cty1 mb_cty2 sub_o sub_t_or_k - -> (True, Nothing, msg1 $$ msg2) - where - sub_what = case sub_t_or_k of Just KindLevel -> text "kinds" - _ -> text "types" - msg1 = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> - case mb_cty2 of - Just cty2 - | printExplicitCoercions - || not (cty1 `pickyEqType` cty2) - -> hang (text "When matching" <+> sub_what) - 2 (vcat [ ppr cty1 <+> dcolon <+> - ppr (tcTypeKind cty1) - , ppr cty2 <+> dcolon <+> - ppr (tcTypeKind cty2) ]) - _ -> text "When matching the kind of" <+> quotes (ppr cty1) - msg2 = case sub_o of - TypeEqOrigin {} - | Just cty2 <- mb_cty2 -> - thdOf3 (mkExpectedActualMsg cty1 cty2 sub_o sub_t_or_k - expandSyns) - _ -> empty - _ -> (True, Nothing, empty) - --- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint --- is left over. -mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs - -> TcType -> TcType -> SDoc -mkCoercibleExplanation rdr_env fam_envs ty1 ty2 - | Just (tc, tys) <- tcSplitTyConApp_maybe ty1 - , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys - , Just msg <- coercible_msg_for_tycon rep_tc - = msg - | Just (tc, tys) <- splitTyConApp_maybe ty2 - , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys - , Just msg <- coercible_msg_for_tycon rep_tc - = msg - | Just (s1, _) <- tcSplitAppTy_maybe ty1 - , Just (s2, _) <- tcSplitAppTy_maybe ty2 - , s1 `eqType` s2 - , has_unknown_roles s1 - = hang (text "NB: We cannot know what roles the parameters to" <+> - quotes (ppr s1) <+> text "have;") - 2 (text "we must assume that the role is nominal") - | otherwise - = empty - where - coercible_msg_for_tycon tc - | isAbstractTyCon tc - = Just $ hsep [ text "NB: The type constructor" - , quotes (pprSourceTyCon tc) - , text "is abstract" ] - | isNewTyCon tc - , [data_con] <- tyConDataCons tc - , let dc_name = dataConName data_con - , isNothing (lookupGRE_Name rdr_env dc_name) - = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name)) - 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) - , text "is not in scope" ]) - | otherwise = Nothing - - has_unknown_roles ty - | Just (tc, tys) <- tcSplitTyConApp_maybe ty - = tys `lengthAtLeast` tyConArity tc -- oversaturated tycon - | Just (s, _) <- tcSplitAppTy_maybe ty - = has_unknown_roles s - | isTyVarTy ty - = True - | otherwise - = False - -{- --- | Make a listing of role signatures for all the parameterised tycons --- used in the provided types - - --- SLPJ Jun 15: I could not convince myself that these hints were really --- useful. Maybe they are, but I think we need more work to make them --- actually helpful. -mkRoleSigs :: Type -> Type -> SDoc -mkRoleSigs ty1 ty2 - = ppUnless (null role_sigs) $ - hang (text "Relevant role signatures:") - 2 (vcat role_sigs) - where - tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2 - role_sigs = mapMaybe ppr_role_sig tcs - - ppr_role_sig tc - | null roles -- if there are no parameters, don't bother printing - = Nothing - | isBuiltInSyntax (tyConName tc) -- don't print roles for (->), etc. - = Nothing - | otherwise - = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles - where - roles = tyConRoles tc --} - -mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report - -> Ct - -> Maybe SwapFlag -- Nothing <=> not sure - -> TcType -> TcType -> TcM ErrMsg -mkEqErr_help dflags ctxt report ct oriented ty1 ty2 - | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 - = mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 - | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2 - = mkTyVarEqErr dflags ctxt report ct swapped tv2 ty1 - | otherwise - = reportEqErr ctxt report ct oriented ty1 ty2 - where - swapped = fmap flipSwap oriented - -reportEqErr :: ReportErrCtxt -> Report - -> Ct - -> Maybe SwapFlag -- Nothing <=> not sure - -> TcType -> TcType -> TcM ErrMsg -reportEqErr ctxt report ct oriented ty1 ty2 - = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo]) - where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2 - eqInfo = important $ mkEqInfoMsg ct ty1 ty2 - -mkTyVarEqErr, mkTyVarEqErr' - :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg --- tv1 and ty2 are already tidied -mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 - = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) - ; mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2 } - -mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2 - | not insoluble_occurs_check -- See Note [Occurs check wins] - , isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would - -- be oriented the other way round; - -- see TcCanonical.canEqTyVarTyVar - || isTyVarTyVar tv1 && not (isTyVarTy ty2) - || ctEqRel ct == ReprEq - -- the cases below don't really apply to ReprEq (except occurs check) - = mkErrorMsgFromCt ctxt ct $ mconcat - [ important $ misMatchOrCND ctxt ct oriented ty1 ty2 - , important $ extraTyVarEqInfo ctxt tv1 ty2 - , report - ] - - | MTVU_Occurs <- occ_check_expand - -- 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 - -- See Note [Occurs check error] in TcCanonical - = do { let main_msg = addArising (ctOrigin ct) $ - hang (text "Occurs check: cannot construct the infinite" <+> what <> colon) - 2 (sep [ppr ty1, char '~', ppr ty2]) - - extra2 = important $ mkEqInfoMsg ct ty1 ty2 - - interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ - filter isTyVar $ - fvVarList $ - tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 - extra3 = relevant_bindings $ - ppWhen (not (null interesting_tyvars)) $ - hang (text "Type variable kinds:") 2 $ - vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) - interesting_tyvars) - - tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) - ; mkErrorMsgFromCt ctxt ct $ - mconcat [important main_msg, extra2, extra3, report] } - - | MTVU_Bad <- occ_check_expand - = do { let msg = vcat [ text "Cannot instantiate unification variable" - <+> quotes (ppr tv1) - , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) - , nest 2 (text "GHC doesn't yet support impredicative polymorphism") ] - -- Unlike the other reports, this discards the old 'report_important' - -- instead of augmenting it. This is because the details are not likely - -- to be helpful since this is just an unimplemented feature. - ; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } } - - -- 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 - -- that there's no occurs-check or forall problem - | (implic:_) <- cec_encl ctxt - , Implic { ic_skols = skols } <- implic - , tv1 `elem` skols - = mkErrorMsgFromCt ctxt ct $ mconcat - [ important $ misMatchMsg ct oriented ty1 ty2 - , important $ extraTyVarEqInfo ctxt tv1 ty2 - , report - ] - - -- Check for skolem escape - | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_skols = skols, ic_info = skol_info } <- implic - , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols - , not (null esc_skols) - = do { let msg = important $ misMatchMsg ct oriented ty1 ty2 - esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols - <+> pprQuotedList esc_skols - , text "would escape" <+> - if isSingleton esc_skols then text "its scope" - else text "their scope" ] - tv_extra = important $ - vcat [ nest 2 $ esc_doc - , sep [ (if isSingleton esc_skols - then text "This (rigid, skolem)" <+> - what <+> text "variable is" - else text "These (rigid, skolem)" <+> - what <+> text "variables are") - <+> text "bound by" - , nest 2 $ ppr skol_info - , nest 2 $ text "at" <+> - ppr (tcl_loc (ic_env implic)) ] ] - ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) } - - -- Nastiest case: attempt to unify an untouchable variable - -- So tv is a meta tyvar (or started that way before we - -- generalised it). So presumably it is an *untouchable* - -- meta tyvar or a TyVarTv, else it'd have been unified - -- See Note [Error messages for untouchables] - | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic - = ASSERT2( not (isTouchableMetaTyVar lvl tv1) - , ppr tv1 $$ ppr lvl ) -- See Note [Error messages for untouchables] - do { let msg = important $ misMatchMsg ct oriented ty1 ty2 - tclvl_extra = important $ - nest 2 $ - sep [ quotes (ppr tv1) <+> text "is untouchable" - , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given - , nest 2 $ text "bound by" <+> ppr skol_info - , nest 2 $ text "at" <+> - ppr (tcl_loc (ic_env implic)) ] - tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2 - add_sig = important $ suggestAddSig ctxt ty1 ty2 - ; mkErrorMsgFromCt ctxt ct $ mconcat - [msg, tclvl_extra, tv_extra, add_sig, report] } - - | otherwise - = reportEqErr ctxt report ct oriented (mkTyVarTy tv1) ty2 - -- This *can* happen (#6123, and test T2627b) - -- Consider an ambiguous top-level constraint (a ~ F a) - -- Not an occurs check, because F is a type function. - where - ty1 = mkTyVarTy tv1 - occ_check_expand = occCheckForErrors dflags tv1 ty2 - insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2 - - what = case ctLocTypeOrKind_maybe (ctLoc ct) of - Just KindLevel -> text "kind" - _ -> text "type" - -mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc --- Report (a) ambiguity if either side is a type function application --- e.g. F a0 ~ Int --- (b) warning about injectivity if both sides are the same --- type function application F a ~ F b --- See Note [Non-injective type functions] -mkEqInfoMsg ct ty1 ty2 - = tyfun_msg $$ ambig_msg - where - mb_fun1 = isTyFun_maybe ty1 - mb_fun2 = isTyFun_maybe ty2 - - ambig_msg | isJust mb_fun1 || isJust mb_fun2 - = snd (mkAmbigMsg False ct) - | otherwise = empty - - tyfun_msg | Just tc1 <- mb_fun1 - , Just tc2 <- mb_fun2 - , tc1 == tc2 - , not (isInjectiveTyCon tc1 Nominal) - = text "NB:" <+> quotes (ppr tc1) - <+> text "is a non-injective type family" - | otherwise = empty - -isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool --- See Note [Reporting occurs-check errors] -isUserSkolem ctxt tv - = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt) - where - is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info }) - = tv `elem` sks && is_user_skol_info skol_info - - is_user_skol_info (InferSkol {}) = False - is_user_skol_info _ = True - -misMatchOrCND :: ReportErrCtxt -> Ct - -> Maybe SwapFlag -> TcType -> TcType -> SDoc --- If oriented then ty1 is actual, ty2 is expected -misMatchOrCND ctxt ct oriented ty1 ty2 - | null givens || - (isRigidTy ty1 && isRigidTy ty2) || - isGivenCt ct - -- If the equality is unconditionally insoluble - -- or there is no context, don't report the context - = misMatchMsg ct oriented ty1 ty2 - | otherwise - = couldNotDeduce givens ([eq_pred], orig) - where - ev = ctEvidence ct - eq_pred = ctEvPred ev - orig = ctEvOrigin ev - givens = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)] - -- Keep only UserGivens that have some equalities. - -- See Note [Suppress redundant givens during error reporting] - -couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc -couldNotDeduce givens (wanteds, orig) - = vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds) - , vcat (pp_givens givens)] - -pp_givens :: [UserGiven] -> [SDoc] -pp_givens givens - = case givens of - [] -> [] - (g:gs) -> ppr_given (text "from the context:") g - : map (ppr_given (text "or from:")) gs - where - ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info }) - = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs)) - -- See Note [Suppress redundant givens during error reporting] - -- for why we use mkMinimalBySCs above. - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> ppr (tcl_loc (ic_env implic)) ]) - --- These are for the "blocked" equalities, as described in TcCanonical --- Note [Equalities with incompatible kinds], wrinkle (2). 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. -mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report - where - report = important msg - msg = vcat [ hang (text "Cannot use equality for substitution:") - 2 (ppr (ctPred ct)) - , text "Doing so would be ill-kinded." ] - -- This is a terrible message. Perhaps worse, if the user - -- has -fprint-explicit-kinds on, they will see that the two - -- sides have the same kind, as there is an invisible cast. - -- I really don't know how to do better. -mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints" - -{- -Note [Suppress redundant givens during error reporting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When GHC is unable to solve a constraint and prints out an error message, it -will print out what given constraints are in scope to provide some context to -the programmer. But we shouldn't print out /every/ given, since some of them -are not terribly helpful to diagnose type errors. Consider this example: - - foo :: Int :~: Int -> a :~: b -> a :~: c - foo Refl Refl = Refl - -When reporting that GHC can't solve (a ~ c), there are two givens in scope: -(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e., -redundant), so it's not terribly useful to report it in an error message. -To accomplish this, we discard any Implications that do not bind any -equalities by filtering the `givens` selected in `misMatchOrCND` (based on -the `ic_no_eqs` field of the Implication). - -But this is not enough to avoid all redundant givens! Consider this example, -from #15361: - - goo :: forall (a :: Type) (b :: Type) (c :: Type). - a :~~: b -> a :~~: c - goo HRefl = HRefl - -Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope. -The (* ~ *) part arises due the kinds of (:~~:) being unified. More -importantly, (* ~ *) is redundant, so we'd like not to report it. However, -the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its -ic_no_eqs field), so the test above will keep it wholesale. - -To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b) -part. This works because mkMinimalBySCs eliminates reflexive equalities in -addition to superclasses (see Note [Remove redundant provided dicts] -in TcPatSyn). --} - -extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc --- Add on extra info about skolem constants --- NB: The types themselves are already tidied -extraTyVarEqInfo ctxt tv1 ty2 - = extraTyVarInfo ctxt tv1 $$ ty_extra ty2 - where - ty_extra ty = case tcGetCastedTyVar_maybe ty of - Just (tv, _) -> extraTyVarInfo ctxt tv - Nothing -> empty - -extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc -extraTyVarInfo ctxt tv - = ASSERT2( isTyVar tv, ppr tv ) - case tcTyVarDetails tv of - SkolemTv {} -> pprSkols ctxt [tv] - RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" - MetaTv {} -> empty - -suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc --- See Note [Suggest adding a type signature] -suggestAddSig ctxt ty1 ty2 - | null inferred_bndrs - = empty - | [bndr] <- inferred_bndrs - = text "Possible fix: add a type signature for" <+> quotes (ppr bndr) - | otherwise - = text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs) - where - inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2) - get_inf ty | Just tv <- tcGetTyVar_maybe ty - , isSkolemTyVar tv - , ((InferSkol prs, _) : _) <- getSkolemInfo (cec_encl ctxt) [tv] - = map fst prs - | otherwise - = [] - --------------------- -misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc --- Types are already tidy --- If oriented then ty1 is actual, ty2 is expected -misMatchMsg ct oriented ty1 ty2 - | Just NotSwapped <- oriented - = misMatchMsg ct (Just IsSwapped) ty2 ty1 - - -- These next two cases are when we're about to report, e.g., that - -- 'LiftedRep doesn't match 'VoidRep. Much better just to say - -- lifted vs. unlifted - | isLiftedRuntimeRep ty1 - = lifted_vs_unlifted - - | isLiftedRuntimeRep ty2 - = lifted_vs_unlifted - - | otherwise -- So now we have Nothing or (Just IsSwapped) - -- For some reason we treat Nothing like IsSwapped - = addArising orig $ - pprWithExplicitKindsWhenMismatch ty1 ty2 (ctOrigin ct) $ - sep [ text herald1 <+> quotes (ppr ty1) - , nest padding $ - text herald2 <+> quotes (ppr ty2) - , sameOccExtra ty2 ty1 ] - where - herald1 = conc [ "Couldn't match" - , if is_repr then "representation of" else "" - , if is_oriented then "expected" else "" - , what ] - herald2 = conc [ "with" - , if is_repr then "that of" else "" - , if is_oriented then ("actual " ++ what) else "" ] - padding = length herald1 - length herald2 - - is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False } - is_oriented = isJust oriented - - orig = ctOrigin ct - what = case ctLocTypeOrKind_maybe (ctLoc ct) of - Just KindLevel -> "kind" - _ -> "type" - - conc :: [String] -> String - conc = foldr1 add_space - - add_space :: String -> String -> String - add_space s1 s2 | null s1 = s2 - | null s2 = s1 - | otherwise = s1 ++ (' ' : s2) - - lifted_vs_unlifted - = addArising orig $ - text "Couldn't match a lifted type with an unlifted type" - --- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a --- type mismatch occurs to due invisible kind arguments. --- --- This function first checks to see if the 'CtOrigin' argument is a --- 'TypeEqOrigin', and if so, uses the expected/actual types from that to --- check for a kind mismatch (as these types typically have more surrounding --- types and are likelier to be able to glean information about whether a --- mismatch occurred in an invisible argument position or not). If the --- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types --- themselves. -pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin - -> SDoc -> SDoc -pprWithExplicitKindsWhenMismatch ty1 ty2 ct - = pprWithExplicitKindsWhen show_kinds - where - (act_ty, exp_ty) = case ct of - TypeEqOrigin { uo_actual = act - , uo_expected = exp } -> (act, exp) - _ -> (ty1, ty2) - show_kinds = tcEqTypeVis act_ty exp_ty - -- True when the visible bit of the types look the same, - -- so we want to show the kinds in the displayed type - -mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool - -> (Bool, Maybe SwapFlag, SDoc) --- NotSwapped means (actual, expected), IsSwapped is the reverse --- First return val is whether or not to print a herald above this msg -mkExpectedActualMsg ty1 ty2 ct@(TypeEqOrigin { uo_actual = act - , uo_expected = exp - , uo_thing = maybe_thing }) - m_level printExpanded - | KindLevel <- level, occurs_check_error = (True, Nothing, empty) - | isUnliftedTypeKind act, isLiftedTypeKind exp = (False, Nothing, msg2) - | isLiftedTypeKind act, isUnliftedTypeKind exp = (False, Nothing, msg3) - | tcIsLiftedTypeKind exp = (False, Nothing, msg4) - | Just msg <- num_args_msg = (False, Nothing, msg $$ msg1) - | KindLevel <- level, Just th <- maybe_thing = (False, Nothing, msg5 th) - | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (True, Just NotSwapped, empty) - | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (True, Just IsSwapped, empty) - | otherwise = (True, Nothing, msg1) - where - level = m_level `orElse` TypeLevel - - occurs_check_error - | Just tv <- tcGetTyVar_maybe ty1 - , tv `elemVarSet` tyCoVarsOfType ty2 - = True - | Just tv <- tcGetTyVar_maybe ty2 - , tv `elemVarSet` tyCoVarsOfType ty1 - = True - | otherwise - = False - - sort = case level of - TypeLevel -> text "type" - KindLevel -> text "kind" - - msg1 = case level of - KindLevel - | Just th <- maybe_thing - -> msg5 th - - _ | not (act `pickyEqType` exp) - -> pprWithExplicitKindsWhenMismatch ty1 ty2 ct $ - vcat [ text "Expected" <+> sort <> colon <+> ppr exp - , text " Actual" <+> sort <> colon <+> ppr act - , if printExpanded then expandedTys else empty ] - - | otherwise - -> empty - - thing_msg = case maybe_thing of - Just thing -> \_ levity -> - quotes thing <+> text "is" <+> levity - Nothing -> \vowel levity -> - text "got a" <> - (if vowel then char 'n' else empty) <+> - levity <+> - text "type" - msg2 = sep [ text "Expecting a lifted type, but" - , thing_msg True (text "unlifted") ] - msg3 = sep [ text "Expecting an unlifted type, but" - , thing_msg False (text "lifted") ] - msg4 = maybe_num_args_msg $$ - sep [ text "Expected a type, but" - , maybe (text "found something with kind") - (\thing -> quotes thing <+> text "has kind") - maybe_thing - , quotes (pprWithTYPE act) ] - - msg5 th = pprWithExplicitKindsWhenMismatch ty1 ty2 ct $ - hang (text "Expected" <+> kind_desc <> comma) - 2 (text "but" <+> quotes th <+> text "has kind" <+> - quotes (ppr act)) - where - kind_desc | tcIsConstraintKind exp = text "a constraint" - - -- TYPE t0 - | Just arg <- kindRep_maybe exp - , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case - True -> text "kind" <+> quotes (ppr exp) - False -> text "a type" - - | otherwise = text "kind" <+> quotes (ppr exp) - - num_args_msg = case level of - KindLevel - | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act) - -- if one is a meta-tyvar, then it's possible that the user - -- has asked for something impredicative, and we couldn't unify. - -- Don't bother with counting arguments. - -> let n_act = count_args act - n_exp = count_args exp in - case n_act - n_exp of - n | n > 0 -- we don't know how many args there are, so don't - -- recommend removing args that aren't - , Just thing <- maybe_thing - -> Just $ text "Expecting" <+> speakN (abs n) <+> - more <+> quotes thing - where - more - | n == 1 = text "more argument to" - | otherwise = text "more arguments to" -- n > 1 - _ -> Nothing - - _ -> Nothing - - maybe_num_args_msg = case num_args_msg of - Nothing -> empty - Just m -> m - - count_args ty = count isVisibleBinder $ fst $ splitPiTys ty - - expandedTys = - ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat - [ text "Type synonyms expanded:" - , text "Expected type:" <+> ppr expTy1 - , text " Actual type:" <+> ppr expTy2 - ] - - (expTy1, expTy2) = expandSynonymsToMatch exp act - -mkExpectedActualMsg _ _ _ _ _ = panic "mkExpectedAcutalMsg" - -{- Note [Insoluble occurs check wins] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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 - Cannot solve a ~ [a] from given constraints a ~ [a] - -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 (isInsolubleOccursCheck) -then report it first. - -(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't -want to be as draconian with them.) - -Note [Expanding type synonyms to make types similar] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In type error messages, if -fprint-expanded-types is used, we want to expand -type synonyms to make expected and found types as similar as possible, but we -shouldn't expand types too much to make type messages even more verbose and -harder to understand. The whole point here is to make the difference in expected -and found types clearer. - -`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms -only as much as necessary. Given two types t1 and t2: - - * If they're already same, it just returns the types. - - * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are - type constructors), it expands C1 and C2 if they're different type synonyms. - Then it recursively does the same thing on expanded types. If C1 and C2 are - same, then it applies the same procedure to arguments of C1 and arguments of - C2 to make them as similar as possible. - - Most important thing here is to keep number of synonym expansions at - minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, - Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and - `T (T3, T3, Bool)`. - - * Otherwise types don't have same shapes and so the difference is clearly - visible. It doesn't do any expansions and show these types. - -Note that we only expand top-layer type synonyms. Only when top-layer -constructors are the same we start expanding inner type synonyms. - -Suppose top-layer type synonyms of t1 and t2 can expand N and M times, -respectively. If their type-synonym-expanded forms will meet at some point (i.e. -will have same shapes according to `sameShapes` function), it's possible to find -where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) -comparisons. We first collect all the top-layer expansions of t1 and t2 in two -lists, then drop the prefix of the longer list so that they have same lengths. -Then we search through both lists in parallel, and return the first pair of -types that have same shapes. Inner types of these two types with same shapes -are then expanded using the same algorithm. - -In case they don't meet, we return the last pair of types in the lists, which -has top-layer type synonyms completely expanded. (in this case the inner types -are not expanded at all, as the current form already shows the type error) --} - --- | Expand type synonyms in given types only enough to make them as similar as --- possible. Returned types are the same in terms of used type synonyms. --- --- To expand all synonyms, see 'Type.expandTypeSynonyms'. --- --- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for --- some examples of how this should work. -expandSynonymsToMatch :: Type -> Type -> (Type, Type) -expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) - where - (ty1_ret, ty2_ret) = go ty1 ty2 - - -- | Returns (type synonym expanded version of first type, - -- type synonym expanded version of second type) - go :: Type -> Type -> (Type, Type) - go t1 t2 - | t1 `pickyEqType` t2 = - -- Types are same, nothing to do - (t1, t2) - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 = - -- Type constructors are same. They may be synonyms, but we don't - -- expand further. - let (tys1', tys2') = - unzip (zipWith (\ty1 ty2 -> go ty1 ty2) tys1 tys2) - in (TyConApp tc1 tys1', TyConApp tc2 tys2') - - go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') - - go ty1@(FunTy _ t1_1 t1_2) ty2@(FunTy _ t2_1 t2_2) = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in ( ty1 { ft_arg = t1_1', ft_res = t1_2' } - , ty2 { ft_arg = t2_1', ft_res = t2_2' }) - - go (ForAllTy b1 t1) (ForAllTy b2 t2) = - -- NOTE: We may have a bug here, but we just can't reproduce it easily. - -- See D1016 comments for details and our attempts at producing a test - -- case. Short version: We probably need RnEnv2 to really get this right. - let (t1', t2') = go t1 t2 - in (ForAllTy b1 t1', ForAllTy b2 t2') - - go (CastTy ty1 _) ty2 = go ty1 ty2 - go ty1 (CastTy ty2 _) = go ty1 ty2 - - go t1 t2 = - -- See Note [Expanding type synonyms to make types similar] for how this - -- works - let - t1_exp_tys = t1 : tyExpansions t1 - t2_exp_tys = t2 : tyExpansions t2 - t1_exps = length t1_exp_tys - t2_exps = length t2_exp_tys - dif = abs (t1_exps - t2_exps) - in - followExpansions $ - zipEqual "expandSynonymsToMatch.go" - (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys) - (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys) - - -- | Expand the top layer type synonyms repeatedly, collect expansions in a - -- list. The list does not include the original type. - -- - -- Example, if you have: - -- - -- type T10 = T9 - -- type T9 = T8 - -- ... - -- type T0 = Int - -- - -- `tyExpansions T10` returns [T9, T8, T7, ... Int] - -- - -- This only expands the top layer, so if you have: - -- - -- type M a = Maybe a - -- - -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) - tyExpansions :: Type -> [Type] - tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t) - - -- | Drop the type pairs until types in a pair look alike (i.e. the outer - -- constructors are the same). - followExpansions :: [(Type, Type)] -> (Type, Type) - followExpansions [] = pprPanic "followExpansions" empty - followExpansions [(t1, t2)] - | sameShapes t1 t2 = go t1 t2 -- expand subtrees - | otherwise = (t1, t2) -- the difference is already visible - followExpansions ((t1, t2) : tss) - -- Traverse subtrees when the outer shapes are the same - | sameShapes t1 t2 = go t1 t2 - -- Otherwise follow the expansions until they look alike - | otherwise = followExpansions tss - - sameShapes :: Type -> Type -> Bool - sameShapes AppTy{} AppTy{} = True - sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 - sameShapes (FunTy {}) (FunTy {}) = True - sameShapes (ForAllTy {}) (ForAllTy {}) = True - sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 - sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 - sameShapes _ _ = False - -sameOccExtra :: TcType -> TcType -> SDoc --- See Note [Disambiguating (X ~ X) errors] -sameOccExtra ty1 ty2 - | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 - , Just (tc2, _) <- tcSplitTyConApp_maybe ty2 - , let n1 = tyConName tc1 - n2 = tyConName tc2 - same_occ = nameOccName n1 == nameOccName n2 - same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2) - , n1 /= n2 -- Different Names - , same_occ -- but same OccName - = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) - | otherwise - = empty - where - ppr_from same_pkg nm - | isGoodSrcSpan loc - = hang (quotes (ppr nm) <+> text "is defined at") - 2 (ppr loc) - | otherwise -- Imported things have an UnhelpfulSrcSpan - = hang (quotes (ppr nm)) - 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) - , ppUnless (same_pkg || pkg == mainUnitId) $ - nest 4 $ text "in package" <+> quotes (ppr pkg) ]) - where - pkg = moduleUnitId mod - mod = nameModule nm - loc = nameSrcSpan nm - -{- -Note [Suggest adding a type signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The OutsideIn algorithm rejects GADT programs that don't have a principal -type, and indeed some that do. Example: - data T a where - MkT :: Int -> T Int - - f (MkT n) = n - -Does this have type f :: T a -> a, or f :: T a -> Int? -The error that shows up tends to be an attempt to unify an -untouchable type variable. So suggestAddSig sees if the offending -type variable is bound by an *inferred* signature, and suggests -adding a declared signature instead. - -This initially came up in #8968, concerning pattern synonyms. - -Note [Disambiguating (X ~ X) errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #8278 - -Note [Reporting occurs-check errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied -type signature, then the best thing is to report that we can't unify -a with [a], because a is a skolem variable. That avoids the confusing -"occur-check" error message. - -But nowadays when inferring the type of a function with no type signature, -even if there are errors inside, we still generalise its signature and -carry on. For example - f x = x:x -Here we will infer something like - f :: forall a. a -> [a] -with a deferred error of (a ~ [a]). So in the deferred unsolved constraint -'a' is now a skolem, but not one bound by the programmer in the context! -Here we really should report an occurs check. - -So isUserSkolem distinguishes the two. - -Note [Non-injective type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very confusing to get a message like - Couldn't match expected type `Depend s' - against inferred type `Depend s1' -so mkTyFunInfoMsg adds: - NB: `Depend' is type function, and hence may not be injective - -Warn of loopy local equalities that were dropped. - - -************************************************************************ -* * - Type-class errors -* * -************************************************************************ --} - -mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkDictErr ctxt cts - = ASSERT( not (null cts) ) - do { inst_envs <- tcGetInstEnvs - ; let (ct1:_) = cts -- ct1 just for its location - min_cts = elim_superclasses cts - lookups = map (lookup_cls_inst inst_envs) min_cts - (no_inst_cts, overlap_cts) = partition is_no_inst lookups - - -- Report definite no-instance errors, - -- or (iff there are none) overlap errors - -- But we report only one of them (hence 'head') because they all - -- have the same source-location origin, to try avoid a cascade - -- of error from one location - ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) - ; mkErrorMsgFromCt ctxt ct1 (important err) } - where - no_givens = null (getUserGivens ctxt) - - is_no_inst (ct, (matches, unifiers, _)) - = no_givens - && null matches - && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) - - lookup_cls_inst inst_envs ct - -- Note [Flattening in error message generation] - = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys)) - where - (clas, tys) = getClassPredTys (ctPred ct) - - - -- 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 cts = mkMinimalBySCs ctPred cts - -mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) - -> TcM (ReportErrCtxt, SDoc) --- Report an overlap error if this class constraint results --- from an overlap (returning Left clas), otherwise return (Right pred) -mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped)) - | null matches -- No matches but perhaps several unifiers - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; candidate_insts <- get_candidate_instances - ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) } - - | null unsafe_overlapped -- Some matches => overlap errors - = return (ctxt, overlap_msg) - - | otherwise - = return (ctxt, safe_haskell_msg) - where - orig = ctOrigin ct - pred = ctPred ct - (clas, tys) = getClassPredTys pred - ispecs = [ispec | (ispec, _) <- matches] - unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped] - useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) - -- useful_givens are the enclosing implications with non-empty givens, - -- modulo the horrid discardProvCtxtGivens - - get_candidate_instances :: TcM [ClsInst] - -- See Note [Report candidate instances] - get_candidate_instances - | [ty] <- tys -- Only try for single-parameter classes - = do { instEnvs <- tcGetInstEnvs - ; return (filter (is_candidate_inst ty) - (classInstances instEnvs clas)) } - | otherwise = return [] - - is_candidate_inst ty inst -- See Note [Report candidate instances] - | [other_ty] <- is_tys inst - , Just (tc1, _) <- tcSplitTyConApp_maybe ty - , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty - = let n1 = tyConName tc1 - n2 = tyConName tc2 - different_names = n1 /= n2 - same_occ_names = nameOccName n1 == nameOccName n2 - in different_names && same_occ_names - | otherwise = False - - cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc - cannot_resolve_msg ct candidate_insts binds_msg - = vcat [ no_inst_msg - , nest 2 extra_note - , vcat (pp_givens useful_givens) - , mb_patsyn_prov `orElse` empty - , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens)) - (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ]) - - , ppWhen (isNothing mb_patsyn_prov) $ - -- Don't suggest fixes for the provided context of a pattern - -- synonym; the right fix is to bind more in the pattern - show_fixes (ctxtFixes has_ambig_tvs pred implics - ++ drv_fixes) - , ppWhen (not (null candidate_insts)) - (hang (text "There are instances for similar types:") - 2 (vcat (map ppr candidate_insts))) ] - -- See Note [Report candidate instances] - where - orig = ctOrigin ct - -- See Note [Highlighting ambiguous type variables] - lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs) - && not (null unifiers) && null useful_givens - - (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct - ambig_tvs = uncurry (++) (getAmbigTkvs ct) - - no_inst_msg - | lead_with_ambig - = ambig_msg <+> pprArising orig - $$ text "prevents the constraint" <+> quotes (pprParendType pred) - <+> text "from being solved." - - | null useful_givens - = addArising orig $ text "No instance for" - <+> pprParendType pred - - | otherwise - = addArising orig $ text "Could not deduce" - <+> pprParendType pred - - potential_msg - = ppWhen (not (null unifiers) && want_potential orig) $ - sdocOption sdocPrintPotentialInstances $ \print_insts -> - getPprStyle $ \sty -> - pprPotentials (PrintPotentialInstances print_insts) sty potential_hdr unifiers - - potential_hdr - = vcat [ ppWhen lead_with_ambig $ - text "Probable fix: use a type annotation to specify what" - <+> pprQuotedList ambig_tvs <+> text "should be." - , text "These potential instance" <> plural unifiers - <+> text "exist:"] - - mb_patsyn_prov :: Maybe SDoc - mb_patsyn_prov - | not lead_with_ambig - , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig - = Just (vcat [ text "In other words, a successful match on the pattern" - , nest 2 $ ppr pat - , text "does not provide the constraint" <+> pprParendType pred ]) - | otherwise = Nothing - - -- Report "potential instances" only when the constraint arises - -- directly from the user's use of an overloaded function - want_potential (TypeEqOrigin {}) = False - want_potential _ = True - - extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) - = text "(maybe you haven't applied a function to enough arguments?)" - | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) - , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) - , Just (tc,_) <- tcSplitTyConApp_maybe ty - , not (isTypeFamilyTyCon tc) - = hang (text "GHC can't yet do polykinded") - 2 (text "Typeable" <+> - parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty))) - | otherwise - = empty - - drv_fixes = case orig of - DerivClauseOrigin -> [drv_fix False] - StandAloneDerivOrigin -> [drv_fix True] - DerivOriginDC _ _ standalone -> [drv_fix standalone] - DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone] - _ -> [] - - drv_fix standalone_wildcard - | standalone_wildcard - = text "fill in the wildcard constraint yourself" - | otherwise - = hang (text "use a standalone 'deriving instance' declaration,") - 2 (text "so you can specify the instance context yourself") - - -- Normal overlap error - overlap_msg - = ASSERT( not (null matches) ) - vcat [ addArising orig (text "Overlapping instances for" - <+> pprType (mkClassPred clas tys)) - - , ppUnless (null matching_givens) $ - sep [text "Matching givens (or their superclasses):" - , nest 2 (vcat matching_givens)] - - , sdocOption sdocPrintPotentialInstances $ \print_insts -> - getPprStyle $ \sty -> - pprPotentials (PrintPotentialInstances print_insts) sty (text "Matching instances:") $ - ispecs ++ unifiers - - , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ - -- Intuitively, some given matched the wanted in their - -- flattened or rewritten (from given equalities) form - -- but the matcher can't figure that out because the - -- constraints are non-flat and non-rewritten so we - -- simply report back the whole given - -- context. Accelerate Smart.hs showed this problem. - sep [ text "There exists a (perhaps superclass) match:" - , nest 2 (vcat (pp_givens useful_givens))] - - , ppWhen (isSingleton matches) $ - parens (vcat [ text "The choice depends on the instantiation of" <+> - quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys)) - , ppWhen (null (matching_givens)) $ - vcat [ text "To pick the first instance above, use IncoherentInstances" - , text "when compiling the other instance declarations"] - ])] - - matching_givens = mapMaybe matchable useful_givens - - matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) - = case ev_vars_matching of - [] -> Nothing - _ -> Just $ hang (pprTheta ev_vars_matching) - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> - ppr (tcl_loc (ic_env implic)) ]) - where ev_vars_matching = [ pred - | ev_var <- evvars - , let pred = evVarPred ev_var - , any can_match (pred : transSuperClasses pred) ] - can_match pred - = case getClassPredTys_maybe pred of - Just (clas', tys') -> clas' == clas - && isJust (tcMatchTys tys tys') - Nothing -> False - - -- Overlap error because of Safe Haskell (first - -- match should be the most specific match) - safe_haskell_msg - = ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) ) - vcat [ addArising orig (text "Unsafe overlapping instances for" - <+> pprType (mkClassPred clas tys)) - , sep [text "The matching instance is:", - nest 2 (pprInstance $ head ispecs)] - , vcat [ text "It is compiled in a Safe module and as such can only" - , text "overlap instances from the same module, however it" - , text "overlaps the following instances from different" <+> - text "modules:" - , nest 2 (vcat [pprInstances $ unsafe_ispecs]) - ] - ] - - -ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc] -ctxtFixes has_ambig_tvs pred implics - | not has_ambig_tvs - , isTyVarClassPred pred - , (skol:skols) <- usefulContext implics pred - , let what | null skols - , SigSkol (PatSynCtxt {}) _ _ <- skol - = text "\"required\"" - | otherwise - = empty - = [sep [ text "add" <+> pprParendType pred - <+> text "to the" <+> what <+> text "context of" - , nest 2 $ ppr_skol skol $$ - vcat [ text "or" <+> ppr_skol skol - | skol <- skols ] ] ] - | otherwise = [] - where - ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc) - ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) - ppr_skol skol_info = ppr skol_info - -discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] -discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] - | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig - = filterOut (discard name) givens - | otherwise - = givens - where - discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' - discard _ _ = False - -usefulContext :: [Implication] -> PredType -> [SkolemInfo] --- usefulContext picks out the implications whose context --- the programmer might plausibly augment to solve 'pred' -usefulContext implics pred - = go implics - where - pred_tvs = tyCoVarsOfType pred - go [] = [] - go (ic : ics) - | implausible ic = rest - | otherwise = ic_info ic : rest - where - -- Stop when the context binds a variable free in the predicate - rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] - | otherwise = go ics - - implausible ic - | null (ic_skols ic) = True - | implausible_info (ic_info ic) = True - | otherwise = False - - implausible_info (SigSkol (InfSigCtxt {}) _ _) = True - implausible_info _ = False - -- Do not suggest adding constraints to an *inferred* type signature - -{- Note [Report candidate instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an unsolved (Num Int), where `Int` is not the Prelude Int, -but comes from some other module, then it may be helpful to point out -that there are some similarly named instances elsewhere. So we get -something like - No instance for (Num Int) arising from the literal ‘3’ - There are instances for similar types: - instance Num GHC.Types.Int -- Defined in ‘GHC.Num’ -Discussion in #9611. - -Note [Highlighting ambiguous type variables] -~------------------------------------------- -When we encounter ambiguous type variables (i.e. type variables -that remain metavariables after type inference), we need a few more -conditions before we can reason that *ambiguity* prevents constraints -from being solved: - - We can't have any givens, as encountering a typeclass error - with given constraints just means we couldn't deduce - a solution satisfying those constraints and as such couldn't - bind the type variable to a known type. - - If we don't have any unifiers, we don't even have potential - instances from which an ambiguity could arise. - - Lastly, I don't want to mess with error reporting for - unknown runtime types so we just fall back to the old message there. -Once these conditions are satisfied, we can safely say that ambiguity prevents -the constraint from being solved. - -Note [discardProvCtxtGivens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In most situations we call all enclosing implications "useful". There is one -exception, and that is when the constraint that causes the error is from the -"provided" context of a pattern synonym declaration: - - pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a - -- required => provided => type - pattern Pat x <- (Just x, 4) - -When checking the pattern RHS we must check that it does actually bind all -the claimed "provided" constraints; in this case, does the pattern (Just x, 4) -bind the (Show a) constraint. Answer: no! - -But the implication we generate for this will look like - forall a. (Num a, Eq a) => [W] Show a -because when checking the pattern we must make the required -constraints available, since they are needed to match the pattern (in -this case the literal '4' needs (Num a, Eq a)). - -BUT we don't want to suggest adding (Show a) to the "required" constraints -of the pattern synonym, thus: - pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a -It would then typecheck but it's silly. We want the /pattern/ to bind -the alleged "provided" constraints, Show a. - -So we suppress that Implication in discardProvCtxtGivens. It's -painfully ad-hoc but the truth is that adding it to the "required" -constraints would work. Suppressing it solves two problems. First, -we never tell the user that we could not deduce a "provided" -constraint from the "required" context. Second, we never give a -possible fix that suggests to add a "provided" constraint to the -"required" context. - -For example, without this distinction the above code gives a bad error -message (showing both problems): - - error: Could not deduce (Show a) ... from the context: (Eq a) - ... Possible fix: add (Show a) to the context of - the signature for pattern synonym `Pat' ... - --} - -show_fixes :: [SDoc] -> SDoc -show_fixes [] = empty -show_fixes (f:fs) = sep [ text "Possible fix:" - , nest 2 (vcat (f : map (text "or" <+>) fs))] - - --- Avoid boolean blindness -newtype PrintPotentialInstances = PrintPotentialInstances Bool - -pprPotentials :: PrintPotentialInstances -> PprStyle -> SDoc -> [ClsInst] -> SDoc --- See Note [Displaying potential instances] -pprPotentials (PrintPotentialInstances show_potentials) sty herald insts - | null insts - = empty - - | null show_these - = hang herald - 2 (vcat [ not_in_scope_msg empty - , flag_hint ]) - - | otherwise - = hang herald - 2 (vcat [ pprInstances show_these - , ppWhen (n_in_scope_hidden > 0) $ - text "...plus" - <+> speakNOf n_in_scope_hidden (text "other") - , not_in_scope_msg (text "...plus") - , flag_hint ]) - where - n_show = 3 :: Int - - (in_scope, not_in_scope) = partition inst_in_scope insts - sorted = sortBy fuzzyClsInstCmp in_scope - show_these | show_potentials = sorted - | otherwise = take n_show sorted - n_in_scope_hidden = length sorted - length show_these - - -- "in scope" means that all the type constructors - -- are lexically in scope; these instances are likely - -- to be more useful - inst_in_scope :: ClsInst -> Bool - inst_in_scope cls_inst = nameSetAll name_in_scope $ - orphNamesOfTypes (is_tys cls_inst) - - name_in_scope name - | isBuiltInSyntax name - = True -- E.g. (->) - | Just mod <- nameModule_maybe name - = qual_in_scope (qualName sty mod (nameOccName name)) - | otherwise - = True - - qual_in_scope :: QualifyName -> Bool - qual_in_scope NameUnqual = True - qual_in_scope (NameQual {}) = True - qual_in_scope _ = False - - not_in_scope_msg herald - | null not_in_scope - = empty - | otherwise - = hang (herald <+> speakNOf (length not_in_scope) (text "instance") - <+> text "involving out-of-scope types") - 2 (ppWhen show_potentials (pprInstances not_in_scope)) - - flag_hint = ppUnless (show_potentials || equalLength show_these insts) $ - text "(use -fprint-potential-instances to see them all)" - -{- Note [Displaying potential instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When showing a list of instances for - - overlapping instances (show ones that match) - - no such instance (show ones that could match) -we want to give it a bit of structure. Here's the plan - -* Say that an instance is "in scope" if all of the - type constructors it mentions are lexically in scope. - These are the ones most likely to be useful to the programmer. - -* Show at most n_show in-scope instances, - and summarise the rest ("plus 3 others") - -* Summarise the not-in-scope instances ("plus 4 not in scope") - -* Add the flag -fshow-potential-instances which replaces the - summary with the full list --} - -{- -Note [Flattening in error message generation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (C (Maybe (F x))), where F is a type function, and we have -instances - C (Maybe Int) and C (Maybe a) -Since (F x) might turn into Int, this is an overlap situation, and -indeed (because of flattening) the main solver will have refrained -from solving. But by the time we get to error message generation, we've -un-flattened the constraint. So we must *re*-flatten it before looking -up in the instance environment, lest we only report one matching -instance when in fact there are two. - -Re-flattening is pretty easy, because we don't need to keep track of -evidence. We don't re-use the code in TcCanonical because that's in -the TcS monad, and we are in TcM here. - -Note [Kind arguments in error messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It can be terribly confusing to get an error message like (#9171) - - Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ - with actual type ‘GetParam Base (GetParam Base Int)’ - -The reason may be that the kinds don't match up. Typically you'll get -more useful information, but not when it's as a result of ambiguity. - -To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag -whenever any error message arises due to a kind mismatch. This means that -the above error message would instead be displayed as: - - Couldn't match expected type - ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’ - with actual type - ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’ - -Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. --} - -mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence - -> Ct -> (Bool, SDoc) -mkAmbigMsg prepend_msg ct - | null ambig_kvs && null ambig_tvs = (False, empty) - | otherwise = (True, msg) - where - (ambig_kvs, ambig_tvs) = getAmbigTkvs ct - - msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] - || any isRuntimeUnkSkol ambig_tvs - = vcat [ text "Cannot resolve unknown runtime type" - <> plural ambig_tvs <+> pprQuotedList ambig_tvs - , text "Use :print or :force to determine these types"] - - | not (null ambig_tvs) - = pp_ambig (text "type") ambig_tvs - - | otherwise - = pp_ambig (text "kind") ambig_kvs - - pp_ambig what tkvs - | prepend_msg -- "Ambiguous type variable 't0'" - = text "Ambiguous" <+> what <+> text "variable" - <> plural tkvs <+> pprQuotedList tkvs - - | otherwise -- "The type variable 't0' is ambiguous" - = text "The" <+> what <+> text "variable" <> plural tkvs - <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" - -pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc -pprSkols ctxt tvs - = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs)) - where - pp_one (UnkSkol, tvs) - = hang (pprQuotedList tvs) - 2 (is_or_are tvs "an" "unknown") - pp_one (RuntimeUnkSkol, tvs) - = hang (pprQuotedList tvs) - 2 (is_or_are tvs "an" "unknown runtime") - pp_one (skol_info, tvs) - = vcat [ hang (pprQuotedList tvs) - 2 (is_or_are tvs "a" "rigid" <+> text "bound by") - , nest 2 (pprSkolInfo skol_info) - , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ] - - is_or_are [_] article adjective = text "is" <+> text article <+> text adjective - <+> text "type variable" - is_or_are _ _ adjective = text "are" <+> text adjective - <+> text "type variables" - -getAmbigTkvs :: Ct -> ([Var],[Var]) -getAmbigTkvs ct - = partition (`elemVarSet` dep_tkv_set) ambig_tkvs - where - tkvs = tyCoVarsOfCtList ct - ambig_tkvs = filter isAmbiguousTyVar tkvs - dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) - -getSkolemInfo :: [Implication] -> [TcTyVar] - -> [(SkolemInfo, [TcTyVar])] -- #14628 --- Get the skolem info for some type variables --- from the implication constraints that bind them. --- --- In the returned (skolem, tvs) pairs, the 'tvs' part is non-empty -getSkolemInfo _ [] - = [] - -getSkolemInfo [] tvs - | all isRuntimeUnkSkol tvs = [(RuntimeUnkSkol, tvs)] -- #14628 - | otherwise = pprPanic "No skolem info:" (ppr tvs) - -getSkolemInfo (implic:implics) tvs - | null tvs_here = getSkolemInfo implics tvs - | otherwise = (ic_info implic, tvs_here) : getSkolemInfo implics tvs_other - where - (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs - ------------------------ --- relevantBindings looks at the value environment and finds values whose --- types mention any of the offending type variables. It has to be --- careful to zonk the Id's type first, so it has to be in the monad. --- We must be careful to pass it a zonked type variable, too. --- --- We always remove closed top-level bindings, though, --- since they are never relevant (cf #8233) - -relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering - -- See #8191 - -> ReportErrCtxt -> Ct - -> TcM (ReportErrCtxt, SDoc, Ct) --- Also returns the zonked and tidied CtOrigin of the constraint -relevantBindings want_filtering ctxt ct - = do { dflags <- getDynFlags - ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) - ; let ct_tvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs - - -- For *kind* errors, report the relevant bindings of the - -- enclosing *type* equality, because that's more useful for the programmer - extra_tvs = case tidy_orig of - KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $ - t1 : maybeToList m_t2 - _ -> emptyVarSet - ; traceTc "relevantBindings" $ - vcat [ ppr ct - , pprCtOrigin (ctLocOrigin loc) - , ppr ct_tvs - , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id) - | TcIdBndr id _ <- tcl_bndrs lcl_env ] - , pprWithCommas id - [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] - - ; (tidy_env', docs, discards) - <- go dflags env1 ct_tvs (maxRelevantBinds dflags) - emptyVarSet [] False - (removeBindingShadowing $ tcl_bndrs lcl_env) - -- tcl_bndrs has the innermost bindings first, - -- which are probably the most relevant ones - - ; let doc = ppUnless (null docs) $ - hang (text "Relevant bindings include") - 2 (vcat docs $$ ppWhen discards discardMsg) - - -- Put a zonked, tidied CtOrigin into the Ct - loc' = setCtLocOrigin loc tidy_orig - ct' = setCtLoc ct loc' - ctxt' = ctxt { cec_tidy = tidy_env' } - - ; return (ctxt', doc, ct') } - where - ev = ctEvidence ct - loc = ctEvLoc ev - lcl_env = ctLocEnv loc - - run_out :: Maybe Int -> Bool - run_out Nothing = False - run_out (Just n) = n <= 0 - - dec_max :: Maybe Int -> Maybe Int - dec_max = fmap (\n -> n - 1) - - - go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc] - -> Bool -- True <=> some filtered out due to lack of fuel - -> [TcBinder] - -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out - -- because of lack of fuel - go _ tidy_env _ _ _ docs discards [] - = return (tidy_env, reverse docs, discards) - go dflags tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs) - = case tc_bndr of - TcTvBndr {} -> discard_it - TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl - TcIdBndr_ExpType name et top_lvl -> - do { mb_ty <- 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 - -- Or we are reporting errors from the ambiguity check on - -- a local type signature - ; case mb_ty of - Just ty -> go2 name ty top_lvl - Nothing -> discard_it -- No info; discard - } - where - discard_it = go dflags tidy_env ct_tvs n_left tvs_seen docs - discards tc_bndrs - go2 id_name id_type top_lvl - = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type - ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) - ; let id_tvs = tyCoVarsOfType tidy_ty - doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty - , nest 2 (parens (text "bound at" - <+> ppr (getSrcLoc id_name)))] - new_seen = tvs_seen `unionVarSet` id_tvs - - ; if (want_filtering && not (hasPprDebug dflags) - && id_tvs `disjointVarSet` ct_tvs) - -- We want to filter out this binding anyway - -- so discard it silently - then discard_it - - else if isTopLevel top_lvl && not (isNothing n_left) - -- It's a top-level binding and we have not specified - -- -fno-max-relevant-bindings, so discard it silently - then discard_it - - else if run_out n_left && id_tvs `subVarSet` tvs_seen - -- We've run out of n_left fuel and this binding only - -- mentions already-seen type variables, so discard it - then go dflags tidy_env ct_tvs n_left tvs_seen docs - True -- Record that we have now discarded something - tc_bndrs - - -- Keep this binding, decrement fuel - else go dflags tidy_env' ct_tvs (dec_max n_left) new_seen - (doc:docs) discards tc_bndrs } - - -discardMsg :: SDoc -discardMsg = text "(Some bindings suppressed;" <+> - text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" - ------------------------ -warnDefaulting :: [Ct] -> Type -> TcM () -warnDefaulting wanteds default_ty - = do { warn_default <- woptM Opt_WarnTypeDefaults - ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyCoVars env0 $ - tyCoVarsOfCtsList (listToBag wanteds) - tidy_wanteds = map (tidyCt tidy_env) wanteds - (loc, ppr_wanteds) = pprWithArising tidy_wanteds - warn_msg = - hang (hsep [ text "Defaulting the following" - , text "constraint" <> plural tidy_wanteds - , text "to type" - , quotes (ppr default_ty) ]) - 2 - ppr_wanteds - ; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg } - -{- -Note [Runtime skolems] -~~~~~~~~~~~~~~~~~~~~~~ -We want to give a reasonably helpful error message for ambiguity -arising from *runtime* skolems in the debugger. These -are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType. - -************************************************************************ -* * - Error from the canonicaliser - These ones are called *during* constraint simplification -* * -************************************************************************ --} - -solverDepthErrorTcS :: CtLoc -> TcType -> TcM a -solverDepthErrorTcS loc ty - = setCtLocM loc $ - do { ty <- zonkTcType ty - ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) - tidy_ty = tidyType tidy_env ty - msg - = vcat [ text "Reduction stack overflow; size =" <+> ppr depth - , hang (text "When simplifying the following type:") - 2 (ppr tidy_ty) - , note ] - ; 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)" ] diff --git a/compiler/typecheck/TcEvTerm.hs b/compiler/typecheck/TcEvTerm.hs deleted file mode 100644 --- a/compiler/typecheck/TcEvTerm.hs +++ /dev/null @@ -1,71 +0,0 @@ - --- (those who have too heavy dependencies for TcEvidence) -module TcEvTerm - ( evDelayedError, evCallStack ) -where - -import GhcPrelude - -import FastString -import GHC.Core.Type -import GHC.Core -import GHC.Core.Make -import GHC.Types.Literal ( Literal(..) ) -import TcEvidence -import GHC.Driver.Types -import GHC.Driver.Session -import GHC.Types.Name -import GHC.Types.Module -import GHC.Core.Utils -import PrelNames -import GHC.Types.SrcLoc - --- Used with Opt_DeferTypeErrors --- See Note [Deferring coercion errors to runtime] --- in TcSimplify -evDelayedError :: Type -> FastString -> EvTerm -evDelayedError ty msg - = EvExpr $ - Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg] - where - errorId = tYPE_ERROR_ID - litMsg = Lit (LitString (bytesFS msg)) - --- Dictionary for CallStack implicit parameters -evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) => - EvCallStack -> m EvExpr --- See Note [Overview of implicit CallStacks] in TcEvidence.hs -evCallStack cs = do - df <- getDynFlags - let platform = targetPlatform df - m <- getModule - srcLocDataCon <- lookupDataCon srcLocDataConName - let mkSrcLoc l = mkCoreConApps srcLocDataCon <$> - sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m) - , mkStringExprFS (moduleNameFS $ moduleName m) - , mkStringExprFS (srcSpanFile l) - , return $ mkIntExprInt platform (srcSpanStartLine l) - , return $ mkIntExprInt platform (srcSpanStartCol l) - , return $ mkIntExprInt platform (srcSpanEndLine l) - , return $ mkIntExprInt platform (srcSpanEndCol l) - ] - - emptyCS <- Var <$> lookupId emptyCallStackName - - pushCSVar <- lookupId pushCallStackName - let pushCS name loc rest = - mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest] - - let mkPush name loc tm = do - nameExpr <- mkStringExprFS name - locExpr <- mkSrcLoc loc - -- at this point tm :: IP sym CallStack - -- but we need the actual CallStack to pass to pushCS, - -- so we use unwrapIP to strip the dictionary wrapper - -- See Note [Overview of implicit CallStacks] - let ip_co = unwrapIP (exprType tm) - return (pushCS nameExpr locExpr (Cast tm ip_co)) - - case cs of - EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm - EvCsEmpty -> return emptyCS diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs deleted file mode 100644 --- a/compiler/typecheck/TcExpr.hs +++ /dev/null @@ -1,2897 +0,0 @@ -{- -% -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcExpr]{Typecheck an expression} --} - -{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC, - tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC, - tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, - tcCheckId, - addExprErrCtxt, - addAmbiguousNameErr, - getFixedTyVars ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) -import THNames( liftStringName, liftName ) - -import GHC.Hs -import Constraint ( HoleSort(..) ) -import TcHsSyn -import TcRnMonad -import TcUnify -import GHC.Types.Basic -import Inst -import TcBinds ( chooseInferredQuantifiers, tcLocalBinds ) -import TcSigs ( tcUserTypeSig, tcInstSig ) -import TcSimplify ( simplifyInfer, InferMode(..) ) -import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst ) -import GHC.Core.FamInstEnv ( FamInstEnvs ) -import GHC.Rename.Env ( addUsedGRE ) -import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr ) -import TcEnv -import TcArrows -import TcMatches -import TcHsType -import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr ) -import TcPat -import TcMType -import TcOrigin -import 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.TyCon -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr -import GHC.Core.TyCo.Subst (substTyWithInScope) -import GHC.Core.Type -import TcEvidence -import GHC.Types.Var.Set -import TysWiredIn -import TysPrim( intPrimTy ) -import PrimOp( tagToEnumKey ) -import PrelNames -import GHC.Driver.Session -import GHC.Types.SrcLoc -import Util -import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet ) -import ListSetOps -import Maybes -import Outputable -import FastString -import Control.Monad -import GHC.Core.Class(classTyCon) -import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) -import qualified GHC.LanguageExtensions as LangExt - -import Data.Function -import Data.List (partition, sortBy, groupBy, intersect) -import qualified Data.Set as Set - -{- -************************************************************************ -* * -\subsection{Main wrappers} -* * -************************************************************************ --} - -tcPolyExpr, tcPolyExprNC - :: LHsExpr GhcRn -- Expression to type check - -> TcSigmaType -- Expected type (could be a polytype) - -> TcM (LHsExpr GhcTcId) -- Generalised expr with expected type - --- tcPolyExpr is a convenient place (frequent but not too frequent) --- place to add context information. --- The NC version does not do so, usually because the caller wants --- to do so himself. - -tcPolyExpr expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty) -tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty) - --- these versions take an ExpType -tc_poly_expr, tc_poly_expr_nc :: LHsExpr GhcRn -> ExpSigmaType - -> TcM (LHsExpr GhcTcId) -tc_poly_expr expr res_ty - = addExprErrCtxt expr $ - do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty } - -tc_poly_expr_nc (L loc expr) res_ty - = setSrcSpan loc $ - do { traceTc "tcPolyExprNC" (ppr res_ty) - ; (wrap, expr') - <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty -> - tcExpr expr res_ty - ; return $ L loc (mkHsWrap wrap expr') } - ---------------- -tcMonoExpr, tcMonoExprNC - :: LHsExpr GhcRn -- Expression to type check - -> ExpRhoType -- Expected type - -- Definitely no foralls at the top - -> TcM (LHsExpr GhcTcId) - -tcMonoExpr expr res_ty - = addErrCtxt (exprCtxt expr) $ - tcMonoExprNC expr res_ty - -tcMonoExprNC (L loc expr) res_ty - = setSrcSpan loc $ - do { expr' <- tcExpr expr res_ty - ; return (L loc expr') } - ---------------- -tcInferSigma, tcInferSigmaNC :: LHsExpr GhcRn -> TcM ( LHsExpr GhcTcId - , TcSigmaType ) --- Infer a *sigma*-type. -tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr) - -tcInferSigmaNC (L loc expr) - = setSrcSpan loc $ - do { (expr', sigma) <- tcInferNoInst (tcExpr expr) - ; return (L loc expr', sigma) } - -tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcRhoType) --- Infer a *rho*-type. The return type is always (shallowly) instantiated. -tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr) - -tcInferRhoNC expr - = do { (expr', sigma) <- tcInferSigmaNC expr - ; (wrap, rho) <- topInstantiate (lexprCtOrigin expr) sigma - ; return (mkLHsWrap wrap expr', rho) } - - -{- -************************************************************************ -* * - tcExpr: the main expression typechecker -* * -************************************************************************ - -NB: The res_ty is always deeply skolemised. --} - -tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcExpr (HsVar _ (L _ name)) res_ty = tcCheckId name res_ty -tcExpr e@(HsUnboundVar _ uv) res_ty = tcUnboundId e uv res_ty - -tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty -tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty - -tcExpr e@(HsLit x lit) res_ty - = do { let lit_ty = hsLitType lit - ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } - -tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty - ; return (HsPar x expr') } - -tcExpr (HsPragE x prag expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty - ; return (HsPragE x (tc_prag prag) expr') } - where - tc_prag :: HsPragE GhcRn -> HsPragE GhcTc - tc_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann - tc_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl - tc_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo - tc_prag (XHsPragE x) = noExtCon x - -tcExpr (HsOverLit x lit) res_ty - = do { lit' <- newOverloadedLit lit res_ty - ; return (HsOverLit x lit') } - -tcExpr (NegApp x expr neg_expr) res_ty - = do { (expr', neg_expr') - <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ - \[arg_ty] -> - tcMonoExpr expr (mkCheckExpType arg_ty) - ; return (NegApp x expr' neg_expr') } - -tcExpr e@(HsIPVar _ x) res_ty - = do { {- Implicit parameters must have a *tau-type* not a - type scheme. We enforce this by creating a fresh - type variable as its type. (Because res_ty may not - be a tau-type.) -} - ip_ty <- newOpenFlexiTyVarTy - ; let ip_name = mkStrLitTy (hsIPNameFS x) - ; ipClass <- tcLookupClass ipClassName - ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) - ; tcWrapResult e - (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLoc ip_var))) - ip_ty res_ty } - where - -- Coerces a dictionary for `IP "x" t` into `t`. - fromDict ipClass x ty = mkHsWrap $ mkWpCastR $ - unwrapIP $ mkClassPred ipClass [x,ty] - origin = IPOccOrigin x - -tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty - = do { -- See Note [Type-checking overloaded labels] - loc <- getSrcSpanM - ; case mb_fromLabel of - Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty - Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName - ; alpha <- newFlexiTyVarTy liftedTypeKind - ; let pred = mkClassPred isLabelClass [lbl, alpha] - ; loc <- getSrcSpanM - ; var <- emitWantedEvVar origin pred - ; tcWrapResult e - (fromDict pred (HsVar noExtField (L loc var))) - alpha res_ty } } - where - -- Coerces a dictionary for `IsLabel "x" t` into `t`, - -- or `HasField "x" r a into `r -> a`. - fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred - origin = OverLabelOrigin l - lbl = mkStrLitTy l - - applyFromLabel loc fromLabel = - HsAppType noExtField - (L loc (HsVar noExtField (L loc fromLabel))) - (mkEmptyWildCardBndrs (L loc (HsTyLit noExtField (HsStrTy NoSourceText l)))) - -tcExpr (HsLam x match) res_ty - = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty - ; return (mkHsWrap wrap (HsLam x match')) } - where - match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } - herald = sep [ text "The lambda expression" <+> - quotes (pprSetDepth (PartWay 1) $ - pprMatches match), - -- The pprSetDepth makes the abstraction print briefly - text "has"] - -tcExpr e@(HsLamCase x matches) res_ty - = do { (matches', wrap) - <- tcMatchLambda msg match_ctxt matches res_ty - -- The laziness annotation is because we don't want to fail here - -- if there are multiple arguments - ; return (mkHsWrap wrap $ HsLamCase x matches') } - where - msg = sep [ text "The function" <+> quotes (ppr e) - , text "requires"] - match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } - -tcExpr e@(ExprWithTySig _ expr sig_ty) res_ty - = do { let loc = getLoc (hsSigWcType sig_ty) - ; sig_info <- checkNoErrs $ -- Avoid error cascade - tcUserTypeSig loc sig_ty Nothing - ; (expr', poly_ty) <- tcExprSig expr sig_info - ; let expr'' = ExprWithTySig noExtField expr' sig_ty - ; tcWrapResult e expr'' poly_ty res_ty } - -{- -Note [Type-checking overloaded labels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Recall that we have - - module GHC.OverloadedLabels where - class IsLabel (x :: Symbol) a where - fromLabel :: a - -We translate `#foo` to `fromLabel @"foo"`, where we use - - * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not - * `GHC.OverloadedLabels.fromLabel`. - -In the `RebindableSyntax` case, the renamer will have filled in the -first field of `HsOverLabel` with the `fromLabel` function to use, and -we simply apply it to the appropriate visible type argument. - -In the `OverloadedLabels` case, when we see an overloaded label like -`#foo`, we generate a fresh variable `alpha` for the type and emit an -`IsLabel "foo" alpha` constraint. Because the `IsLabel` class has a -single method, it is represented by a newtype, so we can coerce -`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters). - --} - - -{- -************************************************************************ -* * - Infix operators and sections -* * -************************************************************************ - -Note [Left sections] -~~~~~~~~~~~~~~~~~~~~ -Left sections, like (4 *), are equivalent to - \ x -> (*) 4 x, -or, if PostfixOperators is enabled, just - (*) 4 -With PostfixOperators we don't actually require the function to take -two arguments at all. For example, (x `not`) means (not x); you get -postfix operators! Not Haskell 98, but it's less work and kind of -useful. - -Note [Typing rule for ($)] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -People write - runST $ blah -so much, where - runST :: (forall s. ST s a) -> a -that I have finally given in and written a special type-checking -rule just for saturated applications of ($). - * Infer the type of the first argument - * Decompose it; should be of form (arg2_ty -> res_ty), - where arg2_ty might be a polytype - * Use arg2_ty to typecheck arg2 --} - -tcExpr expr@(OpApp fix arg1 op arg2) res_ty - | (L loc (HsVar _ (L lv op_name))) <- op - , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] - = do { traceTc "Application rule" (ppr op) - ; (arg1', arg1_ty) <- tcInferSigma arg1 - - ; let doc = text "The first argument of ($) takes" - orig1 = lexprCtOrigin arg1 - ; (wrap_arg1, [arg2_sigma], op_res_ty) <- - matchActualFunTys doc orig1 (Just (unLoc arg1)) 1 arg1_ty - - -- We have (arg1 $ arg2) - -- So: arg1_ty = arg2_ty -> op_res_ty - -- where arg2_sigma maybe polymorphic; that's the point - - ; arg2' <- tcArg op arg2 arg2_sigma 2 - - -- Make sure that the argument type has kind '*' - -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b - -- Eg we do not want to allow (D# $ 4.0#) #5570 - -- (which gives a seg fault) - ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma)) - (tcTypeKind arg2_sigma) liftedTypeKind - -- Ignore the evidence. arg2_sigma must have type * or #, - -- because we know (arg2_sigma -> op_res_ty) is well-kinded - -- (because otherwise matchActualFunTys would fail) - -- So this 'unifyKind' will either succeed with Refl, or will - -- produce an insoluble constraint * ~ #, which we'll report later. - - -- NB: unlike the argument type, the *result* type, op_res_ty can - -- have any kind (#8739), so we don't need to check anything for that - - ; op_id <- tcLookupId op_name - ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep op_res_ty - , arg2_sigma - , op_res_ty]) - (HsVar noExtField (L lv op_id))) - -- arg1' :: arg1_ty - -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) - -- op' :: (a2_ty -> op_res_ty) -> a2_ty -> op_res_ty - - expr' = OpApp fix (mkLHsWrap wrap_arg1 arg1') op' arg2' - - ; tcWrapResult expr expr' op_res_ty res_ty } - - | (L loc (HsRecFld _ (Ambiguous _ lbl))) <- op - , Just sig_ty <- obviousSig (unLoc arg1) - -- See Note [Disambiguating record fields] - = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty - ; sel_name <- disambiguateSelector lbl sig_tc_ty - ; let op' = L loc (HsRecFld noExtField (Unambiguous sel_name lbl)) - ; tcExpr (OpApp fix arg1 op' arg2) res_ty - } - - | otherwise - = do { traceTc "Non Application rule" (ppr op) - ; (wrap, op', [HsValArg arg1', HsValArg arg2']) - <- tcApp (Just $ mk_op_msg op) - op [HsValArg arg1, HsValArg arg2] res_ty - ; return (mkHsWrap wrap $ OpApp fix arg1' op' arg2') } - --- Right sections, equivalent to \ x -> x `op` expr, or --- \ x -> op x expr - -tcExpr expr@(SectionR x op arg2) res_ty - = do { (op', op_ty) <- tcInferFun op - ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) - <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty - ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) - (mkVisFunTy arg1_ty op_res_ty) res_ty - ; arg2' <- tcArg op arg2 arg2_ty 2 - ; return ( mkHsWrap wrap_res $ - SectionR x (mkLHsWrap wrap_fun op') arg2' ) } - where - fn_orig = lexprCtOrigin op - -- It's important to use the origin of 'op', so that call-stacks - -- come out right; they are driven by the OccurrenceOf CtOrigin - -- See #13285 - -tcExpr expr@(SectionL x arg1 op) res_ty - = do { (op', op_ty) <- tcInferFun op - ; dflags <- getDynFlags -- Note [Left sections] - ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1 - | otherwise = 2 - - ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty) - <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) - n_reqd_args op_ty - ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) - (mkVisFunTys arg_tys op_res_ty) res_ty - ; arg1' <- tcArg op arg1 arg1_ty 1 - ; return ( mkHsWrap wrap_res $ - SectionL x arg1' (mkLHsWrap wrap_fn op') ) } - where - fn_orig = lexprCtOrigin op - -- It's important to use the origin of 'op', so that call-stacks - -- come out right; they are driven by the OccurrenceOf CtOrigin - -- See #13285 - -tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty - | all tupArgPresent tup_args - = do { let arity = length tup_args - tup_tc = tupleTyCon boxity arity - -- NB: tupleTyCon doesn't flatten 1-tuples - -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make - ; res_ty <- expTypeToType res_ty - ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty - -- Unboxed tuples have RuntimeRep vars, which we - -- don't care about here - -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys - Boxed -> arg_tys - ; tup_args1 <- tcTupArgs tup_args arg_tys' - ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) } - - | otherwise - = -- The tup_args are a mixture of Present and Missing (for tuple sections) - do { let arity = length tup_args - - ; arg_tys <- case boxity of - { Boxed -> newFlexiTyVarTys arity liftedTypeKind - ; Unboxed -> replicateM arity newOpenFlexiTyVarTy } - ; let actual_res_ty - = mkVisFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args] - (mkTupleTy1 boxity arg_tys) - -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make - - ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple") - (Just expr) - actual_res_ty res_ty - - -- Handle tuple sections where - ; tup_args1 <- tcTupArgs tup_args arg_tys - - ; return $ mkHsWrap wrap (ExplicitTuple x tup_args1 boxity) } - -tcExpr (ExplicitSum _ alt arity expr) res_ty - = do { let sum_tc = sumTyCon arity - ; res_ty <- expTypeToType res_ty - ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty - ; -- Drop levity vars, we don't care about them here - let arg_tys' = drop arity arg_tys - ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1)) - ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } - --- This will see the empty list only when -XOverloadedLists. --- See Note [Empty lists] in GHC.Hs.Expr. -tcExpr (ExplicitList _ witness exprs) res_ty - = case witness of - Nothing -> do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ - mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' } - - Just fln -> do { ((exprs', elt_ty), fln') - <- tcSyntaxOp ListOrigin fln - [synKnownType intTy, SynList] res_ty $ - \ [elt_ty] -> - do { exprs' <- - mapM (tc_elt elt_ty) exprs - ; return (exprs', elt_ty) } - - ; return $ ExplicitList elt_ty (Just fln') exprs' } - where tc_elt elt_ty expr = tcPolyExpr expr elt_ty - -{- -************************************************************************ -* * - Let, case, if, do -* * -************************************************************************ --} - -tcExpr (HsLet x (L l binds) expr) res_ty - = do { (binds', expr') <- tcLocalBinds binds $ - tcMonoExpr expr res_ty - ; return (HsLet x (L l binds') expr') } - -tcExpr (HsCase x scrut matches) res_ty - = do { -- We used to typecheck the case alternatives first. - -- The case patterns tend to give good type info to use - -- when typechecking the scrutinee. For example - -- case (map f) of - -- (x:xs) -> ... - -- will report that map is applied to too few arguments - -- - -- But now, in the GADT world, we need to typecheck the scrutinee - -- first, to get type info that may be refined in the case alternatives - (scrut', scrut_ty) <- tcInferRho scrut - - ; traceTc "HsCase" (ppr scrut_ty) - ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty - ; return (HsCase x scrut' matches') } - where - match_ctxt = MC { mc_what = CaseAlt, - mc_body = tcBody } - -tcExpr (HsIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if' - = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) - ; res_ty <- tauifyExpType res_ty - -- Just like Note [Case branches must never infer a non-tau type] - -- in TcMatches (See #10619) - - ; b1' <- tcMonoExpr b1 res_ty - ; b2' <- tcMonoExpr b2 res_ty - ; return (HsIf x NoSyntaxExprTc pred' b1' b2') } - -tcExpr (HsIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty - = do { ((pred', b1', b2'), fun') - <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $ - \ [pred_ty, b1_ty, b2_ty] -> - do { pred' <- tcPolyExpr pred pred_ty - ; b1' <- tcPolyExpr b1 b1_ty - ; b2' <- tcPolyExpr b2 b2_ty - ; return (pred', b1', b2') } - ; return (HsIf x fun' pred' b1' b2') } - -tcExpr (HsMultiIf _ alts) res_ty - = do { res_ty <- if isSingleton alts - then return res_ty - else tauifyExpType res_ty - -- Just like TcMatches - -- Note [Case branches must never infer a non-tau type] - - ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts - ; res_ty <- readExpType res_ty - ; return (HsMultiIf res_ty alts') } - where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } - -tcExpr (HsDo _ do_or_lc stmts) res_ty - = do { expr' <- tcDoStmts do_or_lc stmts res_ty - ; return expr' } - -tcExpr (HsProc x pat cmd) res_ty - = do { (pat', cmd', coi) <- tcProc pat cmd res_ty - ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } - --- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. --- See Note [Grand plan for static forms] in StaticPtrTable for an overview. --- To type check --- (static e) :: p a --- we want to check (e :: a), --- and wrap (static e) in a call to --- fromStaticPtr :: IsStatic p => StaticPtr a -> p a - -tcExpr (HsStatic fvs expr) res_ty - = do { res_ty <- expTypeToType res_ty - ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty - ; (expr', lie) <- captureConstraints $ - addErrCtxt (hang (text "In the body of a static form:") - 2 (ppr expr) - ) $ - tcPolyExprNC expr expr_ty - - -- Check that the free variables of the static form are closed. - -- It's OK to use nonDetEltsUniqSet here as the only side effects of - -- checkClosedInStaticForm are error messages. - ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs - - -- Require the type of the argument to be Typeable. - -- The evidence is not used, but asking the constraint ensures that - -- the current implementation is as restrictive as future versions - -- of the StaticPointers extension. - ; typeableClass <- tcLookupClass typeableClassName - ; _ <- emitWantedEvVar StaticOrigin $ - mkTyConApp (classTyCon typeableClass) - [liftedTypeKind, expr_ty] - - -- Insert the constraints of the static form in a global list for later - -- validation. - ; emitStaticConstraints lie - - -- Wrap the static form with the 'fromStaticPtr' call. - ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName - [p_ty] - ; let wrap = mkWpTyApps [expr_ty] - ; loc <- getSrcSpanM - ; return $ mkHsWrapCo co $ HsApp noExtField - (L loc $ mkHsWrap wrap fromStaticPtr) - (L loc (HsStatic fvs expr')) - } - -{- -************************************************************************ -* * - Record construction and update -* * -************************************************************************ --} - -tcExpr expr@(RecordCon { rcon_con_name = L loc con_name - , rcon_flds = rbinds }) res_ty - = do { con_like <- tcLookupConLike con_name - - -- Check for missing fields - ; checkMissingFields con_like rbinds - - ; (con_expr, con_sigma) <- tcInferId con_name - ; (con_wrap, con_tau) <- - topInstantiate (OccurrenceOf con_name) con_sigma - -- a shallow instantiation should really be enough for - -- a data constructor. - ; let arity = conLikeArity con_like - Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau - ; case conLikeWrapId_maybe con_like of - Nothing -> nonBidirectionalErr (conLikeName con_like) - Just con_id -> do { - res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon") - (Just expr) actual_res_ty res_ty - ; rbinds' <- tcRecordBinds con_like arg_tys rbinds - ; return $ - mkHsWrap res_wrap $ - RecordCon { rcon_ext = RecordConTc - { rcon_con_like = con_like - , rcon_con_expr = mkHsWrap con_wrap con_expr } - , rcon_con_name = L loc con_id - , rcon_flds = rbinds' } } } - -{- -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 TcTyClsDecls), 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" - --} - -tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty - = ASSERT( notNull rbnds ) - do { -- STEP -2: typecheck the record_expr, the record to be updated - (record_expr', record_rho) <- tcInferRho record_expr - - -- STEP -1 See Note [Disambiguating record fields] - -- After this we know that rbinds is unambiguous - ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty - ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds - upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds - sel_ids = map selectorAmbiguousFieldOcc upd_flds - -- 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 Selectors] - ; 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 - - mtycon :: Maybe TyCon - mtycon = case idDetails sel_id of - RecSelId (RecSelData tycon) _ -> Just tycon - _ -> Nothing - - 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 - ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes) - - -- Take apart a representative constructor - ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons - (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _) - = conLikeFullSig con1 - con1_flds = map flLabel $ conLikeFieldLabels con1 - con1_tv_tys = mkTyVarTys con1_tvs - con1_res_ty = case mtycon of - Just tc -> mkFamilyTyConApp tc con1_tv_tys - Nothing -> conLikeResTy con1 con1_tv_tys - - -- Check that we're not dealing with a unidirectional pattern - -- synonym - ; unless (isJust $ conLikeWrapId_maybe con1) - (nonBidirectionalErr (conLikeName con1)) - - -- STEP 3 Note [Criteria for update] - -- Check that each updated field is polymorphic; that is, its type - -- mentions only the universally-quantified variables of the data con - ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys - bad_upd_flds = filter bad_fld flds1_w_tys - con1_tv_set = mkVarSet con1_tvs - bad_fld (fld, ty) = fld `elem` upd_fld_occs && - not (tyCoVarsOfType ty `subVarSet` con1_tv_set) - ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds) - - -- STEP 4 Note [Type of a record update] - -- Figure out types for the scrutinee and result - -- Both are of form (T a b c), with fresh type variables, but with - -- common variables where the scrutinee and result must have the same type - -- These are variables that appear in *any* arg of *any* of the - -- relevant constructors *except* in the updated fields - -- - ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons - is_fixed_tv tv = tv `elemVarSet` fixed_tvs - - mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType) - -- Deals with instantiation of kind variables - -- c.f. TcMType.newMetaTyVars - mk_inst_ty subst (tv, result_inst_ty) - | is_fixed_tv tv -- Same as result type - = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) - | otherwise -- Fresh type, of correct kind - = do { (subst', new_tv) <- newMetaTyVarX subst tv - ; return (subst', mkTyVarTy new_tv) } - - ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs - ; let result_inst_tys = mkTyVarTys con1_tvs' - init_subst = mkEmptyTCvSubst (getTCvInScope result_subst) - - ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst - (con1_tvs `zip` result_inst_tys) - - ; let rec_res_ty = TcType.substTy result_subst con1_res_ty - scrut_ty = TcType.substTy scrut_subst con1_res_ty - con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys - - ; wrap_res <- tcSubTypeHR (exprCtOrigin expr) - (Just expr) rec_res_ty res_ty - ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty - -- NB: normal unification is OK here (as opposed to subsumption), - -- because for this to work out, both record_rho and scrut_ty have - -- to be normal datatypes -- no contravariant stuff can go on - - -- STEP 5 - -- Typecheck the bindings - ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds - - -- STEP 6: Deal with the stupid theta - ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1) - ; instStupidTheta RecordUpdOrigin theta' - - -- Step 7: make a cast for the scrutinee, in the - -- case that it's from a data family - ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty - fam_co | Just tycon <- mtycon - , Just co_con <- tyConFamilyCoercion_maybe tycon - = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys []) - | otherwise - = idHsWrapper - - -- Step 8: Check that the req constraints are satisfied - -- For normal data constructors req_theta is empty but we must do - -- this check for pattern synonyms. - ; let req_theta' = substThetaUnchecked scrut_subst req_theta - ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta' - - -- Phew! - ; return $ - mkHsWrap wrap_res $ - RecordUpd { rupd_expr - = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr') - , rupd_flds = rbinds' - , rupd_ext = RecordUpdTc - { rupd_cons = relevant_cons - , rupd_in_tys = scrut_inst_tys - , rupd_out_tys = result_inst_tys - , rupd_wrap = req_wrap }} } - -tcExpr e@(HsRecFld _ f) res_ty - = tcCheckRecSelId e f res_ty - -{- -************************************************************************ -* * - Arithmetic sequences e.g. [a,b..] - and their parallel-array counterparts e.g. [: a,b.. :] - -* * -************************************************************************ --} - -tcExpr (ArithSeq _ witness seq) res_ty - = tcArithSeq witness seq res_ty - -{- -************************************************************************ -* * - Template Haskell -* * -************************************************************************ --} - --- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceExpr'. --- Here we get rid of it and add the finalizers to the global environment. --- --- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. -tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr))) - res_ty - = do addModFinalizersWithLclEnv mod_finalizers - tcExpr expr res_ty -tcExpr (HsSpliceE _ splice) res_ty - = tcSpliceExpr splice res_ty -tcExpr e@(HsBracket _ brack) res_ty - = tcTypedBracket e brack res_ty -tcExpr e@(HsRnBracketOut _ brack ps) res_ty - = tcUntypedBracket e brack ps res_ty - -{- -************************************************************************ -* * - Catch-all -* * -************************************************************************ --} - -tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) - -- Include ArrForm, ArrApp, which shouldn't appear at all - -- Also HsTcBracketOut, HsQuasiQuoteE - -{- -************************************************************************ -* * - Arithmetic sequences [a..b] etc -* * -************************************************************************ --} - -tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType - -> TcM (HsExpr GhcTcId) - -tcArithSeq witness seq@(From expr) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr' <- tcPolyExpr expr elt_ty - ; enum_from <- newMethodFromName (ArithSeqOrigin seq) - enumFromName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq enum_from wit' (From expr') } - -tcArithSeq witness seq@(FromThen expr1 expr2) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq enum_from_then wit' (FromThen expr1' expr2') } - -tcArithSeq witness seq@(FromTo expr1 expr2) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) - enumFromToName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq enum_from_to wit' (FromTo expr1' expr2') } - -tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; expr3' <- tcPolyExpr expr3 elt_ty - ; eft <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenToName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } - ------------------ -arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType - -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr GhcTc)) -arithSeqEltType Nothing res_ty - = do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; return (mkWpCastN coi, elt_ty, Nothing) } -arithSeqEltType (Just fl) res_ty - = do { (elt_ty, fl') - <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ - \ [elt_ty] -> return elt_ty - ; return (idHsWrapper, elt_ty, Just fl') } - -{- -************************************************************************ -* * - Applications -* * -************************************************************************ --} - --- HsArg is defined in GHC.Hs.Types - -wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn) - => LHsExpr (GhcPass id) - -> [HsArg (LHsExpr (GhcPass id)) (LHsWcType GhcRn)] - -> LHsExpr (GhcPass id) -wrapHsArgs f [] = f -wrapHsArgs f (HsValArg a : args) = wrapHsArgs (mkHsApp f a) args -wrapHsArgs f (HsTypeArg _ t : args) = wrapHsArgs (mkHsAppType f t) args -wrapHsArgs f (HsArgPar sp : args) = wrapHsArgs (L sp $ HsPar noExtField f) args - -isHsValArg :: HsArg tm ty -> Bool -isHsValArg (HsValArg {}) = True -isHsValArg (HsTypeArg {}) = False -isHsValArg (HsArgPar {}) = False - -isArgPar :: HsArg tm ty -> Bool -isArgPar (HsArgPar {}) = True -isArgPar (HsValArg {}) = False -isArgPar (HsTypeArg {}) = False - -isArgPar_maybe :: HsArg a b -> Maybe (HsArg c d) -isArgPar_maybe (HsArgPar sp) = Just $ HsArgPar sp -isArgPar_maybe _ = Nothing - -type LHsExprArgIn = HsArg (LHsExpr GhcRn) (LHsWcType GhcRn) -type LHsExprArgOut = HsArg (LHsExpr GhcTcId) (LHsWcType GhcRn) - -tcApp1 :: HsExpr GhcRn -- either HsApp or HsAppType - -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcApp1 e res_ty - = do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty - ; return (mkHsWrap wrap $ unLoc $ wrapHsArgs fun args) } - -tcApp :: Maybe SDoc -- like "The function `f' is applied to" - -- or leave out to get exactly that message - -> LHsExpr GhcRn -> [LHsExprArgIn] -- Function and args - -> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) - -- (wrap, fun, args). For an ordinary function application, - -- these should be assembled as (wrap (fun args)). - -- But OpApp is slightly different, so that's why the caller - -- must assemble - -tcApp m_herald (L sp (HsPar _ fun)) args res_ty - = tcApp m_herald fun (HsArgPar sp : args) res_ty - -tcApp m_herald (L _ (HsApp _ fun arg1)) args res_ty - = tcApp m_herald fun (HsValArg arg1 : args) res_ty - -tcApp m_herald (L _ (HsAppType _ fun ty1)) args res_ty - = tcApp m_herald fun (HsTypeArg noSrcSpan ty1 : args) res_ty - -tcApp m_herald fun@(L loc (HsRecFld _ fld_lbl)) args res_ty - | Ambiguous _ lbl <- fld_lbl -- Still ambiguous - , HsValArg (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first - , Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates - = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty - ; sel_name <- disambiguateSelector lbl sig_tc_ty - ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl) - ; tcFunApp m_herald fun (L loc tc_fun) fun_ty args res_ty } - -tcApp _m_herald (L loc (HsVar _ (L _ fun_id))) args res_ty - -- Special typing rule for tagToEnum# - | fun_id `hasKey` tagToEnumKey - , n_val_args == 1 - = tcTagToEnum loc fun_id args res_ty - where - n_val_args = count isHsValArg args - -tcApp m_herald fun args res_ty - = do { (tc_fun, fun_ty) <- tcInferFun fun - ; tcFunApp m_herald fun tc_fun fun_ty args res_ty } - ---------------------- -tcFunApp :: Maybe SDoc -- like "The function `f' is applied to" - -- or leave out to get exactly that message - -> LHsExpr GhcRn -- Renamed function - -> LHsExpr GhcTcId -> TcSigmaType -- Function and its type - -> [LHsExprArgIn] -- Arguments - -> ExpRhoType -- Overall result type - -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) - -- (wrapper-for-result, fun, args) - -- For an ordinary function application, - -- these should be assembled as wrap_res[ fun args ] - -- But OpApp is slightly different, so that's why the caller - -- must assemble - --- tcFunApp deals with the general case; --- the special cases are handled by tcApp -tcFunApp m_herald rn_fun tc_fun fun_sigma rn_args res_ty - = do { let orig = lexprCtOrigin rn_fun - - ; traceTc "tcFunApp" (ppr rn_fun <+> dcolon <+> ppr fun_sigma $$ ppr rn_args $$ ppr res_ty) - ; (wrap_fun, tc_args, actual_res_ty) - <- tcArgs rn_fun fun_sigma orig rn_args - (m_herald `orElse` mk_app_msg rn_fun rn_args) - - -- this is just like tcWrapResult, but the types don't line - -- up to call that function - ; wrap_res <- addFunResCtxt True (unLoc rn_fun) actual_res_ty res_ty $ - tcSubTypeDS_NC_O orig GenSigCtxt - (Just $ unLoc $ wrapHsArgs rn_fun rn_args) - actual_res_ty res_ty - - ; return (wrap_res, mkLHsWrap wrap_fun tc_fun, tc_args) } - -mk_app_msg :: LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc -mk_app_msg fun args = sep [ text "The" <+> text what <+> quotes (ppr expr) - , text "is applied to"] - where - what | null type_app_args = "function" - | otherwise = "expression" - -- Include visible type arguments (but not other arguments) in the herald. - -- See Note [Herald for matchExpectedFunTys] in TcUnify. - expr = mkHsAppTypes fun type_app_args - type_app_args = [hs_ty | HsTypeArg _ hs_ty <- args] - -mk_op_msg :: LHsExpr GhcRn -> SDoc -mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" - ----------------- -tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType) --- Infer type of a function -tcInferFun (L loc (HsVar _ (L _ name))) - = do { (fun, ty) <- setSrcSpan loc (tcInferId name) - -- Don't wrap a context around a plain Id - ; return (L loc fun, ty) } - -tcInferFun (L loc (HsRecFld _ f)) - = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f) - -- Don't wrap a context around a plain Id - ; return (L loc fun, ty) } - -tcInferFun fun - = tcInferSigma fun - -- NB: tcInferSigma; see TcUnify - -- Note [Deep instantiation of InferResult] in TcUnify - - ----------------- --- | Type-check the arguments to a function, possibly including visible type --- applications -tcArgs :: LHsExpr GhcRn -- ^ The function itself (for err msgs only) - -> TcSigmaType -- ^ the (uninstantiated) type of the function - -> CtOrigin -- ^ the origin for the function's type - -> [LHsExprArgIn] -- ^ the args - -> SDoc -- ^ the herald for matchActualFunTys - -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType) - -- ^ (a wrapper for the function, the tc'd args, result type) -tcArgs fun orig_fun_ty fun_orig orig_args herald - = go [] 1 orig_fun_ty orig_args - where - -- Don't count visible type arguments when determining how many arguments - -- an expression is given in an arity mismatch error, since visible type - -- arguments reported as a part of the expression herald itself. - -- See Note [Herald for matchExpectedFunTys] in TcUnify. - orig_expr_args_arity = count isHsValArg orig_args - - fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] - = case fun of - L _ (HsUnboundVar {}) -> True - _ -> False - - go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty) - - go acc_args n fun_ty (HsArgPar sp : args) - = do { (inner_wrap, args', res_ty) <- go acc_args n fun_ty args - ; return (inner_wrap, HsArgPar sp : args', res_ty) - } - - go acc_args n fun_ty (HsTypeArg l hs_ty_arg : args) - | fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] - = go acc_args (n+1) fun_ty args - - | otherwise - = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty - -- wrap1 :: fun_ty "->" upsilon_ty - ; case tcSplitForAllTy_maybe upsilon_ty of - Just (tvb, inner_ty) - | binderArgFlag tvb == Specified -> - -- It really can't be Inferred, because we've justn - -- instantiated those. But, oddly, it might just be Required. - -- See Note [Required quantifiers in the type of a term] - do { let tv = binderVar tvb - kind = tyVarKind tv - ; ty_arg <- tcHsTypeApp hs_ty_arg kind - - ; inner_ty <- zonkTcType inner_ty - -- See Note [Visible type application zonk] - ; let in_scope = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg]) - - insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty - -- NB: tv and ty_arg have the same kind, so this - -- substitution is kind-respecting - ; traceTc "VTA" (vcat [ppr tv, debugPprType kind - , debugPprType ty_arg - , debugPprType (tcTypeKind ty_arg) - , debugPprType inner_ty - , debugPprType insted_ty ]) - - ; (inner_wrap, args', res_ty) - <- go acc_args (n+1) insted_ty args - -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty - ; let inst_wrap = mkWpTyApps [ty_arg] - ; return ( inner_wrap <.> inst_wrap <.> wrap1 - , HsTypeArg l hs_ty_arg : args' - , res_ty ) } - _ -> ty_app_err upsilon_ty hs_ty_arg } - - go acc_args n fun_ty (HsValArg arg : args) - = do { (wrap, [arg_ty], res_ty) - <- matchActualFunTysPart herald fun_orig (Just (unLoc fun)) 1 fun_ty - acc_args orig_expr_args_arity - -- wrap :: fun_ty "->" arg_ty -> res_ty - ; arg' <- tcArg fun arg arg_ty n - ; (inner_wrap, args', inner_res_ty) - <- go (arg_ty : acc_args) (n+1) res_ty args - -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty - ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty doc <.> wrap - , HsValArg arg' : args' - , inner_res_ty ) } - where - doc = text "When checking the" <+> speakNth n <+> - text "argument to" <+> quotes (ppr fun) - - ty_app_err ty arg - = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty - ; failWith $ - text "Cannot apply expression of type" <+> quotes (ppr ty) $$ - text "to a visible type argument" <+> quotes (ppr arg) } - -{- Note [Required quantifiers in the type of a term] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#15859) - - data A k :: k -> Type -- A :: forall k -> k -> Type - type KindOf (a :: k) = k -- KindOf :: forall k. k -> Type - a = (undefind :: KindOf A) @Int - -With ImpredicativeTypes (thin ice, I know), we instantiate -KindOf at type (forall k -> k -> Type), so - KindOf A = forall k -> k -> Type -whose first argument is Required - -We want to reject this type application to Int, but in earlier -GHCs we had an ASSERT that Required could not occur here. - -The ice is thin; c.f. Note [No Required TyCoBinder in terms] -in GHC.Core.TyCo.Rep. - -Note [VTA for out-of-scope functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose 'wurble' is not in scope, and we have - (wurble @Int @Bool True 'x') - -Then the renamer will make (HsUnboundVar "wurble) for 'wurble', -and the typechecker will typecheck it with tcUnboundId, giving it -a type 'alpha', and emitting a deferred CHoleCan constraint, to -be reported later. - -But then comes the visible type application. If we do nothing, we'll -generate an immediate failure (in tc_app_err), saying that a function -of type 'alpha' can't be applied to Bool. That's insane! And indeed -users complain bitterly (#13834, #17150.) - -The right error is the CHoleCan, which has /already/ been emitted by -tcUnboundId. It later reports 'wurble' as out of scope, and tries to -give its type. - -Fortunately in tcArgs we still have access to the function, so we can -check if it is a HsUnboundVar. We use this info to simply skip over -any visible type arguments. We've already inferred the type of the -function, so we'll /already/ have emitted a CHoleCan constraint; -failing preserves that constraint. - -We do /not/ want to fail altogether in this case (via failM) becuase -that may abandon an entire instance decl, which (in the presence of --fdefer-type-errors) leads to leading to #17792. - -Downside; the typechecked term has lost its visible type arguments; we -don't even kind-check them. But let's jump that bridge if we come to -it. Meanwhile, let's not crash! - -Note [Visible type application zonk] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg). - -* tcHsTypeApp only guarantees that - - ty_arg is zonked - - kind(zonk(tv)) = kind(ty_arg) - (checkExpectedKind zonks as it goes). - -So we must zonk inner_ty as well, to guarantee consistency between zonk(tv) -and inner_ty. Otherwise we can build an ill-kinded type. An example was -#14158, where we had: - id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a -and we had the visible type application - id @(->) - -* We instantiated k := kappa, yielding - forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a -* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *). -* That instantiated (->) as ((->) q1 q1), and unified kappa := q1, - Here q1 :: RuntimeRep -* Now we substitute - cat :-> (->) q1 q1 :: TYPE q1 -> TYPE q1 -> * - but we must first zonk the inner_ty to get - forall (a :: TYPE q1). cat a a - so that the result of substitution is well-kinded - Failing to do so led to #14158. --} - ----------------- -tcArg :: LHsExpr GhcRn -- The function (for error messages) - -> LHsExpr GhcRn -- Actual arguments - -> TcRhoType -- expected arg type - -> Int -- # of argument - -> TcM (LHsExpr GhcTcId) -- Resulting argument -tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $ - tcPolyExprNC arg ty - ----------------- -tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId] -tcTupArgs args tys - = ASSERT( equalLength args tys ) mapM go (args `zip` tys) - where - go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty)) - go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty - ; return (L l (Present x expr')) } - go (L _ (XTupArg nec), _) = noExtCon nec - ---------------------------- --- See TcType.SyntaxOpType also for commentary -tcSyntaxOp :: CtOrigin - -> SyntaxExprRn - -> [SyntaxOpType] -- ^ shape of syntax operator arguments - -> ExpRhoType -- ^ overall result type - -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments - -> TcM (a, SyntaxExprTc) --- ^ Typecheck a syntax operator --- The operator is a variable or a lambda at this stage (i.e. renamer --- output) -tcSyntaxOp orig expr arg_tys res_ty - = tcSyntaxOpGen orig expr arg_tys (SynType res_ty) - --- | Slightly more general version of 'tcSyntaxOp' that allows the caller --- to specify the shape of the result of the syntax operator -tcSyntaxOpGen :: CtOrigin - -> SyntaxExprRn - -> [SyntaxOpType] - -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) - -> TcM (a, SyntaxExprTc) -tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside - = do { (expr, sigma) <- tcInferSigma $ noLoc op - ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma) - ; (result, expr_wrap, arg_wraps, res_wrap) - <- tcSynArgA orig sigma arg_tys res_ty $ - thing_inside - ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma ) - ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap $ unLoc expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) } -tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen" - -{- -Note [tcSynArg] -~~~~~~~~~~~~~~~ -Because of the rich structure of SyntaxOpType, we must do the -contra-/covariant thing when working down arrows, to get the -instantiation vs. skolemisation decisions correct (and, more -obviously, the orientation of the HsWrappers). We thus have -two tcSynArgs. --} - --- works on "expected" types, skolemising where necessary --- See Note [tcSynArg] -tcSynArgE :: CtOrigin - -> TcSigmaType - -> SyntaxOpType -- ^ shape it is expected to have - -> ([TcSigmaType] -> TcM a) -- ^ check the arguments - -> TcM (a, HsWrapper) - -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) -tcSynArgE orig sigma_ty syn_ty thing_inside - = do { (skol_wrap, (result, ty_wrapper)) - <- tcSkolemise GenSigCtxt sigma_ty $ \ _ rho_ty -> - go rho_ty syn_ty - ; return (result, skol_wrap <.> ty_wrapper) } - where - go rho_ty SynAny - = do { result <- thing_inside [rho_ty] - ; return (result, idHsWrapper) } - - go rho_ty SynRho -- same as SynAny, because we skolemise eagerly - = do { result <- thing_inside [rho_ty] - ; return (result, idHsWrapper) } - - go rho_ty SynList - = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty - ; result <- thing_inside [elt_ty] - ; return (result, mkWpCastN list_co) } - - go rho_ty (SynFun arg_shape res_shape) - = do { ( ( ( (result, arg_ty, res_ty) - , res_wrapper ) -- :: res_ty_out "->" res_ty - , arg_wrapper1, [], arg_wrapper2 ) -- :: arg_ty "->" arg_ty_out - , match_wrapper ) -- :: (arg_ty -> res_ty) "->" rho_ty - <- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $ - \ [arg_ty] res_ty -> - do { arg_tc_ty <- expTypeToType arg_ty - ; res_tc_ty <- expTypeToType res_ty - - -- another nested arrow is too much for now, - -- but I bet we'll never need this - ; MASSERT2( case arg_shape of - SynFun {} -> False; - _ -> True - , text "Too many nested arrows in SyntaxOpType" $$ - pprCtOrigin orig ) - - ; tcSynArgA orig arg_tc_ty [] arg_shape $ - \ arg_results -> - tcSynArgE orig res_tc_ty res_shape $ - \ res_results -> - do { result <- thing_inside (arg_results ++ res_results) - ; return (result, arg_tc_ty, res_tc_ty) }} - - ; return ( result - , match_wrapper <.> - mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper - arg_ty res_ty doc ) } - where - herald = text "This rebindable syntax expects a function with" - doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig - - go rho_ty (SynType the_ty) - = do { wrap <- tcSubTypeET orig GenSigCtxt the_ty rho_ty - ; result <- thing_inside [] - ; return (result, wrap) } - --- works on "actual" types, instantiating where necessary --- See Note [tcSynArg] -tcSynArgA :: CtOrigin - -> TcSigmaType - -> [SyntaxOpType] -- ^ argument shapes - -> SyntaxOpType -- ^ result shape - -> ([TcSigmaType] -> TcM a) -- ^ check the arguments - -> TcM (a, HsWrapper, [HsWrapper], HsWrapper) - -- ^ returns a wrapper to be applied to the original function, - -- wrappers to be applied to arguments - -- and a wrapper to be applied to the overall expression -tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside - = do { (match_wrapper, arg_tys, res_ty) - <- matchActualFunTys herald orig Nothing (length arg_shapes) sigma_ty - -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) - ; ((result, res_wrapper), arg_wrappers) - <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results -> - tc_syn_arg res_ty res_shape $ \ res_results -> - thing_inside (arg_results ++ res_results) - ; return (result, match_wrapper, arg_wrappers, res_wrapper) } - where - herald = text "This rebindable syntax expects a function with" - - tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType] - -> ([TcSigmaType] -> TcM a) - -> TcM (a, [HsWrapper]) - -- the wrappers are for arguments - tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside - = do { ((result, arg_wraps), arg_wrap) - <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results -> - tc_syn_args_e arg_tys arg_shapes $ \ args_results -> - thing_inside (arg1_results ++ args_results) - ; return (result, arg_wrap : arg_wraps) } - tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] - - tc_syn_arg :: TcSigmaType -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) - -> TcM (a, HsWrapper) - -- the wrapper applies to the overall result - tc_syn_arg res_ty SynAny thing_inside - = do { result <- thing_inside [res_ty] - ; return (result, idHsWrapper) } - tc_syn_arg res_ty SynRho thing_inside - = do { (inst_wrap, rho_ty) <- deeplyInstantiate orig res_ty - -- inst_wrap :: res_ty "->" rho_ty - ; result <- thing_inside [rho_ty] - ; return (result, inst_wrap) } - tc_syn_arg res_ty SynList thing_inside - = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty - -- inst_wrap :: res_ty "->" rho_ty - ; (list_co, elt_ty) <- matchExpectedListTy rho_ty - -- list_co :: [elt_ty] ~N rho_ty - ; result <- thing_inside [elt_ty] - ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) } - tc_syn_arg _ (SynFun {}) _ - = pprPanic "tcSynArgA hits a SynFun" (ppr orig) - tc_syn_arg res_ty (SynType the_ty) thing_inside - = do { wrap <- tcSubTypeO orig GenSigCtxt res_ty the_ty - ; result <- thing_inside [] - ; return (result, wrap) } - -{- -Note [Push result type in] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unify with expected result before type-checking the args so that the -info from res_ty percolates to args. This is when we might detect a -too-few args situation. (One can think of cases when the opposite -order would give a better error message.) -experimenting with putting this first. - -Here's an example where it actually makes a real difference - - class C t a b | t a -> b - instance C Char a Bool - - data P t a = forall b. (C t a b) => MkP b - data Q t = MkQ (forall a. P t a) - - f1, f2 :: Q Char; - f1 = MkQ (MkP True) - f2 = MkQ (MkP True :: forall a. P Char a) - -With the change, f1 will type-check, because the 'Char' info from -the signature is propagated into MkQ's argument. With the check -in the other order, the extra signature in f2 is reqd. - -************************************************************************ -* * - Expressions with a type signature - expr :: type -* * -********************************************************************* -} - -tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTcId, TcType) -tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) - = setSrcSpan loc $ -- Sets the location for the implication constraint - do { (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id - ; given <- newEvVars theta - ; traceTc "tcExprSig: CompleteSig" $ - vcat [ text "poly_id:" <+> ppr poly_id <+> dcolon <+> ppr (idType poly_id) - , text "tv_prs:" <+> ppr tv_prs ] - - ; let skol_info = SigSkol ExprSigCtxt (idType poly_id) tv_prs - skol_tvs = map snd tv_prs - ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $ - tcExtendNameTyVarEnv tv_prs $ - tcPolyExprNC expr tau - - ; let poly_wrap = mkWpTyLams skol_tvs - <.> mkWpLams given - <.> mkWpLet ev_binds - ; return (mkLHsWrap poly_wrap expr', idType poly_id) } - -tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) - = setSrcSpan loc $ -- Sets the location for the implication constraint - do { (tclvl, wanted, (expr', sig_inst)) - <- pushLevelAndCaptureConstraints $ - do { sig_inst <- tcInstSig sig - ; expr' <- tcExtendNameTyVarEnv (sig_inst_skols sig_inst) $ - tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $ - tcPolyExprNC expr (sig_inst_tau sig_inst) - ; return (expr', sig_inst) } - -- See Note [Partial expression signatures] - ; let tau = sig_inst_tau sig_inst - infer_mode | null (sig_inst_theta sig_inst) - , isNothing (sig_inst_wcx sig_inst) - = ApplyMR - | otherwise - = NoRestrictions - ; (qtvs, givens, ev_binds, residual, _) - <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted - ; emitConstraints residual - - ; tau <- zonkTcType tau - ; let inferred_theta = map evVarPred givens - tau_tvs = tyCoVarsOfType tau - ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta - tau_tvs qtvs (Just sig_inst) - ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau - my_sigma = mkForAllTys binders (mkPhiTy my_theta tau) - ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis. - then return idHsWrapper -- Fast path; also avoids complaint when we infer - -- an ambiguous type and have AllowAmbiguousType - -- e..g infer x :: forall a. F a -> Int - else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma - - ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) - ; let poly_wrap = wrap - <.> mkWpTyLams qtvs - <.> mkWpLams givens - <.> mkWpLet ev_binds - ; return (mkLHsWrap poly_wrap expr', my_sigma) } - - -{- Note [Partial expression signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Partial type signatures on expressions are easy to get wrong. But -here is a guiding principile - e :: ty -should behave like - let x :: ty - x = e - in x - -So for partial signatures we apply the MR if no context is given. So - e :: IO _ apply the MR - e :: _ => IO _ do not apply the MR -just like in TcBinds.decideGeneralisationPlan - -This makes a difference (#11670): - peek :: Ptr a -> IO CLong - peek ptr = peekElemOff undefined 0 :: _ -from (peekElemOff undefined 0) we get - type: IO w - constraints: Storable w - -We must NOT try to generalise over 'w' because the signature specifies -no constraints so we'll complain about not being able to solve -Storable w. Instead, don't generalise; then _ gets instantiated to -CLong, as it should. --} - -{- ********************************************************************* -* * - tcInferId -* * -********************************************************************* -} - -tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcCheckId name res_ty - = do { (expr, actual_res_ty) <- tcInferId name - ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) - ; addFunResCtxt False (HsVar noExtField (noLoc name)) actual_res_ty res_ty $ - tcWrapResultO (OccurrenceOf name) (HsVar noExtField (noLoc name)) expr - actual_res_ty res_ty } - -tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcCheckRecSelId rn_expr f@(Unambiguous _ (L _ lbl)) res_ty - = do { (expr, actual_res_ty) <- tcInferRecSelId f - ; addFunResCtxt False (HsRecFld noExtField f) actual_res_ty res_ty $ - tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty } -tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty - = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of - Nothing -> ambiguousSelector lbl - Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg - ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl) - res_ty } -tcCheckRecSelId _ (XAmbiguousFieldOcc nec) _ = noExtCon nec - ------------------------- -tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType) -tcInferRecSelId (Unambiguous sel (L _ lbl)) - = do { (expr', ty) <- tc_infer_id lbl sel - ; return (expr', ty) } -tcInferRecSelId (Ambiguous _ lbl) - = ambiguousSelector lbl -tcInferRecSelId (XAmbiguousFieldOcc nec) = noExtCon nec - ------------------------- -tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType) --- Look up an occurrence of an Id --- Do not instantiate its type -tcInferId id_name - | id_name `hasKey` tagToEnumKey - = failWithTc (text "tagToEnum# must appear applied to one argument") - -- tcApp catches the case (tagToEnum# arg) - - | id_name `hasKey` assertIdKey - = do { dflags <- getDynFlags - ; if gopt Opt_IgnoreAsserts dflags - then tc_infer_id (nameRdrName id_name) id_name - else tc_infer_assert id_name } - - | otherwise - = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name - ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty) - ; return (expr, ty) } - -tc_infer_assert :: Name -> TcM (HsExpr GhcTcId, TcSigmaType) --- Deal with an occurrence of 'assert' --- See Note [Adding the implicit parameter to 'assert'] -tc_infer_assert assert_name - = do { assert_error_id <- tcLookupId assertErrorName - ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) - (idType assert_error_id) - ; return (mkHsWrap wrap (HsVar noExtField (noLoc assert_error_id)), id_rho) - } - -tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType) -tc_infer_id lbl id_name - = do { thing <- tcLookup id_name - ; case thing of - ATcId { tct_id = id } - -> do { check_naughty id -- Note [Local record selectors] - ; checkThLocalId id - ; return_id id } - - AGlobal (AnId id) - -> do { check_naughty id - ; return_id id } - -- A global cannot possibly be ill-staged - -- nor does it need the 'lifting' treatment - -- hence no checkTh stuff here - - AGlobal (AConLike cl) -> case cl of - RealDataCon con -> return_data_con con - PatSynCon ps -> tcPatSynBuilderOcc ps - - _ -> failWithTc $ - ppr thing <+> text "used where a value identifier was expected" } - where - return_id id = return (HsVar noExtField (noLoc id), idType id) - - return_data_con con - -- For data constructors, must perform the stupid-theta check - | null stupid_theta - = return (HsConLikeOut noExtField (RealDataCon con), con_ty) - - | otherwise - -- See Note [Instantiating stupid theta] - = do { let (tvs, theta, rho) = tcSplitSigmaTy con_ty - ; (subst, tvs') <- newMetaTyVars tvs - ; let tys' = mkTyVarTys tvs' - theta' = substTheta subst theta - rho' = substTy subst rho - ; wrap <- instCall (OccurrenceOf id_name) tys' theta' - ; addDataConStupidTheta con tys' - ; return ( mkHsWrap wrap (HsConLikeOut noExtField (RealDataCon con)) - , rho') } - - where - con_ty = dataConUserType con - stupid_theta = dataConStupidTheta con - - check_naughty id - | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) - | otherwise = return () - - -tcUnboundId :: HsExpr GhcRn -> OccName -> ExpRhoType -> TcM (HsExpr GhcTcId) --- Typecheck an occurrence of an unbound Id --- --- Some of these started life as a true expression hole "_". --- Others might simply be variables that accidentally have no binding site --- --- We turn all of them into HsVar, since HsUnboundVar can't contain an --- Id; and indeed the evidence for the CHoleCan does bind it, so it's --- not unbound any more! -tcUnboundId rn_expr occ res_ty - = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531) - ; name <- newSysName occ - ; let ev = mkLocalId name ty - ; can <- newHoleCt ExprHole ev ty - ; emitInsoluble can - ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr - (HsVar noExtField (noLoc ev)) ty res_ty } - - -{- -Note [Adding the implicit parameter to 'assert'] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker transforms (assert e1 e2) to (assertError e1 e2). -This isn't really the Right Thing because there's no way to "undo" -if you want to see the original source code in the typechecker -output. We'll have fix this in due course, when we care more about -being able to reconstruct the exact original program. - -Note [tagToEnum#] -~~~~~~~~~~~~~~~~~ -Nasty check to ensure that tagToEnum# is applied to a type that is an -enumeration TyCon. Unification may refine the type later, but this -check won't see that, alas. It's crude, because it relies on our -knowing *now* that the type is ok, which in turn relies on the -eager-unification part of the type checker pushing enough information -here. In theory the Right Thing to do is to have a new form of -constraint but I definitely cannot face that! And it works ok as-is. - -Here's are two cases that should fail - f :: forall a. a - f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable - - g :: Int - g = tagToEnum# 0 -- Int is not an enumeration - -When data type families are involved it's a bit more complicated. - data family F a - data instance F [Int] = A | B | C -Then we want to generate something like - tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int] -Usually that coercion is hidden inside the wrappers for -constructors of F [Int] but here we have to do it explicitly. - -It's all grotesquely complicated. - -Note [Instantiating stupid theta] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Normally, when we infer the type of an Id, we don't instantiate, -because we wish to allow for visible type application later on. -But if a datacon has a stupid theta, we're a bit stuck. We need -to emit the stupid theta constraints with instantiated types. It's -difficult to defer this to the lazy instantiation, because a stupid -theta has no spot to put it in a type. So we just instantiate eagerly -in this case. Thus, users cannot use visible type application with -a data constructor sporting a stupid theta. I won't feel so bad for -the users that complain. - --} - -tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType - -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) --- tagToEnum# :: forall a. Int# -> a --- See Note [tagToEnum#] Urgh! -tcTagToEnum loc fun_name args res_ty - = do { fun <- tcLookupId fun_name - - ; let pars1 = mapMaybe isArgPar_maybe before - pars2 = mapMaybe isArgPar_maybe after - -- args contains exactly one HsValArg - (before, _:after) = break isHsValArg args - - ; arg <- case filterOut isArgPar args of - [HsTypeArg _ hs_ty_arg, HsValArg term_arg] - -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind - ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg res_ty - -- other than influencing res_ty, we just - -- don't care about a type arg passed in. - -- So drop the evidence. - ; return term_arg } - [HsValArg term_arg] -> do { _ <- expTypeToType res_ty - ; return term_arg } - _ -> too_many_args "tagToEnum#" args - - ; res_ty <- readExpType res_ty - ; ty' <- zonkTcType res_ty - - -- Check that the type is algebraic - ; let mb_tc_app = tcSplitTyConApp_maybe ty' - Just (tc, tc_args) = mb_tc_app - ; checkTc (isJust mb_tc_app) - (mk_error ty' doc1) - - -- Look through any type family - ; fam_envs <- tcGetFamInstEnvs - ; let (rep_tc, rep_args, coi) - = tcLookupDataFamInst fam_envs tc tc_args - -- coi :: tc tc_args ~R rep_tc rep_args - - ; checkTc (isEnumerationTyCon rep_tc) - (mk_error ty' doc2) - - ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy) - ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExtField (L loc fun))) - rep_ty = mkTyConApp rep_tc rep_args - out_args = concat - [ pars1 - , [HsValArg arg'] - , pars2 - ] - - ; return (mkWpCastR (mkTcSymCo coi), fun', out_args) } - -- coi is a Representational coercion - where - doc1 = vcat [ text "Specify the type by giving a type signature" - , text "e.g. (tagToEnum# x) :: Bool" ] - doc2 = text "Result type must be an enumeration type" - - mk_error :: TcType -> SDoc -> SDoc - mk_error ty what - = hang (text "Bad call to tagToEnum#" - <+> text "at type" <+> ppr ty) - 2 what - -too_many_args :: String -> [LHsExprArgIn] -> TcM a -too_many_args fun args - = failWith $ - hang (text "Too many type arguments to" <+> text fun <> colon) - 2 (sep (map pp args)) - where - pp (HsValArg e) = ppr e - pp (HsTypeArg _ (HsWC { hswc_body = L _ t })) = pprHsType t - pp (HsTypeArg _ (XHsWildCardBndrs nec)) = noExtCon nec - pp (HsArgPar _) = empty - - -{- -************************************************************************ -* * - Template Haskell checks -* * -************************************************************************ --} - -checkThLocalId :: Id -> TcM () --- The renamer has already done checkWellStaged, --- in RnSplice.checkThLocalName, so don't repeat that here. --- Here we just just add constraints fro cross-stage lifting -checkThLocalId id - = do { mb_local_use <- getStageAndBindLevel (idName id) - ; case mb_local_use of - Just (top_lvl, bind_lvl, use_stage) - | thLevel use_stage > bind_lvl - -> checkCrossStageLifting top_lvl id use_stage - _ -> return () -- Not a locally-bound thing, or - -- no cross-stage link - } - --------------------------------------- -checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM () --- If we are inside typed brackets, and (use_lvl > bind_lvl) --- we must check whether there's a cross-stage lift to do --- Examples \x -> [|| x ||] --- [|| map ||] --- --- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but --- this code is applied to *typed* brackets. - -checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) - | isTopLevel top_lvl - = when (isExternalName id_name) (keepAlive id_name) - -- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice - - | otherwise - = -- Nested identifiers, such as 'x' in - -- E.g. \x -> [|| h x ||] - -- We must behave as if the reference to x was - -- h $(lift x) - -- We use 'x' itself as the splice proxy, used by - -- the desugarer to stitch it all back together. - -- If 'x' occurs many times we may get many identical - -- 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) (polySpliceErr 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 - -- solve this, and it's probably unimportant, so I'm - -- just going to flag an error for now - - ; lift <- if isStringTy id_ty then - do { sid <- tcLookupId THNames.liftStringName - -- See Note [Lifting strings] - ; return (HsVar noExtField (noLoc sid)) } - else - setConstraintVar lie_var $ - -- Put the 'lift' constraint into the right LIE - newMethodFromName (OccurrenceOf id_name) - THNames.liftName - [getRuntimeRep id_ty, id_ty] - - -- Update the pending splices - ; ps <- readMutVar ps_var - ; let pending_splice = PendingTcSplice id_name - (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLoc lift)) - (nlHsVar id)) - ; writeMutVar ps_var (pending_splice : ps) - - ; return () } - where - id_name = idName id - -checkCrossStageLifting _ _ _ = return () - -polySpliceErr :: Id -> SDoc -polySpliceErr id - = text "Can't splice the polymorphic local variable" <+> quotes (ppr id) - -{- -Note [Lifting strings] -~~~~~~~~~~~~~~~~~~~~~~ -If we see $(... [| s |] ...) where s::String, we don't want to -generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. -So this conditional short-circuits the lifting mechanism to generate -(liftString "xy") in that case. I didn't want to use overlapping instances -for the Lift class in TH.Syntax, because that can lead to overlapping-instance -errors in a polymorphic situation. - -If this check fails (which isn't impossible) we get another chance; see -Note [Converting strings] in Convert.hs - -Local record selectors -~~~~~~~~~~~~~~~~~~~~~~ -Record selectors for TyCons in this module are ordinary local bindings, -which show up as ATcIds rather than AGlobals. So we need to check for -naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds. - - -************************************************************************ -* * -\subsection{Record bindings} -* * -************************************************************************ --} - -getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet --- These tyvars must not change across the updates -getFixedTyVars upd_fld_occs univ_tvs cons - = mkVarSet [tv1 | con <- cons - , let (u_tvs, _, eqspec, prov_theta - , req_theta, arg_tys, _) - = conLikeFullSig con - theta = eqSpecPreds eqspec - ++ prov_theta - ++ req_theta - flds = conLikeFieldLabels con - fixed_tvs = exactTyCoVarsOfTypes fixed_tys - -- fixed_tys: See Note [Type of a record update] - `unionVarSet` tyCoVarsOfTypes theta - -- Universally-quantified tyvars that - -- appear in any of the *implicit* - -- arguments to the constructor are fixed - -- See Note [Implicit type sharing] - - fixed_tys = [ty | (fl, ty) <- zip flds arg_tys - , not (flLabel fl `elem` upd_fld_occs)] - , (tv1,tv) <- univ_tvs `zip` u_tvs - , tv `elemVarSet` fixed_tvs ] - -{- -Note [Disambiguating record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the -XDuplicateRecordFields extension is used, and the renamer -encounters a record selector or update that it cannot immediately -disambiguate (because it involves fields that belong to multiple -datatypes), it will defer resolution of the ambiguity to the -typechecker. In this case, the `Ambiguous` constructor of -`AmbiguousFieldOcc` is used. - -Consider the following definitions: - - data S = MkS { foo :: Int } - data T = MkT { foo :: Int, bar :: Int } - data U = MkU { bar :: Int, baz :: Int } - -When the renamer sees `foo` as a selector or an update, it will not -know which parent datatype is in use. - -For selectors, there are two possible ways to disambiguate: - -1. Check if the pushed-in type is a function whose domain is a - datatype, for example: - - f s = (foo :: S -> Int) s - - g :: T -> Int - g = foo - - This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`. - -2. Check if the selector is applied to an argument that has a type - signature, for example: - - h = foo (s :: S) - - This is checked by `tcApp`. - - -Updates are slightly more complex. The `disambiguateRecordBinds` -function tries to determine the parent datatype in three ways: - -1. Check for types that have all the fields being updated. For example: - - f x = x { foo = 3, bar = 2 } - - Here `f` must be updating `T` because neither `S` nor `U` have - both fields. This may also discover that no possible type exists. - For example the following will be rejected: - - f' x = x { foo = 3, baz = 3 } - -2. Use the type being pushed in, if it is already a TyConApp. The - following are valid updates to `T`: - - g :: T -> T - g x = x { foo = 3 } - - g' x = x { foo = 3 } :: T - -3. Use the type signature of the record expression, if it exists and - is a TyConApp. Thus this is valid update to `T`: - - h x = (x :: T) { foo = 3 } - - -Note that we do not look up the types of variables being updated, and -no constraint-solving is performed, so for example the following will -be rejected as ambiguous: - - let bad (s :: S) = foo s - - let r :: T - r = blah - in r { foo = 3 } - - \r. (r { foo = 3 }, r :: T ) - -We could add further tests, of a more heuristic nature. For example, -rather than looking for an explicit signature, we could try to infer -the type of the argument to a selector or the record expression being -updated, in case we are lucky enough to get a TyConApp straight -away. However, it might be hard for programmers to predict whether a -particular update is sufficiently obvious for the signature to be -omitted. Moreover, this might change the behaviour of typechecker in -non-obvious ways. - -See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat. --} - --- Given a RdrName that refers to multiple record fields, and the type --- of its argument, try to determine the name of the selector that is --- meant. -disambiguateSelector :: Located RdrName -> Type -> TcM Name -disambiguateSelector lr@(L _ rdr) parent_type - = do { fam_inst_envs <- tcGetFamInstEnvs - ; case tyConOf fam_inst_envs parent_type of - Nothing -> ambiguousSelector lr - Just p -> - do { xs <- lookupParents rdr - ; let parent = RecSelData p - ; case lookup parent xs of - Just gre -> do { addUsedGRE True gre - ; return (gre_name gre) } - Nothing -> failWithTc (fieldNotInType parent rdr) } } - --- This field name really is ambiguous, so add a suitable "ambiguous --- occurrence" error, then give up. -ambiguousSelector :: Located RdrName -> TcM a -ambiguousSelector (L _ rdr) - = do { addAmbiguousNameErr rdr - ; failM } - --- | This name really is ambiguous, so add a suitable "ambiguous --- occurrence" error, then continue -addAmbiguousNameErr :: RdrName -> TcM () -addAmbiguousNameErr rdr - = do { env <- getGlobalRdrEnv - ; let gres = lookupGRE_RdrName rdr env - ; setErrCtxt [] $ addNameClashErrRn rdr gres} - --- Disambiguate the fields in a record update. --- See Note [Disambiguating record fields] -disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType - -> [LHsRecUpdField GhcRn] -> ExpRhoType - -> TcM [LHsRecField' (AmbiguousFieldOcc 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 } - where - -- Extract the selector name of a field update if it is unambiguous - isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name) - isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of - Unambiguous sel_name _ -> Just (x, sel_name) - Ambiguous{} -> Nothing - XAmbiguousFieldOcc nec -> noExtCon nec - - -- Look up the possible parents and selector GREs for each field - getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn - , [(RecSelParent, GlobalRdrElt)])] - getUpdFieldsParents - = fmap (zip rbnds) $ mapM - (lookupParents . 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 (noPossibleParents rbnds) - - -- Exactly one datatype with all the fields: use that - [p] -> return p - - -- 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 -> return (RecSelData p) - - -- 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 - -> return (RecSelData tc) - - -- Nothing else we can try... - _ -> failWithTc badOverloadedUpdate - - -- 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 (LHsRecField' (AmbiguousFieldOcc 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 _ = hsRecFieldLbl (unLoc upd) - setSrcSpan loc $ addUsedGRE True gre - ; lookupSelector (upd, gre_name 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, gre_name (snd (head xs))) } - - -- 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 (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) - lookupSelector (L l upd, n) - = do { i <- tcLookupId n - ; let L loc af = hsRecFieldLbl upd - lbl = rdrNameAmbiguousFieldOcc af - ; return $ L l upd { hsRecFieldLbl - = L loc (Unambiguous i (L loc lbl)) } } - - --- Extract the outermost TyCon of a type, if there is one; for --- data families this is the representation tycon (because that's --- where the fields live). -tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon -tyConOf fam_inst_envs ty0 - = case tcSplitTyConApp_maybe ty of - Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys)) - Nothing -> Nothing - where - (_, _, ty) = tcSplitSigmaTy ty0 - --- Variant of tyConOf that works for ExpTypes -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 :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)] -lookupParents rdr - = do { env <- getGlobalRdrEnv - ; let gres = lookupGRE_RdrName rdr env - ; mapM lookupParent gres } - where - lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) - lookupParent gre = do { id <- tcLookupId (gre_name gre) - ; if isRecordSelector id - then return (recordSelectorTyCon id, gre) - else failWithTc (notSelector (gre_name gre)) } - --- A type signature on the argument of an ambiguous record selector or --- the record expression in an update must be "obvious", i.e. the --- outermost constructor ignoring parentheses. -obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) -obviousSig (ExprWithTySig _ _ ty) = Just ty -obviousSig (HsPar _ p) = obviousSig (unLoc p) -obviousSig _ = Nothing - - -{- -Game plan for record bindings -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -1. Find the TyCon for the bindings, from the first field label. - -2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. - -For each binding field = value - -3. Instantiate the field type (from the field label) using the type - envt from step 2. - -4 Type check the value using tcArg, passing the field type as - the expected argument type. - -This extends OK when the field types are universally quantified. --} - -tcRecordBinds - :: ConLike - -> [TcType] -- Expected type for each field - -> HsRecordBinds GhcRn - -> TcM (HsRecordBinds GhcTcId) - -tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) - = do { mb_binds <- mapM do_bind rbinds - ; return (HsRecFields (catMaybes mb_binds) dd) } - where - fields = map flSelector $ conLikeFieldLabels con_like - flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys - - do_bind :: LHsRecField GhcRn (LHsExpr GhcRn) - -> TcM (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))) - do_bind (L l fld@(HsRecField { hsRecFieldLbl = f - , hsRecFieldArg = rhs })) - - = do { mb <- tcRecordField con_like flds_w_tys f rhs - ; case mb of - Nothing -> return Nothing - Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f' - , hsRecFieldArg = rhs' }))) } - -tcRecordUpd - :: ConLike - -> [TcType] -- Expected type for each field - -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] - -> TcM [LHsRecUpdField GhcTcId] - -tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds - where - fields = map flSelector $ conLikeFieldLabels con_like - flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys - - do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) - -> TcM (Maybe (LHsRecUpdField GhcTcId)) - do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af - , hsRecFieldArg = rhs })) - = do { let lbl = rdrNameAmbiguousFieldOcc af - sel_id = selectorAmbiguousFieldOcc af - f = L loc (FieldOcc (idName sel_id) (L loc lbl)) - ; mb <- tcRecordField con_like flds_w_tys f rhs - ; case mb of - Nothing -> return Nothing - Just (f', rhs') -> - return (Just - (L l (fld { hsRecFieldLbl - = L loc (Unambiguous - (extFieldOcc (unLoc f')) - (L loc lbl)) - , hsRecFieldArg = rhs' }))) } - -tcRecordField :: ConLike -> Assoc Name Type - -> LFieldOcc GhcRn -> LHsExpr GhcRn - -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) -tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs - | Just field_ty <- assocMaybe flds_w_tys sel_name - = addErrCtxt (fieldCtxt field_lbl) $ - do { rhs' <- tcPolyExprNC rhs field_ty - ; let field_id = mkUserLocal (nameOccName sel_name) - (nameUnique sel_name) - field_ty loc - -- Yuk: the field_id has the *unique* of the selector Id - -- (so we can find it easily) - -- but is a LocalId with the appropriate type of the RHS - -- (so the desugarer knows the type of local binder to make) - ; return (Just (L loc (FieldOcc field_id lbl), rhs')) } - | otherwise - = do { addErrTc (badFieldCon con_like field_lbl) - ; return Nothing } - where - field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) -tcRecordField _ _ (L _ (XFieldOcc nec)) _ = noExtCon nec - - -checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM () -checkMissingFields con_like rbinds - | null field_labels -- Not declared as a record; - -- But C{} is still valid if no strict fields - = if any isBanged field_strs then - -- Illegal if any arg is strict - addErrTc (missingStrictFields con_like []) - else do - warn <- woptM Opt_WarnMissingFields - when (warn && notNull field_strs && null field_labels) - (warnTc (Reason Opt_WarnMissingFields) True - (missingFields con_like [])) - - | otherwise = do -- A record - unless (null missing_s_fields) - (addErrTc (missingStrictFields con_like missing_s_fields)) - - warn <- woptM Opt_WarnMissingFields - when (warn && notNull missing_ns_fields) - (warnTc (Reason Opt_WarnMissingFields) True - (missingFields con_like missing_ns_fields)) - - where - missing_s_fields - = [ flLabel fl | (fl, str) <- field_info, - isBanged str, - not (fl `elemField` field_names_used) - ] - missing_ns_fields - = [ flLabel fl | (fl, str) <- field_info, - not (isBanged str), - not (fl `elemField` field_names_used) - ] - - field_names_used = hsRecFields rbinds - field_labels = conLikeFieldLabels con_like - - field_info = zipEqual "missingFields" - field_labels - field_strs - - field_strs = conLikeImplBangs con_like - - fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds - -{- -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ - -Boring and alphabetical: --} - -addExprErrCtxt :: LHsExpr GhcRn -> TcM a -> TcM a -addExprErrCtxt expr = addErrCtxt (exprCtxt expr) - -exprCtxt :: LHsExpr GhcRn -> SDoc -exprCtxt expr - = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr)) - -fieldCtxt :: FieldLabelString -> SDoc -fieldCtxt field_name - = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") - -addFunResCtxt :: Bool -- There is at least one argument - -> HsExpr GhcRn -> TcType -> ExpRhoType - -> TcM a -> TcM a --- When we have a mis-match in the return type of a function --- try to give a helpful message about too many/few arguments --- --- Used for naked variables too; but with has_args = False -addFunResCtxt has_args fun fun_res_ty env_ty - = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg) - -- NB: use a landmark error context, so that an empty context - -- doesn't suppress some more useful context - where - mk_msg - = 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 } - ; let -- See Note [Splitting nested sigma types in mismatched - -- function types] - (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res' - -- No need to call tcSplitNestedSigmaTys here, since env_ty is - -- an ExpRhoTy, i.e., it's already deeply instantiated. - (_, _, env_tau) = tcSplitSigmaTy env' - (args_fun, res_fun) = tcSplitFunTys fun_tau - (args_env, res_env) = tcSplitFunTys env_tau - n_fun = length args_fun - n_env = length args_env - info | n_fun == n_env = Outputable.empty - | n_fun > n_env - , not_fun res_env - = text "Probable cause:" <+> quotes (ppr fun) - <+> text "is applied to too few arguments" - - | has_args - , not_fun res_fun - = text "Possible cause:" <+> quotes (ppr fun) - <+> text "is applied to too many arguments" - - | otherwise - = Outputable.empty -- Never suggest that a naked variable is -- applied to too many args! - ; return info } - where - not_fun ty -- ty is definitely not an arrow type, - -- and cannot conceivably become one - = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> isAlgTyCon tc - Nothing -> False - -{- -Note [Splitting nested sigma types in mismatched function types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When one applies a function to too few arguments, GHC tries to determine this -fact if possible so that it may give a helpful error message. It accomplishes -this by checking if the type of the applied function has more argument types -than supplied arguments. - -Previously, GHC computed the number of argument types through tcSplitSigmaTy. -This is incorrect in the face of nested foralls, however! This caused Trac -#13311, for instance: - - f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b - -If one uses `f` like so: - - do { f; putChar 'a' } - -Then tcSplitSigmaTy will decompose the type of `f` into: - - Tyvars: [a] - Context: (Monoid a) - Argument types: [] - Return type: forall b. Monoid b => Maybe a -> Maybe b - -That is, it will conclude that there are *no* argument types, and since `f` -was given no arguments, it won't print a helpful error message. On the other -hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to: - - Tyvars: [a, b] - Context: (Monoid a, Monoid b) - Argument types: [Maybe a] - Return type: Maybe b - -So now GHC recognizes that `f` has one more argument type than it was actually -provided. --} - -badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc -badFieldTypes prs - = hang (text "Record update for insufficiently polymorphic field" - <> plural prs <> colon) - 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) - -badFieldsUpd - :: [LHsRecField' (AmbiguousFieldOcc 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 - -> SDoc -badFieldsUpd rbinds data_cons - = hang (text "No constructor has all these fields:") - 2 (pprQuotedList 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 (Set.member fld) fieldLabelSets)) $ - map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds - - fieldLabelSets :: [Set.Set FieldLabelString] - fieldLabelSets = map (Set.fromList . 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. --} - -naughtyRecordSel :: RdrName -> SDoc -naughtyRecordSel sel_id - = text "Cannot use record selector" <+> quotes (ppr sel_id) <+> - text "as a function due to escaped type variables" $$ - text "Probable fix: use pattern-matching syntax instead" - -notSelector :: Name -> SDoc -notSelector field - = hsep [quotes (ppr field), text "is not a record selector"] - -mixedSelectors :: [Id] -> [Id] -> SDoc -mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) - = ptext - (sLit "Cannot use a mixture of pattern synonym and record selectors") $$ - text "Record selectors defined by" - <+> quotes (ppr (tyConName rep_dc)) - <> text ":" - <+> pprWithCommas ppr data_sels $$ - text "Pattern synonym selectors defined by" - <+> quotes (ppr (patSynName rep_ps)) - <> text ":" - <+> pprWithCommas ppr pat_syn_sels - where - RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id - RecSelData rep_dc = recordSelectorTyCon dc_rep_id -mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists" - - -missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc -missingStrictFields con fields - = header <> rest - where - rest | null fields = Outputable.empty -- Happens for non-record constructors - -- with strict fields - | otherwise = colon <+> pprWithCommas ppr fields - - header = text "Constructor" <+> quotes (ppr con) <+> - text "does not have the required strict field(s)" - -missingFields :: ConLike -> [FieldLabelString] -> SDoc -missingFields con fields - = header <> rest - where - rest | null fields = Outputable.empty - | otherwise = colon <+> pprWithCommas ppr fields - header = text "Fields of" <+> quotes (ppr con) <+> - text "not initialised" - --- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args)) - -noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc -noPossibleParents rbinds - = hang (text "No type has all these fields:") - 2 (pprQuotedList fields) - where - fields = map (hsRecFieldLbl . unLoc) rbinds - -badOverloadedUpdate :: SDoc -badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature" - -fieldNotInType :: RecSelParent -> RdrName -> SDoc -fieldNotInType p rdr - = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr - -{- -************************************************************************ -* * -\subsection{Static Pointers} -* * -************************************************************************ --} - --- | A data type to describe why a variable is not closed. -data NotClosedReason = NotLetBoundReason - | NotTypeClosed VarSet - | NotClosed Name NotClosedReason - --- | Checks if the given name is closed and emits an error if not. --- --- See Note [Not-closed error messages]. -checkClosedInStaticForm :: Name -> TcM () -checkClosedInStaticForm name = do - type_env <- getLclTypeEnv - case checkClosed type_env name of - Nothing -> return () - Just reason -> addErrTc $ explain name reason - where - -- See Note [Checking closedness]. - checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason - checkClosed type_env n = checkLoop type_env (unitNameSet n) n - - checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason - checkLoop type_env visited n = do - -- The @visited@ set is an accumulating parameter that contains the set of - -- visited nodes, so we avoid repeating cycles in the traversal. - case lookupNameEnv type_env n of - Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of - ClosedLet -> Nothing - NotLetBound -> Just NotLetBoundReason - NonClosedLet fvs type_closed -> listToMaybe $ - -- Look for a non-closed variable in fvs - [ NotClosed n' reason - | n' <- nameSetElemsStable fvs - , not (elemNameSet n' visited) - , Just reason <- [checkLoop type_env (extendNameSet visited n') n'] - ] ++ - if type_closed then - [] - else - -- We consider non-let-bound variables easier to figure out than - -- non-closed types, so we report non-closed types to the user - -- only if we cannot spot the former. - [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ] - -- The binding is closed. - _ -> Nothing - - -- Converts a reason into a human-readable sentence. - -- - -- @explain name reason@ starts with - -- - -- " is used in a static form but it is not closed because it" - -- - -- and then follows a list of causes. For each id in the path, the text - -- - -- "uses which" - -- - -- is appended, yielding something like - -- - -- "uses which uses which uses which" - -- - -- until the end of the path is reached, which is reported as either - -- - -- "is not let-bound" - -- - -- when the final node is not let-bound, or - -- - -- "has a non-closed type because it contains the type variables: - -- v1, v2, v3" - -- - -- when the final node has a non-closed type. - -- - explain :: Name -> NotClosedReason -> SDoc - explain name reason = - quotes (ppr name) <+> text "is used in a static form but it is not closed" - <+> text "because it" - $$ - sep (causes reason) - - causes :: NotClosedReason -> [SDoc] - causes NotLetBoundReason = [text "is not let-bound."] - causes (NotTypeClosed vs) = - [ text "has a non-closed type because it contains the" - , text "type variables:" <+> - pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) - ] - causes (NotClosed n reason) = - let msg = text "uses" <+> quotes (ppr n) <+> text "which" - in case reason of - NotClosed _ _ -> msg : causes reason - _ -> let (xs0, xs1) = splitAt 1 $ causes reason - in fmap (msg <+>) xs0 ++ xs1 - --- Note [Not-closed error messages] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- When variables in a static form are not closed, we go through the trouble --- of explaining why they aren't. --- --- Thus, the following program --- --- > {-# LANGUAGE StaticPointers #-} --- > module M where --- > --- > f x = static g --- > where --- > g = h --- > h = x --- --- produces the error --- --- 'g' is used in a static form but it is not closed because it --- uses 'h' which uses 'x' which is not let-bound. --- --- And a program like --- --- > {-# LANGUAGE StaticPointers #-} --- > module M where --- > --- > import Data.Typeable --- > import GHC.StaticPtr --- > --- > f :: Typeable a => a -> StaticPtr TypeRep --- > f x = const (static (g undefined)) (h x) --- > where --- > g = h --- > h = typeOf --- --- produces the error --- --- 'g' is used in a static form but it is not closed because it --- uses 'h' which has a non-closed type because it contains the --- type variables: 'a' --- - --- Note [Checking closedness] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- @checkClosed@ checks if a binding is closed and returns a reason if it is --- not. --- --- The bindings define a graph where the nodes are ids, and there is an edge --- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free --- variables. --- --- When @n@ is not closed, it has to exist in the graph some node reachable --- from @n@ that it is not a let-bound variable or that it has a non-closed --- type. Thus, the "reason" is a path from @n@ to this offending node. --- --- When @n@ is not closed, we traverse the graph reachable from @n@ to build --- the reason. --- diff --git a/compiler/typecheck/TcExpr.hs-boot b/compiler/typecheck/TcExpr.hs-boot deleted file mode 100644 --- a/compiler/typecheck/TcExpr.hs-boot +++ /dev/null @@ -1,42 +0,0 @@ -module TcExpr where -import GHC.Types.Name -import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn, SyntaxExprTc ) -import TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) -import TcRnTypes( TcM ) -import TcOrigin ( CtOrigin ) -import GHC.Hs.Extension ( GhcRn, GhcTcId ) - -tcPolyExpr :: - LHsExpr GhcRn - -> TcSigmaType - -> TcM (LHsExpr GhcTcId) - -tcMonoExpr, tcMonoExprNC :: - LHsExpr GhcRn - -> ExpRhoType - -> TcM (LHsExpr GhcTcId) - -tcInferSigma :: - LHsExpr GhcRn - -> TcM (LHsExpr GhcTcId, TcSigmaType) - -tcInferRho, tcInferRhoNC :: - LHsExpr GhcRn - -> TcM (LHsExpr GhcTcId, TcRhoType) - -tcSyntaxOp :: CtOrigin - -> SyntaxExprRn - -> [SyntaxOpType] -- ^ shape of syntax operator arguments - -> ExpType -- ^ overall result type - -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments - -> TcM (a, SyntaxExprTc) - -tcSyntaxOpGen :: CtOrigin - -> SyntaxExprRn - -> [SyntaxOpType] - -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) - -> TcM (a, SyntaxExprTc) - - -tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId) diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs deleted file mode 100644 --- a/compiler/typecheck/TcFlatten.hs +++ /dev/null @@ -1,1925 +0,0 @@ -{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns, BangPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcFlatten( - FlattenMode(..), - flatten, flattenKind, flattenArgsNom, - rewriteTyVar, - - unflattenWanteds - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnTypes -import GHC.Core.TyCo.Ppr ( pprTyVar ) -import Constraint -import GHC.Core.Predicate -import TcType -import GHC.Core.Type -import TcEvidence -import GHC.Core.TyCon -import GHC.Core.TyCo.Rep -- performs delicate algorithm on types -import GHC.Core.Coercion -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import Outputable -import TcSMonad as TcS -import GHC.Types.Basic( SwapFlag(..) ) - -import Util -import Bag -import Control.Monad -import MonadUtils ( zipWith3M ) -import Data.Foldable ( foldrM ) - -import Control.Arrow ( first ) - -{- -Note [The flattening story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* A CFunEqCan is either of form - [G] : F xis ~ fsk -- fsk is a FlatSkolTv - [W] x : F xis ~ fmv -- fmv is a FlatMetaTv - where - x is the witness variable - xis are function-free - fsk/fmv is a flatten skolem; - it is always untouchable (level 0) - -* CFunEqCans can have any flavour: [G], [W], [WD] or [D] - -* KEY INSIGHTS: - - - A given flatten-skolem, fsk, is known a-priori to be equal to - F xis (the LHS), with evidence. The fsk is still a - unification variable, but it is "owned" by its CFunEqCan, and - is filled in (unflattened) only by unflattenGivens. - - - A unification flatten-skolem, fmv, stands for the as-yet-unknown - type to which (F xis) will eventually reduce. It is filled in - - - - All fsk/fmv variables are "untouchable". To make it simple to test, - we simply give them TcLevel=0. This means that in a CTyVarEq, say, - fmv ~ Int - we NEVER unify fmv. - - - A unification flatten-skolem, fmv, ONLY gets unified when either - a) The CFunEqCan takes a step, using an axiom - b) By unflattenWanteds - They are never unified in any other form of equality. - For example [W] ffmv ~ Int is stuck; it does not unify with fmv. - -* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan. - That would destroy the invariant about the shape of a CFunEqCan, - and it would risk wanted/wanted interactions. The only way we - learn information about fsk is when the CFunEqCan takes a step. - - However we *do* substitute in the LHS of a CFunEqCan (else it - would never get to fire!) - -* Unflattening: - - We unflatten Givens when leaving their scope (see unflattenGivens) - - We unflatten Wanteds at the end of each attempt to simplify the - wanteds; see unflattenWanteds, called from solveSimpleWanteds. - -* Ownership of fsk/fmv. Each canonical [G], [W], or [WD] - CFunEqCan x : F xis ~ fsk/fmv - "owns" a distinct evidence variable x, and flatten-skolem fsk/fmv. - Why? We make a fresh fsk/fmv when the constraint is born; - and we never rewrite the RHS of a CFunEqCan. - - In contrast a [D] CFunEqCan /shares/ its fmv with its partner [W], - but does not "own" it. If we reduce a [D] F Int ~ fmv, where - say type instance F Int = ty, then we don't discharge fmv := ty. - Rather we simply generate [D] fmv ~ ty (in TcInteract.reduce_top_fun_eq, - and dischargeFmv) - -* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2 - then xis1 /= xis2 - i.e. at most one CFunEqCan with a particular LHS - -* Flattening a type (F xis): - - If we are flattening in a Wanted/Derived constraint - then create new [W] x : F xis ~ fmv - else create new [G] x : F xis ~ fsk - with fresh evidence variable x and flatten-skolem fsk/fmv - - - Add it to the work list - - - Replace (F xis) with fsk/fmv in the type you are flattening - - - You can also add the CFunEqCan to the "flat cache", which - simply keeps track of all the function applications you - have flattened. - - - If (F xis) is in the cache already, just - use its fsk/fmv and evidence x, and emit nothing. - - - No need to substitute in the flat-cache. It's not the end - of the world if we start with, say (F alpha ~ fmv1) and - (F Int ~ fmv2) and then find alpha := Int. Athat will - simply give rise to fmv1 := fmv2 via [Interacting rule] below - -* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv - - Flatten xis (to substitute any tyvars; there are already no functions) - cos :: xis ~ flat_xis - - New wanted x2 :: F flat_xis ~ fsk/fmv - - Add new wanted to flat cache - - Discharge x = F cos ; x2 - -* [Interacting rule] - (inert) [W] x1 : F tys ~ fmv1 - (work item) [W] x2 : F tys ~ fmv2 - Just solve one from the other: - x2 := x1 - fmv2 := fmv1 - This just unites the two fsks into one. - Always solve given from wanted if poss. - -* For top-level reductions, see Note [Top-level reductions for type functions] - in TcInteract - - -Why given-fsks, alone, doesn't work -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Could we get away with only flatten meta-tyvars, with no flatten-skolems? No. - - [W] w : alpha ~ [F alpha Int] - ----> flatten - w = ...w'... - [W] w' : alpha ~ [fsk] - [G] : F alpha Int ~ fsk - ---> unify (no occurs check) - alpha := [fsk] - -But since fsk = F alpha Int, this is really an occurs check error. If -that is all we know about alpha, we will succeed in constraint -solving, producing a program with an infinite type. - -Even if we did finally get (g : fsk ~ Bool) by solving (F alpha Int ~ fsk) -using axiom, zonking would not see it, so (x::alpha) sitting in the -tree will get zonked to an infinite type. (Zonking always only does -refl stuff.) - -Why flatten-meta-vars, alone doesn't work -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Look at Simple13, with unification-fmvs only - - [G] g : a ~ [F a] - ----> Flatten given - g' = g;[x] - [G] g' : a ~ [fmv] - [W] x : F a ~ fmv - ---> subst a in x - g' = g;[x] - x = F g' ; x2 - [W] x2 : F [fmv] ~ fmv - -And now we have an evidence cycle between g' and x! - -If we used a given instead (ie current story) - - [G] g : a ~ [F a] - ----> Flatten given - g' = g;[x] - [G] g' : a ~ [fsk] - [G] : F a ~ fsk - ----> Substitute for a - [G] g' : a ~ [fsk] - [G] F (sym g'); : F [fsk] ~ fsk - - -Why is it right to treat fmv's differently to ordinary unification vars? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - f :: forall a. a -> a -> Bool - g :: F Int -> F Int -> Bool - -Consider - f (x:Int) (y:Bool) -This gives alpha~Int, alpha~Bool. There is an inconsistency, -but really only one error. SherLoc may tell you which location -is most likely, based on other occurrences of alpha. - -Consider - g (x:Int) (y:Bool) -Here we get (F Int ~ Int, F Int ~ Bool), which flattens to - (fmv ~ Int, fmv ~ Bool) -But there are really TWO separate errors. - - ** We must not complain about Int~Bool. ** - -Moreover these two errors could arise in entirely unrelated parts of -the code. (In the alpha case, there must be *some* connection (eg -v:alpha in common envt).) - -Note [Unflattening can force the solver to iterate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Look at #10340: - type family Any :: * -- No instances - get :: MonadState s m => m s - instance MonadState s (State s) where ... - - foo :: State Any Any - foo = get - -For 'foo' we instantiate 'get' at types mm ss - [WD] MonadState ss mm, [WD] mm ss ~ State Any Any -Flatten, and decompose - [WD] MonadState ss mm, [WD] Any ~ fmv - [WD] mm ~ State fmv, [WD] fmv ~ ss -Unify mm := State fmv: - [WD] MonadState ss (State fmv) - [WD] Any ~ fmv, [WD] fmv ~ ss -Now we are stuck; the instance does not match!! So unflatten: - fmv := Any - ss := Any (*) - [WD] MonadState Any (State Any) - -The unification (*) represents progress, so we must do a second -round of solving; this time it succeeds. This is done by the 'go' -loop in solveSimpleWanteds. - -This story does not feel right but it's the best I can do; and the -iteration only happens in pretty obscure circumstances. - - -************************************************************************ -* * -* Examples - Here is a long series of examples I had to work through -* * -************************************************************************ - -Simple20 -~~~~~~~~ -axiom F [a] = [F a] - - [G] F [a] ~ a ---> - [G] fsk ~ a - [G] [F a] ~ fsk (nc) ---> - [G] F a ~ fsk2 - [G] fsk ~ [fsk2] - [G] fsk ~ a ---> - [G] F a ~ fsk2 - [G] a ~ [fsk2] - [G] fsk ~ a - ----------------------------------------- -indexed-types/should_compile/T44984 - - [W] H (F Bool) ~ H alpha - [W] alpha ~ F Bool ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 - - fmv1 ~ fmv2 - fmv0 ~ alpha - -flatten -~~~~~~~ - fmv0 := F Bool - fmv1 := H (F Bool) - fmv2 := H alpha - alpha := F Bool -plus - fmv1 ~ fmv2 - -But these two are equal under the above assumptions. -Solve by Refl. - - ---- under plan B, namely solve fmv1:=fmv2 eagerly --- - [W] H (F Bool) ~ H alpha - [W] alpha ~ F Bool ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 - - fmv1 ~ fmv2 - fmv0 ~ alpha ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 fmv2 := fmv1 - - fmv0 ~ alpha - -flatten - fmv0 := F Bool - fmv1 := H fmv0 = H (F Bool) - retain H alpha ~ fmv2 - because fmv2 has been filled - alpha := F Bool - - ----------------------------- -indexed-types/should_failt/T4179 - -after solving - [W] fmv_1 ~ fmv_2 - [W] A3 (FCon x) ~ fmv_1 (CFunEqCan) - [W] A3 (x (aoa -> fmv_2)) ~ fmv_2 (CFunEqCan) - ----------------------------------------- -indexed-types/should_fail/T7729a - -a) [W] BasePrimMonad (Rand m) ~ m1 -b) [W] tt m1 ~ BasePrimMonad (Rand m) - ----> process (b) first - BasePrimMonad (Ramd m) ~ fmv_atH - fmv_atH ~ tt m1 - ----> now process (a) - m1 ~ s_atH ~ tt m1 -- An obscure occurs check - - ----------------------------------------- -typecheck/TcTypeNatSimple - -Original constraint - [W] x + y ~ x + alpha (non-canonical) -==> - [W] x + y ~ fmv1 (CFunEqCan) - [W] x + alpha ~ fmv2 (CFuneqCan) - [W] fmv1 ~ fmv2 (CTyEqCan) - -(sigh) - ----------------------------------------- -indexed-types/should_fail/GADTwrong1 - - [G] Const a ~ () -==> flatten - [G] fsk ~ () - work item: Const a ~ fsk -==> fire top rule - [G] fsk ~ () - work item fsk ~ () - -Surely the work item should rewrite to () ~ ()? Well, maybe not; -it'a very special case. More generally, our givens look like -F a ~ Int, where (F a) is not reducible. - - ----------------------------------------- -indexed_types/should_fail/T8227: - -Why using a different can-rewrite rule in CFunEqCan heads -does not work. - -Assuming NOT rewriting wanteds with wanteds - - Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk - [W] fmv_aBk ~ fsk_aBh - - [G] Scalar fsk_aBg ~ fsk_aBh - [G] V a ~ f_aBg - - Worklist includes [W] Scalar fmv_aBi ~ fmv_aBk - fmv_aBi, fmv_aBk are flatten unification variables - - Work item: [W] V fsk_aBh ~ fmv_aBi - -Note that the inert wanteds are cyclic, because we do not rewrite -wanteds with wanteds. - - -Then we go into a loop when normalise the work-item, because we -use rewriteOrSame on the argument of V. - -Conclusion: Don't make canRewrite context specific; instead use -[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable. - - ----------------------------------------- - -Here is a somewhat similar case: - - type family G a :: * - - blah :: (G a ~ Bool, Eq (G a)) => a -> a - blah = error "urk" - - foo x = blah x - -For foo we get - [W] Eq (G a), G a ~ Bool -Flattening - [W] G a ~ fmv, Eq fmv, fmv ~ Bool -We can't simplify away the Eq Bool unless we substitute for fmv. -Maybe that doesn't matter: we would still be left with unsolved -G a ~ Bool. - --------------------------- -#9318 has a very simple program leading to - - [W] F Int ~ Int - [W] F Int ~ Bool - -We don't want to get "Error Int~Bool". But if fmv's can rewrite -wanteds, we will - - [W] fmv ~ Int - [W] fmv ~ Bool ----> - [W] Int ~ Bool - - -************************************************************************ -* * -* FlattenEnv & FlatM -* The flattening environment & monad -* * -************************************************************************ - --} - -type FlatWorkListRef = TcRef [Ct] -- See Note [The flattening work list] - -data FlattenEnv - = FE { fe_mode :: !FlattenMode - , fe_loc :: CtLoc -- See Note [Flattener CtLoc] - -- unbanged because it's bogus in rewriteTyVar - , fe_flavour :: !CtFlavour - , fe_eq_rel :: !EqRel -- See Note [Flattener EqRels] - , fe_work :: !FlatWorkListRef } -- See Note [The flattening work list] - -data FlattenMode -- Postcondition for all three: inert wrt the type substitution - = FM_FlattenAll -- Postcondition: function-free - | FM_SubstOnly -- See Note [Flattening under a forall] - --- | FM_Avoid TcTyVar Bool -- See Note [Lazy flattening] --- -- Postcondition: --- -- * tyvar is only mentioned in result under a rigid path --- -- e.g. [a] is ok, but F a won't happen --- -- * If flat_top is True, top level is not a function application --- -- (but under type constructors is ok e.g. [F a]) - -instance Outputable FlattenMode where - ppr FM_FlattenAll = text "FM_FlattenAll" - ppr FM_SubstOnly = text "FM_SubstOnly" - -eqFlattenMode :: FlattenMode -> FlattenMode -> Bool -eqFlattenMode FM_FlattenAll FM_FlattenAll = True -eqFlattenMode FM_SubstOnly FM_SubstOnly = True --- FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2 -eqFlattenMode _ _ = False - --- | The 'FlatM' monad is a wrapper around 'TcS' with the following --- extra capabilities: (1) it offers access to a 'FlattenEnv'; --- and (2) it maintains the flattening worklist. --- See Note [The flattening work list]. -newtype FlatM a - = FlatM { runFlatM :: FlattenEnv -> TcS a } - deriving (Functor) - -instance Monad FlatM where - m >>= k = FlatM $ \env -> - do { a <- runFlatM m env - ; runFlatM (k a) env } - -instance Applicative FlatM where - pure x = FlatM $ const (pure x) - (<*>) = ap - -liftTcS :: TcS a -> FlatM a -liftTcS thing_inside - = FlatM $ const thing_inside - -emitFlatWork :: Ct -> FlatM () --- See Note [The flattening work list] -emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :) - --- convenient wrapper when you have a CtEvidence describing --- the flattening operation -runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS a -runFlattenCtEv mode ev - = runFlatten mode (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev) - --- Run thing_inside (which does flattening), and put all --- the work it generates onto the main work list --- See Note [The flattening work list] -runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a -runFlatten mode loc flav eq_rel thing_inside - = do { flat_ref <- newTcRef [] - ; let fmode = FE { fe_mode = mode - , fe_loc = bumpCtLocDepth loc - -- See Note [Flatten when discharging CFunEqCan] - , fe_flavour = flav - , fe_eq_rel = eq_rel - , fe_work = flat_ref } - ; res <- runFlatM thing_inside fmode - ; new_flats <- readTcRef flat_ref - ; updWorkListTcS (add_flats new_flats) - ; return res } - where - add_flats new_flats wl - = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) } - - add_funeqs [] wl = wl - add_funeqs (f:fs) wl = add_funeqs fs (f:wl) - -- add_funeqs fs ws = reverse fs ++ ws - -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4] - -- = [f3,f2,f1,w1,w2,w3,w4] - -traceFlat :: String -> SDoc -> FlatM () -traceFlat herald doc = liftTcS $ traceTcS herald doc - -getFlatEnvField :: (FlattenEnv -> a) -> FlatM a -getFlatEnvField accessor - = FlatM $ \env -> return (accessor env) - -getEqRel :: FlatM EqRel -getEqRel = getFlatEnvField fe_eq_rel - -getRole :: FlatM Role -getRole = eqRelRole <$> getEqRel - -getFlavour :: FlatM CtFlavour -getFlavour = getFlatEnvField fe_flavour - -getFlavourRole :: FlatM CtFlavourRole -getFlavourRole - = do { flavour <- getFlavour - ; eq_rel <- getEqRel - ; return (flavour, eq_rel) } - -getMode :: FlatM FlattenMode -getMode = getFlatEnvField fe_mode - -getLoc :: FlatM CtLoc -getLoc = getFlatEnvField fe_loc - -checkStackDepth :: Type -> FlatM () -checkStackDepth ty - = do { loc <- getLoc - ; liftTcS $ checkReductionDepth loc ty } - --- | Change the 'EqRel' in a 'FlatM'. -setEqRel :: EqRel -> FlatM a -> FlatM a -setEqRel new_eq_rel thing_inside - = FlatM $ \env -> - if new_eq_rel == fe_eq_rel env - then runFlatM thing_inside env - else runFlatM thing_inside (env { fe_eq_rel = new_eq_rel }) - --- | Change the 'FlattenMode' in a 'FlattenEnv'. -setMode :: FlattenMode -> FlatM a -> FlatM a -setMode new_mode thing_inside - = FlatM $ \env -> - if new_mode `eqFlattenMode` fe_mode env - then runFlatM thing_inside env - else runFlatM thing_inside (env { fe_mode = new_mode }) - --- | Make sure that flattening actually produces a coercion (in other --- words, make sure our flavour is not Derived) --- Note [No derived kind equalities] -noBogusCoercions :: FlatM a -> FlatM a -noBogusCoercions thing_inside - = FlatM $ \env -> - -- No new thunk is made if the flavour hasn't changed (note the bang). - let !env' = case fe_flavour env of - Derived -> env { fe_flavour = Wanted WDeriv } - _ -> env - in - runFlatM thing_inside env' - -bumpDepth :: FlatM a -> FlatM a -bumpDepth (FlatM thing_inside) - = FlatM $ \env -> do - -- bumpDepth can be called a lot during flattening so we force the - -- new env to avoid accumulating thunks. - { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) } - ; thing_inside env' } - -{- -Note [The flattening work list] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The "flattening work list", held in the fe_work field of FlattenEnv, -is a list of CFunEqCans generated during flattening. The key idea -is this. Consider flattening (Eq (F (G Int) (H Bool)): - * The flattener recursively calls itself on sub-terms before building - the main term, so it will encounter the terms in order - G Int - H Bool - F (G Int) (H Bool) - flattening to sub-goals - w1: G Int ~ fuv0 - w2: H Bool ~ fuv1 - w3: F fuv0 fuv1 ~ fuv2 - - * Processing w3 first is BAD, because we can't reduce i t,so it'll - get put into the inert set, and later kicked out when w1, w2 are - solved. In #9872 this led to inert sets containing hundreds - of suspended calls. - - * So we want to process w1, w2 first. - - * So you might think that we should just use a FIFO deque for the work-list, - so that putting adding goals in order w1,w2,w3 would mean we processed - w1 first. - - * BUT suppose we have 'type instance G Int = H Char'. Then processing - w1 leads to a new goal - w4: H Char ~ fuv0 - We do NOT want to put that on the far end of a deque! Instead we want - to put it at the *front* of the work-list so that we continue to work - on it. - -So the work-list structure is this: - - * The wl_funeqs (in TcS) is a LIFO stack; we push new goals (such as w4) on - top (extendWorkListFunEq), and take new work from the top - (selectWorkItem). - - * When flattening, emitFlatWork pushes new flattening goals (like - w1,w2,w3) onto the flattening work list, fe_work, another - push-down stack. - - * When we finish flattening, we *reverse* the fe_work stack - onto the wl_funeqs stack (which brings w1 to the top). - -The function runFlatten initialises the fe_work stack, and reverses -it onto wl_fun_eqs at the end. - -Note [Flattener EqRels] -~~~~~~~~~~~~~~~~~~~~~~~ -When flattening, we need to know which equality relation -- nominal -or representation -- we should be respecting. The only difference is -that we rewrite variables by representational equalities when fe_eq_rel -is ReprEq, and that we unwrap newtypes when flattening w.r.t. -representational equality. - -Note [Flattener CtLoc] -~~~~~~~~~~~~~~~~~~~~~~ -The flattener does eager type-family reduction. -Type families might loop, and we -don't want GHC to do so. A natural solution is to have a bounded depth -to these processes. A central difficulty is that such a solution isn't -quite compositional. For example, say it takes F Int 10 steps to get to Bool. -How many steps does it take to get from F Int -> F Int to Bool -> Bool? -10? 20? What about getting from Const Char (F Int) to Char? 11? 1? Hard to -know and hard to track. So, we punt, essentially. We store a CtLoc in -the FlattenEnv and just update the environment when recurring. In the -TyConApp case, where there may be multiple type families to flatten, -we just copy the current CtLoc into each branch. If any branch hits the -stack limit, then the whole thing fails. - -A consequence of this is that setting the stack limits appropriately -will be essentially impossible. So, the official recommendation if a -stack limit is hit is to disable the check entirely. Otherwise, there -will be baffling, unpredictable errors. - -Note [Lazy flattening] -~~~~~~~~~~~~~~~~~~~~~~ -The idea of FM_Avoid mode is to flatten less aggressively. If we have - a ~ [F Int] -there seems to be no great merit in lifting out (F Int). But if it was - a ~ [G a Int] -then we *do* want to lift it out, in case (G a Int) reduces to Bool, say, -which gets rid of the occurs-check problem. (For the flat_top Bool, see -comments above and at call sites.) - -HOWEVER, the lazy flattening actually seems to make type inference go -*slower*, not faster. perf/compiler/T3064 is a case in point; it gets -*dramatically* worse with FM_Avoid. I think it may be because -floating the types out means we normalise them, and that often makes -them smaller and perhaps allows more re-use of previously solved -goals. But to be honest I'm not absolutely certain, so I am leaving -FM_Avoid in the code base. What I'm removing is the unique place -where it is *used*, namely in TcCanonical.canEqTyVar. - -See also Note [Conservative unification check] in TcUnify, which gives -other examples where lazy flattening caused problems. - -Bottom line: FM_Avoid is unused for now (Nov 14). -Note: T5321Fun got faster when I disabled FM_Avoid - T5837 did too, but it's pathological anyway - -Note [Phantoms in the flattener] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - -data Proxy p = Proxy - -and we're flattening (Proxy ty) w.r.t. ReprEq. Then, we know that `ty` -is really irrelevant -- it will be ignored when solving for representational -equality later on. So, we omit flattening `ty` entirely. This may -violate the expectation of "xi"s for a bit, but the canonicaliser will -soon throw out the phantoms when decomposing a TyConApp. (Or, the -canonicaliser will emit an insoluble, in which case the unflattened version -yields a better error message anyway.) - -Note [No derived kind equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A kind-level coercion can appear in types, via mkCastTy. So, whenever -we are generating a coercion in a dependent context (in other words, -in a kind) we need to make sure that our flavour is never Derived -(as Derived constraints have no evidence). The noBogusCoercions function -changes the flavour from Derived just for this purpose. - --} - -{- ********************************************************************* -* * -* Externally callable flattening functions * -* * -* They are all wrapped in runFlatten, so their * -* flattening work gets put into the work list * -* * -********************************************************************* - -Note [rewriteTyVar] -~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an injective function F and - inert_funeqs: F t1 ~ fsk1 - F t2 ~ fsk2 - inert_eqs: fsk1 ~ [a] - a ~ Int - fsk2 ~ [Int] - -We never rewrite the RHS (cc_fsk) of a CFunEqCan. But we /do/ want to get the -[D] t1 ~ t2 from the injectiveness of F. So we flatten cc_fsk of CFunEqCans -when trying to find derived equalities arising from injectivity. --} - --- | See Note [Flattening]. --- If (xi, co) <- flatten mode ev ty, then co :: xi ~r ty --- where r is the role in @ev@. If @mode@ is 'FM_FlattenAll', --- then 'xi' is almost function-free (Note [Almost function-free] --- in TcRnTypes). -flatten :: FlattenMode -> CtEvidence -> TcType - -> TcS (Xi, TcCoercion) -flatten mode ev ty - = do { traceTcS "flatten {" (ppr mode <+> ppr ty) - ; (ty', co) <- runFlattenCtEv mode ev (flatten_one ty) - ; traceTcS "flatten }" (ppr ty') - ; return (ty', co) } - --- Apply the inert set as an *inert generalised substitution* to --- a variable, zonking along the way. --- See Note [inert_eqs: the inert equalities] in TcSMonad. --- Equivalently, this flattens the variable with respect to NomEq --- in a Derived constraint. (Why Derived? Because Derived allows the --- most about of rewriting.) Returns no coercion, because we're --- using Derived constraints. --- See Note [rewriteTyVar] -rewriteTyVar :: TcTyVar -> TcS TcType -rewriteTyVar tv - = do { traceTcS "rewriteTyVar {" (ppr tv) - ; (ty, _) <- runFlatten FM_SubstOnly fake_loc Derived NomEq $ - flattenTyVar tv - ; traceTcS "rewriteTyVar }" (ppr ty) - ; return ty } - where - fake_loc = pprPanic "rewriteTyVar used a CtLoc" (ppr tv) - --- specialized to flattening kinds: never Derived, always Nominal --- See Note [No derived kind equalities] --- See Note [Flattening] -flattenKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN) -flattenKind loc flav ty - = do { traceTcS "flattenKind {" (ppr flav <+> ppr ty) - ; let flav' = case flav of - Derived -> Wanted WDeriv -- the WDeriv/WOnly choice matters not - _ -> flav - ; (ty', co) <- runFlatten FM_FlattenAll loc flav' NomEq (flatten_one ty) - ; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic - ; return (ty', co) } - --- See Note [Flattening] -flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN) --- Externally-callable, hence runFlatten --- Flatten a vector of types all at once; in fact they are --- always the arguments of type family or class, so --- ctEvFlavour ev = Nominal --- and we want to flatten all at nominal role --- The kind passed in is the kind of the type family or class, call it T --- The last coercion returned has type (tcTypeKind(T xis) ~N tcTypeKind(T tys)) --- --- For Derived constraints the returned coercion may be undefined --- because flattening may use a Derived equality ([D] a ~ ty) -flattenArgsNom ev tc tys - = do { traceTcS "flatten_args {" (vcat (map ppr tys)) - ; (tys', cos, kind_co) - <- runFlattenCtEv FM_FlattenAll ev (flatten_args_tc tc (repeat Nominal) tys) - ; traceTcS "flatten }" (vcat (map ppr tys')) - ; return (tys', cos, kind_co) } - - -{- ********************************************************************* -* * -* The main flattening functions -* * -********************************************************************* -} - -{- Note [Flattening] -~~~~~~~~~~~~~~~~~~~~ - flatten ty ==> (xi, co) - where - xi has no type functions, unless they appear under ForAlls - has no skolems that are mapped in the inert set - has no filled-in metavariables - co :: xi ~ ty - -Key invariants: - (F0) co :: xi ~ zonk(ty) - (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind - (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) - -Note that it is flatten's job to flatten *every type function it sees*. -flatten is only called on *arguments* to type functions, by canEqGiven. - -Flattening also: - * zonks, removing any metavariables, and - * applies the substitution embodied in the inert set - -The result of flattening is *almost function-free*. See -Note [Almost function-free] in TcRnTypes. - -Because flattening zonks and the returned coercion ("co" above) is also -zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead, -we can rely on this fact: - - (F0) co :: xi ~ zonk(ty) - -Note that the left-hand type of co is *always* precisely xi. The right-hand -type may or may not be ty, however: if ty has unzonked filled-in metavariables, -then the right-hand type of co will be the zonked version of ty. -It is for this reason that we -occasionally have to explicitly zonk, when (co :: xi ~ ty) is important -even before we zonk the whole program. For example, see the FTRNotFollowed -case in flattenTyVar. - -Why have these invariants on flattening? Because we sometimes use tcTypeKind -during canonicalisation, and we want this kind to be zonked (e.g., see -TcCanonical.canEqTyVar). - -Flattening is always homogeneous. That is, the kind of the result of flattening is -always the same as the kind of the input, modulo zonking. More formally: - - (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) - -This invariant means that the kind of a flattened type might not itself be flat. - -Recall that in comments we use alpha[flat = ty] to represent a -flattening skolem variable alpha which has been generated to stand in -for ty. - ------ Example of flattening a constraint: ------ - flatten (List (F (G Int))) ==> (xi, cc) - where - xi = List alpha - cc = { G Int ~ beta[flat = G Int], - F beta ~ alpha[flat = F beta] } -Here - * alpha and beta are 'flattening skolem variables'. - * All the constraints in cc are 'given', and all their coercion terms - are the identity. - -NB: Flattening Skolems only occur in canonical constraints, which -are never zonked, so we don't need to worry about zonking doing -accidental unflattening. - -Note that we prefer to leave type synonyms unexpanded when possible, -so when the flattener encounters one, it first asks whether its -transitive expansion contains any type function applications. If so, -it expands the synonym and proceeds; if not, it simply returns the -unexpanded synonym. - -Note [flatten_args performance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In programs with lots of type-level evaluation, flatten_args becomes -part of a tight loop. For example, see test perf/compiler/T9872a, which -calls flatten_args a whopping 7,106,808 times. It is thus important -that flatten_args be efficient. - -Performance testing showed that the current implementation is indeed -efficient. It's critically important that zipWithAndUnzipM be -specialized to TcS, and it's also quite helpful to actually `inline` -it. On test T9872a, here are the allocation stats (Dec 16, 2014): - - * Unspecialized, uninlined: 8,472,613,440 bytes allocated in the heap - * Specialized, uninlined: 6,639,253,488 bytes allocated in the heap - * Specialized, inlined: 6,281,539,792 bytes allocated in the heap - -To improve performance even further, flatten_args_nom is split off -from flatten_args, as nominal equality is the common case. This would -be natural to write using mapAndUnzipM, but even inlined, that function -is not as performant as a hand-written loop. - - * mapAndUnzipM, inlined: 7,463,047,432 bytes allocated in the heap - * hand-written recursion: 5,848,602,848 bytes allocated in the heap - -If you make any change here, pay close attention to the T9872{a,b,c} tests -and T5321Fun. - -If we need to make this yet more performant, a possible way forward is to -duplicate the flattener code for the nominal case, and make that case -faster. This doesn't seem quite worth it, yet. - -Note [flatten_exact_fam_app_fully performance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The refactor of GRefl seems to cause performance trouble for T9872x: the allocation of flatten_exact_fam_app_fully_performance increased. See note [Generalized reflexive coercion] in GHC.Core.TyCo.Rep for more information about GRefl and #15192 for the current state. - -The explicit pattern match in homogenise_result helps with T9872a, b, c. - -Still, it increases the expected allocation of T9872d by ~2%. - -TODO: a step-by-step replay of the refactor to analyze the performance. - --} - -{-# INLINE flatten_args_tc #-} -flatten_args_tc - :: TyCon -- T - -> [Role] -- Role r - -> [Type] -- Arg types [t1,..,tn] - -> FlatM ( [Xi] -- List of flattened args [x1,..,xn] - -- 1-1 corresp with [t1,..,tn] - , [Coercion] -- List of arg coercions [co1,..,con] - -- 1-1 corresp with [t1,..,tn] - -- coi :: xi ~r ti - , CoercionN) -- Result coercion, rco - -- rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con)) -flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet - -- NB: TyCon kinds are always closed - where - (bndrs, named) - = ty_con_binders_ty_binders' (tyConBinders tc) - -- it's possible that the result kind has arrows (for, e.g., a type family) - -- so we must split it - (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc) - !all_bndrs = bndrs `chkAppend` inner_bndrs - !any_named_bndrs = named || inner_named - -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%. - -{-# INLINE flatten_args #-} -flatten_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are - -- named. - -> Kind -> TcTyCoVarSet -- function kind; kind's free vars - -> [Role] -> [Type] -- these are in 1-to-1 correspondence - -> FlatM ([Xi], [Coercion], CoercionN) --- Coercions :: Xi ~ Type, at roles given --- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys) --- That is, the third coercion relates the kind of some function (whose kind is --- passed as the first parameter) instantiated at xis to the kind of that --- function instantiated at the tys. This is useful in keeping flattening --- homoegeneous. The list of roles must be at least as long as the list of --- types. -flatten_args orig_binders - any_named_bndrs - orig_inner_ki - orig_fvs - orig_roles - orig_tys - = if any_named_bndrs - then flatten_args_slow orig_binders - orig_inner_ki - orig_fvs - orig_roles - orig_tys - else flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys - -{-# INLINE flatten_args_fast #-} --- | fast path flatten_args, in which none of the binders are named and --- therefore we can avoid tracking a lifting context. --- There are many bang patterns in here. It's been observed that they --- greatly improve performance of an optimized build. --- The T9872 test cases are good witnesses of this fact. -flatten_args_fast :: [TyCoBinder] - -> Kind - -> [Role] - -> [Type] - -> FlatM ([Xi], [Coercion], CoercionN) -flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys - = fmap finish (iterate orig_tys orig_roles orig_binders) - where - - iterate :: [Type] - -> [Role] - -> [TyCoBinder] - -> FlatM ([Xi], [Coercion], [TyCoBinder]) - iterate (ty:tys) (role:roles) (_:binders) = do - (xi, co) <- go role ty - (xis, cos, binders) <- iterate tys roles binders - pure (xi : xis, co : cos, binders) - iterate [] _ binders = pure ([], [], binders) - iterate _ _ _ = pprPanic - "flatten_args wandered into deeper water than usual" (vcat []) - -- This debug information is commented out because leaving it in - -- causes a ~2% increase in allocations in T9872{a,c,d}. - {- - (vcat [ppr orig_binders, - ppr orig_inner_ki, - ppr (take 10 orig_roles), -- often infinite! - ppr orig_tys]) - -} - - {-# INLINE go #-} - go :: Role - -> Type - -> FlatM (Xi, Coercion) - go role ty - = case role of - -- In the slow path we bind the Xi and Coercion from the recursive - -- call and then use it such - -- - -- let kind_co = mkTcSymCo $ mkReflCo Nominal (tyBinderType binder) - -- casted_xi = xi `mkCastTy` kind_co - -- casted_co = xi |> kind_co ~r xi ; co - -- - -- but this isn't necessary: - -- mkTcSymCo (Refl a b) = Refl a b, - -- mkCastTy x (Refl _ _) = x - -- mkTcGReflLeftCo _ ty (Refl _ _) `mkTransCo` co = co - -- - -- Also, no need to check isAnonTyCoBinder or isNamedBinder, since - -- we've already established that they're all anonymous. - Nominal -> setEqRel NomEq $ flatten_one ty - Representational -> setEqRel ReprEq $ flatten_one ty - Phantom -> -- See Note [Phantoms in the flattener] - do { ty <- liftTcS $ zonkTcType ty - ; return (ty, mkReflCo Phantom ty) } - - - {-# INLINE finish #-} - finish :: ([Xi], [Coercion], [TyCoBinder]) -> ([Xi], [Coercion], CoercionN) - finish (xis, cos, binders) = (xis, cos, kind_co) - where - final_kind = mkPiTys binders orig_inner_ki - kind_co = mkNomReflCo final_kind - -{-# INLINE flatten_args_slow #-} --- | Slow path, compared to flatten_args_fast, because this one must track --- a lifting context. -flatten_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet - -> [Role] -> [Type] - -> FlatM ([Xi], [Coercion], CoercionN) -flatten_args_slow binders inner_ki fvs roles tys --- Arguments used dependently must be flattened with proper coercions, but --- we're not guaranteed to get a proper coercion when flattening with the --- "Derived" flavour. So we must call noBogusCoercions when flattening arguments --- corresponding to binders that are dependent. However, we might legitimately --- have *more* arguments than binders, in the case that the inner_ki is a variable --- that gets instantiated with a Π-type. We conservatively choose not to produce --- bogus coercions for these, too. Note that this might miss an opportunity for --- a Derived rewriting a Derived. The solution would be to generate evidence for --- Deriveds, thus avoiding this whole noBogusCoercions idea. See also --- Note [No derived kind equalities] - = do { flattened_args <- zipWith3M fl (map isNamedBinder binders ++ repeat True) - roles tys - ; return (simplifyArgsWorker binders inner_ki fvs roles flattened_args) } - where - {-# INLINE fl #-} - fl :: Bool -- must we ensure to produce a real coercion here? - -- see comment at top of function - -> Role -> Type -> FlatM (Xi, Coercion) - fl True r ty = noBogusCoercions $ fl1 r ty - fl False r ty = fl1 r ty - - {-# INLINE fl1 #-} - fl1 :: Role -> Type -> FlatM (Xi, Coercion) - fl1 Nominal ty - = setEqRel NomEq $ - flatten_one ty - - fl1 Representational ty - = setEqRel ReprEq $ - flatten_one ty - - fl1 Phantom ty - -- See Note [Phantoms in the flattener] - = do { ty <- liftTcS $ zonkTcType ty - ; return (ty, mkReflCo Phantom ty) } - ------------------- -flatten_one :: TcType -> FlatM (Xi, Coercion) --- Flatten a type to get rid of type function applications, returning --- the new type-function-free type, and a collection of new equality --- constraints. See Note [Flattening] for more detail. --- --- Postcondition: Coercion :: Xi ~ TcType --- The role on the result coercion matches the EqRel in the FlattenEnv - -flatten_one xi@(LitTy {}) - = do { role <- getRole - ; return (xi, mkReflCo role xi) } - -flatten_one (TyVarTy tv) - = flattenTyVar tv - -flatten_one (AppTy ty1 ty2) - = flatten_app_tys ty1 [ty2] - -flatten_one (TyConApp tc tys) - -- Expand type synonyms that mention type families - -- on the RHS; see Note [Flattening synonyms] - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' - = do { mode <- getMode - ; case mode of - FM_FlattenAll | not (isFamFreeTyCon tc) - -> flatten_one expanded_ty - _ -> flatten_ty_con_app tc tys } - - -- Otherwise, it's a type function application, and we have to - -- flatten it away as well, and generate a new given equality constraint - -- between the application and a newly generated flattening skolem variable. - | isTypeFamilyTyCon tc - = flatten_fam_app tc tys - - -- For * a normal data type application - -- * data family application - -- we just recursively flatten the arguments. - | otherwise --- FM_Avoid stuff commented out; see Note [Lazy flattening] --- , let fmode' = case fmode of -- Switch off the flat_top bit in FM_Avoid --- FE { fe_mode = FM_Avoid tv _ } --- -> fmode { fe_mode = FM_Avoid tv False } --- _ -> fmode - = flatten_ty_con_app tc tys - -flatten_one ty@(FunTy _ ty1 ty2) - = do { (xi1,co1) <- flatten_one ty1 - ; (xi2,co2) <- flatten_one ty2 - ; role <- getRole - ; return (ty { ft_arg = xi1, ft_res = xi2 } - , mkFunCo role co1 co2) } - -flatten_one ty@(ForAllTy {}) --- TODO (RAE): This is inadequate, as it doesn't flatten the kind of --- the bound tyvar. Doing so will require carrying around a substitution --- and the usual substTyVarBndr-like silliness. Argh. - --- We allow for-alls when, but only when, no type function --- applications inside the forall involve the bound type variables. - = do { let (bndrs, rho) = tcSplitForAllVarBndrs ty - tvs = binderVars bndrs - ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho - -- Substitute only under a forall - -- See Note [Flattening under a forall] - ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) } - -flatten_one (CastTy ty g) - = do { (xi, co) <- flatten_one ty - ; (g', _) <- flatten_co g - - ; role <- getRole - ; return (mkCastTy xi g', castCoercionKind co role xi ty g' g) } - -flatten_one (CoercionTy co) = first mkCoercionTy <$> flatten_co co - --- | "Flatten" a coercion. Really, just zonk it so we can uphold --- (F1) of Note [Flattening] -flatten_co :: Coercion -> FlatM (Coercion, Coercion) -flatten_co co - = do { co <- liftTcS $ zonkCo co - ; env_role <- getRole - ; let co' = mkTcReflCo env_role (mkCoercionTy co) - ; return (co, co') } - --- flatten (nested) AppTys -flatten_app_tys :: Type -> [Type] -> FlatM (Xi, Coercion) --- commoning up nested applications allows us to look up the function's kind --- only once. Without commoning up like this, we would spend a quadratic amount --- of time looking up functions' types -flatten_app_tys (AppTy ty1 ty2) tys = flatten_app_tys ty1 (ty2:tys) -flatten_app_tys fun_ty arg_tys - = do { (fun_xi, fun_co) <- flatten_one fun_ty - ; flatten_app_ty_args fun_xi fun_co arg_tys } - --- Given a flattened function (with the coercion produced by flattening) and --- a bunch of unflattened arguments, flatten the arguments and apply. --- The coercion argument's role matches the role stored in the FlatM monad. --- --- The bang patterns used here were observed to improve performance. If you --- wish to remove them, be sure to check for regeressions in allocations. -flatten_app_ty_args :: Xi -> Coercion -> [Type] -> FlatM (Xi, Coercion) -flatten_app_ty_args fun_xi fun_co [] - -- this will be a common case when called from flatten_fam_app, so shortcut - = return (fun_xi, fun_co) -flatten_app_ty_args fun_xi fun_co arg_tys - = do { (xi, co, kind_co) <- case tcSplitTyConApp_maybe fun_xi of - Just (tc, xis) -> - do { let tc_roles = tyConRolesRepresentational tc - arg_roles = dropList xis tc_roles - ; (arg_xis, arg_cos, kind_co) - <- flatten_vector (tcTypeKind fun_xi) arg_roles arg_tys - - -- Here, we have fun_co :: T xi1 xi2 ~ ty - -- and we need to apply fun_co to the arg_cos. The problem is - -- that using mkAppCo is wrong because that function expects - -- its second coercion to be Nominal, and the arg_cos might - -- not be. The solution is to use transitivity: - -- T arg_cos ;; fun_co - ; eq_rel <- getEqRel - ; let app_xi = mkTyConApp tc (xis ++ arg_xis) - app_co = case eq_rel of - NomEq -> mkAppCos fun_co arg_cos - ReprEq -> mkTcTyConAppCo Representational tc - (zipWith mkReflCo tc_roles xis ++ arg_cos) - `mkTcTransCo` - mkAppCos fun_co (map mkNomReflCo arg_tys) - ; return (app_xi, app_co, kind_co) } - Nothing -> - do { (arg_xis, arg_cos, kind_co) - <- flatten_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys - ; let arg_xi = mkAppTys fun_xi arg_xis - arg_co = mkAppCos fun_co arg_cos - ; return (arg_xi, arg_co, kind_co) } - - ; role <- getRole - ; return (homogenise_result xi co role kind_co) } - -flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) -flatten_ty_con_app tc tys - = do { role <- getRole - ; (xis, cos, kind_co) <- flatten_args_tc tc (tyConRolesX role tc) tys - ; let tyconapp_xi = mkTyConApp tc xis - tyconapp_co = mkTyConAppCo role tc cos - ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) } - --- Make the result of flattening homogeneous (Note [Flattening] (F2)) -homogenise_result :: Xi -- a flattened type - -> Coercion -- :: xi ~r original ty - -> Role -- r - -> CoercionN -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty) - -> (Xi, Coercion) -- (xi |> kind_co, (xi |> kind_co) - -- ~r original ty) -homogenise_result xi co r kind_co - -- the explicit pattern match here improves the performance of T9872a, b, c by - -- ~2% - | isGReflCo kind_co = (xi `mkCastTy` kind_co, co) - | otherwise = (xi `mkCastTy` kind_co - , (mkSymCo $ GRefl r xi (MCo kind_co)) `mkTransCo` co) -{-# INLINE homogenise_result #-} - --- Flatten a vector (list of arguments). -flatten_vector :: Kind -- of the function being applied to these arguments - -> [Role] -- If we're flatten w.r.t. ReprEq, what roles do the - -- args have? - -> [Type] -- the args to flatten - -> FlatM ([Xi], [Coercion], CoercionN) -flatten_vector ki roles tys - = do { eq_rel <- getEqRel - ; case eq_rel of - NomEq -> flatten_args bndrs - any_named_bndrs - inner_ki - fvs - (repeat Nominal) - tys - ReprEq -> flatten_args bndrs - any_named_bndrs - inner_ki - fvs - roles - tys - } - where - (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki - fvs = tyCoVarsOfType ki -{-# INLINE flatten_vector #-} - -{- -Note [Flattening synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Not expanding synonyms aggressively improves error messages, and -keeps types smaller. But we need to take care. - -Suppose - type T a = a -> a -and we want to flatten the type (T (F a)). Then we can safely flatten -the (F a) to a skolem, and return (T fsk). We don't need to expand the -synonym. This works because TcTyConAppCo can deal with synonyms -(unlike TyConAppCo), see Note [TcCoercions] in TcEvidence. - -But (#8979) for - type T a = (F a, a) where F is a type function -we must expand the synonym in (say) T Int, to expose the type function -to the flattener. - - -Note [Flattening under a forall] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Under a forall, we - (a) MUST apply the inert substitution - (b) MUST NOT flatten type family applications -Hence FMSubstOnly. - -For (a) consider c ~ a, a ~ T (forall b. (b, [c])) -If we don't apply the c~a substitution to the second constraint -we won't see the occurs-check error. - -For (b) consider (a ~ forall b. F a b), we don't want to flatten -to (a ~ forall b.fsk, F a b ~ fsk) -because now the 'b' has escaped its scope. We'd have to flatten to - (a ~ forall b. fsk b, forall b. F a b ~ fsk b) -and we have not begun to think about how to make that work! - -************************************************************************ -* * - Flattening a type-family application -* * -************************************************************************ --} - -flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) - -- flatten_fam_app can be over-saturated - -- flatten_exact_fam_app is exactly saturated - -- flatten_exact_fam_app_fully lifts out the application to top level - -- Postcondition: Coercion :: Xi ~ F tys -flatten_fam_app tc tys -- Can be over-saturated - = ASSERT2( tys `lengthAtLeast` tyConArity tc - , ppr tc $$ ppr (tyConArity tc) $$ ppr tys) - - do { mode <- getMode - ; case mode of - { FM_SubstOnly -> flatten_ty_con_app tc tys - ; FM_FlattenAll -> - - -- Type functions are saturated - -- The type function might be *over* saturated - -- in which case the remaining arguments should - -- be dealt with by AppTys - do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys - ; (xi1, co1) <- flatten_exact_fam_app_fully tc tys1 - -- co1 :: xi1 ~ F tys1 - - ; flatten_app_ty_args xi1 co1 tys_rest } } } - --- the [TcType] exactly saturate the TyCon --- See note [flatten_exact_fam_app_fully performance] -flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion) -flatten_exact_fam_app_fully tc tys - -- See Note [Reduce type family applications eagerly] - -- the following tcTypeKind should never be evaluated, as it's just used in - -- casting, and casts by refl are dropped - = do { mOut <- try_to_reduce_nocache tc tys - ; case mOut of - Just out -> pure out - Nothing -> do - { -- First, flatten the arguments - ; (xis, cos, kind_co) - <- setEqRel NomEq $ -- just do this once, instead of for - -- each arg - flatten_args_tc tc (repeat Nominal) tys - -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys) - ; eq_rel <- getEqRel - ; cur_flav <- getFlavour - ; let role = eqRelRole eq_rel - ret_co = mkTyConAppCo role tc cos - -- ret_co :: F xis ~ F tys; might be heterogeneous - - -- Now, look in the cache - ; mb_ct <- liftTcS $ lookupFlatCache tc xis - ; case mb_ct of - Just (co, rhs_ty, flav) -- co :: F xis ~ fsk - -- flav is [G] or [WD] - -- See Note [Type family equations] in TcSMonad - | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav - -> -- Usable hit in the flat-cache - do { traceFlat "flatten/flat-cache hit" $ - (ppr tc <+> ppr xis $$ ppr rhs_ty) - ; (fsk_xi, fsk_co) <- flatten_one rhs_ty - -- The fsk may already have been unified, so - -- flatten it - -- fsk_co :: fsk_xi ~ fsk - ; let xi = fsk_xi `mkCastTy` kind_co - co' = mkTcCoherenceLeftCo role fsk_xi kind_co fsk_co - `mkTransCo` - maybeTcSubCo eq_rel (mkSymCo co) - `mkTransCo` ret_co - ; return (xi, co') - } - -- :: fsk_xi ~ F xis - - -- Try to reduce the family application right now - -- See Note [Reduce type family applications eagerly] - _ -> do { mOut <- try_to_reduce tc - xis - kind_co - (`mkTransCo` ret_co) - ; case mOut of - Just out -> pure out - Nothing -> do - { loc <- getLoc - ; (ev, co, fsk) <- liftTcS $ - newFlattenSkolem cur_flav loc tc xis - - -- The new constraint (F xis ~ fsk) is not - -- necessarily inert (e.g. the LHS may be a - -- redex) so we must put it in the work list - ; let ct = CFunEqCan { cc_ev = ev - , cc_fun = tc - , cc_tyargs = xis - , cc_fsk = fsk } - ; emitFlatWork ct - - ; traceFlat "flatten/flat-cache miss" $ - (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev) - - -- NB: fsk's kind is already flattened because - -- the xis are flattened - ; let fsk_ty = mkTyVarTy fsk - xi = fsk_ty `mkCastTy` kind_co - co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeTcSubCo eq_rel (mkSymCo co)) - `mkTransCo` ret_co - ; return (xi, co') - } - } - } - } - - where - - -- try_to_reduce and try_to_reduce_nocache (below) could be unified into - -- a more general definition, but it was observed that separating them - -- gives better performance (lower allocation numbers in T9872x). - - try_to_reduce :: TyCon -- F, family tycon - -> [Type] -- args, not necessarily flattened - -> CoercionN -- kind_co :: tcTypeKind(F args) ~N - -- tcTypeKind(F orig_args) - -- where - -- orig_args is what was passed to the outer - -- function - -> ( Coercion -- :: (xi |> kind_co) ~ F args - -> Coercion ) -- what to return from outer function - -> FlatM (Maybe (Xi, Coercion)) - try_to_reduce tc tys kind_co update_co - = do { checkStackDepth (mkTyConApp tc tys) - ; mb_match <- liftTcS $ matchFam tc tys - ; case mb_match of - -- NB: norm_co will always be homogeneous. All type families - -- are homogeneous. - Just (norm_co, norm_ty) - -> do { traceFlat "Eager T.F. reduction success" $ - vcat [ ppr tc, ppr tys, ppr norm_ty - , ppr norm_co <+> dcolon - <+> ppr (coercionKind norm_co) - ] - ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty - ; eq_rel <- getEqRel - ; let co = maybeTcSubCo eq_rel norm_co - `mkTransCo` mkSymCo final_co - ; flavour <- getFlavour - -- NB: only extend cache with nominal equalities - ; when (eq_rel == NomEq) $ - liftTcS $ - extendFlatCache tc tys ( co, xi, flavour ) - ; let role = eqRelRole eq_rel - xi' = xi `mkCastTy` kind_co - co' = update_co $ - mkTcCoherenceLeftCo role xi kind_co (mkSymCo co) - ; return $ Just (xi', co') } - Nothing -> pure Nothing } - - try_to_reduce_nocache :: TyCon -- F, family tycon - -> [Type] -- args, not necessarily flattened - -> FlatM (Maybe (Xi, Coercion)) - try_to_reduce_nocache tc tys - = do { checkStackDepth (mkTyConApp tc tys) - ; mb_match <- liftTcS $ matchFam tc tys - ; case mb_match of - -- NB: norm_co will always be homogeneous. All type families - -- are homogeneous. - Just (norm_co, norm_ty) - -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty - ; eq_rel <- getEqRel - ; let co = mkSymCo (maybeTcSubCo eq_rel norm_co - `mkTransCo` mkSymCo final_co) - ; return $ Just (xi, co) } - Nothing -> pure Nothing } - -{- Note [Reduce type family applications eagerly] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we come across a type-family application like (Append (Cons x Nil) t), -then, rather than flattening to a skolem etc, we may as well just reduce -it on the spot to (Cons x t). This saves a lot of intermediate steps. -Examples that are helped are tests T9872, and T5321Fun. - -Performance testing indicates that it's best to try this *twice*, once -before flattening arguments and once after flattening arguments. -Adding the extra reduction attempt before flattening arguments cut -the allocation amounts for the T9872{a,b,c} tests by half. - -An example of where the early reduction appears helpful: - - type family Last x where - Last '[x] = x - Last (h ': t) = Last t - - workitem: (x ~ Last '[1,2,3,4,5,6]) - -Flattening the argument never gets us anywhere, but trying to flatten -it at every step is quadratic in the length of the list. Reducing more -eagerly makes simplifying the right-hand type linear in its length. - -Testing also indicated that the early reduction should *not* use the -flat-cache, but that the later reduction *should*. (Although the -effect was not large.) Hence the Bool argument to try_to_reduce. To -me (SLPJ) this seems odd; I get that eager reduction usually succeeds; -and if don't use the cache for eager reduction, we will miss most of -the opportunities for using it at all. More exploration would be good -here. - -At the end, once we've got a flat rhs, we extend the flatten-cache to record -the result. Doing so can save lots of work when the same redex shows up more -than once. Note that we record the link from the redex all the way to its -*final* value, not just the single step reduction. Interestingly, using the -flat-cache for the first reduction resulted in an increase in allocations -of about 3% for the four T9872x tests. However, using the flat-cache in -the later reduction is a similar gain. I (Richard E) don't currently (Dec '14) -have any knowledge as to *why* these facts are true. - -************************************************************************ -* * - Flattening a type variable -* * -********************************************************************* -} - --- | The result of flattening a tyvar "one step". -data FlattenTvResult - = FTRNotFollowed - -- ^ The inert set doesn't make the tyvar equal to anything else - - | FTRFollowed TcType Coercion - -- ^ The tyvar flattens to a not-necessarily flat other type. - -- co :: new type ~r old type, where the role is determined by - -- the FlattenEnv - -flattenTyVar :: TyVar -> FlatM (Xi, Coercion) -flattenTyVar tv - = do { mb_yes <- flatten_tyvar1 tv - ; case mb_yes of - FTRFollowed ty1 co1 -- Recur - -> do { (ty2, co2) <- flatten_one ty1 - -- ; traceFlat "flattenTyVar2" (ppr tv $$ ppr ty2) - ; return (ty2, co2 `mkTransCo` co1) } - - FTRNotFollowed -- Done, but make sure the kind is zonked - -- Note [Flattening] invariant (F0) and (F1) - -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv - ; role <- getRole - ; let ty' = mkTyVarTy tv' - ; return (ty', mkTcReflCo role ty') } } - -flatten_tyvar1 :: TcTyVar -> FlatM FlattenTvResult --- "Flattening" a type variable means to apply the substitution to it --- Specifically, look up the tyvar in --- * the internal MetaTyVar box --- * the inerts --- See also the documentation for FlattenTvResult - -flatten_tyvar1 tv - = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty -> do { traceFlat "Following filled tyvar" - (ppr tv <+> equals <+> ppr ty) - ; role <- getRole - ; return (FTRFollowed ty (mkReflCo role ty)) } ; - Nothing -> do { traceFlat "Unfilled tyvar" (pprTyVar tv) - ; fr <- getFlavourRole - ; flatten_tyvar2 tv fr } } - -flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult --- The tyvar is not a filled-in meta-tyvar --- Try in the inert equalities --- See Definition [Applying a generalised substitution] in TcSMonad --- See Note [Stability of flattening] in TcSMonad - -flatten_tyvar2 tv fr@(_, eq_rel) - = do { ieqs <- liftTcS $ getInertEqs - ; mode <- getMode - ; case lookupDVarEnv ieqs tv of - Just (ct:_) -- If the first doesn't work, - -- the subsequent ones won't either - | CTyEqCan { cc_ev = ctev, cc_tyvar = tv - , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct - , let ct_fr = (ctEvFlavour ctev, ct_eq_rel) - , ct_fr `eqCanRewriteFR` fr -- This is THE key call of eqCanRewriteFR - -> do { traceFlat "Following inert tyvar" - (ppr mode <+> - ppr tv <+> - equals <+> - ppr rhs_ty $$ ppr ctev) - ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev) - rewrite_co = case (ct_eq_rel, eq_rel) of - (ReprEq, _rel) -> ASSERT( _rel == ReprEq ) - -- if this ASSERT fails, then - -- eqCanRewriteFR answered incorrectly - rewrite_co1 - (NomEq, NomEq) -> rewrite_co1 - (NomEq, ReprEq) -> mkSubCo rewrite_co1 - - ; return (FTRFollowed rhs_ty rewrite_co) } - -- NB: ct is Derived then fmode must be also, hence - -- we are not going to touch the returned coercion - -- so ctEvCoercion is fine. - - _other -> return FTRNotFollowed } - -{- -Note [An alternative story for the inert substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(This entire note is just background, left here in case we ever want - to return the previous state of affairs) - -We used (GHC 7.8) to have this story for the inert substitution inert_eqs - - * 'a' is not in fvs(ty) - * They are *inert* in the weaker sense that there is no infinite chain of - (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc - -This means that flattening must be recursive, but it does allow - [G] a ~ [b] - [G] b ~ Maybe c - -This avoids "saturating" the Givens, which can save a modest amount of work. -It is easy to implement, in TcInteract.kick_out, 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 -in occurs-check cases, but we don't care about them much. #5837 -is an example; all the constraints here are Givens - - [G] a ~ TF (a,Int) - --> - work TF (a,Int) ~ fsk - inert fsk ~ a - - ---> - work fsk ~ (TF a, TF Int) - inert fsk ~ a - - ---> - work a ~ (TF a, TF Int) - inert fsk ~ a - - ---> (attempting to flatten (TF a) so that it does not mention a - work TF a ~ fsk2 - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (substitute for a) - work TF (fsk2, TF Int) ~ fsk2 - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (top-level reduction, re-orient) - work fsk2 ~ (TF fsk2, TF Int) - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (attempt to flatten (TF fsk2) to get rid of fsk2 - work TF fsk2 ~ fsk3 - work fsk2 ~ (fsk3, TF Int) - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> - work TF fsk2 ~ fsk3 - inert fsk2 ~ (fsk3, TF Int) - inert a ~ ((fsk3, TF Int), TF Int) - inert fsk ~ ((fsk3, TF Int), TF Int) - -Because the incoming given rewrites all the inert givens, we get more and -more duplication in the inert set. But this really only happens in pathological -casee, so we don't care. - - -************************************************************************ -* * - Unflattening -* * -************************************************************************ - -An unflattening example: - [W] F a ~ alpha -flattens to - [W] F a ~ fmv (CFunEqCan) - [W] fmv ~ alpha (CTyEqCan) -We must solve both! --} - -unflattenWanteds :: Cts -> Cts -> TcS Cts -unflattenWanteds tv_eqs funeqs - = do { tclvl <- getTcLevel - - ; traceTcS "Unflattening" $ braces $ - vcat [ text "Funeqs =" <+> pprCts funeqs - , text "Tv eqs =" <+> pprCts tv_eqs ] - - -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check - -- Occurs check: consider [W] alpha ~ [F alpha] - -- ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv] - -- ==> (unify) [W] F [fmv] ~ fmv - -- See Note [Unflatten using funeqs first] - ; funeqs <- foldrM unflatten_funeq emptyCts funeqs - ; traceTcS "Unflattening 1" $ braces (pprCts funeqs) - - -- Step 2: unify the tv_eqs, if possible - ; tv_eqs <- foldrM (unflatten_eq tclvl) emptyCts tv_eqs - ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs) - - -- Step 3: fill any remaining fmvs with fresh unification variables - ; funeqs <- mapBagM finalise_funeq funeqs - ; traceTcS "Unflattening 3" $ braces (pprCts funeqs) - - -- Step 4: remove any tv_eqs that look like ty ~ ty - ; tv_eqs <- foldrM finalise_eq emptyCts tv_eqs - - ; let all_flat = tv_eqs `andCts` funeqs - ; traceTcS "Unflattening done" $ braces (pprCts all_flat) - - ; return all_flat } - where - ---------------- - unflatten_funeq :: Ct -> Cts -> TcS Cts - unflatten_funeq ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis - , cc_fsk = fmv, cc_ev = ev }) rest - = do { -- fmv should be an un-filled flatten meta-tv; - -- we now fix its final value by filling it, being careful - -- to observe the occurs check. Zonking will eliminate it - -- altogether in due course - rhs' <- zonkTcType (mkTyConApp tc xis) - ; case occCheckExpand [fmv] rhs' of - Just rhs'' -- Normal case: fill the tyvar - -> do { setReflEvidence ev NomEq rhs'' - ; unflattenFmv fmv rhs'' - ; return rest } - - Nothing -> -- Occurs check - return (ct `consCts` rest) } - - unflatten_funeq other_ct _ - = pprPanic "unflatten_funeq" (ppr other_ct) - - ---------------- - finalise_funeq :: Ct -> TcS Ct - finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev }) - = do { demoteUnfilledFmv fmv - ; return (mkNonCanonical ev) } - finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct) - - ---------------- - unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts - unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv - , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest - - | NomEq <- eq_rel -- See Note [Do not unify representational equalities] - -- in TcInteract - , isFmvTyVar tv -- Previously these fmvs were untouchable, - -- but now they are touchable - -- NB: unlike unflattenFmv, filling a fmv here /does/ - -- bump the unification count; it is "improvement" - -- Note [Unflattening can force the solver to iterate] - = ASSERT2( tyVarKind tv `eqType` tcTypeKind rhs, ppr ct ) - -- CTyEqCan invariant (TyEq:K) should ensure this is true - do { is_filled <- isFilledMetaTyVar tv - ; elim <- case is_filled of - False -> do { traceTcS "unflatten_eq 2" (ppr ct) - ; tryFill ev tv rhs } - True -> do { traceTcS "unflatten_eq 3" (ppr ct) - ; try_fill_rhs ev tclvl tv rhs } - ; if elim - then do { setReflEvidence ev eq_rel (mkTyVarTy tv) - ; return rest } - else return (ct `consCts` rest) } - - | otherwise - = return (ct `consCts` rest) - - unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct) - - ---------------- - try_fill_rhs ev tclvl lhs_tv rhs - -- Constraint is lhs_tv ~ rhs_tv, - -- and lhs_tv is filled, so try RHS - | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs - -- co :: kind(rhs_tv) ~ kind(lhs_tv) - , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv - && not (isTyVarTyVar rhs_tv)) - -- LHS is a filled fmv, and so is a type - -- family application, which a TyVarTv should - -- not unify with - = do { is_filled <- isFilledMetaTyVar rhs_tv - ; if is_filled then return False - else tryFill ev rhs_tv - (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) } - - | otherwise - = return False - - ---------------- - finalise_eq :: Ct -> Cts -> TcS Cts - finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv - , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest - | isFmvTyVar tv - = do { ty1 <- zonkTcTyVar tv - ; rhs' <- zonkTcType rhs - ; if ty1 `tcEqType` rhs' - then do { setReflEvidence ev eq_rel rhs' - ; return rest } - else return (mkNonCanonical ev `consCts` rest) } - - | otherwise - = return (mkNonCanonical ev `consCts` rest) - - finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct) - -tryFill :: CtEvidence -> TcTyVar -> TcType -> TcS Bool --- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv --- If tv does not appear in 'rhs', it set tv := rhs, --- binds the evidence (which should be a CtWanted) to Refl --- and return True. Otherwise returns False -tryFill ev tv rhs - = ASSERT2( not (isGiven ev), ppr ev ) - do { rhs' <- zonkTcType rhs - ; case () of - _ | Just tv' <- tcGetTyVar_maybe rhs' - , tv == tv' -- tv == rhs - -> return True - - _ | Just rhs'' <- occCheckExpand [tv] rhs' - -> do { -- Fill the tyvar - unifyTyVar tv rhs'' - ; return True } - - _ | otherwise -- Occurs check - -> return False - } - -setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS () -setReflEvidence ev eq_rel rhs - = setEvBindIfWanted ev (evCoercion refl_co) - where - refl_co = mkTcReflCo (eqRelRole eq_rel) rhs - -{- -Note [Unflatten using funeqs first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - [W] G a ~ Int - [W] F (G a) ~ G a - -do not want to end up with - [W] F Int ~ Int -because that might actually hold! Better to end up with the two above -unsolved constraints. The flat form will be - - G a ~ fmv1 (CFunEqCan) - F fmv1 ~ fmv2 (CFunEqCan) - fmv1 ~ Int (CTyEqCan) - fmv1 ~ fmv2 (CTyEqCan) - -Flatten using the fun-eqs first. --} - --- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at --- least one named binder. -split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool) -split_pi_tys' ty = split ty ty - where - split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' - split _ (ForAllTy b res) = let (bs, ty, _) = split res res - in (Named b : bs, ty, True) - split _ (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) - = let (bs, ty, named) = split res res - in (Anon af arg : bs, ty, named) - split orig_ty _ = ([], orig_ty, False) -{-# INLINE split_pi_tys' #-} - --- | Like 'tyConBindersTyCoBinders' but you also get a 'Bool' which is true iff --- there is at least one named binder. -ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool) -ty_con_binders_ty_binders' = foldr go ([], False) - where - go (Bndr tv (NamedTCB vis)) (bndrs, _) - = (Named (Bndr tv vis) : bndrs, True) - go (Bndr tv (AnonTCB af)) (bndrs, n) - = (Anon af (tyVarKind tv) : bndrs, n) - {-# INLINE go #-} -{-# INLINE ty_con_binders_ty_binders' #-} diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs deleted file mode 100644 --- a/compiler/typecheck/TcForeign.hs +++ /dev/null @@ -1,571 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1998 - -\section[TcForeign]{Typechecking \tr{foreign} declarations} - -A foreign declaration is used to either give an externally -implemented function a Haskell type (and calling interface) or -give a Haskell function an external calling interface. Either way, -the range of argument and result types these functions can accommodate -is restricted to what the outside world understands (read C), and this -module checks to see if a foreign declaration has got a legal type. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -module TcForeign - ( tcForeignImports - , tcForeignExports - - -- Low-level exports for hooks - , isForeignImport, isForeignExport - , tcFImport, tcFExport - , tcForeignImports' - , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes - , normaliseFfiType - , nonIOok, mustBeIO - , checkSafe, noCheckSafe - , tcForeignExports' - , tcCheckFEType - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs - -import TcRnMonad -import TcHsType -import TcExpr -import TcEnv - -import FamInst -import GHC.Core.FamInstEnv -import GHC.Core.Coercion -import GHC.Core.Type -import GHC.Types.ForeignCall -import ErrUtils -import GHC.Types.Id -import GHC.Types.Name -import GHC.Types.Name.Reader -import GHC.Core.DataCon -import GHC.Core.TyCon -import TcType -import PrelNames -import GHC.Driver.Session -import Outputable -import GHC.Platform -import GHC.Types.SrcLoc -import Bag -import GHC.Driver.Hooks -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad - --- Defines a binding -isForeignImport :: LForeignDecl name -> Bool -isForeignImport (L _ (ForeignImport {})) = True -isForeignImport _ = False - --- Exports a binding -isForeignExport :: LForeignDecl name -> Bool -isForeignExport (L _ (ForeignExport {})) = True -isForeignExport _ = False - -{- -Note [Don't recur in normaliseFfiType'] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -normaliseFfiType' is the workhorse for normalising a type used in a foreign -declaration. If we have - -newtype Age = MkAge Int - -we want to see that Age -> IO () is the same as Int -> IO (). But, we don't -need to recur on any type parameters, because no paramaterized types (with -interesting parameters) are marshalable! The full list of marshalable types -is in the body of boxedMarshalableTyCon in TcType. The only members of that -list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled -the same way regardless of type parameter. So, no need to recur into -parameters. - -Similarly, we don't need to look in AppTy's, because nothing headed by -an AppTy will be marshalable. - -Note [FFI type roles] -~~~~~~~~~~~~~~~~~~~~~ -The 'go' helper function within normaliseFfiType' always produces -representational coercions. But, in the "children_only" case, we need to -use these coercions in a TyConAppCo. Accordingly, the roles on the coercions -must be twiddled to match the expectation of the enclosing TyCon. However, -we cannot easily go from an R coercion to an N one, so we forbid N roles -on FFI type constructors. Currently, only two such type constructors exist: -IO and FunPtr. Thus, this is not an onerous burden. - -If we ever want to lift this restriction, we would need to make 'go' take -the target role as a parameter. This wouldn't be hard, but it's a complication -not yet necessary and so is not yet implemented. --} - --- normaliseFfiType takes the type from an FFI declaration, and --- evaluates any type synonyms, type functions, and newtypes. However, --- we are only allowed to look through newtypes if the constructor is --- in scope. We return a bag of all the newtype constructors thus found. --- Always returns a Representational coercion -normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt) -normaliseFfiType ty - = do fam_envs <- tcGetFamInstEnvs - normaliseFfiType' fam_envs ty - -normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) -normaliseFfiType' env ty0 = go initRecTc ty0 - where - go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) - go rec_nts ty - | Just ty' <- tcView ty -- Expand synonyms - = go rec_nts ty' - - | Just (tc, tys) <- splitTyConApp_maybe ty - = go_tc_app rec_nts tc tys - - | (bndrs, inner_ty) <- splitForAllVarBndrs ty - , not (null bndrs) - = do (coi, nty1, gres1) <- go rec_nts inner_ty - return ( mkHomoForAllCos (binderVars bndrs) coi - , mkForAllTys bndrs nty1, gres1 ) - - | otherwise -- see Note [Don't recur in normaliseFfiType'] - = return (mkRepReflCo ty, ty, emptyBag) - - go_tc_app :: RecTcChecker -> TyCon -> [Type] - -> TcM (Coercion, Type, Bag GlobalRdrElt) - go_tc_app rec_nts tc tys - -- We don't want to look through the IO newtype, even if it is - -- in scope, so we have a special case for it: - | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey] - -- These *must not* have nominal roles on their parameters! - -- See Note [FFI type roles] - = children_only - - | isNewTyCon tc -- Expand newtypes - , Just rec_nts' <- checkRecTc rec_nts tc - -- See Note [Expanding newtypes] in GHC.Core.TyCon - -- We can't just use isRecursiveTyCon; sometimes recursion is ok: - -- newtype T = T (Ptr T) - -- Here, we don't reject the type for being recursive. - -- If this is a recursive newtype then it will normally - -- be rejected later as not being a valid FFI type. - = do { rdr_env <- getGlobalRdrEnv - ; case checkNewtypeFFI rdr_env tc of - Nothing -> nothing - Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs - ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } } - - | isFamilyTyCon tc -- Expand open tycons - , (co, ty) <- normaliseTcApp env Representational tc tys - , not (isReflexiveCo co) - = do (co', ty', gres) <- go rec_nts ty - return (mkTransCo co co', ty', gres) - - | otherwise - = nothing -- see Note [Don't recur in normaliseFfiType'] - where - tc_key = getUnique tc - children_only - = do xs <- mapM (go rec_nts) tys - let (cos, tys', gres) = unzip3 xs - -- the (repeat Representational) is because 'go' always - -- returns R coercions - cos' = zipWith3 downgradeRole (tyConRoles tc) - (repeat Representational) cos - return ( mkTyConAppCo Representational tc cos' - , mkTyConApp tc tys', unionManyBags gres) - nt_co = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys [] - nt_rhs = newTyConInstRhs tc tys - - ty = mkTyConApp tc tys - nothing = return (mkRepReflCo ty, ty, emptyBag) - -checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt -checkNewtypeFFI rdr_env tc - | Just con <- tyConSingleDataCon_maybe tc - , Just gre <- lookupGRE_Name rdr_env (dataConName con) - = Just gre -- See Note [Newtype constructor usage in foreign declarations] - | otherwise - = Nothing - -{- -Note [Newtype constructor usage in foreign declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC automatically "unwraps" newtype constructors in foreign import/export -declarations. In effect that means that a newtype data constructor is -used even though it is not mentioned expclitly in the source, so we don't -want to report it as "defined but not used" or "imported but not used". -eg newtype D = MkD Int - foreign import foo :: D -> IO () -Here 'MkD' us used. See #7408. - -GHC also expands type functions during this process, so it's not enough -just to look at the free variables of the declaration. -eg type instance F Bool = D - foreign import bar :: F Bool -> IO () -Here again 'MkD' is used. - -So we really have wait until the type checker to decide what is used. -That's why tcForeignImports and tecForeignExports return a (Bag GRE) -for the newtype constructors they see. Then TcRnDriver can add them -to the module's usages. - - -************************************************************************ -* * -\subsection{Imports} -* * -************************************************************************ --} - -tcForeignImports :: [LForeignDecl GhcRn] - -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) -tcForeignImports decls - = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls) - -tcForeignImports' :: [LForeignDecl GhcRn] - -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) --- For the (Bag GlobalRdrElt) result, --- see Note [Newtype constructor usage in foreign declarations] -tcForeignImports' decls - = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $ - filter isForeignImport decls - ; return (ids, decls, unionManyBags gres) } - -tcFImport :: LForeignDecl GhcRn - -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt) -tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty - , fd_fi = imp_decl })) - = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo) $ - do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty - ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty - ; let - -- Drop the foralls before inspecting the - -- structure of the foreign type. - (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty) - id = mkLocalId nm sig_ty - -- Use a LocalId to obey the invariant that locally-defined - -- things are LocalIds. However, it does not need zonking, - -- (so TcHsSyn.zonkForeignExports ignores it). - - ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl - -- Can't use sig_ty here because sig_ty :: Type and - -- we need HsType Id hence the undefined - ; let fi_decl = ForeignImport { fd_name = L nloc id - , fd_sig_ty = undefined - , fd_i_ext = mkSymCo norm_co - , fd_fi = imp_decl' } - ; return (id, L dloc fi_decl, gres) } -tcFImport d = pprPanic "tcFImport" (ppr d) - --- ------------ Checking types for foreign import ---------------------- - -tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport - -tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src) - -- Foreign import label - = do checkCg checkCOrAsmOrLlvmOrInterp - -- NB check res_ty not sig_ty! - -- In case sig_ty is (forall a. ForeignPtr a) - check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty) - cconv' <- checkCConv cconv - return (CImport (L lc cconv') safety mh l src) - -tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do - -- Foreign wrapper (former f.e.d.) - -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid - -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. - -- The use of the latter form is DEPRECATED, though. - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv - case arg_tys of - [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys - checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty - checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty - where - (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty - _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected")) - return (CImport (L lc cconv') safety mh CWrapper src) - -tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh - (CFunction target) src) - | isDynamicTarget target = do -- Foreign import dynamic - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv - case arg_tys of -- The first arg must be Ptr or FunPtr - [] -> - addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected")) - (arg1_ty:arg_tys) -> do - dflags <- getDynFlags - let curried_res_ty = mkVisFunTys arg_tys res_ty - check (isFFIDynTy curried_res_ty arg1_ty) - (illegalForeignTyErr argument) - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys - checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src - | cconv == PrimCallConv = do - dflags <- getDynFlags - checkTc (xopt LangExt.GHCForeignImportPrim dflags) - (text "Use GHCForeignImportPrim to allow `foreign import prim'.") - checkCg checkCOrAsmOrLlvmOrInterp - checkCTarget target - checkTc (playSafe safety) - (text "The safe/unsafe annotation should not be used with `foreign import prim'.") - checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys - -- prim import result is more liberal, allows (#,,#) - checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty - return idecl - | otherwise = do -- Normal foreign import - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv - checkCTarget target - dflags <- getDynFlags - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys - checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - checkMissingAmpersand dflags arg_tys res_ty - case target of - StaticTarget _ _ _ False - | not (null arg_tys) -> - addErrTc (text "`value' imports cannot have function types") - _ -> return () - return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src - - --- This makes a convenient place to check --- that the C identifier is valid for C -checkCTarget :: CCallTarget -> TcM () -checkCTarget (StaticTarget _ str _ _) = do - checkCg checkCOrAsmOrLlvmOrInterp - checkTc (isCLabelString str) (badCName str) - -checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" - - -checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () -checkMissingAmpersand dflags arg_tys res_ty - | null arg_tys && isFunPtrTy res_ty && - wopt Opt_WarnDodgyForeignImports dflags - = addWarn (Reason Opt_WarnDodgyForeignImports) - (text "possible missing & in foreign import of FunPtr") - | otherwise - = return () - -{- -************************************************************************ -* * -\subsection{Exports} -* * -************************************************************************ --} - -tcForeignExports :: [LForeignDecl GhcRn] - -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt) -tcForeignExports decls = - getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls) - -tcForeignExports' :: [LForeignDecl GhcRn] - -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt) --- For the (Bag GlobalRdrElt) result, --- see Note [Newtype constructor usage in foreign declarations] -tcForeignExports' decls - = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls) - where - combine (binds, fs, gres1) (L loc fe) = do - (b, f, gres2) <- setSrcSpan loc (tcFExport fe) - return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) - -tcFExport :: ForeignDecl GhcRn - -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt) -tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec }) - = addErrCtxt (foreignDeclCtxt fo) $ do - - sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty - rhs <- tcPolyExpr (nlHsVar nm) sig_ty - - (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty - - spec' <- tcCheckFEType norm_sig_ty spec - - -- we're exporting a function, but at a type possibly more - -- constrained than its declared/inferred type. Hence the need - -- to create a local binding which will call the exported function - -- at a particular type (and, maybe, overloading). - - - -- We need to give a name to the new top-level binding that - -- is *stable* (i.e. the compiler won't change it later), - -- because this name will be referred to by the C code stub. - id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc - return ( mkVarBind id rhs - , ForeignExport { fd_name = L loc id - , fd_sig_ty = undefined - , fd_e_ext = norm_co, fd_fe = spec' } - , gres) -tcFExport d = pprPanic "tcFExport" (ppr d) - --- ------------ Checking argument types for foreign export ---------------------- - -tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport -tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do - checkCg checkCOrAsmOrLlvm - checkTc (isCLabelString str) (badCName str) - cconv' <- checkCConv cconv - checkForeignArgs isFFIExternalTy arg_tys - checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty - return (CExport (L l (CExportStatic esrc str cconv')) src) - where - -- Drop the foralls before inspecting - -- the structure of the foreign type. - (arg_tys, res_ty) = tcSplitFunTys (dropForAlls sig_ty) - -{- -************************************************************************ -* * -\subsection{Miscellaneous} -* * -************************************************************************ --} - ------------- Checking argument types for foreign import ---------------------- -checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM () -checkForeignArgs pred tys = mapM_ go tys - where - go ty = check (pred ty) (illegalForeignTyErr argument) - ------------- Checking result types for foreign calls ---------------------- --- | Check that the type has the form --- (IO t) or (t) , and that t satisfies the given predicate. --- When calling this function, any newtype wrappers (should) have been --- already dealt with by normaliseFfiType. --- --- We also check that the Safe Haskell condition of FFI imports having --- results in the IO monad holds. --- -checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM () -checkForeignRes non_io_result_ok check_safe pred_res_ty ty - | Just (_, res_ty) <- tcSplitIOType_maybe ty - = -- Got an IO result type, that's always fine! - check (pred_res_ty res_ty) (illegalForeignTyErr result) - - -- We disallow nested foralls in foreign types - -- (at least, for the time being). See #16702. - | tcIsForAllTy ty - = addErrTc $ illegalForeignTyErr result (text "Unexpected nested forall") - - -- Case for non-IO result type with FFI Import - | not non_io_result_ok - = addErrTc $ illegalForeignTyErr result (text "IO result type expected") - - | otherwise - = do { dflags <- getDynFlags - ; case pred_res_ty ty of - -- Handle normal typecheck fail, we want to handle this first and - -- only report safe haskell errors if the normal type check is OK. - NotValid msg -> addErrTc $ illegalForeignTyErr result msg - - -- handle safe infer fail - _ | check_safe && safeInferOn dflags - -> recordUnsafeInfer emptyBag - - -- handle safe language typecheck fail - _ | check_safe && safeLanguageOn dflags - -> addErrTc (illegalForeignTyErr result safeHsErr) - - -- success! non-IO return is fine - _ -> return () } - where - safeHsErr = - text "Safe Haskell is on, all FFI imports must be in the IO monad" - -nonIOok, mustBeIO :: Bool -nonIOok = True -mustBeIO = False - -checkSafe, noCheckSafe :: Bool -checkSafe = True -noCheckSafe = False - --- Checking a supported backend is in use - -checkCOrAsmOrLlvm :: HscTarget -> Validity -checkCOrAsmOrLlvm HscC = IsValid -checkCOrAsmOrLlvm HscAsm = IsValid -checkCOrAsmOrLlvm HscLlvm = IsValid -checkCOrAsmOrLlvm _ - = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)") - -checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity -checkCOrAsmOrLlvmOrInterp HscC = IsValid -checkCOrAsmOrLlvmOrInterp HscAsm = IsValid -checkCOrAsmOrLlvmOrInterp HscLlvm = IsValid -checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid -checkCOrAsmOrLlvmOrInterp _ - = NotValid (text "requires interpreted, unregisterised, llvm or native code generation") - -checkCg :: (HscTarget -> Validity) -> TcM () -checkCg check = do - dflags <- getDynFlags - let target = hscTarget dflags - case target of - HscNothing -> return () - _ -> - case check target of - IsValid -> return () - NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err) - --- Calling conventions - -checkCConv :: CCallConv -> TcM CCallConv -checkCConv CCallConv = return CCallConv -checkCConv CApiConv = return CApiConv -checkCConv StdCallConv = do dflags <- getDynFlags - let platform = targetPlatform dflags - if platformArch platform == ArchX86 - then return StdCallConv - else do -- This is a warning, not an error. see #3336 - when (wopt Opt_WarnUnsupportedCallingConventions dflags) $ - addWarnTc (Reason Opt_WarnUnsupportedCallingConventions) - (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") - return CCallConv -checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") - return PrimCallConv -checkCConv JavaScriptCallConv = do dflags <- getDynFlags - if platformArch (targetPlatform dflags) == ArchJavaScript - then return JavaScriptCallConv - else do addErrTc (text "The `javascript' calling convention is unsupported on this platform") - return JavaScriptCallConv - --- Warnings - -check :: Validity -> (MsgDoc -> MsgDoc) -> TcM () -check IsValid _ = return () -check (NotValid doc) err_fn = addErrTc (err_fn doc) - -illegalForeignTyErr :: SDoc -> SDoc -> SDoc -illegalForeignTyErr arg_or_res extra - = hang msg 2 extra - where - msg = hsep [ text "Unacceptable", arg_or_res - , text "type in foreign declaration:"] - --- Used for 'arg_or_res' argument to illegalForeignTyErr -argument, result :: SDoc -argument = text "argument" -result = text "result" - -badCName :: CLabelString -> MsgDoc -badCName target - = sep [quotes (ppr target) <+> text "is not a valid C identifier"] - -foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc -foreignDeclCtxt fo - = hang (text "When checking declaration:") - 2 (ppr fo) diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs deleted file mode 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ /dev/null @@ -1,2425 +0,0 @@ -{- - % -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcGenDeriv: Generating derived instance declarations - -This module is nominally ``subordinate'' to @TcDeriv@, which is the -``official'' interface to deriving-related things. - -This is where we do all the grimy bindings' generation. --} - -{-# LANGUAGE CPP, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcGenDeriv ( - BagDerivStuff, DerivStuff(..), - - gen_Eq_binds, - gen_Ord_binds, - gen_Enum_binds, - gen_Bounded_binds, - gen_Ix_binds, - gen_Show_binds, - gen_Read_binds, - gen_Data_binds, - gen_Lift_binds, - gen_Newtype_binds, - mkCoerceClassMethEqn, - genAuxBinds, - ordOpTbl, boxConTbl, litConTbl, - mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnMonad -import GHC.Hs -import GHC.Types.Name.Reader -import GHC.Types.Basic -import GHC.Core.DataCon -import GHC.Types.Name -import Fingerprint -import Encoding - -import GHC.Driver.Session -import PrelInfo -import FamInst -import GHC.Core.FamInstEnv -import PrelNames -import THNames -import GHC.Types.Id.Make ( coerceId ) -import PrimOp -import GHC.Types.SrcLoc -import GHC.Core.TyCon -import TcEnv -import TcType -import TcValidity ( checkValidCoAxBranch ) -import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch ) -import TysPrim -import TysWiredIn -import GHC.Core.Type -import GHC.Core.Class -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import Util -import GHC.Types.Var -import Outputable -import GHC.Utils.Lexeme -import FastString -import Pair -import Bag - -import Data.List ( find, partition, intersperse ) - -type BagDerivStuff = Bag DerivStuff - -data AuxBindSpec - = DerivCon2Tag TyCon -- The con2Tag for given TyCon - | DerivTag2Con TyCon -- ...ditto tag2Con - | DerivMaxTag TyCon -- ...and maxTag - deriving( Eq ) - -- All these generate ZERO-BASED tag operations - -- I.e first constructor has tag 0 - -data DerivStuff -- Please add this auxiliary stuff - = DerivAuxBind AuxBindSpec - - -- Generics and DeriveAnyClass - | DerivFamInst FamInst -- New type family instances - - -- New top-level auxiliary bindings - | DerivHsBind (LHsBind GhcPs, LSig GhcPs) -- Also used for SYB - - -{- -************************************************************************ -* * - Eq instances -* * -************************************************************************ - -Here are the heuristics for the code we generate for @Eq@. Let's -assume we have a data type with some (possibly zero) nullary data -constructors and some ordinary, non-nullary ones (the rest, also -possibly zero of them). Here's an example, with both \tr{N}ullary and -\tr{O}rdinary data cons. - - data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... - -* For the ordinary constructors (if any), we emit clauses to do The - Usual Thing, e.g.,: - - (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2 - (==) (O2 a1) (O2 a2) = a1 == a2 - (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2 - - Note: if we're comparing unlifted things, e.g., if 'a1' and - 'a2' are Float#s, then we have to generate - case (a1 `eqFloat#` a2) of r -> r - for that particular test. - -* If there are a lot of (more than ten) nullary constructors, we emit a - catch-all clause of the form: - - (==) a b = case (con2tag_Foo a) of { a# -> - case (con2tag_Foo b) of { b# -> - case (a# ==# b#) of { - r -> r }}} - - If con2tag gets inlined this leads to join point stuff, so - it's better to use regular pattern matching if there aren't too - many nullary constructors. "Ten" is arbitrary, of course - -* If there aren't any nullary constructors, we emit a simpler - catch-all: - - (==) a b = False - -* For the @(/=)@ method, we normally just use the default method. - If the type is an enumeration type, we could/may/should? generate - special code that calls @con2tag_Foo@, much like for @(==)@ shown - above. - -We thought about doing this: If we're also deriving 'Ord' for this -tycon, we generate: - instance ... Eq (Foo ...) where - (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False} - (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True } -However, that requires that (Ord ) was put in the context -for the instance decl, which it probably wasn't, so the decls -produced don't get through the typechecker. --} - -gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) -gen_Eq_binds loc tycon = do - dflags <- getDynFlags - return (method_binds dflags, aux_binds) - where - all_cons = tyConDataCons tycon - (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons - - -- If there are ten or more (arbitrary number) nullary constructors, - -- use the con2tag stuff. For small types it's better to use - -- ordinary pattern matching. - (tag_match_cons, pat_match_cons) - | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons) - | otherwise = ([], all_cons) - - no_tag_match_cons = null tag_match_cons - - fall_through_eqn dflags - | no_tag_match_cons -- All constructors have arguments - = case pat_match_cons of - [] -> [] -- No constructors; no fall-though case - [_] -> [] -- One constructor; no fall-though case - _ -> -- Two or more constructors; add fall-through of - -- (==) _ _ = False - [([nlWildPat, nlWildPat], false_Expr)] - - | otherwise -- One or more tag_match cons; add fall-through of - -- extract tags compare for equality - = [([a_Pat, b_Pat], - untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] - (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] - - aux_binds | no_tag_match_cons = emptyBag - | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon - - method_binds dflags = unitBag (eq_bind dflags) - eq_bind dflags = mkFunBindEC 2 loc eq_RDR (const true_Expr) - (map pats_etc pat_match_cons - ++ fall_through_eqn dflags) - - ------------------------------------------------------------------ - pats_etc data_con - = let - con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed - con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed - - data_con_RDR = getRdrName data_con - con_arity = length tys_needed - as_needed = take con_arity as_RDRs - bs_needed = take con_arity bs_RDRs - tys_needed = dataConOrigArgTys data_con - in - ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) - where - nested_eq_expr [] [] [] = true_Expr - nested_eq_expr tys as bs - = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) - -- Using 'foldr1' here ensures that the derived code is correctly - -- associated. See #10859. - where - nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b)) - -{- -************************************************************************ -* * - Ord instances -* * -************************************************************************ - -Note [Generating Ord instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose constructors are K1..Kn, and some are nullary. -The general form we generate is: - -* Do case on first argument - case a of - K1 ... -> rhs_1 - K2 ... -> rhs_2 - ... - Kn ... -> rhs_n - _ -> nullary_rhs - -* To make rhs_i - If i = 1, 2, n-1, n, generate a single case. - rhs_2 case b of - K1 {} -> LT - K2 ... -> ...eq_rhs(K2)... - _ -> GT - - Otherwise do a tag compare against the bigger range - (because this is the one most likely to succeed) - rhs_3 case tag b of tb -> - if 3 <# tg then GT - else case b of - K3 ... -> ...eq_rhs(K3).... - _ -> LT - -* To make eq_rhs(K), which knows that - a = K a1 .. av - b = K b1 .. bv - we just want to compare (a1,b1) then (a2,b2) etc. - Take care on the last field to tail-call into comparing av,bv - -* To make nullary_rhs generate this - case con2tag a of a# -> - case con2tag b of -> - a# `compare` b# - -Several special cases: - -* Two or fewer nullary constructors: don't generate nullary_rhs - -* Be careful about unlifted comparisons. When comparing unboxed - values we can't call the overloaded functions. - See function unliftedOrdOp - -Note [Game plan for deriving Ord] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's a bad idea to define only 'compare', and build the other binary -comparisons on top of it; see #2130, #4019. Reason: we don't -want to laboriously make a three-way comparison, only to extract a -binary result, something like this: - (>) (I# x) (I# y) = case <# x y of - True -> False - False -> case ==# x y of - True -> False - False -> True - -This being said, we can get away with generating full code only for -'compare' and '<' thus saving us generation of other three operators. -Other operators can be cheaply expressed through '<': -a <= b = not $ b < a -a > b = b < a -a >= b = not $ a < b - -So for sufficiently small types (few constructors, or all nullary) -we generate all methods; for large ones we just use 'compare'. - --} - -data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT - ------------- -ordMethRdr :: OrdOp -> RdrName -ordMethRdr op - = case op of - OrdCompare -> compare_RDR - OrdLT -> lt_RDR - OrdLE -> le_RDR - OrdGE -> ge_RDR - OrdGT -> gt_RDR - ------------- -ltResult :: OrdOp -> LHsExpr GhcPs --- Knowing a LHsExpr GhcPs --- Knowing a=b, what is the result for a `op` b? -eqResult OrdCompare = eqTag_Expr -eqResult OrdLT = false_Expr -eqResult OrdLE = true_Expr -eqResult OrdGE = true_Expr -eqResult OrdGT = false_Expr - ------------- -gtResult :: OrdOp -> LHsExpr GhcPs --- Knowing a>b, what is the result for a `op` b? -gtResult OrdCompare = gtTag_Expr -gtResult OrdLT = false_Expr -gtResult OrdLE = false_Expr -gtResult OrdGE = true_Expr -gtResult OrdGT = true_Expr - ------------- -gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) -gen_Ord_binds loc tycon = do - dflags <- getDynFlags - return $ if null tycon_data_cons -- No data-cons => invoke bale-out case - then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) [] - , emptyBag) - else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags - , aux_binds) - where - aux_binds | single_con_type = emptyBag - | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon - - -- Note [Game plan for deriving Ord] - other_ops dflags - | (last_tag - first_tag) <= 2 -- 1-3 constructors - || null non_nullary_cons -- Or it's an enumeration - = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE] - | otherwise - = emptyBag - - negate_expr = nlHsApp (nlHsVar not_RDR) - lE = mkSimpleGeneratedFunBind loc le_RDR [a_Pat, b_Pat] $ - negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr) - gT = mkSimpleGeneratedFunBind loc gt_RDR [a_Pat, b_Pat] $ - nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr - gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $ - negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr) - - get_tag con = dataConTag con - fIRST_TAG - -- We want *zero-based* tags, because that's what - -- con2Tag returns (generated by untag_Expr)! - - tycon_data_cons = tyConDataCons tycon - single_con_type = isSingleton tycon_data_cons - (first_con : _) = tycon_data_cons - (last_con : _) = reverse tycon_data_cons - first_tag = get_tag first_con - last_tag = get_tag last_con - - (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons - - - mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs - -- Returns a binding op a b = ... compares a and b according to op .... - mkOrdOp dflags op = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat] - (mkOrdOpRhs dflags op) - - mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs - mkOrdOpRhs dflags op -- RHS for comparing 'a' and 'b' according to op - | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases - = nlHsCase (nlHsVar a_RDR) $ - map (mkOrdOpAlt dflags op) tycon_data_cons - -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y... - -- C2 x -> case b of C2 x -> ....comopare x.... } - - | null non_nullary_cons -- All nullary, so go straight to comparing tags - = mkTagCmp dflags op - - | otherwise -- Mixed nullary and non-nullary - = nlHsCase (nlHsVar a_RDR) $ - (map (mkOrdOpAlt dflags op) non_nullary_cons - ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)]) - - - mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon - -> LMatch GhcPs (LHsExpr GhcPs) - -- Make the alternative (Ki a1 a2 .. av -> - mkOrdOpAlt dflags op data_con - = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed) - (mkInnerRhs dflags op data_con) - where - as_needed = take (dataConSourceArity data_con) as_RDRs - data_con_RDR = getRdrName data_con - - mkInnerRhs dflags op data_con - | single_con_type - = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ] - - | tag == first_tag - = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (ltResult op) ] - | tag == last_tag - = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (gtResult op) ] - - | tag == first_tag + 1 - = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con) - (gtResult op) - , mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (ltResult op) ] - | tag == last_tag - 1 - = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con) - (ltResult op) - , mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (gtResult op) ] - - | tag > last_tag `div` 2 -- lower range is larger - = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ - nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit) - (gtResult op) $ -- Definitely GT - nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (ltResult op) ] - - | otherwise -- upper range is larger - = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ - nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit) - (ltResult op) $ -- Definitely LT - nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (gtResult op) ] - where - tag = get_tag data_con - tag_lit = noLoc (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag))) - - mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) - -- First argument 'a' known to be built with K - -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) - mkInnerEqAlt op data_con - = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $ - mkCompareFields op (dataConOrigArgTys data_con) - where - data_con_RDR = getRdrName data_con - bs_needed = take (dataConSourceArity data_con) bs_RDRs - - mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs - -- Both constructors known to be nullary - -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b# - mkTagCmp dflags op = - untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ - unliftedOrdOp intPrimTy op ah_RDR bh_RDR - -mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs --- Generates nested comparisons for (a1,a2...) against (b1,b2,...) --- where the ai,bi have the given types -mkCompareFields op tys - = go tys as_RDRs bs_RDRs - where - go [] _ _ = eqResult op - go [ty] (a:_) (b:_) - | isUnliftedType ty = unliftedOrdOp ty op a b - | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b) - go (ty:tys) (a:as) (b:bs) = mk_compare ty a b - (ltResult op) - (go tys as bs) - (gtResult op) - go _ _ _ = panic "mkCompareFields" - - -- (mk_compare ty a b) generates - -- (case (compare a b) of { LT -> ; EQ -> ; GT -> }) - -- but with suitable special cases for - mk_compare ty a b lt eq gt - | isUnliftedType ty - = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt - | otherwise - = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr)) - [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt, - mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq, - mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt] - where - a_expr = nlHsVar a - b_expr = nlHsVar b - (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty - -unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs -unliftedOrdOp ty op a b - = case op of - OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr - ltTag_Expr eqTag_Expr gtTag_Expr - OrdLT -> wrap lt_op - OrdLE -> wrap le_op - OrdGE -> wrap ge_op - OrdGT -> wrap gt_op - where - (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty - wrap prim_op = genPrimOpApp a_expr prim_op b_expr - a_expr = nlHsVar a - b_expr = nlHsVar b - -unliftedCompare :: RdrName -> RdrName - -> LHsExpr GhcPs -> LHsExpr GhcPs -- What to compare - -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs - -- Three results - -> LHsExpr GhcPs --- Return (if a < b then lt else if a == b then eq else gt) -unliftedCompare lt_op eq_op a_expr b_expr lt eq gt - = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $ - -- Test (<) first, not (==), because the latter - -- is true less often, so putting it first would - -- mean more tests (dynamically) - nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt - where - ascribeBool e = nlExprWithTySig e boolTy - -nlConWildPat :: DataCon -> LPat GhcPs --- The pattern (K {}) -nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con)) - (RecCon (HsRecFields { rec_flds = [] - , rec_dotdot = Nothing }))) - -{- -************************************************************************ -* * - Enum instances -* * -************************************************************************ - -@Enum@ can only be derived for enumeration types. For a type -\begin{verbatim} -data Foo ... = N1 | N2 | ... | Nn -\end{verbatim} - -we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a -@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@). - -\begin{verbatim} -instance ... Enum (Foo ...) where - succ x = toEnum (1 + fromEnum x) - pred x = toEnum (fromEnum x - 1) - - toEnum i = tag2con_Foo i - - enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo] - - -- or, really... - enumFrom a - = case con2tag_Foo a of - a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo) - - enumFromThen a b - = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo] - - -- or, really... - enumFromThen a b - = case con2tag_Foo a of { a# -> - case con2tag_Foo b of { b# -> - map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo) - }} -\end{verbatim} - -For @enumFromTo@ and @enumFromThenTo@, we use the default methods. --} - -gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) -gen_Enum_binds loc tycon = do - dflags <- getDynFlags - return (method_binds dflags, aux_binds) - where - method_binds dflags = listToBag - [ succ_enum dflags - , pred_enum dflags - , to_enum dflags - , enum_from dflags - , enum_from_then dflags - , from_enum dflags - ] - aux_binds = listToBag $ map DerivAuxBind - [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon] - - occ_nm = getOccString tycon - - succ_enum dflags - = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon), - nlHsVarApps intDataCon_RDR [ah_RDR]]) - (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration") - (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) - (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], - nlHsIntLit 1])) - - pred_enum dflags - = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, - nlHsVarApps intDataCon_RDR [ah_RDR]]) - (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") - (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) - (nlHsApps plus_RDR - [ nlHsVarApps intDataCon_RDR [ah_RDR] - , nlHsLit (HsInt noExtField - (mkIntegralLit (-1 :: Int)))])) - - to_enum dflags - = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $ - nlHsIf (nlHsApps and_RDR - [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], - nlHsApps le_RDR [ nlHsVar a_RDR - , nlHsVar (maxtag_RDR dflags tycon)]]) - (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR]) - (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon)) - - enum_from dflags - = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - nlHsApps map_RDR - [nlHsVar (tag2con_RDR dflags tycon), - nlHsPar (enum_from_to_Expr - (nlHsVarApps intDataCon_RDR [ah_RDR]) - (nlHsVar (maxtag_RDR dflags tycon)))] - - enum_from_then dflags - = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ - nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ - nlHsPar (enum_from_then_to_Expr - (nlHsVarApps intDataCon_RDR [ah_RDR]) - (nlHsVarApps intDataCon_RDR [bh_RDR]) - (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], - nlHsVarApps intDataCon_RDR [bh_RDR]]) - (nlHsIntLit 0) - (nlHsVar (maxtag_RDR dflags tycon)) - )) - - from_enum dflags - = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - (nlHsVarApps intDataCon_RDR [ah_RDR]) - -{- -************************************************************************ -* * - Bounded instances -* * -************************************************************************ --} - -gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) -gen_Bounded_binds loc tycon - | isEnumerationTyCon tycon - = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag) - | otherwise - = ASSERT(isSingleton data_cons) - (listToBag [ min_bound_1con, max_bound_1con ], emptyBag) - where - data_cons = tyConDataCons tycon - - ----- enum-flavored: --------------------------- - min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) - max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) - - data_con_1 = head data_cons - data_con_N = last data_cons - data_con_1_RDR = getRdrName data_con_1 - data_con_N_RDR = getRdrName data_con_N - - ----- single-constructor-flavored: ------------- - arity = dataConSourceArity data_con_1 - - min_bound_1con = mkHsVarBind loc minBound_RDR $ - nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR) - max_bound_1con = mkHsVarBind loc maxBound_RDR $ - nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR) - -{- -************************************************************************ -* * - Ix instances -* * -************************************************************************ - -Deriving @Ix@ is only possible for enumeration types and -single-constructor types. We deal with them in turn. - -For an enumeration type, e.g., -\begin{verbatim} - data Foo ... = N1 | N2 | ... | Nn -\end{verbatim} -things go not too differently from @Enum@: -\begin{verbatim} -instance ... Ix (Foo ...) where - range (a, b) - = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b] - - -- or, really... - range (a, b) - = case (con2tag_Foo a) of { a# -> - case (con2tag_Foo b) of { b# -> - map tag2con_Foo (enumFromTo (I# a#) (I# b#)) - }} - - -- Generate code for unsafeIndex, because using index leads - -- to lots of redundant range tests - unsafeIndex c@(a, b) d - = case (con2tag_Foo d -# con2tag_Foo a) of - r# -> I# r# - - inRange (a, b) c - = let - p_tag = con2tag_Foo c - in - p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b - - -- or, really... - inRange (a, b) c - = case (con2tag_Foo a) of { a_tag -> - case (con2tag_Foo b) of { b_tag -> - case (con2tag_Foo c) of { c_tag -> - if (c_tag >=# a_tag) then - c_tag <=# b_tag - else - False - }}} -\end{verbatim} -(modulo suitable case-ification to handle the unlifted tags) - -For a single-constructor type (NB: this includes all tuples), e.g., -\begin{verbatim} - data Foo ... = MkFoo a b Int Double c c -\end{verbatim} -we follow the scheme given in Figure~19 of the Haskell~1.2 report -(p.~147). --} - -gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) - -gen_Ix_binds loc tycon = do - dflags <- getDynFlags - return $ if isEnumerationTyCon tycon - then (enum_ixes dflags, listToBag $ map DerivAuxBind - [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]) - else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon))) - where - -------------------------------------------------------------- - enum_ixes dflags = listToBag - [ enum_range dflags - , enum_index dflags - , enum_inRange dflags - ] - - enum_range dflags - = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ - nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ - nlHsPar (enum_from_to_Expr - (nlHsVarApps intDataCon_RDR [ah_RDR]) - (nlHsVarApps intDataCon_RDR [bh_RDR])) - - enum_index dflags - = mkSimpleGeneratedFunBind loc unsafeIndex_RDR - [noLoc (AsPat noExtField (noLoc c_RDR) - (nlTuplePat [a_Pat, nlWildPat] Boxed)), - d_Pat] ( - untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( - untag_Expr dflags tycon [(d_RDR, dh_RDR)] ( - let - rhs = nlHsVarApps intDataCon_RDR [c_RDR] - in - nlHsCase - (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR)) - [mkHsCaseAlt (nlVarPat c_RDR) rhs] - )) - ) - - -- This produces something like `(ch >= ah) && (ch <= bh)` - enum_inRange dflags - = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( - untag_Expr dflags tycon [(b_RDR, bh_RDR)] ( - untag_Expr dflags tycon [(c_RDR, ch_RDR)] ( - -- This used to use `if`, which interacts badly with RebindableSyntax. - -- See #11396. - nlHsApps and_RDR - [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR) - , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR) - ] - ))) - - -------------------------------------------------------------- - single_con_ixes - = listToBag [single_con_range, single_con_index, single_con_inRange] - - data_con - = case tyConSingleDataCon_maybe tycon of -- just checking... - Nothing -> panic "get_Ix_binds" - Just dc -> dc - - con_arity = dataConSourceArity data_con - data_con_RDR = getRdrName data_con - - as_needed = take con_arity as_RDRs - bs_needed = take con_arity bs_RDRs - cs_needed = take con_arity cs_RDRs - - con_pat xs = nlConVarPat data_con_RDR xs - con_expr = nlHsVarApps data_con_RDR cs_needed - - -------------------------------------------------------------- - single_con_range - = mkSimpleGeneratedFunBind loc range_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ - noLoc (mkHsComp ListComp stmts con_expr) - where - stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed - - mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c) - (nlHsApp (nlHsVar range_RDR) - (mkLHsVarTuple [a,b])) - - ---------------- - single_con_index - = mkSimpleGeneratedFunBind loc unsafeIndex_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, - con_pat cs_needed] - -- We need to reverse the order we consider the components in - -- so that - -- range (l,u) !! index (l,u) i == i -- when i is in range - -- (from http://haskell.org/onlinereport/ix.html) holds. - (mk_index (reverse $ zip3 as_needed bs_needed cs_needed)) - where - -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) - mk_index [] = nlHsIntLit 0 - mk_index [(l,u,i)] = mk_one l u i - mk_index ((l,u,i) : rest) - = genOpApp ( - mk_one l u i - ) plus_RDR ( - genOpApp ( - (nlHsApp (nlHsVar unsafeRangeSize_RDR) - (mkLHsVarTuple [l,u])) - ) times_RDR (mk_index rest) - ) - mk_one l u i - = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i] - - ------------------ - single_con_inRange - = mkSimpleGeneratedFunBind loc inRange_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, - con_pat cs_needed] $ - if con_arity == 0 - -- If the product type has no fields, inRange is trivially true - -- (see #12853). - then true_Expr - else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range - as_needed bs_needed cs_needed) - where - in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c] - -{- -************************************************************************ -* * - Read instances -* * -************************************************************************ - -Example - - infix 4 %% - data T = Int %% Int - | T1 { f1 :: Int } - | T2 T - -instance Read T where - readPrec = - parens - ( prec 4 ( - do x <- ReadP.step Read.readPrec - expectP (Symbol "%%") - y <- ReadP.step Read.readPrec - return (x %% y)) - +++ - prec (appPrec+1) ( - -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok - -- Record construction binds even more tightly than application - do expectP (Ident "T1") - expectP (Punc '{') - x <- Read.readField "f1" (ReadP.reset readPrec) - expectP (Punc '}') - return (T1 { f1 = x })) - +++ - prec appPrec ( - do expectP (Ident "T2") - x <- ReadP.step Read.readPrec - return (T2 x)) - ) - - readListPrec = readListPrecDefault - readList = readListDefault - - -Note [Use expectP] -~~~~~~~~~~~~~~~~~~ -Note that we use - expectP (Ident "T1") -rather than - Ident "T1" <- lexP -The latter desugares to inline code for matching the Ident and the -string, and this can be very voluminous. The former is much more -compact. Cf #7258, although that also concerned non-linearity in -the occurrence analyser, a separate issue. - -Note [Read for empty data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should we get for this? (#7931) - data Emp deriving( Read ) -- No data constructors - -Here we want - read "[]" :: [Emp] to succeed, returning [] -So we do NOT want - instance Read Emp where - readPrec = error "urk" -Rather we want - instance Read Emp where - readPred = pfail -- Same as choose [] - -Because 'pfail' allows the parser to backtrack, but 'error' doesn't. -These instances are also useful for Read (Either Int Emp), where -we want to be able to parse (Left 3) just fine. --} - -gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon - -> (LHsBinds GhcPs, BagDerivStuff) - -gen_Read_binds get_fixity loc tycon - = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag) - where - ----------------------------------------------------------------------- - default_readlist - = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR) - - default_readlistprec - = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) - ----------------------------------------------------------------------- - - data_cons = tyConDataCons tycon - (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons - - read_prec = mkHsVarBind loc readPrec_RDR rhs - where - rhs | null data_cons -- See Note [Read for empty data types] - = nlHsVar pfail_RDR - | otherwise - = nlHsApp (nlHsVar parens_RDR) - (foldr1 mk_alt (read_nullary_cons ++ - read_non_nullary_cons)) - - read_non_nullary_cons = map read_non_nullary_con non_nullary_cons - - read_nullary_cons - = case nullary_cons of - [] -> [] - [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])] - _ -> [nlHsApp (nlHsVar choose_RDR) - (nlList (map mk_pair nullary_cons))] - -- NB For operators the parens around (:=:) are matched by the - -- enclosing "parens" call, so here we must match the naked - -- data_con_str con - - match_con con | isSym con_str = [symbol_pat con_str] - | otherwise = ident_h_pat con_str - where - con_str = data_con_str con - -- For nullary constructors we must match Ident s for normal constrs - -- and Symbol s for operators - - mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), - result_expr con []] - - read_non_nullary_con data_con - | is_infix = mk_parser infix_prec infix_stmts body - | is_record = mk_parser record_prec record_stmts body --- Using these two lines instead allows the derived --- read for infix and record bindings to read the prefix form --- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body) --- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body) - | otherwise = prefix_parser - where - body = result_expr data_con as_needed - con_str = data_con_str data_con - - prefix_parser = mk_parser prefix_prec prefix_stmts body - - read_prefix_con - | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"] - | otherwise = ident_h_pat con_str - - read_infix_con - | isSym con_str = [symbol_pat con_str] - | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"] - - prefix_stmts -- T a b c - = read_prefix_con ++ read_args - - infix_stmts -- a %% b, or a `T` b - = [read_a1] - ++ read_infix_con - ++ [read_a2] - - record_stmts -- T { f1 = a, f2 = b } - = read_prefix_con - ++ [read_punc "{"] - ++ concat (intersperse [read_punc ","] field_stmts) - ++ [read_punc "}"] - - field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed - - con_arity = dataConSourceArity data_con - labels = map flLabel $ dataConFieldLabels data_con - dc_nm = getName data_con - is_infix = dataConIsInfix data_con - is_record = labels `lengthExceeds` 0 - as_needed = take con_arity as_RDRs - read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con) - (read_a1:read_a2:_) = read_args - - prefix_prec = appPrecedence - infix_prec = getPrecedence get_fixity dc_nm - record_prec = appPrecedence + 1 -- Record construction binds even more tightly - -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2}) - - ------------------------------------------------------------------------ - -- Helpers - ------------------------------------------------------------------------ - mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 - mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) - , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])] - con_app con as = nlHsVarApps (getRdrName con) as -- con as - result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) - - -- For constructors and field labels ending in '#', we hackily - -- let the lexer generate two tokens, and look for both in sequence - -- Thus [Ident "I"; Symbol "#"]. See #5041 - ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] - | otherwise = [ ident_pat s ] - - bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p - -- See Note [Use expectP] - ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo") - symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>") - read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<") - - data_con_str con = occNameString (getOccName con) - - read_arg a ty = ASSERT( not (isUnliftedType ty) ) - noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) - - -- When reading field labels we might encounter - -- a = 3 - -- _a = 3 - -- or (#) = 4 - -- Note the parens! - read_field lbl a = - [noLoc - (mkBindStmt - (nlVarPat a) - (nlHsApp - read_field - (nlHsVarApps reset_RDR [readPrec_RDR]) - ) - ) - ] - where - lbl_str = unpackFS lbl - mk_read_field read_field_rdr lbl - = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)] - read_field - | isSym lbl_str - = mk_read_field readSymField_RDR lbl_str - | Just (ss, '#') <- snocView lbl_str -- #14918 - = mk_read_field readFieldHash_RDR ss - | otherwise - = mk_read_field readField_RDR lbl_str - -{- -************************************************************************ -* * - Show instances -* * -************************************************************************ - -Example - - infixr 5 :^: - - data Tree a = Leaf a | Tree a :^: Tree a - - instance (Show a) => Show (Tree a) where - - showsPrec d (Leaf m) = showParen (d > app_prec) showStr - where - showStr = showString "Leaf " . showsPrec (app_prec+1) m - - showsPrec d (u :^: v) = showParen (d > up_prec) showStr - where - showStr = showsPrec (up_prec+1) u . - showString " :^: " . - showsPrec (up_prec+1) v - -- Note: right-associativity of :^: ignored - - up_prec = 5 -- Precedence of :^: - app_prec = 10 -- Application has precedence one more than - -- the most tightly-binding operator --} - -gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon - -> (LHsBinds GhcPs, BagDerivStuff) - -gen_Show_binds get_fixity loc tycon - = (unitBag shows_prec, emptyBag) - where - data_cons = tyConDataCons tycon - shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons) - comma_space = nlHsVar showCommaSpace_RDR - - pats_etc data_con - | nullary_con = -- skip the showParen junk... - ASSERT(null bs_needed) - ([nlWildPat, con_pat], mk_showString_app op_con_str) - | otherwise = - ([a_Pat, con_pat], - showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit - (HsInt noExtField (mkIntegralLit con_prec_plus_one)))) - (nlHsPar (nested_compose_Expr show_thingies))) - where - data_con_RDR = getRdrName data_con - con_arity = dataConSourceArity data_con - bs_needed = take con_arity bs_RDRs - arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed - con_pat = nlConVarPat data_con_RDR bs_needed - nullary_con = con_arity == 0 - labels = map flLabel $ dataConFieldLabels data_con - lab_fields = length labels - record_syntax = lab_fields > 0 - - dc_nm = getName data_con - dc_occ_nm = getOccName data_con - con_str = occNameString dc_occ_nm - op_con_str = wrapOpParens con_str - backquote_str = wrapOpBackquotes con_str - - show_thingies - | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2] - | record_syntax = mk_showString_app (op_con_str ++ " {") : - show_record_args ++ [mk_showString_app "}"] - | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args - - show_label l = mk_showString_app (nm ++ " = ") - -- Note the spaces around the "=" sign. If we - -- don't have them then we get Foo { x=-1 } and - -- the "=-" parses as a single lexeme. Only the - -- space after the '=' is necessary, but it - -- seems tidier to have them both sides. - where - nm = wrapOpParens (unpackFS l) - - show_args = zipWith show_arg bs_needed arg_tys - (show_arg1:show_arg2:_) = show_args - show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args - - -- Assumption for record syntax: no of fields == no of - -- labelled fields (and in same order) - show_record_args = concat $ - intersperse [comma_space] $ - [ [show_label lbl, arg] - | (lbl,arg) <- zipEqual "gen_Show_binds" - labels show_args ] - - show_arg :: RdrName -> Type -> LHsExpr GhcPs - show_arg b arg_ty - | isUnliftedType arg_ty - -- See Note [Deriving and unboxed types] in TcDerivInfer - = with_conv $ - nlHsApps compose_RDR - [mk_shows_app boxed_arg, mk_showString_app postfixMod] - | otherwise - = mk_showsPrec_app arg_prec arg - where - 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 - con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm - arg_prec | record_syntax = 0 -- Record fields don't need parens - | otherwise = con_prec_plus_one - -wrapOpParens :: String -> String -wrapOpParens s | isSym s = '(' : s ++ ")" - | otherwise = s - -wrapOpBackquotes :: String -> String -wrapOpBackquotes s | isSym s = s - | otherwise = '`' : s ++ "`" - -isSym :: String -> Bool -isSym "" = False -isSym (c : _) = startsVarSym c || startsConSym c - --- | showString :: String -> ShowS -mk_showString_app :: String -> LHsExpr GhcPs -mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) - --- | showsPrec :: Show a => Int -> a -> ShowS -mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs -mk_showsPrec_app p x - = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExtField (mkIntegralLit p)), x] - --- | shows :: Show a => a -> ShowS -mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs -mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x - -getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer -getPrec is_infix get_fixity nm - | not is_infix = appPrecedence - | otherwise = getPrecedence get_fixity nm - -appPrecedence :: Integer -appPrecedence = fromIntegral maxPrecedence + 1 - -- One more than the precedence of the most - -- tightly-binding operator - -getPrecedence :: (Name -> Fixity) -> Name -> Integer -getPrecedence get_fixity nm - = case get_fixity nm of - Fixity _ x _assoc -> fromIntegral x - -- NB: the Report says that associativity is not taken - -- into account for either Read or Show; hence we - -- ignore associativity here - -{- -************************************************************************ -* * - Data instances -* * -************************************************************************ - -From the data type - - data T a b = T1 a b | T2 - -we generate - - $cT1 = mkDataCon $dT "T1" Prefix - $cT2 = mkDataCon $dT "T2" Prefix - $dT = mkDataType "Module.T" [] [$con_T1, $con_T2] - -- the [] is for field labels. - - instance (Data a, Data b) => Data (T a b) where - gfoldl k z (T1 a b) = z T `k` a `k` b - gfoldl k z T2 = z T2 - -- ToDo: add gmapT,Q,M, gfoldr - - gunfold k z c = case conIndex c of - I# 1# -> k (k (z T1)) - I# 2# -> z T2 - - toConstr (T1 _ _) = $cT1 - toConstr T2 = $cT2 - - dataTypeOf _ = $dT - - dataCast1 = gcast1 -- If T :: * -> * - dataCast2 = gcast2 -- if T :: * -> * -> * --} - -gen_Data_binds :: SrcSpan - -> TyCon -- For data families, this is the - -- *representation* TyCon - -> TcM (LHsBinds GhcPs, -- The method bindings - BagDerivStuff) -- Auxiliary bindings -gen_Data_binds loc rep_tc - = do { dflags <- getDynFlags - - -- Make unique names for the data type and constructor - -- auxiliary bindings. Start with the name of the TyCon/DataCon - -- but that might not be unique: see #12245. - ; dt_occ <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc)) - ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName) - (tyConDataCons rep_tc) - ; let dt_rdr = mkRdrUnqual dt_occ - dc_rdrs = map mkRdrUnqual dc_occs - - -- OK, now do the work - ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) } - -gen_data :: DynFlags -> RdrName -> [RdrName] - -> SrcSpan -> TyCon - -> (LHsBinds GhcPs, -- The method bindings - BagDerivStuff) -- Auxiliary bindings -gen_data dflags data_type_name constr_names loc rep_tc - = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] - `unionBags` gcast_binds, - -- Auxiliary definitions: the data type and constructors - listToBag ( genDataTyCon - : zipWith genDataDataCon data_cons constr_names ) ) - where - data_cons = tyConDataCons rep_tc - n_cons = length data_cons - one_constr = n_cons == 1 - genDataTyCon :: DerivStuff - genDataTyCon -- $dT - = DerivHsBind (mkHsVarBind loc data_type_name rhs, - L loc (TypeSig noExtField [L loc data_type_name] sig_ty)) - - sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR) - rhs = nlHsVar mkDataType_RDR - `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc))) - `nlHsApp` nlList (map nlHsVar constr_names) - - genDataDataCon :: DataCon -> RdrName -> DerivStuff - genDataDataCon dc constr_name -- $cT1 etc - = DerivHsBind (mkHsVarBind loc constr_name rhs, - L loc (TypeSig noExtField [L loc constr_name] sig_ty)) - where - sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR) - rhs = nlHsApps mkConstr_RDR constr_args - - constr_args - = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag - nlHsVar (data_type_name) -- DataType - , nlHsLit (mkHsString (occNameString dc_occ)) -- String name - , nlList labels -- Field labels - , nlHsVar fixity ] -- Fixity - - labels = map (nlHsLit . mkHsString . unpackFS . flLabel) - (dataConFieldLabels dc) - dc_occ = getOccName dc - is_infix = isDataSymOcc dc_occ - fixity | is_infix = infix_RDR - | otherwise = prefix_RDR - - ------------ gfoldl - gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons) - - gfoldl_eqn con - = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed], - foldl' mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed) - where - con_name :: RdrName - con_name = getRdrName con - as_needed = take (dataConSourceArity con) as_RDRs - mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) - - ------------ gunfold - gunfold_bind = mkSimpleGeneratedFunBind loc - gunfold_RDR - [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat] - gunfold_rhs - - gunfold_rhs - | one_constr = mk_unfold_rhs (head data_cons) -- No need for case - | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) - (map gunfold_alt data_cons) - - gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) - mk_unfold_rhs dc = foldr nlHsApp - (z_Expr `nlHsApp` nlHsVar (getRdrName dc)) - (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) - - mk_unfold_pat dc -- Last one is a wild-pat, to avoid - -- redundant test, and annoying warning - | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor - | otherwise = nlConPat intDataCon_RDR - [nlLitPat (HsIntPrim NoSourceText (toInteger tag))] - where - tag = dataConTag dc - - ------------ toConstr - toCon_bind = mkFunBindEC 1 loc toConstr_RDR id - (zipWith to_con_eqn data_cons constr_names) - to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) - - ------------ dataTypeOf - dataTypeOf_bind = mkSimpleGeneratedFunBind - loc - dataTypeOf_RDR - [nlWildPat] - (nlHsVar data_type_name) - - ------------ gcast1/2 - -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> * - -- or dataCast2 x = gcast2 s -- if T :: * -> * -> * - -- (or nothing if T has neither of these two types) - - -- But care is needed for data families: - -- If we have data family D a - -- data instance D (a,b,c) = A | B deriving( Data ) - -- and we want instance ... => Data (D [(a,b,c)]) where ... - -- then we need dataCast1 x = gcast1 x - -- because D :: * -> * - -- even though rep_tc has kind * -> * -> * -> * - -- Hence looking for the kind of fam_tc not rep_tc - -- See #4896 - tycon_kind = case tyConFamInst_maybe rep_tc of - Just (fam_tc, _) -> tyConKind fam_tc - Nothing -> tyConKind rep_tc - gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR - | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR - | otherwise = emptyBag - mk_gcast dataCast_RDR gcast_RDR - = unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR] - (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)) - - -kind1, kind2 :: Kind -kind1 = typeToTypeKind -kind2 = liftedTypeKind `mkVisFunTy` kind1 - -gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, - mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, - dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR, - constr_RDR, dataType_RDR, - eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR , - eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , - eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR , - eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR , - eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR , - eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR , - eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR, - 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, - extendWord8_RDR, extendInt8_RDR, - extendWord16_RDR, extendInt16_RDR :: RdrName -gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") -gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") -toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") -dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf") -dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1") -dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2") -gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1") -gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2") -mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") -constr_RDR = tcQual_RDR gENERICS (fsLit "Constr") -mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") -dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType") -conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") -prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix") -infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") - -eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#") -ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#") -leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#") -gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#") -geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#") - -eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#") -ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" ) -leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#") -gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" ) -geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#") - -eqInt8_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt8#") -ltInt8_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt8#" ) -leInt8_RDR = varQual_RDR gHC_PRIM (fsLit "leInt8#") -gtInt8_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt8#" ) -geInt8_RDR = varQual_RDR gHC_PRIM (fsLit "geInt8#") - -eqInt16_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt16#") -ltInt16_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt16#" ) -leInt16_RDR = varQual_RDR gHC_PRIM (fsLit "leInt16#") -gtInt16_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt16#" ) -geInt16_RDR = varQual_RDR gHC_PRIM (fsLit "geInt16#") - -eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#") -ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#") -leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#") -gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#") -geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#") - -eqWord8_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord8#") -ltWord8_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord8#" ) -leWord8_RDR = varQual_RDR gHC_PRIM (fsLit "leWord8#") -gtWord8_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord8#" ) -geWord8_RDR = varQual_RDR gHC_PRIM (fsLit "geWord8#") - -eqWord16_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord16#") -ltWord16_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord16#" ) -leWord16_RDR = varQual_RDR gHC_PRIM (fsLit "leWord16#") -gtWord16_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord16#" ) -geWord16_RDR = varQual_RDR gHC_PRIM (fsLit "geWord16#") - -eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#") -ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#") -leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#") -gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#") -geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#") - -eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#") -ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#") -leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#") -gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#") -geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#") - -eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##") -ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" ) -leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##") -gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" ) -geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##") - -extendWord8_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord8#") -extendInt8_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt8#") - -extendWord16_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord16#") -extendInt16_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt16#") - - -{- -************************************************************************ -* * - Lift instances -* * -************************************************************************ - -Example: - - data Foo a = Foo a | a :^: a deriving Lift - - ==> - - instance (Lift a) => Lift (Foo a) where - lift (Foo a) = [| Foo a |] - lift ((:^:) u v) = [| (:^:) u v |] - - liftTyped (Foo a) = [|| Foo a ||] - liftTyped ((:^:) u v) = [|| (:^:) u v ||] --} - - -gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) -gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag) - where - lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr) - (map (pats_etc mk_exp) data_cons) - liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr) - (map (pats_etc mk_texp) data_cons) - - mk_exp = ExpBr noExtField - mk_texp = TExpBr noExtField - data_cons = tyConDataCons tycon - - pats_etc mk_bracket data_con - = ([con_pat], lift_Expr) - where - con_pat = nlConVarPat data_con_RDR as_needed - data_con_RDR = getRdrName data_con - con_arity = dataConSourceArity data_con - as_needed = take con_arity as_RDRs - lift_Expr = noLoc (HsBracket noExtField (mk_bracket br_body)) - br_body = nlHsApps (Exact (dataConName data_con)) - (map nlHsVar as_needed) - -{- -************************************************************************ -* * - Newtype-deriving instances -* * -************************************************************************ - -Note [Newtype-deriving instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We take every method in the original instance and `coerce` it to fit -into the derived instance. We need type applications on the argument -to `coerce` to make it obvious what instantiation of the method we're -coercing from. So from, say, - - class C a b where - op :: forall c. a -> [b] -> c -> Int - - newtype T x = MkT - - instance C a => C a (T x) where - op :: forall c. a -> [T x] -> c -> Int - op = coerce @(a -> [] -> c -> Int) - @(a -> [T x] -> c -> Int) - op - -In addition to the type applications, we also have an explicit -type signature on the entire RHS. This brings the method-bound variable -`c` into scope over the two type applications. -See Note [GND and QuantifiedConstraints] for more information on why this -is important. - -Giving 'coerce' two explicitly-visible type arguments grants us finer control -over how it should be instantiated. Recall - - coerce :: Coercible a b => a -> b - -By giving it explicit type arguments we deal with the case where -'op' has a higher rank type, and so we must instantiate 'coerce' with -a polytype. E.g. - - class C a where op :: a -> forall b. b -> b - newtype T x = MkT - instance C => C (T x) where - op :: T x -> forall b. b -> b - op = coerce @( -> forall b. b -> b) - @(T x -> forall b. b -> b) - op - -The use of type applications is crucial here. If we had tried using only -explicit type signatures, like so: - - instance C => C (T x) where - op :: T x -> forall b. b -> b - op = coerce (op :: -> forall b. b -> b) - -Then GHC will attempt to deeply skolemize the two type signatures, which will -wreak havoc with the Coercible solver. Therefore, we instead use type -applications, which do not deeply skolemize and thus avoid this issue. -The downside is that we currently require -XImpredicativeTypes to permit this -polymorphic type instantiation, so we have to switch that flag on locally in -TcDeriv.genInst. See #8503 for more discussion. - -Note [Newtype-deriving trickiness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#12768): - class C a where { op :: D a => a -> a } - - instance C a => C [a] where { op = opList } - - opList :: (C a, D [a]) => [a] -> [a] - opList = ... - -Now suppose we try GND on this: - newtype N a = MkN [a] deriving( C ) - -The GND is expecting to get an implementation of op for N by -coercing opList, thus: - - instance C a => C (N a) where { op = opN } - - opN :: (C a, D (N a)) => N a -> N a - opN = coerce @([a] -> [a]) - @([N a] -> [N a] - opList :: D (N a) => [N a] -> [N a] - -But there is no reason to suppose that (D [a]) and (D (N a)) -are inter-coercible; these instances might completely different. -So GHC rightly rejects this code. - -Note [GND and QuantifiedConstraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example from #15290: - - class C m where - join :: m (m a) -> m a - - newtype T m a = MkT (m a) - - deriving instance - (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => - C (T m) - -The code that GHC used to generate for this was: - - instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => - C (T m) where - join = coerce @(forall a. m (m a) -> m a) - @(forall a. T m (T m a) -> T m a) - join - -This instantiates `coerce` at a polymorphic type, a form of impredicative -polymorphism, so we're already on thin ice. And in fact the ice breaks, -as we'll explain: - -The call to `coerce` gives rise to: - - Coercible (forall a. m (m a) -> m a) - (forall a. T m (T m a) -> T m a) - -And that simplified to the following implication constraint: - - forall a . m (T m a) ~R# m (m a) - -But because this constraint is under a `forall`, inside a type, we have to -prove it *without computing any term evidence* (hence the ). Alas, we -*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 TcInteract. - -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 -we can avoid this situation altogether. Instead of applying `coerce` to two -polymorphic types, we instead let an instance signature do the polymorphic -instantiation, and omit the `forall`s in the type applications. -More concretely, we generate the following code instead: - - instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => - C (T m) where - join :: forall a. T m (T m a) -> T m a - join = coerce @( m (m a) -> m a) - @(T m (T m a) -> T m a) - join - -Now the visible type arguments are both monotypes, so we don't need any of this -funny quantified constraint instantiation business. While this particular -example no longer uses impredicative instantiation, we still need to enable -ImpredicativeTypes to typecheck GND-generated code for class methods with -higher-rank types. See Note [Newtype-deriving instances]. - -You might think that that second @(T m (T m a) -> T m a) argument is redundant -in the presence of the instance signature, but in fact leaving it off will -break this example (from the T15290d test case): - - class C a where - c :: Int -> forall b. b -> a - - instance C Int - - instance C Age where - c :: Int -> forall b. b -> Age - c = coerce @(Int -> forall b. b -> Int) - c - -That is because the instance signature deeply skolemizes the forall-bound -`b`, which wreaks havoc with the `Coercible` solver. An additional visible type -argument of @(Int -> forall b. b -> Age) is enough to prevent this. - -Be aware that the use of an instance signature doesn't /solve/ this -problem; it just makes it less likely to occur. For example, if a class has -a truly higher-rank type like so: - - class CProblem m where - op :: (forall b. ... (m b) ...) -> Int - -Then the same situation will arise again. But at least it won't arise for the -common case of methods with ordinary, prenex-quantified types. - -Note [GND and ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~ -We make an effort to make the code generated through GND be robust w.r.t. -ambiguous type variables. As one example, consider the following example -(from #15637): - - class C a where f :: String - instance C () where f = "foo" - newtype T = T () deriving C - -A naïve attempt and generating a C T instance would be: - - instance C T where - f :: String - f = coerce @String @String f - -This isn't going to typecheck, however, since GHC doesn't know what to -instantiate the type variable `a` with in the call to `f` in the method body. -(Note that `f :: forall a. String`!) To compensate for the possibility of -ambiguity here, we explicitly instantiate `a` like so: - - instance C T where - f :: String - f = coerce @String @String (f @()) - -All better now. --} - -gen_Newtype_binds :: SrcSpan - -> Class -- the class being derived - -> [TyVar] -- the tvs in the instance head (this includes - -- the tvs from both the class types and the - -- newtype itself) - -> [Type] -- instance head parameters (incl. newtype) - -> Type -- the representation type - -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff) --- See Note [Newtype-deriving instances] -gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty - = do let ats = classATs cls - (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls) - atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats ) - mapM mk_atf_inst ats - return ( listToBag binds - , sigs - , listToBag $ map DerivFamInst atf_insts ) - where - -- For each class method, generate its derived binding and instance - -- signature. Using the first example from - -- Note [Newtype-deriving instances]: - -- - -- class C a b where - -- op :: forall c. a -> [b] -> c -> Int - -- - -- newtype T x = MkT - -- - -- Then we would generate below: - -- - -- instance C a => C a (T x) where - -- - mk_bind_and_sig :: Id -> (LHsBind GhcPs, LSig GhcPs) - mk_bind_and_sig meth_id - = ( -- The derived binding, e.g., - -- - -- op = coerce @(a -> [] -> c -> Int) - -- @(a -> [T x] -> c -> Int) - -- op - mkRdrFunBind loc_meth_RDR [mkSimpleMatch - (mkPrefixFunRhs loc_meth_RDR) - [] rhs_expr] - , -- The derived instance signature, e.g., - -- - -- op :: forall c. a -> [T x] -> c -> Int - L loc $ ClassOpSig noExtField False [loc_meth_RDR] - $ mkLHsSigType $ typeToLHsType to_ty - ) - where - Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id - (_, _, from_tau) = tcSplitSigmaTy from_ty - (_, _, to_tau) = tcSplitSigmaTy to_ty - - meth_RDR = getRdrName meth_id - loc_meth_RDR = L loc meth_RDR - - rhs_expr = nlHsVar (getRdrName coerceId) - `nlHsAppType` from_tau - `nlHsAppType` to_tau - `nlHsApp` meth_app - - -- The class method, applied to all of the class instance types - -- (including the representation type) to avoid potential ambiguity. - -- See Note [GND and ambiguity] - meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $ - filterOutInferredTypes (classTyCon cls) underlying_inst_tys - -- Filter out any inferred arguments, since they can't be - -- applied with visible type application. - - mk_atf_inst :: TyCon -> TcM FamInst - mk_atf_inst fam_tc = do - rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) - rep_lhs_tys - let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs' - fam_tc rep_lhs_tys rep_rhs_ty - -- Check (c) from Note [GND and associated type families] in TcDeriv - checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom) - newFamInst SynFamilyInst axiom - where - cls_tvs = classTyVars cls - in_scope = mkInScopeSet $ mkVarSet inst_tvs - lhs_env = zipTyEnv cls_tvs inst_tys - lhs_subst = mkTvSubst in_scope lhs_env - rhs_env = zipTyEnv cls_tvs underlying_inst_tys - rhs_subst = mkTvSubst in_scope rhs_env - fam_tvs = tyConTyVars fam_tc - rep_lhs_tys = substTyVars lhs_subst fam_tvs - rep_rhs_tys = substTyVars rhs_subst fam_tvs - rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys - rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys - (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs - rep_tvs' = scopedSort rep_tvs - rep_cvs' = scopedSort rep_cvs - - -- Same as inst_tys, but with the last argument type replaced by the - -- representation type. - underlying_inst_tys :: [Type] - underlying_inst_tys = changeLast inst_tys rhs_ty - -nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty) - where - hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s) - -nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty - where - hs_ty = mkLHsSigWcType (typeToLHsType s) - -mkCoerceClassMethEqn :: Class -- the class being derived - -> [TyVar] -- the tvs in the instance head (this includes - -- the tvs from both the class types and the - -- newtype itself) - -> [Type] -- instance head parameters (incl. newtype) - -> Type -- the representation type - -> Id -- the method to look at - -> Pair Type --- See Note [Newtype-deriving instances] --- See also Note [Newtype-deriving trickiness] --- The pair is the (from_type, to_type), where to_type is --- the type of the method we are trying to get -mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id - = Pair (substTy rhs_subst user_meth_ty) - (substTy lhs_subst user_meth_ty) - where - cls_tvs = classTyVars cls - in_scope = mkInScopeSet $ mkVarSet inst_tvs - lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys) - rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty)) - (_class_tvs, _class_constraint, user_meth_ty) - = tcSplitMethodTy (varType id) - -{- -************************************************************************ -* * -\subsection{Generating extra binds (@con2tag@ and @tag2con@)} -* * -************************************************************************ - -\begin{verbatim} -data Foo ... = ... - -con2tag_Foo :: Foo ... -> Int# -tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# -maxtag_Foo :: Int -- ditto (NB: not unlifted) -\end{verbatim} - -The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) -fiddling around. --} - -genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec - -> (LHsBind GhcPs, LSig GhcPs) -genAuxBindSpec dflags loc (DerivCon2Tag tycon) - = (mkFunBindSE 0 loc rdr_name eqns, - L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) - where - rdr_name = con2tag_RDR dflags tycon - - sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $ - mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ - mkParentType tycon `mkVisFunTy` intPrimTy - - lots_of_constructors = tyConFamilySize tycon > 8 - -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS - -- but we don't do vectored returns any more. - - eqns | lots_of_constructors = [get_tag_eqn] - | otherwise = map mk_eqn (tyConDataCons tycon) - - get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr) - - mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs) - mk_eqn con = ([nlWildConPat con], - nlHsLit (HsIntPrim NoSourceText - (toInteger ((dataConTag con) - fIRST_TAG)))) - -genAuxBindSpec dflags loc (DerivTag2Con tycon) - = (mkFunBindSE 0 loc rdr_name - [([nlConVarPat intDataCon_RDR [a_RDR]], - nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], - L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) - where - sig_ty = mkLHsSigWcType $ L loc $ - XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ - intTy `mkVisFunTy` mkParentType tycon - - rdr_name = tag2con_RDR dflags tycon - -genAuxBindSpec dflags loc (DerivMaxTag tycon) - = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) - where - rdr_name = maxtag_RDR dflags tycon - sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy))) - rhs = nlHsApp (nlHsVar intDataCon_RDR) - (nlHsLit (HsIntPrim NoSourceText max_tag)) - max_tag = case (tyConDataCons tycon) of - data_cons -> toInteger ((length data_cons) - fIRST_TAG) - -type SeparateBagsDerivStuff = - -- AuxBinds and SYB bindings - ( Bag (LHsBind GhcPs, LSig GhcPs) - -- Extra family instances (used by Generic and DeriveAnyClass) - , Bag (FamInst) ) - -genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff -genAuxBinds dflags loc b = genAuxBinds' b2 where - (b1,b2) = partitionBagWith splitDerivAuxBind b - splitDerivAuxBind (DerivAuxBind x) = Left x - splitDerivAuxBind x = Right x - - rm_dups = foldr dup_check emptyBag - dup_check a b = if anyBag (== a) b then b else consBag a b - - genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff - genAuxBinds' = foldr f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1) - , emptyBag ) - f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff - f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before - f (DerivHsBind b) = add1 b - f (DerivFamInst t) = add2 t - - add1 x (a,b) = (x `consBag` a,b) - add2 x (a,b) = (a,x `consBag` b) - -mkParentType :: TyCon -> Type --- Turn the representation tycon of a family into --- a use of its family constructor -mkParentType tc - = case tyConFamInst_maybe tc of - Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc)) - Just (fam_tc,tys) -> mkTyConApp fam_tc tys - -{- -************************************************************************ -* * -\subsection{Utility bits for generating bindings} -* * -************************************************************************ --} - --- | Make a function binding. If no equations are given, produce a function --- with the given arity that produces a stock error. -mkFunBindSE :: Arity -> SrcSpan -> RdrName - -> [([LPat GhcPs], LHsExpr GhcPs)] - -> LHsBind GhcPs -mkFunBindSE arity loc fun pats_and_exprs - = mkRdrFunBindSE arity (L loc fun) matches - where - matches = [mkMatch (mkPrefixFunRhs (L loc fun)) - (map (parenthesizePat appPrec) p) e - (noLoc emptyLocalBinds) - | (p,e) <-pats_and_exprs] - -mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] - -> LHsBind GhcPs -mkRdrFunBind fun@(L loc _fun_rdr) matches - = L loc (mkFunBind Generated 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 --- argument that is passes to the given function to produce the right-hand --- side. -mkFunBindEC :: Arity -> SrcSpan -> RdrName - -> (LHsExpr GhcPs -> LHsExpr GhcPs) - -> [([LPat GhcPs], LHsExpr GhcPs)] - -> LHsBind GhcPs -mkFunBindEC arity loc fun catch_all pats_and_exprs - = mkRdrFunBindEC arity catch_all (L loc fun) matches - where - matches = [ mkMatch (mkPrefixFunRhs (L loc fun)) - (map (parenthesizePat appPrec) p) e - (noLoc emptyLocalBinds) - | (p,e) <- pats_and_exprs ] - --- | Produces a function binding. When no equations are given, it generates --- a binding of the given arity and an empty case expression --- for the last argument that it passes to the given function to produce --- the right-hand side. -mkRdrFunBindEC :: Arity - -> (LHsExpr GhcPs -> LHsExpr GhcPs) - -> Located RdrName - -> [LMatch GhcPs (LHsExpr GhcPs)] - -> LHsBind GhcPs -mkRdrFunBindEC arity catch_all - fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches') - where - -- Catch-all eqn looks like - -- fmap _ z = case z of {} - -- or - -- traverse _ z = pure (case z of) - -- or - -- foldMap _ z = mempty - -- It's needed if there no data cons at all, - -- which can happen with -XEmptyDataDecls - -- See #4302 - matches' = if null matches - then [mkMatch (mkPrefixFunRhs fun) - (replicate (arity - 1) nlWildPat ++ [z_Pat]) - (catch_all $ nlHsCase z_Expr []) - (noLoc emptyLocalBinds)] - else matches - --- | Produces a function binding. When there are no equations, it generates --- a binding with the given arity that produces an error based on the name of --- the type of the last argument. -mkRdrFunBindSE :: Arity -> Located RdrName -> - [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs -mkRdrFunBindSE arity - fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches') - where - -- Catch-all eqn looks like - -- compare _ _ = error "Void compare" - -- It's needed if there no data cons at all, - -- which can happen with -XEmptyDataDecls - -- See #4302 - matches' = if null matches - then [mkMatch (mkPrefixFunRhs fun) - (replicate arity nlWildPat) - (error_Expr str) (noLoc emptyLocalBinds)] - else matches - str = "Void " ++ occNameString (rdrNameOcc fun_rdr) - - -box :: String -- The class involved - -> LHsExpr GhcPs -- The argument - -> Type -- The argument type - -> LHsExpr GhcPs -- Boxed version of the arg --- See Note [Deriving and unboxed types] in TcDerivInfer -box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg - ---------------------- -primOrdOps :: String -- The class involved - -> Type -- The type - -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt) --- See Note [Deriving and unboxed types] in TcDerivInfer -primOrdOps str ty = assoc_ty_id str ordOpTbl ty - -ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] -ordOpTbl - = [(charPrimTy , (ltChar_RDR , leChar_RDR - , eqChar_RDR , geChar_RDR , gtChar_RDR )) - ,(intPrimTy , (ltInt_RDR , leInt_RDR - , eqInt_RDR , geInt_RDR , gtInt_RDR )) - ,(int8PrimTy , (ltInt8_RDR , leInt8_RDR - , eqInt8_RDR , geInt8_RDR , gtInt8_RDR )) - ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR - , eqInt16_RDR , geInt16_RDR , gtInt16_RDR )) - ,(wordPrimTy , (ltWord_RDR , leWord_RDR - , eqWord_RDR , geWord_RDR , gtWord_RDR )) - ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR - , eqWord8_RDR , geWord8_RDR , gtWord8_RDR )) - ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR - , eqWord16_RDR, geWord16_RDR, gtWord16_RDR )) - ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR - , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) - ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR - , eqFloat_RDR , geFloat_RDR , gtFloat_RDR )) - ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR - , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ] - --- 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)) - , (intPrimTy , nlHsApp (nlHsVar $ getRdrName intDataCon)) - , (wordPrimTy , nlHsApp (nlHsVar $ getRdrName wordDataCon )) - , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon )) - , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon)) - , (int8PrimTy, - nlHsApp (nlHsVar $ getRdrName intDataCon) - . nlHsApp (nlHsVar extendInt8_RDR)) - , (word8PrimTy, - nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar extendWord8_RDR)) - , (int16PrimTy, - nlHsApp (nlHsVar $ getRdrName intDataCon) - . nlHsApp (nlHsVar extendInt16_RDR)) - , (word16PrimTy, - nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar extendWord16_RDR)) - ] - - --- | A table of postfix modifiers for unboxed values. -postfixModTbl :: [(Type, String)] -postfixModTbl - = [(charPrimTy , "#" ) - ,(intPrimTy , "#" ) - ,(wordPrimTy , "##") - ,(floatPrimTy , "#" ) - ,(doublePrimTy, "##") - ,(int8PrimTy, "#") - ,(word8PrimTy, "##") - ,(int16PrimTy, "#") - ,(word16PrimTy, "##") - ] - -primConvTbl :: [(Type, String)] -primConvTbl = - [ (int8PrimTy, "narrowInt8#") - , (word8PrimTy, "narrowWord8#") - , (int16PrimTy, "narrowInt16#") - , (word16PrimTy, "narrowWord16#") - ] - -litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] -litConTbl - = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR)) - ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR) - . nlHsApp (nlHsVar toInteger_RDR)) - ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR) - . nlHsApp (nlHsVar toInteger_RDR)) - ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR) - . nlHsApp (nlHsApp - (nlHsVar map_RDR) - (compose_RDR `nlHsApps` - [ nlHsVar fromIntegral_RDR - , nlHsVar fromEnum_RDR - ]))) - ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR) - . nlHsApp (nlHsVar toRational_RDR)) - ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR) - . nlHsApp (nlHsVar toRational_RDR)) - ] - --- | Lookup `Type` in an association list. -assoc_ty_id :: HasCallStack => String -- The class involved - -> [(Type,a)] -- The table - -> Type -- The type - -> a -- The result of the lookup -assoc_ty_id cls_str tbl ty - | Just a <- assoc_ty_id_maybe tbl ty = a - | otherwise = - pprPanic "Error in deriving:" - (text "Can't derive" <+> text cls_str <+> - text "for primitive type" <+> ppr ty) - --- | Lookup `Type` in an association list. -assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a -assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl - ------------------------------------------------------------------------ - -and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -and_Expr a b = genOpApp a and_RDR b - ------------------------------------------------------------------------ - -eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -eq_Expr ty a b - | not (isUnliftedType ty) = genOpApp a eq_RDR b - | otherwise = genPrimOpApp a prim_eq b - where - (_, _, prim_eq, _, _) = primOrdOps "Eq" ty - -untag_Expr :: DynFlags -> TyCon -> [( RdrName, RdrName)] - -> LHsExpr GhcPs -> LHsExpr GhcPs -untag_Expr _ _ [] expr = expr -untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr - = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon) - [untag_this])) {-of-} - [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)] - -enum_from_to_Expr - :: LHsExpr GhcPs -> LHsExpr GhcPs - -> LHsExpr GhcPs -enum_from_then_to_Expr - :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs - -> LHsExpr GhcPs - -enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2 -enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2 - -showParen_Expr - :: LHsExpr GhcPs -> LHsExpr GhcPs - -> LHsExpr GhcPs - -showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 - -nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs - -nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty -nested_compose_Expr [e] = parenify e -nested_compose_Expr (e:es) - = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es) - --- impossible_Expr is used in case RHSs that should never happen. --- We generate these to keep the desugarer from complaining that they *might* happen! -error_Expr :: String -> LHsExpr GhcPs -error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string)) - --- illegal_Expr is used when signalling error conditions in the RHS of a derived --- method. It is currently only used by Enum.{succ,pred} -illegal_Expr :: String -> String -> String -> LHsExpr GhcPs -illegal_Expr meth tp msg = - nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg))) - --- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you --- to include the value of a_RDR in the error string. -illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs -illegal_toEnum_tag tp maxtag = - nlHsApp (nlHsVar error_RDR) - (nlHsApp (nlHsApp (nlHsVar append_RDR) - (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag (")))) - (nlHsApp (nlHsApp (nlHsApp - (nlHsVar showsPrec_RDR) - (nlHsIntLit 0)) - (nlHsVar a_RDR)) - (nlHsApp (nlHsApp - (nlHsVar append_RDR) - (nlHsLit (mkHsString ") is outside of enumeration's range (0,"))) - (nlHsApp (nlHsApp (nlHsApp - (nlHsVar showsPrec_RDR) - (nlHsIntLit 0)) - (nlHsVar maxtag)) - (nlHsLit (mkHsString ")")))))) - -parenify :: LHsExpr GhcPs -> LHsExpr GhcPs -parenify e@(L _ (HsVar _ _)) = e -parenify e = mkHsPar e - --- genOpApp wraps brackets round the operator application, so that the --- renamer won't subsequently try to re-associate it. -genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs -genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) - -genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs -genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2)) - -a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR - :: RdrName -a_RDR = mkVarUnqual (fsLit "a") -b_RDR = mkVarUnqual (fsLit "b") -c_RDR = mkVarUnqual (fsLit "c") -d_RDR = mkVarUnqual (fsLit "d") -f_RDR = mkVarUnqual (fsLit "f") -k_RDR = mkVarUnqual (fsLit "k") -z_RDR = mkVarUnqual (fsLit "z") -ah_RDR = mkVarUnqual (fsLit "a#") -bh_RDR = mkVarUnqual (fsLit "b#") -ch_RDR = mkVarUnqual (fsLit "c#") -dh_RDR = mkVarUnqual (fsLit "d#") - -as_RDRs, bs_RDRs, cs_RDRs :: [RdrName] -as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] -bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] -cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] - -a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr, - true_Expr, pure_Expr :: LHsExpr GhcPs -a_Expr = nlHsVar a_RDR -b_Expr = nlHsVar b_RDR -c_Expr = nlHsVar c_RDR -z_Expr = nlHsVar z_RDR -ltTag_Expr = nlHsVar ltTag_RDR -eqTag_Expr = nlHsVar eqTag_RDR -gtTag_Expr = nlHsVar gtTag_RDR -false_Expr = nlHsVar false_RDR -true_Expr = nlHsVar true_RDR -pure_Expr = nlHsVar pure_RDR - -a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs -a_Pat = nlVarPat a_RDR -b_Pat = nlVarPat b_RDR -c_Pat = nlVarPat c_RDR -d_Pat = nlVarPat d_RDR -k_Pat = nlVarPat k_RDR -z_Pat = nlVarPat z_RDR - -minusInt_RDR, tagToEnum_RDR :: RdrName -minusInt_RDR = getRdrName (primOpId IntSubOp ) -tagToEnum_RDR = getRdrName (primOpId TagToEnumOp) - -con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName --- Generates Orig s RdrName, for the binding positions -con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc -tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc -maxtag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc - -mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName -mk_tc_deriv_name dflags tycon occ_fun = - mkAuxBinderName dflags (tyConName tycon) occ_fun - -mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName --- ^ Make a top-level binder name for an auxiliary binding for a parent name --- See Note [Auxiliary binders] -mkAuxBinderName dflags parent occ_fun - = mkRdrUnqual (occ_fun stable_parent_occ) - where - stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string - stable_string - | hasPprDebug dflags = parent_stable - | otherwise = parent_stable_hash - parent_stable = nameStableString parent - parent_stable_hash = - let Fingerprint high low = fingerprintString parent_stable - in toBase62 high ++ toBase62Padded low - -- See Note [Base 62 encoding 128-bit integers] in Encoding - parent_occ = nameOccName parent - - -{- -Note [Auxiliary binders] -~~~~~~~~~~~~~~~~~~~~~~~~ -We often want to make a top-level auxiliary binding. E.g. for comparison we have - - instance Ord T where - compare a b = $con2tag a `compare` $con2tag b - - $con2tag :: T -> Int - $con2tag = ...code.... - -Of course these top-level bindings should all have distinct name, and we are -generating RdrNames here. We can't just use the TyCon or DataCon to distinguish -because with standalone deriving two imported TyCons might both be called T! -(See #7947.) - -So we use package name, module name and the name of the parent -(T in this example) as part of the OccName we generate for the new binding. -To make the symbol names short we take a base62 hash of the full name. - -In the past we used the *unique* from the parent, but that's not stable across -recompilations as uniques are nondeterministic. --} diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs deleted file mode 100644 --- a/compiler/typecheck/TcGenFunctor.hs +++ /dev/null @@ -1,1440 +0,0 @@ -{- -(c) The University of Glasgow 2011 - - -The deriving code for the Functor, Foldable, and Traversable classes -(equivalent to the code in TcGenDeriv, for other classes) --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} - -module TcGenFunctor ( - FFoldType(..), functorLikeTraverse, - deepSubtypesContaining, foldDataConArgs, - - gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Bag -import GHC.Core.DataCon -import FastString -import GHC.Hs -import Outputable -import PrelNames -import GHC.Types.Name.Reader -import GHC.Types.SrcLoc -import State -import TcGenDeriv -import TcType -import GHC.Core.TyCon -import GHC.Core.TyCo.Rep -import GHC.Core.Type -import Util -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Id.Make (coerceId) -import TysWiredIn (true_RDR, false_RDR) - -import Data.Maybe (catMaybes, isJust) - -{- -************************************************************************ -* * - Functor instances - - see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html - -* * -************************************************************************ - -For the data type: - - data T a = T1 Int a | T2 (T a) - -We generate the instance: - - instance Functor T where - fmap f (T1 b1 a) = T1 b1 (f a) - fmap f (T2 ta) = T2 (fmap f ta) - -Notice that we don't simply apply 'fmap' to the constructor arguments. -Rather - - Do nothing to an argument whose type doesn't mention 'a' - - Apply 'f' to an argument of type 'a' - - Apply 'fmap f' to other arguments -That's why we have to recurse deeply into the constructor argument types, -rather than just one level, as we typically do. - -What about types with more than one type parameter? In general, we only -derive Functor for the last position: - - data S a b = S1 [b] | S2 (a, T a b) - instance Functor (S a) where - fmap f (S1 bs) = S1 (fmap f bs) - fmap f (S2 (p,q)) = S2 (a, fmap f q) - -However, we have special cases for - - tuples - - functions - -More formally, we write the derivation of fmap code over type variable -'a for type 'b as ($fmap 'a 'b x). In this general notation the derived -instance for T is: - - instance Functor T where - fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2) - fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1) - - $(fmap 'a 'b x) = x -- when b does not contain a - $(fmap 'a 'a x) = f x - $(fmap 'a '(b1,b2) x) = case x of (x1,x2) -> ($(fmap 'a 'b1 x1), $(fmap 'a 'b2 x2)) - $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T - $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 - $(fmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(fmap 'a' 'tc' (x $(cofmap 'a 'tb y))) - -For functions, the type parameter 'a can occur in a contravariant position, -which means we need to derive a function like: - - cofmap :: (a -> b) -> (f b -> f a) - -This is pretty much the same as $fmap, only without the $(cofmap 'a 'a x) and -$(cofmap 'a '(T b1 a) x) cases: - - $(cofmap 'a 'b x) = x -- when b does not contain a - $(cofmap 'a 'a x) = error "type variable in contravariant position" - $(cofmap 'a '(b1,b2) x) = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2) - $(cofmap 'a '(T b1 a) x) = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T - $(cofmap 'a '(T b1 b2) x) = fmap (\y. $(cofmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 - $(cofmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(cofmap 'a' 'tc' (x $(fmap 'a 'tb y))) - -Note that the code produced by $(fmap _ _ _) is always a higher order function, -with type `(a -> b) -> (g a -> g b)` for some g. - -Note that there are two distinct cases in $fmap (and $cofmap) that match on an -application of some type constructor T (where T is not a tuple type -constructor): - - $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T - $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 - -While the latter case technically subsumes the former case, it is important to -give special treatment to the former case to avoid unnecessary eta expansion. -See Note [Avoid unnecessary eta expansion in derived fmap implementations]. - -We also generate code for (<$) in addition to fmap—see Note [Deriving <$] for -an explanation of why this is important. Just like $fmap/$cofmap above, there -is a similar algorithm for generating `p <$ x` (for some constant `p`): - - $(replace 'a 'b x) = x -- when b does not contain a - $(replace 'a 'a x) = p - $(replace 'a '(b1,b2) x) = case x of (x1,x2) -> ($(replace 'a 'b1 x1), $(replace 'a 'b2 x2)) - $(replace 'a '(T b1 a) x) = p <$ x -- when a only occurs directly as the last argument of T - $(replace 'a '(T b1 b2) x) = fmap (\y. $(replace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 - $(replace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(replace 'a' 'tc' (x $(coreplace 'a 'tb y))) - - $(coreplace 'a 'b x) = x -- when b does not contain a - $(coreplace 'a 'a x) = error "type variable in contravariant position" - $(coreplace 'a '(b1,b2) x) = case x of (x1,x2) -> ($(coreplace 'a 'b1 x1), $(coreplace 'a 'b2 x2)) - $(coreplace 'a '(T b1 a) x) = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T - $(coreplace 'a '(T b1 b2) x) = fmap (\y. $(coreplace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 - $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y))) --} - -gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) --- When the argument is phantom, we can use fmap _ = coerce --- See Note [Phantom types with Functor, Foldable, and Traversable] -gen_Functor_binds loc tycon - | Phantom <- last (tyConRoles tycon) - = (unitBag fmap_bind, emptyBag) - where - fmap_name = L loc fmap_RDR - fmap_bind = mkRdrFunBind fmap_name fmap_eqns - fmap_eqns = [mkSimpleMatch fmap_match_ctxt - [nlWildPat] - coerce_Expr] - fmap_match_ctxt = mkPrefixFunRhs fmap_name - -gen_Functor_binds loc tycon - = (listToBag [fmap_bind, replace_bind], emptyBag) - where - data_cons = tyConDataCons tycon - fmap_name = L loc fmap_RDR - - -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] - fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns - fmap_match_ctxt = mkPrefixFunRhs fmap_name - - fmap_eqn con = flip evalState bs_RDRs $ - match_for_con fmap_match_ctxt [f_Pat] con parts - where - parts = foldDataConArgs ft_fmap con - - fmap_eqns = map fmap_eqn data_cons - - ft_fmap :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) - ft_fmap = FT { ft_triv = \x -> pure x - -- fmap f x = x - , ft_var = \x -> pure $ nlHsApp f_Expr x - -- fmap f x = f x - , ft_fun = \g h x -> mkSimpleLam $ \b -> do - gg <- g b - h $ nlHsApp x gg - -- fmap f x = \b -> h (x (g b)) - , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt) - -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..) - , ft_ty_app = \_ arg_ty g x -> - -- If the argument type is a bare occurrence of the - -- data type's last type variable, then we can generate - -- more efficient code. - -- See Note [Avoid unnecessary eta expansion in derived fmap implementations] - if tcIsTyVarTy arg_ty - then pure $ nlHsApps fmap_RDR [f_Expr,x] - else do gg <- mkSimpleLam g - pure $ nlHsApps fmap_RDR [gg,x] - -- fmap f x = fmap g x - , ft_forall = \_ g x -> g x - , ft_bad_app = panic "in other argument in ft_fmap" - , ft_co_var = panic "contravariant in ft_fmap" } - - -- See Note [Deriving <$] - replace_name = L loc replace_RDR - - -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] - replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns - replace_match_ctxt = mkPrefixFunRhs replace_name - - replace_eqn con = flip evalState bs_RDRs $ - match_for_con replace_match_ctxt [z_Pat] con parts - where - parts = foldDataConArgs ft_replace con - - replace_eqns = map replace_eqn data_cons - - ft_replace :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) - ft_replace = FT { ft_triv = \x -> pure x - -- p <$ x = x - , ft_var = \_ -> pure z_Expr - -- p <$ _ = p - , ft_fun = \g h x -> mkSimpleLam $ \b -> do - gg <- g b - h $ nlHsApp x gg - -- p <$ x = \b -> h (x (g b)) - , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt) - -- p <$ x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..) - , ft_ty_app = \_ arg_ty g x -> - -- If the argument type is a bare occurrence of the - -- data type's last type variable, then we can generate - -- more efficient code. - -- See [Deriving <$] - if tcIsTyVarTy arg_ty - then pure $ nlHsApps replace_RDR [z_Expr,x] - else do gg <- mkSimpleLam g - pure $ nlHsApps fmap_RDR [gg,x] - -- p <$ x = fmap (p <$) x - , ft_forall = \_ g x -> g x - , ft_bad_app = panic "in other argument in ft_replace" - , ft_co_var = panic "contravariant in ft_replace" } - - -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... - match_for_con :: Monad m - => HsMatchContext GhcPs - -> [LPat GhcPs] -> DataCon - -> [LHsExpr GhcPs -> m (LHsExpr GhcPs)] - -> m (LMatch GhcPs (LHsExpr GhcPs)) - match_for_con ctxt = mkSimpleConMatch ctxt $ - \con_name xsM -> do xs <- sequence xsM - pure $ nlHsApps con_name xs -- Con x1 x2 .. - -{- -Note [Avoid unnecessary eta expansion in derived fmap implementations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For the sake of simplicity, the algorithm that derived implementations of -fmap used to have a single case that dealt with applications of some type -constructor T (where T is not a tuple type constructor): - - $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 - -This generated less than optimal code in certain situations, however. Consider -this example: - - data List a = Nil | Cons a (List a) deriving Functor - -This would generate the following Functor instance: - - instance Functor List where - fmap f Nil = Nil - fmap f (Cons x xs) = Cons (f x) (fmap (\y -> f y) xs) - -The code `fmap (\y -> f y) xs` is peculiar, since it eta expands an application -of `f`. What's worse, this eta expansion actually degrades performance! To see -why, we can trace an invocation of fmap on a small List: - - fmap id $ Cons 0 $ Cons 0 $ Cons 0 $ Cons 0 Nil - - Cons (id 0) $ fmap (\y -> id y) - $ Cons 0 $ Cons 0 $ Cons 0 Nil - - Cons (id 0) $ Cons ((\y -> id y) 0) - $ fmap (\y' -> (\y -> id y) y') - $ Cons 0 $ Cons 0 Nil - - Cons (id 0) $ Cons ((\y -> id y) 0) - $ Cons ((\y' -> (\y -> id y) y') 0) - $ fmap (\y'' -> (\y' -> (\y -> id y) y') y'') - $ Cons 0 Nil - - Cons (id 0) $ Cons ((\y -> id y) 0) - $ Cons ((\y' -> (\y -> id y) y') 0) - $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0) - $ fmap (\y''' -> (\y'' -> (\y' -> (\y -> id y) y') y'') y''') - $ Nil - - Cons (id 0) $ Cons ((\y -> id y) 0) - $ Cons ((\y' -> (\y -> id y) y') 0) - $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0) - $ Nil - -Notice how the number of lambdas—and hence, the number of closures—one -needs to evaluate grows very quickly. In general, a List with N cons cells will -require (1 + 2 + ... (N-1)) beta reductions, which takes O(N^2) time! This is -what caused the performance issues observed in #7436. - -But hold on a second: shouldn't GHC's optimizer be able to eta reduce -`\y -> f y` to `f` and avoid these beta reductions? Unfortunately, this is not -the case. In general, eta reduction can change the semantics of a program. For -instance, (\x -> ⊥) `seq` () converges, but ⊥ `seq` () diverges. It just so -happens that the fmap implementation above would have the same semantics -regardless of whether or not `\y -> f y` or `f` is used, but GHC's optimizer is -not yet smart enough to realize this (see #17881). - -To avoid this quadratic blowup, we add a special case to $fmap that applies -`fmap f` directly: - - $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T - $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 - -With this modified algorithm, the derived Functor List instance becomes: - - instance Functor List where - fmap f Nil = Nil - fmap f (Cons x xs) = Cons (f x) (fmap f xs) - -No lambdas in sight, just the way we like it. - -This special case does not prevent all sources quadratic closure buildup, -however. In this example: - - data PolyList a = PLNil | PLCons a (PolyList (PolyList a)) - deriving Functor - -We would derive the following code: - - instance Functor PolyList where - fmap f PLNil = PLNil - fmap f (PLCons x xs) = PLCons (f x) (fmap (\y -> fmap f y) xs) - -The use of `fmap (\y -> fmap f y) xs` builds up closures in much the same way -as `fmap (\y -> f y) xs`. The difference here is that even if we eta reduced -to `fmap (fmap f) xs`, GHC would /still/ build up a closure, since we are -recursively invoking fmap with a different argument (fmap f). Since we end up -paying the price of building a closure either way, we do not extend the special -case in $fmap any further, since it wouldn't buy us anything. - -The ft_ty_app field of FFoldType distinguishes between these two $fmap cases by -inspecting the argument type. If the argument type is a bare type variable, -then we can conclude the type variable /must/ be the same as the data type's -last type parameter. We know that this must be the case since there is an -invariant that the argument type in ft_ty_app will always contain the last -type parameter somewhere (see Note [FFoldType and functorLikeTraverse]), so -if the argument type is a bare variable, then that must be exactly the last -type parameter. - -Note that the ft_ty_app case of ft_replace (which derives implementations of -(<$)) also inspects the argument type to generate more efficient code. -See Note [Deriving <$]. - -Note [Deriving <$] -~~~~~~~~~~~~~~~~~~ - -We derive the definition of <$. Allowing this to take the default definition -can lead to memory leaks: mapping over a structure with a constant function can -fill the result structure with trivial thunks that retain the values from the -original structure. The simplifier seems to handle this all right for simple -types, but not for recursive ones. Consider - -data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor - --- fmap _ Tip = Tip --- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r) - -Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that -simplifies no further. Why is that? `fmap` is defined recursively, so GHC -cannot inline it. The static argument transformation would turn the definition -into a non-recursive one - --- fmap f = go where --- go Tip = Tip --- go (Bin l v r) = Bin (go l) (f v) (go r) - -which GHC could inline, producing an efficient definion of `<$`. But there are -several problems. First, GHC does not perform the static argument transformation -by default, even with -O2. Second, even when it does perform the static argument -transformation, it does so only when there are at least two static arguments, -which is not the case for fmap. Finally, when the type in question is -non-regular, such as - -data Nesty a = Z a | S (Nesty a) (Nest (a, a)) - -the function argument is no longer (entirely) static, so the static argument -transformation will do nothing for us. - -Applying the default definition of `<$` will produce a tree full of thunks that -look like ((\_ -> x) x0), which represents unnecessary thunk allocation and -also retention of the previous value, potentially leaking memory. Instead, we -derive <$ separately. Two aspects are different from fmap: the case of the -sought type variable (ft_var) and the case of a type application (ft_ty_app). -The interesting one is ft_ty_app. We have to distinguish two cases: the -"immediate" case where the type argument *is* the sought type variable, and -the "nested" case where the type argument *contains* the sought type variable. - -The immediate case: - -Suppose we have - -data Imm a = Imm (F ... a) - -Then we want to define - -x <$ Imm q = Imm (x <$ q) - -The nested case: - -Suppose we have - -data Nes a = Nes (F ... (G a)) - -Then we want to define - -x <$ Nes q = Nes (fmap (x <$) q) - -We inspect the argument type in ft_ty_app -(see Note [FFoldType and functorLikeTraverse]) to distinguish between these -two cases. If the argument type is a bare type variable, then we know that it -must be the same variable as the data type's last type parameter. -This is very similar to a trick that derived fmap implementations -use in their own ft_ty_app case. -See Note [Avoid unnecessary eta expansion in derived fmap implementations], -which explains why checking if the argument type is a bare variable is -the right thing to do. - -We could, but do not, give tuples special treatment to improve efficiency -in some cases. Suppose we have - -data Nest a = Z a | S (Nest (a,a)) - -The optimal definition would be - -x <$ Z _ = Z x -x <$ S t = S ((x, x) <$ t) - -which produces a result with maximal internal sharing. The reason we do not -attempt to treat this case specially is that we have no way to give -user-provided tuple-like types similar treatment. If the user changed the -definition to - -data Pair a = Pair a a -data Nest a = Z a | S (Nest (Pair a)) - -they would experience a surprising degradation in performance. -} - - -{- -Utility functions related to Functor deriving. - -Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse. -This function works like a fold: it makes a value of type 'a' in a bottom up way. --} - --- Generic traversal for Functor deriving --- See Note [FFoldType and functorLikeTraverse] -data FFoldType a -- Describes how to fold over a Type in a functor like way - = FT { ft_triv :: a - -- ^ Does not contain variable - , ft_var :: a - -- ^ The variable itself - , ft_co_var :: a - -- ^ The variable itself, contravariantly - , ft_fun :: a -> a -> a - -- ^ Function type - , ft_tup :: TyCon -> [a] -> a - -- ^ Tuple type. The @[a]@ is the result of folding over the - -- arguments of the tuple. - , ft_ty_app :: Type -> Type -> a -> a - -- ^ Type app, variable only in last argument. The two 'Type's are - -- the function and argument parts of @fun_ty arg_ty@, - -- respectively. - , ft_bad_app :: a - -- ^ Type app, variable other than in last argument - , ft_forall :: TcTyVar -> a -> a - -- ^ Forall type - } - -functorLikeTraverse :: forall a. - TyVar -- ^ Variable to look for - -> FFoldType a -- ^ How to fold - -> Type -- ^ Type to process - -> a -functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar - , ft_co_var = caseCoVar, ft_fun = caseFun - , ft_tup = caseTuple, ft_ty_app = caseTyApp - , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) - ty - = fst (go False ty) - where - go :: Bool -- Covariant or contravariant context - -> Type - -> (a, Bool) -- (result of type a, does type contain var) - - go co ty | Just ty' <- tcView ty = go co ty' - go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True) - go co (FunTy { ft_arg = x, ft_res = y, ft_af = af }) - | InvisArg <- af = go co y - | xc || yc = (caseFun xr yr,True) - where (xr,xc) = go (not co) x - (yr,yc) = go co y - go co (AppTy x y) | xc = (caseWrongArg, True) - | yc = (caseTyApp x y yr, True) - where (_, xc) = go co x - (yr,yc) = go co y - go co ty@(TyConApp con args) - | not (or xcs) = (caseTrivial, False) -- Variable does not occur - -- At this point we know that xrs, xcs is not empty, - -- and at least one xr is True - | isTupleTyCon con = (caseTuple con xrs, True) - | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty - | Just (fun_ty, arg_ty) <- splitAppTy_maybe ty -- T (..no var..) ty - = (caseTyApp fun_ty arg_ty (last xrs), True) - | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function) - where - -- When folding over an unboxed tuple, we must explicitly drop the - -- runtime rep arguments, or else GHC will generate twice as many - -- variables in a unboxed tuple pattern match and expression as it - -- actually needs. See #12399 - (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args)) - go co (ForAllTy (Bndr v vis) x) - | isVisibleArgFlag vis = panic "unexpected visible binder" - | v /= var && xc = (caseForAll v xr,True) - where (xr,xc) = go co x - - go _ _ = (caseTrivial,False) - --- Return all syntactic subterms of ty that contain var somewhere --- These are the things that should appear in instance constraints -deepSubtypesContaining :: TyVar -> Type -> [TcType] -deepSubtypesContaining tv - = functorLikeTraverse tv - (FT { ft_triv = [] - , ft_var = [] - , ft_fun = (++) - , ft_tup = \_ xs -> concat xs - , ft_ty_app = \t _ ts -> t:ts - , ft_bad_app = panic "in other argument in deepSubtypesContaining" - , ft_co_var = panic "contravariant in deepSubtypesContaining" - , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs }) - - -foldDataConArgs :: FFoldType a -> DataCon -> [a] --- Fold over the arguments of the datacon -foldDataConArgs ft con - = map foldArg (dataConOrigArgTys con) - where - foldArg - = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of - Just tv -> functorLikeTraverse tv ft - Nothing -> const (ft_triv ft) - -- If we are deriving Foldable for a GADT, there is a chance that the last - -- type variable in the data type isn't actually a type variable at all. - -- (for example, this can happen if the last type variable is refined to - -- be a concrete type such as Int). If the last type variable is refined - -- to be a specific type, then getTyVar_maybe will return Nothing. - -- See Note [DeriveFoldable with ExistentialQuantification] - -- - -- The kind checks have ensured the last type parameter is of kind *. - --- Make a HsLam using a fresh variable from a State monad -mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) - -> State [RdrName] (LHsExpr GhcPs) --- (mkSimpleLam fn) returns (\x. fn(x)) -mkSimpleLam lam = - get >>= \case - n:names -> do - put names - body <- lam (nlHsVar n) - return (mkHsLam [nlVarPat n] body) - _ -> panic "mkSimpleLam" - -mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs - -> State [RdrName] (LHsExpr GhcPs)) - -> State [RdrName] (LHsExpr GhcPs) -mkSimpleLam2 lam = - get >>= \case - n1:n2:names -> do - put names - body <- lam (nlHsVar n1) (nlHsVar n2) - return (mkHsLam [nlVarPat n1,nlVarPat n2] body) - _ -> panic "mkSimpleLam2" - --- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" --- --- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in --- which the LHS pattern-matches on @extra_pats@, followed by a match on the --- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ --- and its arguments, applying an expression (from @insides@) to each of the --- respective arguments of @con@. -mkSimpleConMatch :: Monad m => HsMatchContext GhcPs - -> (RdrName -> [a] -> m (LHsExpr GhcPs)) - -> [LPat GhcPs] - -> DataCon - -> [LHsExpr GhcPs -> a] - -> m (LMatch GhcPs (LHsExpr GhcPs)) -mkSimpleConMatch ctxt fold extra_pats con insides = do - let con_name = getRdrName con - let vars_needed = takeList insides as_RDRs - let bare_pat = nlConVarPat con_name vars_needed - let pat = if null vars_needed - then bare_pat - else nlParPat bare_pat - rhs <- fold con_name - (zipWith (\i v -> i $ nlHsVar v) insides vars_needed) - return $ mkMatch ctxt (extra_pats ++ [pat]) rhs - (noLoc emptyLocalBinds) - --- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" --- --- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to --- 'mkSimpleConMatch', with two key differences: --- --- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a --- @[LHsExpr RdrName]@. This is because it filters out the expressions --- corresponding to arguments whose types do not mention the last type --- variable in a derived 'Foldable' or 'Traversable' instance (i.e., the --- 'Nothing' elements of @insides@). --- --- 2. @fold@ takes an expression as its first argument instead of a --- constructor name. This is because it uses a specialized --- constructor function expression that only takes as many parameters as --- there are argument types that mention the last type variable. --- --- See Note [Generated code for DeriveFoldable and DeriveTraversable] -mkSimpleConMatch2 :: Monad m - => HsMatchContext GhcPs - -> (LHsExpr GhcPs -> [LHsExpr GhcPs] - -> m (LHsExpr GhcPs)) - -> [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> m (LMatch GhcPs (LHsExpr GhcPs)) -mkSimpleConMatch2 ctxt fold extra_pats con insides = do - let con_name = getRdrName con - vars_needed = takeList insides as_RDRs - pat = nlConVarPat con_name vars_needed - -- Make sure to zip BEFORE invoking catMaybes. We want the variable - -- indices in each expression to match up with the argument indices - -- in con_expr (defined below). - exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i) - insides vars_needed - -- An element of argTysTyVarInfo is True if the constructor argument - -- with the same index has a type which mentions the last type - -- variable. - argTysTyVarInfo = map isJust insides - (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars - - con_expr - | null asWithTyVar = nlHsApps con_name asWithoutTyVar - | otherwise = - let bs = filterByList argTysTyVarInfo bs_RDRs - vars = filterByLists argTysTyVarInfo bs_Vars as_Vars - in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars) - - rhs <- fold con_expr exps - return $ mkMatch ctxt (extra_pats ++ [pat]) rhs - (noLoc emptyLocalBinds) - --- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" -mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a] - -> m (LMatch GhcPs (LHsExpr GhcPs))) - -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs) -mkSimpleTupleCase match_for_con tc insides x - = do { let data_con = tyConSingleDataCon tc - ; match <- match_for_con [] data_con insides - ; return $ nlHsCase x [match] } - -{- -************************************************************************ -* * - Foldable instances - - see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html - -* * -************************************************************************ - -Deriving Foldable instances works the same way as Functor instances, -only Foldable instances are not possible for function types at all. -Given (data T a = T a a (T a) deriving Foldable), we get: - - instance Foldable T where - foldr f z (T x1 x2 x3) = - $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) ) - --XDeriveFoldable is different from -XDeriveFunctor in that it filters out -arguments to the constructor that would produce useless code in a Foldable -instance. For example, the following datatype: - - data Foo a = Foo Int a Int deriving Foldable - -would have the following generated Foldable instance: - - instance Foldable Foo where - foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2 - -since neither of the two Int arguments are folded over. - -The cases are: - - $(foldr 'a 'a) = f - $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z ) - $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2 - -Note that the arguments to the real foldr function are the wrong way around, -since (f :: a -> b -> b), while (foldr f :: b -> t a -> b). - -One can envision a case for types that don't contain the last type variable: - - $(foldr 'a 'b) = \x z -> z -- when b does not contain a - -But this case will never materialize, since the aforementioned filtering -removes all such types from consideration. -See Note [Generated code for DeriveFoldable and DeriveTraversable]. - -Foldable instances differ from Functor and Traversable instances in that -Foldable instances can be derived for data types in which the last type -variable is existentially quantified. In particular, if the last type variable -is refined to a more specific type in a GADT: - - data GADT a where - G :: a ~ Int => a -> G Int - -then the deriving machinery does not attempt to check that the type a contains -Int, since it is not syntactically equal to a type variable. That is, the -derived Foldable instance for GADT is: - - instance Foldable GADT where - foldr _ z (GADT _) = z - -See Note [DeriveFoldable with ExistentialQuantification]. - -Note [Deriving null] -~~~~~~~~~~~~~~~~~~~~ - -In some cases, deriving the definition of 'null' can produce much better -results than the default definition. For example, with - - data SnocList a = Nil | Snoc (SnocList a) a - -the default definition of 'null' would walk the entire spine of a -nonempty snoc-list before concluding that it is not null. But looking at -the Snoc constructor, we can immediately see that it contains an 'a', and -so 'null' can return False immediately if it matches on Snoc. When we -derive 'null', we keep track of things that cannot be null. The interesting -case is type application. Given - - data Wrap a = Wrap (Foo (Bar a)) - -we use - - null (Wrap fba) = all null fba - -but if we see - - data Wrap a = Wrap (Foo a) - -we can just use - - null (Wrap fa) = null fa - -Indeed, we allow this to happen even for tuples: - - data Wrap a = Wrap (Foo (a, Int)) - -produces - - null (Wrap fa) = null fa - -As explained in Note [Deriving <$], giving tuples special performance treatment -could surprise users if they switch to other types, but Ryan Scott seems to -think it's okay to do it for now. --} - -gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) --- When the parameter is phantom, we can use foldMap _ _ = mempty --- See Note [Phantom types with Functor, Foldable, and Traversable] -gen_Foldable_binds loc tycon - | Phantom <- last (tyConRoles tycon) - = (unitBag foldMap_bind, emptyBag) - where - foldMap_name = L loc foldMap_RDR - foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns - foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt - [nlWildPat, nlWildPat] - mempty_Expr] - foldMap_match_ctxt = mkPrefixFunRhs foldMap_name - -gen_Foldable_binds loc tycon - | null data_cons -- There's no real point producing anything but - -- foldMap for a type with no constructors. - = (unitBag foldMap_bind, emptyBag) - - | otherwise - = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag) - where - data_cons = tyConDataCons tycon - - foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns - eqns = map foldr_eqn data_cons - foldr_eqn con - = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs - where - parts = sequence $ foldDataConArgs ft_foldr con - - foldMap_name = L loc foldMap_RDR - - -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] - foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr) - foldMap_name foldMap_eqns - - foldMap_eqns = map foldMap_eqn data_cons - - foldMap_eqn con - = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs - where - parts = sequence $ foldDataConArgs ft_foldMap con - - -- Given a list of NullM results, produce Nothing if any of - -- them is NotNull, and otherwise produce a list of Maybes - -- with Justs representing unknowns and Nothings representing - -- things that are definitely null. - convert :: [NullM a] -> Maybe [Maybe a] - convert = traverse go where - go IsNull = Just Nothing - go NotNull = Nothing - go (NullM a) = Just (Just a) - - null_name = L loc null_RDR - null_match_ctxt = mkPrefixFunRhs null_name - null_bind = mkRdrFunBind null_name null_eqns - null_eqns = map null_eqn data_cons - null_eqn con - = flip evalState bs_RDRs $ do - parts <- sequence $ foldDataConArgs ft_null con - case convert parts of - Nothing -> return $ - mkMatch null_match_ctxt [nlParPat (nlWildConPat con)] - false_Expr (noLoc emptyLocalBinds) - Just cp -> match_null [] con cp - - -- Yields 'Just' an expression if we're folding over a type that mentions - -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. - -- See Note [FFoldType and functorLikeTraverse] - ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) - ft_foldr - = FT { ft_triv = return Nothing - -- foldr f = \x z -> z - , ft_var = return $ Just f_Expr - -- foldr f = f - , ft_tup = \t g -> do - gg <- sequence g - lam <- mkSimpleLam2 $ \x z -> - mkSimpleTupleCase (match_foldr z) t gg x - return (Just lam) - -- foldr f = (\x z -> case x of ...) - , ft_ty_app = \_ _ g -> do - gg <- g - mapM (\gg' -> mkSimpleLam2 $ \x z -> return $ - nlHsApps foldable_foldr_RDR [gg',z,x]) gg - -- foldr f = (\x z -> foldr g z x) - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant in ft_foldr" - , ft_fun = panic "function in ft_foldr" - , ft_bad_app = panic "in other argument in ft_foldr" } - - match_foldr :: Monad m - => LHsExpr GhcPs - -> [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> m (LMatch GhcPs (LHsExpr GhcPs)) - match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs) - where - -- g1 v1 (g2 v2 (.. z)) - mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs - mkFoldr = foldr nlHsApp z - - -- See Note [FFoldType and functorLikeTraverse] - ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) - ft_foldMap - = FT { ft_triv = return Nothing - -- foldMap f = \x -> mempty - , ft_var = return (Just f_Expr) - -- foldMap f = f - , ft_tup = \t g -> do - gg <- sequence g - lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg - return (Just lam) - -- foldMap f = \x -> case x of (..,) - , ft_ty_app = \_ _ g -> fmap (nlHsApp foldMap_Expr) <$> g - -- foldMap f = foldMap g - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant in ft_foldMap" - , ft_fun = panic "function in ft_foldMap" - , ft_bad_app = panic "in other argument in ft_foldMap" } - - match_foldMap :: Monad m - => [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> m (LMatch GhcPs (LHsExpr GhcPs)) - match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs) - where - -- mappend v1 (mappend v2 ..) - mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs - mkFoldMap [] = mempty_Expr - mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs - - -- See Note [FFoldType and functorLikeTraverse] - -- Yields NullM an expression if we're folding over an expression - -- that may or may not be null. Yields IsNull if it's certainly - -- null, and yields NotNull if it's certainly not null. - -- See Note [Deriving null] - ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs))) - ft_null - = FT { ft_triv = return IsNull - -- null = \_ -> True - , ft_var = return NotNull - -- null = \_ -> False - , ft_tup = \t g -> do - gg <- sequence g - case convert gg of - Nothing -> pure NotNull - Just ggg -> - NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg) - -- null = \x -> case x of (..,) - , ft_ty_app = \_ _ g -> flip fmap g $ \nestedResult -> - case nestedResult of - -- If e definitely contains the parameter, - -- then we can test if (G e) contains it by - -- simply checking if (G e) is null - NotNull -> NullM null_Expr - -- This case is unreachable--it will actually be - -- caught by ft_triv - IsNull -> IsNull - -- The general case uses (all null), - -- (all (all null)), etc. - NullM nestedTest -> NullM $ - nlHsApp all_Expr nestedTest - -- null fa = null fa, or null fa = all null fa, or null fa = True - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant in ft_null" - , ft_fun = panic "function in ft_null" - , ft_bad_app = panic "in other argument in ft_null" } - - match_null :: Monad m - => [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> m (LMatch GhcPs (LHsExpr GhcPs)) - match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs) - where - -- v1 && v2 && .. - mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs - mkNull [] = true_Expr - mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs - -data NullM a = - IsNull -- Definitely null - | NotNull -- Definitely not null - | NullM a -- Unknown - -{- -************************************************************************ -* * - Traversable instances - - see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html -* * -************************************************************************ - -Again, Traversable is much like Functor and Foldable. - -The cases are: - - $(traverse 'a 'a) = f - $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> - liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2) - $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2 - -Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types -do not mention the last type parameter. Therefore, the following datatype: - - data Foo a = Foo Int a Int - -would have the following derived Traversable instance: - - instance Traversable Foo where - traverse f (Foo x1 x2 x3) = - fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 ) - -since the two Int arguments do not produce any effects in a traversal. - -One can envision a case for types that do not mention the last type parameter: - - $(traverse 'a 'b) = pure -- when b does not contain a - -But this case will never materialize, since the aforementioned filtering -removes all such types from consideration. -See Note [Generated code for DeriveFoldable and DeriveTraversable]. --} - -gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) --- When the argument is phantom, we can use traverse = pure . coerce --- See Note [Phantom types with Functor, Foldable, and Traversable] -gen_Traversable_binds loc tycon - | Phantom <- last (tyConRoles tycon) - = (unitBag traverse_bind, emptyBag) - where - traverse_name = L loc traverse_RDR - traverse_bind = mkRdrFunBind traverse_name traverse_eqns - traverse_eqns = - [mkSimpleMatch traverse_match_ctxt - [nlWildPat, z_Pat] - (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])] - traverse_match_ctxt = mkPrefixFunRhs traverse_name - -gen_Traversable_binds loc tycon - = (unitBag traverse_bind, emptyBag) - where - data_cons = tyConDataCons tycon - - traverse_name = L loc traverse_RDR - - -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] - traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr) - traverse_name traverse_eqns - traverse_eqns = map traverse_eqn data_cons - traverse_eqn con - = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs - where - parts = sequence $ foldDataConArgs ft_trav con - - -- Yields 'Just' an expression if we're folding over a type that mentions - -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. - -- See Note [FFoldType and functorLikeTraverse] - ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) - ft_trav - = FT { ft_triv = return Nothing - -- traverse f = pure x - , ft_var = return (Just f_Expr) - -- traverse f = f x - , ft_tup = \t gs -> do - gg <- sequence gs - lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg - return (Just lam) - -- traverse f = \x -> case x of (a1,a2,..) -> - -- liftA2 (,,) (g1 a1) (g2 a2) <*> .. - , ft_ty_app = \_ _ g -> fmap (nlHsApp traverse_Expr) <$> g - -- traverse f = traverse g - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant in ft_trav" - , ft_fun = panic "function in ft_trav" - , ft_bad_app = panic "in other argument in ft_trav" } - - -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) - -- (g2 a2) <*> ... - match_for_con :: Monad m - => [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> m (LMatch GhcPs (LHsExpr GhcPs)) - match_for_con = mkSimpleConMatch2 CaseAlt $ - \con xs -> return (mkApCon con xs) - where - -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. - mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs - mkApCon con [] = nlHsApps pure_RDR [con] - mkApCon con [x] = nlHsApps fmap_RDR [con,x] - mkApCon con (x1:x2:xs) = - foldl' appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs - where appAp x y = nlHsApps ap_RDR [x,y] - ------------------------------------------------------------------------ - -f_Expr, z_Expr, mempty_Expr, foldMap_Expr, - traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr, - all_Expr, null_Expr :: LHsExpr GhcPs -f_Expr = nlHsVar f_RDR -z_Expr = nlHsVar z_RDR -mempty_Expr = nlHsVar mempty_RDR -foldMap_Expr = nlHsVar foldMap_RDR -traverse_Expr = nlHsVar traverse_RDR -coerce_Expr = nlHsVar (getRdrName coerceId) -pure_Expr = nlHsVar pure_RDR -true_Expr = nlHsVar true_RDR -false_Expr = nlHsVar false_RDR -all_Expr = nlHsVar all_RDR -null_Expr = nlHsVar null_RDR - -f_RDR, z_RDR :: RdrName -f_RDR = mkVarUnqual (fsLit "f") -z_RDR = mkVarUnqual (fsLit "z") - -as_RDRs, bs_RDRs :: [RdrName] -as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] -bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] - -as_Vars, bs_Vars :: [LHsExpr GhcPs] -as_Vars = map nlHsVar as_RDRs -bs_Vars = map nlHsVar bs_RDRs - -f_Pat, z_Pat :: LPat GhcPs -f_Pat = nlVarPat f_RDR -z_Pat = nlVarPat z_RDR - -{- -Note [DeriveFoldable with ExistentialQuantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Functor and Traversable instances can only be derived for data types whose -last type parameter is truly universally polymorphic. For example: - - data T a b where - T1 :: b -> T a b -- YES, b is unconstrained - T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b) - T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int) - T4 :: Int -> T a Int -- NO, this is just like T3 - T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even - -- though a is existential - T6 :: Int -> T Int b -- YES, b is unconstrained - -For Foldable instances, however, we can completely lift the constraint that -the last type parameter be truly universally polymorphic. This means that T -(as defined above) can have a derived Foldable instance: - - instance Foldable (T a) where - foldr f z (T1 b) = f b z - foldr f z (T2 b) = f b z - foldr f z (T3 b) = f b z - foldr f z (T4 b) = z - foldr f z (T5 a b) = f b z - foldr f z (T6 a) = z - - foldMap f (T1 b) = f b - foldMap f (T2 b) = f b - foldMap f (T3 b) = f b - foldMap f (T4 b) = mempty - foldMap f (T5 a b) = f b - foldMap f (T6 a) = mempty - -In a Foldable instance, it is safe to fold over an occurrence of the last type -parameter that is not truly universally polymorphic. However, there is a bit -of subtlety in determining what is actually an occurrence of a type parameter. -T3 and T4, as defined above, provide one example: - - data T a b where - ... - T3 :: b ~ Int => b -> T a b - T4 :: Int -> T a Int - ... - - instance Foldable (T a) where - ... - foldr f z (T3 b) = f b z - foldr f z (T4 b) = z - ... - foldMap f (T3 b) = f b - foldMap f (T4 b) = mempty - ... - -Notice that the argument of T3 is folded over, whereas the argument of T4 is -not. This is because we only fold over constructor arguments that -syntactically mention the universally quantified type parameter of that -particular data constructor. See foldDataConArgs for how this is implemented. - -As another example, consider the following data type. The argument of each -constructor has the same type as the last type parameter: - - data E a where - E1 :: (a ~ Int) => a -> E a - E2 :: Int -> E Int - E3 :: (a ~ Int) => a -> E Int - E4 :: (a ~ Int) => Int -> E a - -Only E1's argument is an occurrence of a universally quantified type variable -that is syntactically equivalent to the last type parameter, so only E1's -argument will be folded over in a derived Foldable instance. - -See #10447 for the original discussion on this feature. Also see -https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/derive-functor -for a more in-depth explanation. - -Note [FFoldType and functorLikeTraverse] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deriving Functor, Foldable, and Traversable all require generating expressions -which perform an operation on each argument of a data constructor depending -on the argument's type. In particular, a generated operation can be different -depending on whether the type mentions the last type variable of the datatype -(e.g., if you have data T a = MkT a Int, then a generated foldr expression would -fold over the first argument of MkT, but not the second). - -This pattern is abstracted with the FFoldType datatype, which provides hooks -for the user to specify how a constructor argument should be folded when it -has a type with a particular "shape". The shapes are as follows (assume that -a is the last type variable in a given datatype): - -* ft_triv: The type does not mention the last type variable at all. - Examples: Int, b - -* ft_var: The type is syntactically equal to the last type variable. - Moreover, the type appears in a covariant position (see - the Deriving Functor instances section of the user's guide - for an in-depth explanation of covariance vs. contravariance). - Example: a (covariantly) - -* ft_co_var: The type is syntactically equal to the last type variable. - Moreover, the type appears in a contravariant position. - Example: a (contravariantly) - -* ft_fun: A function type which mentions the last type variable in - the argument position, result position or both. - Examples: a -> Int, Int -> a, Maybe a -> [a] - -* ft_tup: A tuple type which mentions the last type variable in at least - one of its fields. The TyCon argument of ft_tup represents the - particular tuple's type constructor. - Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #) - -* ft_ty_app: A type is being applied to the last type parameter, where the - applied type does not mention the last type parameter (if it - did, it would fall under ft_bad_app) and the argument type - mentions the last type parameter (if it did not, it would fall - under ft_triv). The first two Type arguments to - ft_ty_app represent the applied type and argument type, - respectively. - - Currently, only DeriveFunctor makes use of the argument type. - It inspects the argument type so that it can generate more - efficient implementations of fmap - (see Note [Avoid unnecessary eta expansion in derived fmap implementations]) - and (<$) (see Note [Deriving <$]) in certain cases. - - Note that functions, tuples, and foralls are distinct cases - and take precedence over ft_ty_app. (For example, (Int -> a) would - fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a). - Examples: Maybe a, Either b a - -* ft_bad_app: A type application uses the last type parameter in a position - other than the last argument. This case is singled out because - Functor, Foldable, and Traversable instances cannot be derived - for datatypes containing arguments with such types. - Examples: Either a Int, Const a b - -* ft_forall: A forall'd type mentions the last type parameter on its right- - hand side (and is not quantified on the left-hand side). This - case is present mostly for plumbing purposes. - Example: forall b. Either b a - -If FFoldType describes a strategy for folding subcomponents of a Type, then -functorLikeTraverse is the function that applies that strategy to the entirety -of a Type, returning the final folded-up result. - -foldDataConArgs applies functorLikeTraverse to every argument type of a -constructor, returning a list of the fold results. This makes foldDataConArgs -a natural way to generate the subexpressions in a generated fmap, foldr, -foldMap, or traverse definition (the subexpressions must then be combined in -a method-specific fashion to form the final generated expression). - -Deriving Generic1 also does validity checking by looking for the last type -variable in certain positions of a constructor's argument types, so it also -uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics. - -Note [Generated code for DeriveFoldable and DeriveTraversable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on -that of -XDeriveFunctor. However, there an important difference between deriving -the former two typeclasses and the latter one, which is best illustrated by the -following scenario: - - data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable) - -The generated code for the Functor instance is straightforward: - - instance Functor WithInt where - fmap f (WithInt a i) = WithInt (f a) i - -But if we use too similar of a strategy for deriving the Foldable and -Traversable instances, we end up with this code: - - instance Foldable WithInt where - foldMap f (WithInt a i) = f a <> mempty - - instance Traversable WithInt where - traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i - -This is unsatisfying for two reasons: - -1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure - expects an argument whose type is of kind *. This effectively prevents - Traversable from being derived for any datatype with an unlifted argument - type (#11174). - -2. The generated code contains superfluous expressions. By the Monoid laws, - we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can - reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)). - -We can fix both of these issues by incorporating a slight twist to the usual -algorithm that we use for -XDeriveFunctor. The differences can be summarized -as follows: - -1. In the generated expression, we only fold over arguments whose types - mention the last type parameter. Any other argument types will simply - produce useless 'mempty's or 'pure's, so they can be safely ignored. - -2. In the case of -XDeriveTraversable, instead of applying ConName, - we apply (\b_i ... b_k -> ConName a_1 ... a_n), where - - * ConName has n arguments - * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond - to the arguments whose types mention the last type parameter. As a - consequence, taking the difference of {a_1, ..., a_n} and - {b_i, ..., b_k} yields the all the argument values of ConName whose types - do not mention the last type parameter. Note that [i, ..., k] is a - strictly increasing—but not necessarily consecutive—integer sequence. - - For example, the datatype - - data Foo a = Foo Int a Int a - - would generate the following Traversable instance: - - instance Traversable Foo where - traverse f (Foo a1 a2 a3 a4) = - fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4 - -Technically, this approach would also work for -XDeriveFunctor as well, but we -decide not to do so because: - -1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a)) - instead of (WithInt (f a) i). - -2. There would be certain datatypes for which the above strategy would - generate Functor code that would fail to typecheck. For example: - - data Bar f a = Bar (forall f. Functor f => f a) deriving Functor - - With the conventional algorithm, it would generate something like: - - fmap f (Bar a) = Bar (fmap f a) - - which typechecks. But with the strategy mentioned above, it would generate: - - fmap f (Bar a) = (\b -> Bar b) (fmap f a) - - which does not typecheck, since GHC cannot unify the rank-2 type variables - in the types of b and (fmap f a). - -Note [Phantom types with Functor, Foldable, and Traversable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Given a type F :: * -> * whose type argument has a phantom role, we can always -produce lawful Functor and Traversable instances using - - fmap _ = coerce - traverse _ = pure . coerce - -Indeed, these are equivalent to any *strictly lawful* instances one could -write, except that this definition of 'traverse' may be lazier. That is, if -instances obey the laws under true equality (rather than up to some equivalence -relation), then they will be essentially equivalent to these. These definitions -are incredibly cheap, so we want to use them even if it means ignoring some -non-strictly-lawful instance in an embedded type. - -Foldable has far fewer laws to work with, which leaves us unwelcome -freedom in implementing it. At a minimum, we would like to ensure that -a derived foldMap is always at least as good as foldMapDefault with a -derived traverse. To accomplish that, we must define - - foldMap _ _ = mempty - -in these cases. - -This may have different strictness properties from a standard derivation. -Consider - - data NotAList a = Nil | Cons (NotAList a) deriving Foldable - -The usual deriving mechanism would produce - - foldMap _ Nil = mempty - foldMap f (Cons x) = foldMap f x - -which is strict in the entire spine of the NotAList. - -Final point: why do we even care about such types? Users will rarely if ever -map, fold, or traverse over such things themselves, but other derived -instances may: - - data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable - -Note [EmptyDataDecls with Functor, Foldable, and Traversable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are some slightly tricky decisions to make about how to handle -Functor, Foldable, and Traversable instances for types with no constructors. -For fmap, the two basic options are - - fmap _ _ = error "Sorry, no constructors" - -or - - fmap _ z = case z of - -In most cases, the latter is more helpful: if the thunk passed to fmap -throws an exception, we're generally going to be much more interested in -that exception than in the fact that there aren't any constructors. - -In order to match the semantics for phantoms (see note above), we need to -be a bit careful about 'traverse'. The obvious definition would be - - traverse _ z = case z of - -but this is stricter than the one for phantoms. We instead use - - traverse _ z = pure $ case z of - -For foldMap, the obvious choices are - - foldMap _ _ = mempty - -or - - foldMap _ z = case z of - -We choose the first one to be consistent with what foldMapDefault does for -a derived Traversable instance. --} diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs deleted file mode 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ /dev/null @@ -1,1035 +0,0 @@ -{- -(c) The University of Glasgow 2011 - - -The deriving code for the Generic class -(equivalent to the code in TcGenDeriv, for other classes) --} - -{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcGenGenerics (canDoGenerics, canDoGenerics1, - GenericKind(..), - gen_Generic_binds, get_gen1_constrained_tys) where - -import GhcPrelude - -import GHC.Hs -import GHC.Core.Type -import TcType -import TcGenDeriv -import TcGenFunctor -import GHC.Core.DataCon -import GHC.Core.TyCon -import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) -import FamInst -import GHC.Types.Module ( moduleName, moduleNameFS - , moduleUnitId, unitIdFS, getModule ) -import GHC.Iface.Env ( newGlobalBinder ) -import GHC.Types.Name hiding ( varName ) -import GHC.Types.Name.Reader -import GHC.Types.Basic -import TysPrim -import TysWiredIn -import PrelNames -import TcEnv -import TcRnMonad -import GHC.Driver.Types -import ErrUtils( Validity(..), andValid ) -import GHC.Types.SrcLoc -import Bag -import GHC.Types.Var.Env -import GHC.Types.Var.Set (elemVarSet) -import Outputable -import FastString -import Util - -import Control.Monad (mplus) -import Data.List (zip4, partition) -import Data.Maybe (isJust) - -#include "HsVersions.h" - -{- -************************************************************************ -* * -\subsection{Bindings for the new generic deriving mechanism} -* * -************************************************************************ - -For the generic representation we need to generate: -\begin{itemize} -\item A Generic instance -\item A Rep type instance -\item Many auxiliary datatypes and instances for them (for the meta-information) -\end{itemize} --} - -gen_Generic_binds :: GenericKind -> TyCon -> [Type] - -> TcM (LHsBinds GhcPs, FamInst) -gen_Generic_binds gk tc inst_tys = do - repTyInsts <- tc_mkRepFamInsts gk tc inst_tys - return (mkBindsRep gk tc, repTyInsts) - -{- -************************************************************************ -* * -\subsection{Generating representation types} -* * -************************************************************************ --} - -get_gen1_constrained_tys :: TyVar -> Type -> [Type] --- called by TcDeriv.inferConstraints; generates a list of types, each of which --- must be a Functor in order for the Generic1 instance to work. -get_gen1_constrained_tys argVar - = argTyFold argVar $ ArgTyAlg { ata_rec0 = const [] - , ata_par1 = [], ata_rec1 = const [] - , ata_comp = (:) } - -{- - -Note [Requirements for deriving Generic and Rep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In the following, T, Tfun, and Targ are "meta-variables" ranging over type -expressions. - -(Generic T) and (Rep T) are derivable for some type expression T if the -following constraints are satisfied. - - (a) D is a type constructor *value*. In other words, D is either a type - constructor or it is equivalent to the head of a data family instance (up to - alpha-renaming). - - (b) D cannot have a "stupid context". - - (c) The right-hand side of D cannot include existential types, universally - quantified types, or "exotic" unlifted types. An exotic unlifted type - is one which is not listed in the definition of allowedUnliftedTy - (i.e., one for which we have no representation type). - See Note [Generics and unlifted types] - - (d) T :: *. - -(Generic1 T) and (Rep1 T) are derivable for some type expression T if the -following constraints are satisfied. - - (a),(b),(c) As above. - - (d) T must expect arguments, and its last parameter must have kind *. - - We use `a' to denote the parameter of D that corresponds to the last - parameter of T. - - (e) For any type-level application (Tfun Targ) in the right-hand side of D - where the head of Tfun is not a tuple constructor: - - (b1) `a' must not occur in Tfun. - - (b2) If `a' occurs in Targ, then Tfun :: * -> *. - --} - -canDoGenerics :: TyCon -> Validity --- canDoGenerics determines if Generic/Rep can be derived. --- --- Check (a) from Note [Requirements for deriving Generic and Rep] is taken --- care of because canDoGenerics is applied to rep tycons. --- --- It returns IsValid if deriving is possible. It returns (NotValid reason) --- if not. -canDoGenerics tc - = mergeErrors ( - -- Check (b) from Note [Requirements for deriving Generic and Rep]. - (if (not (null (tyConStupidTheta tc))) - then (NotValid (tc_name <+> text "must not have a datatype context")) - else IsValid) - -- See comment below - : (map bad_con (tyConDataCons tc))) - where - -- The tc can be a representation tycon. When we want to display it to the - -- user (in an error message) we should print its parent - tc_name = ppr $ case tyConFamInst_maybe tc of - Just (ptc, _) -> ptc - _ -> tc - - -- Check (c) from Note [Requirements for deriving Generic and Rep]. - -- - -- If any of the constructors has an exotic unlifted type as argument, - -- then we can't build the embedding-projection pair, because - -- it relies on instantiating *polymorphic* sum and product types - -- at the argument types of the constructors - bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc)) - then (NotValid (ppr dc <+> text - "must not have exotic unlifted or polymorphic arguments")) - else (if (not (isVanillaDataCon dc)) - then (NotValid (ppr dc <+> text "must be a vanilla data constructor")) - else IsValid) - - -- Nor can we do the job if it's an existential data constructor, - -- Nor if the args are polymorphic types (I don't think) - bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty)) - || not (isTauTy ty) - --- Returns True the Type argument is an unlifted type which has a --- corresponding generic representation type. For example, --- (allowedUnliftedTy Int#) would return True since there is the UInt --- representation type. -allowedUnliftedTy :: Type -> Bool -allowedUnliftedTy = isJust . unboxedRepRDRs - -mergeErrors :: [Validity] -> Validity -mergeErrors [] = IsValid -mergeErrors (NotValid s:t) = case mergeErrors t of - IsValid -> NotValid s - NotValid s' -> NotValid (s <> text ", and" $$ s') -mergeErrors (IsValid : t) = mergeErrors t - --- A datatype used only inside of canDoGenerics1. It's the result of analysing --- a type term. -data Check_for_CanDoGenerics1 = CCDG1 - { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in - -- this type? - , _ccdg1_errors :: Validity -- errors generated by this type - } - -{- - -Note [degenerate use of FFoldType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We use foldDataConArgs here only for its ability to treat tuples -specially. foldDataConArgs also tracks covariance (though it assumes all -higher-order type parameters are covariant) and has hooks for special handling -of functions and polytypes, but we do *not* use those. - -The key issue is that Generic1 deriving currently offers no sophisticated -support for functions. For example, we cannot handle - - data F a = F ((a -> Int) -> Int) - -even though a is occurring covariantly. - -In fact, our rule is harsh: a is simply not allowed to occur within the first -argument of (->). We treat (->) the same as any other non-tuple tycon. - -Unfortunately, this means we have to track "the parameter occurs in this type" -explicitly, even though foldDataConArgs is also doing this internally. - --} - --- canDoGenerics1 determines if a Generic1/Rep1 can be derived. --- --- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep] --- are taken care of by the call to canDoGenerics. --- --- It returns IsValid if deriving is possible. It returns (NotValid reason) --- if not. -canDoGenerics1 :: TyCon -> Validity -canDoGenerics1 rep_tc = - canDoGenerics rep_tc `andValid` additionalChecks - where - additionalChecks - -- check (d) from Note [Requirements for deriving Generic and Rep] - | null (tyConTyVars rep_tc) = NotValid $ - text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters" - - | otherwise = mergeErrors $ concatMap check_con data_cons - - data_cons = tyConDataCons rep_tc - check_con con = case check_vanilla con of - j@(NotValid {}) -> [j] - IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con - - bad :: DataCon -> SDoc -> SDoc - bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg - - check_vanilla :: DataCon -> Validity - check_vanilla con | isVanillaDataCon con = IsValid - | otherwise = NotValid (bad con existential) - - bmzero = CCDG1 False IsValid - bmbad con s = CCDG1 True $ NotValid $ bad con s - bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2) - - -- check (e) from Note [Requirements for deriving Generic and Rep] - -- See also Note [degenerate use of FFoldType] - ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1 - ft_check con = FT - { ft_triv = bmzero - - , ft_var = caseVar, ft_co_var = caseVar - - -- (component_0,component_1,...,component_n) - , ft_tup = \_ components -> if any _ccdg1_hasParam (init components) - then bmbad con wrong_arg - else foldr bmplus bmzero components - - -- (dom -> rng), where the head of ty is not a tuple tycon - , ft_fun = \dom rng -> -- cf #8516 - if _ccdg1_hasParam dom - then bmbad con wrong_arg - else bmplus dom rng - - -- (ty arg), where head of ty is neither (->) nor a tuple constructor and - -- the parameter of interest does not occur in ty - , ft_ty_app = \_ _ arg -> arg - - , ft_bad_app = bmbad con wrong_arg - , ft_forall = \_ body -> body -- polytypes are handled elsewhere - } - where - caseVar = CCDG1 True IsValid - - - existential = text "must not have existential arguments" - wrong_arg = text "applies a type to an argument involving the last parameter" - $$ text "but the applied type is not of kind * -> *" - -{- -************************************************************************ -* * -\subsection{Generating the RHS of a generic default method} -* * -************************************************************************ --} - -type US = Int -- Local unique supply, just a plain Int -type Alt = (LPat GhcPs, LHsExpr GhcPs) - --- GenericKind serves to mark if a datatype derives Generic (Gen0) or --- Generic1 (Gen1). -data GenericKind = Gen0 | Gen1 - --- as above, but with a payload of the TyCon's name for "the" parameter -data GenericKind_ = Gen0_ | Gen1_ TyVar - --- as above, but using a single datacon's name for "the" parameter -data GenericKind_DC = Gen0_DC | Gen1_DC TyVar - -forgetArgVar :: GenericKind_DC -> GenericKind -forgetArgVar Gen0_DC = Gen0 -forgetArgVar Gen1_DC{} = Gen1 - --- When working only within a single datacon, "the" parameter's name should --- match that datacon's name for it. -gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC -gk2gkDC Gen0_ _ = Gen0_DC -gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d - - --- Bindings for the Generic instance -mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs -mkBindsRep gk tycon = - unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn]) - `unionBags` - unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn]) - where - -- The topmost M1 (the datatype metadata) has the exact same type - -- across all cases of a from/to definition, and can be factored out - -- to save some allocations during typechecking. - -- See Note [Generics compilation speed tricks] - from_eqn = mkHsCaseAlt x_Pat $ mkM1_E - $ nlHsPar $ nlHsCase x_Expr from_matches - to_eqn = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches - - from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts] - to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ] - loc = srcLocSpan (getSrcLoc tycon) - datacons = tyConDataCons tycon - - (from01_RDR, to01_RDR) = case gk of - Gen0 -> (from_RDR, to_RDR) - Gen1 -> (from1_RDR, to1_RDR) - - -- Recurse over the sum first - from_alts, to_alts :: [Alt] - (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons - where gk_ = case gk of - Gen0 -> Gen0_ - Gen1 -> ASSERT(tyvars `lengthAtLeast` 1) - Gen1_ (last tyvars) - where tyvars = tyConTyVars tycon - --------------------------------------------------------------------------------- --- The type synonym instance and synonym --- type instance Rep (D a b) = Rep_D a b --- type Rep_D a b = ...representation type for D ... --------------------------------------------------------------------------------- - -tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 - -> TyCon -- The type to generate representation for - -> [Type] -- The type(s) to which Generic(1) is applied - -- in the generated instance - -> TcM FamInst -- Generated representation0 coercion -tc_mkRepFamInsts gk tycon inst_tys = - -- Consider the example input tycon `D`, where data D a b = D_ a - -- Also consider `R:DInt`, where { data family D x y :: * -> * - -- ; data instance D Int a b = D_ a } - do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family) - fam_tc <- case gk of - Gen0 -> tcLookupTyCon repTyConName - Gen1 -> tcLookupTyCon rep1TyConName - - ; fam_envs <- tcGetFamInstEnvs - - ; let -- If the derived instance is - -- instance Generic (Foo x) - -- then: - -- `arg_ki` = *, `inst_ty` = Foo x :: * - -- - -- If the derived instance is - -- instance Generic1 (Bar x :: k -> *) - -- then: - -- `arg_k` = k, `inst_ty` = Bar x :: k -> * - (arg_ki, inst_ty) = case (gk, inst_tys) of - (Gen0, [inst_t]) -> (liftedTypeKind, inst_t) - (Gen1, [arg_k, inst_t]) -> (arg_k, inst_t) - _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys) - - ; let mbFamInst = tyConFamInst_maybe tycon - -- If we're examining a data family instance, we grab the parent - -- TyCon (ptc) and use it to determine the type arguments - -- (inst_args) for the data family *instance*'s type variables. - ptc = maybe tycon fst mbFamInst - (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd - $ tcSplitTyConApp inst_ty - - ; let -- `tyvars` = [a,b] - (tyvars, gk_) = case gk of - Gen0 -> (all_tyvars, Gen0_) - Gen1 -> ASSERT(not $ null all_tyvars) - (init all_tyvars, Gen1_ $ last all_tyvars) - where all_tyvars = tyConTyVars tycon - - -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * - ; repTy <- tc_mkRepTy gk_ tycon arg_ki - - -- `rep_name` is a name we generate for the synonym - ; mod <- getModule - ; loc <- getSrcSpanM - ; let tc_occ = nameOccName (tyConName tycon) - rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ - ; rep_name <- newGlobalBinder mod rep_occ loc - - -- We make sure to substitute the tyvars with their user-supplied - -- type arguments before generating the Rep/Rep1 instance, since some - -- of the tyvars might have been instantiated when deriving. - -- See Note [Generating a correctly typed Rep instance]. - ; let (env_tyvars, env_inst_args) - = case gk_ of - Gen0_ -> (tyvars, inst_args) - Gen1_ last_tv - -- See the "wrinkle" in - -- Note [Generating a correctly typed Rep instance] - -> ( last_tv : tyvars - , anyTypeOfKind (tyVarKind last_tv) : inst_args ) - env = zipTyEnv env_tyvars env_inst_args - in_scope = mkInScopeSet (tyCoVarsOfTypes inst_tys) - subst = mkTvSubst in_scope env - repTy' = substTyUnchecked subst repTy - tcv' = tyCoVarsOfTypeList inst_ty - (tv', cv') = partition isTyVar tcv' - tvs' = scopedSort tv' - cvs' = scopedSort cv' - axiom = mkSingleCoAxiom Nominal rep_name tvs' [] cvs' - fam_tc inst_tys repTy' - - ; newFamInst SynFamilyInst axiom } - --------------------------------------------------------------------------------- --- Type representation --------------------------------------------------------------------------------- - --- | See documentation of 'argTyFold'; that function uses the fields of this --- type to interpret the structure of a type when that type is considered as an --- argument to a constructor that is being represented with 'Rep1'. -data ArgTyAlg a = ArgTyAlg - { ata_rec0 :: (Type -> a) - , ata_par1 :: a, ata_rec1 :: (Type -> a) - , ata_comp :: (Type -> a -> a) - } - --- | @argTyFold@ implements a generalised and safer variant of the @arg@ --- function from Figure 3 in . @arg@ --- is conceptually equivalent to: --- --- > arg t = case t of --- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t --- > App f [t'] | --- > representable1 f && --- > t' == argVar -> Rec1 f --- > App f [t'] | --- > representable1 f && --- > t' has tyvars -> f :.: (arg t') --- > _ -> Rec0 t --- --- where @argVar@ is the last type variable in the data type declaration we are --- finding the representation for. --- --- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to --- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and --- @:.:@. --- --- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for --- some data types. The problematic case is when @t@ is an application of a --- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the --- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in --- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some --- representable1 checks have been relaxed, and others were moved to --- @canDoGenerics1@. -argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a -argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0, - ata_par1 = mkPar1, ata_rec1 = mkRec1, - ata_comp = mkComp}) = - -- mkRec0 is the default; use it if there is no interesting structure - -- (e.g. occurrences of parameters or recursive occurrences) - \t -> maybe (mkRec0 t) id $ go t where - go :: Type -> -- type to fold through - Maybe a -- the result (e.g. representation type), unless it's trivial - go t = isParam `mplus` isApp where - - isParam = do -- handles parameters - t' <- getTyVar_maybe t - Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter - else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0 - - isApp = do -- handles applications - (phi, beta) <- tcSplitAppTy_maybe t - - let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta - - -- Does it have no interesting structure to represent? - if not interesting then Nothing - else -- Is the argument the parameter? Special case for mkRec1. - if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi - else mkComp phi `fmap` go beta -- It must be a composition. - - -tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 - GenericKind_ - -- The type to generate representation for - -> TyCon - -- The kind of the representation type's argument - -- See Note [Handling kinds in a Rep instance] - -> Kind - -- Generated representation0 type - -> TcM Type -tc_mkRepTy gk_ tycon k = - do - d1 <- tcLookupTyCon d1TyConName - c1 <- tcLookupTyCon c1TyConName - s1 <- tcLookupTyCon s1TyConName - rec0 <- tcLookupTyCon rec0TyConName - rec1 <- tcLookupTyCon rec1TyConName - par1 <- tcLookupTyCon par1TyConName - u1 <- tcLookupTyCon u1TyConName - v1 <- tcLookupTyCon v1TyConName - plus <- tcLookupTyCon sumTyConName - times <- tcLookupTyCon prodTyConName - comp <- tcLookupTyCon compTyConName - uAddr <- tcLookupTyCon uAddrTyConName - uChar <- tcLookupTyCon uCharTyConName - uDouble <- tcLookupTyCon uDoubleTyConName - uFloat <- tcLookupTyCon uFloatTyConName - uInt <- tcLookupTyCon uIntTyConName - uWord <- tcLookupTyCon uWordTyConName - - let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon - - md <- tcLookupPromDataCon metaDataDataConName - mc <- tcLookupPromDataCon metaConsDataConName - ms <- tcLookupPromDataCon metaSelDataConName - pPrefix <- tcLookupPromDataCon prefixIDataConName - pInfix <- tcLookupPromDataCon infixIDataConName - pLA <- tcLookupPromDataCon leftAssociativeDataConName - pRA <- tcLookupPromDataCon rightAssociativeDataConName - pNA <- tcLookupPromDataCon notAssociativeDataConName - pSUpk <- tcLookupPromDataCon sourceUnpackDataConName - pSNUpk <- tcLookupPromDataCon sourceNoUnpackDataConName - pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName - pSLzy <- tcLookupPromDataCon sourceLazyDataConName - pSStr <- tcLookupPromDataCon sourceStrictDataConName - pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName - pDLzy <- tcLookupPromDataCon decidedLazyDataConName - pDStr <- tcLookupPromDataCon decidedStrictDataConName - pDUpk <- tcLookupPromDataCon decidedUnpackDataConName - - fix_env <- getFixityEnv - - let mkSum' a b = mkTyConApp plus [k,a,b] - mkProd a b = mkTyConApp times [k,a,b] - mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a - mkRec1 a = mkTyConApp rec1 [k,a] - mkPar1 = mkTyConTy par1 - mkD a = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ] - mkC a = mkTyConApp c1 [ k - , metaConsTy a - , prod (dataConInstOrigArgTys a - . mkTyVarTys . tyConTyVars $ tycon) - (dataConSrcBangs a) - (dataConImplBangs a) - (dataConFieldLabels a)] - mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a] - - -- Sums and products are done in the same way for both Rep and Rep1 - sumP l = foldBal mkSum' (mkTyConApp v1 [k]) . map mkC $ l - -- The Bool is True if this constructor has labelled fields - prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type - prod l sb ib fl = foldBal mkProd (mkTyConApp u1 [k]) - [ ASSERT(null fl || lengthExceeds fl j) - arg t sb' ib' (if null fl - then Nothing - else Just (fl !! j)) - | (t,sb',ib',j) <- zip4 l sb ib [0..] ] - - arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type - arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of - -- Here we previously used Par0 if t was a type variable, but we - -- realized that we can't always guarantee that we are wrapping-up - -- all type variables in Par0. So we decided to stop using Par0 - -- altogether, and use Rec0 all the time. - Gen0_ -> mkRec0 t - Gen1_ argVar -> argPar argVar t - where - -- Builds argument representation for Rep1 (more complicated due to - -- the presence of composition). - argPar argVar = argTyFold argVar $ ArgTyAlg - {ata_rec0 = mkRec0, ata_par1 = mkPar1, - ata_rec1 = mkRec1, ata_comp = mkComp comp k} - - tyConName_user = case tyConFamInst_maybe tycon of - Just (ptycon, _) -> tyConName ptycon - Nothing -> tyConName tycon - - dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user - mdName = mkStrLitTy . moduleNameFS . moduleName - . nameModule . tyConName $ tycon - pkgName = mkStrLitTy . unitIdFS . moduleUnitId - . nameModule . tyConName $ tycon - isNT = mkTyConTy $ if isNewTyCon tycon - then promotedTrueDataCon - else promotedFalseDataCon - - ctName = mkStrLitTy . occNameFS . nameOccName . dataConName - ctFix c - | dataConIsInfix c - = case lookupFixity fix_env (dataConName c) of - Fixity _ n InfixL -> buildFix n pLA - Fixity _ n InfixR -> buildFix n pRA - Fixity _ n InfixN -> buildFix n pNA - | otherwise = mkTyConTy pPrefix - buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc - , mkNumLitTy (fromIntegral n)] - - isRec c = mkTyConTy $ if dataConFieldLabels c `lengthExceeds` 0 - then promotedTrueDataCon - else promotedFalseDataCon - - selName = mkStrLitTy . flLabel - - mbSel Nothing = mkTyConApp promotedNothingDataCon [typeSymbolKind] - mbSel (Just s) = mkTyConApp promotedJustDataCon - [typeSymbolKind, selName s] - - metaDataTy = mkTyConApp md [dtName, mdName, pkgName, isNT] - metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c] - metaSelTy mlbl su ss ib = - mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness] - where - pSUpkness = mkTyConTy $ case su of - SrcUnpack -> pSUpk - SrcNoUnpack -> pSNUpk - NoSrcUnpack -> pNSUpkness - - pSStrness = mkTyConTy $ case ss of - SrcLazy -> pSLzy - SrcStrict -> pSStr - NoSrcStrict -> pNSStrness - - pDStrness = mkTyConTy $ case ib of - HsLazy -> pDLzy - HsStrict -> pDStr - HsUnpack{} -> pDUpk - - return (mkD tycon) - -mkComp :: TyCon -> Kind -> Type -> Type -> Type -mkComp comp k f g - | k1_first = mkTyConApp comp [k,liftedTypeKind,f,g] - | otherwise = mkTyConApp comp [liftedTypeKind,k,f,g] - where - -- Which of these is the case? - -- newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... - -- or newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... - -- We want to instantiate with k1=k, and k2=* - -- Reason for k2=*: see Note [Handling kinds in a Rep instance] - -- But we need to know which way round! - k1_first = k_first == p_kind_var - [k_first,_,_,_,p] = tyConTyVars comp - Just p_kind_var = getTyVar_maybe (tyVarKind p) - --- Given the TyCons for each URec-related type synonym, check to see if the --- given type is an unlifted type that generics understands. If so, return --- its representation type. Otherwise, return Rec0. --- See Note [Generics and unlifted types] -mkBoxTy :: TyCon -- UAddr - -> TyCon -- UChar - -> TyCon -- UDouble - -> TyCon -- UFloat - -> TyCon -- UInt - -> TyCon -- UWord - -> TyCon -- Rec0 - -> Kind -- What to instantiate Rec0's kind variable with - -> Type - -> Type -mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty - | ty `eqType` addrPrimTy = mkTyConApp uAddr [k] - | ty `eqType` charPrimTy = mkTyConApp uChar [k] - | ty `eqType` doublePrimTy = mkTyConApp uDouble [k] - | ty `eqType` floatPrimTy = mkTyConApp uFloat [k] - | ty `eqType` intPrimTy = mkTyConApp uInt [k] - | ty `eqType` wordPrimTy = mkTyConApp uWord [k] - | otherwise = mkTyConApp rec0 [k,ty] - --------------------------------------------------------------------------------- --- Dealing with sums --------------------------------------------------------------------------------- - -mkSum :: GenericKind_ -- Generic or Generic1? - -> US -- Base for generating unique names - -> [DataCon] -- The data constructors - -> ([Alt], -- Alternatives for the T->Trep "from" function - [Alt]) -- Alternatives for the Trep->T "to" function - --- Datatype without any constructors -mkSum _ _ [] = ([from_alt], [to_alt]) - where - from_alt = (x_Pat, nlHsCase x_Expr []) - to_alt = (x_Pat, nlHsCase x_Expr []) - -- These M1s are meta-information for the datatype - --- Datatype with at least one constructor -mkSum gk_ us datacons = - -- switch the payload of gk_ to be datacon-centric instead of tycon-centric - unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d - | (d,i) <- zip datacons [1..] ] - --- Build the sum for a particular constructor -mk1Sum :: GenericKind_DC -- Generic or Generic1? - -> US -- Base for generating unique names - -> Int -- The index of this constructor - -> Int -- Total number of constructors - -> DataCon -- The data constructor - -> (Alt, -- Alternative for the T->Trep "from" function - Alt) -- Alternative for the Trep->T "to" function -mk1Sum gk_ us i n datacon = (from_alt, to_alt) - where - gk = forgetArgVar gk_ - - -- Existentials already excluded - argTys = dataConOrigArgTys datacon - n_args = dataConSourceArity datacon - - datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys - datacon_vars = map fst datacon_varTys - - datacon_rdr = getRdrName datacon - - from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) - from_alt_rhs = genLR_E i n (mkProd_E gk_ datacon_varTys) - - to_alt = ( genLR_P i n (mkProd_P gk datacon_varTys) - , to_alt_rhs - ) -- These M1s are meta-information for the datatype - to_alt_rhs = case gk_ of - Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars - Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys - where - argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where - converter = argTyFold argVar $ ArgTyAlg - {ata_rec0 = nlHsVar . unboxRepRDR, - ata_par1 = nlHsVar unPar1_RDR, - ata_rec1 = const $ nlHsVar unRec1_RDR, - ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv) - `nlHsCompose` nlHsVar unComp1_RDR} - - --- Generates the L1/R1 sum pattern -genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs -genLR_P i n p - | n == 0 = error "impossible" - | n == 1 = p - | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] - | otherwise = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] - where m = div n 2 - --- Generates the L1/R1 sum expression -genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs -genLR_E i n e - | n == 0 = error "impossible" - | n == 1 = e - | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` - nlHsPar (genLR_E i (div n 2) e) - | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` - nlHsPar (genLR_E (i-m) (n-m) e) - where m = div n 2 - --------------------------------------------------------------------------------- --- Dealing with products --------------------------------------------------------------------------------- - --- Build a product expression -mkProd_E :: GenericKind_DC -- Generic or Generic1? - -> [(RdrName, Type)] - -- List of variables matched on the lhs and their types - -> LHsExpr GhcPs -- Resulting product expression -mkProd_E gk_ varTys = mkM1_E (foldBal prod (nlHsVar u1DataCon_RDR) appVars) - -- These M1s are meta-information for the constructor - where - appVars = map (wrapArg_E gk_) varTys - prod a b = prodDataCon_RDR `nlHsApps` [a,b] - -wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs -wrapArg_E Gen0_DC (var, ty) = mkM1_E $ - boxRepRDR ty `nlHsVarApps` [var] - -- This M1 is meta-information for the selector -wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ - converter ty `nlHsApp` nlHsVar var - -- This M1 is meta-information for the selector - where converter = argTyFold argVar $ ArgTyAlg - {ata_rec0 = nlHsVar . boxRepRDR, - ata_par1 = nlHsVar par1DataCon_RDR, - ata_rec1 = const $ nlHsVar rec1DataCon_RDR, - ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose` - (nlHsVar fmap_RDR `nlHsApp` cnv)} - -boxRepRDR :: Type -> RdrName -boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs - -unboxRepRDR :: Type -> RdrName -unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs - --- Retrieve the RDRs associated with each URec data family instance --- constructor. See Note [Generics and unlifted types] -unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName) -unboxedRepRDRs ty - | ty `eqType` addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR) - | ty `eqType` charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR) - | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR) - | ty `eqType` floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR) - | ty `eqType` intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR) - | ty `eqType` wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR) - | otherwise = Nothing - --- Build a product pattern -mkProd_P :: GenericKind -- Gen0 or Gen1 - -> [(RdrName, Type)] -- List of variables to match, - -- along with their types - -> LPat GhcPs -- Resulting product pattern -mkProd_P gk varTys = mkM1_P (foldBal prod (nlNullaryConPat u1DataCon_RDR) appVars) - -- These M1s are meta-information for the constructor - where - appVars = unzipWith (wrapArg_P gk) varTys - prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b] - -wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs -wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v]) - -- This M1 is meta-information for the selector -wrapArg_P Gen1 v _ = nlParPat $ m1DataCon_RDR `nlConVarPat` [v] - -mkGenericLocal :: US -> RdrName -mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) - -x_RDR :: RdrName -x_RDR = mkVarUnqual (fsLit "x") - -x_Expr :: LHsExpr GhcPs -x_Expr = nlHsVar x_RDR - -x_Pat :: LPat GhcPs -x_Pat = nlVarPat x_RDR - -mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs -mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e - -mkM1_P :: LPat GhcPs -> LPat GhcPs -mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p] - -nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -nlHsCompose x y = compose_RDR `nlHsApps` [x, y] - --- | Variant of foldr for producing balanced lists -foldBal :: (a -> a -> a) -> a -> [a] -> a -foldBal _ x [] = x -foldBal _ _ [y] = y -foldBal op x l = let (a,b) = splitAt (length l `div` 2) l - in foldBal op x a `op` foldBal op x b - -{- -Note [Generics and unlifted types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Normally, all constants are marked with K1/Rec0. The exception to this rule is -when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In -that case, we must use a data family instance of URec (from GHC.Generics) to -mark it. As a result, before we can generate K1 or unK1, we must first check -to see if the type is actually one of the unlifted types for which URec has a -data family instance; if so, we generate that instead. - -See wiki:commentary/compiler/generic-deriving#handling-unlifted-types for more -details on why URec is implemented the way it is. - -Note [Generating a correctly typed Rep instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving -Generic(1). That is, it derives the ellipsis in the following: - - instance Generic Foo where - type Rep Foo = ... - -However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which -a Generic(1) instance is being derived, not the fully instantiated type. As a -result, tc_mkRepTy builds the most generalized Rep(1) instance possible using -the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This -can cause problems when the instance has instantiated type variables -(see #11732). As an example: - - data T a = MkT a - deriving instance Generic (T Int) - ==> - instance Generic (T Int) where - type Rep (T Int) = (... (Rec0 a)) -- wrong! - --XStandaloneDeriving is one way for the type variables to become instantiated. -Another way is when Generic1 is being derived for a datatype with a visible -kind binder, e.g., - - data P k (a :: k) = MkP k deriving Generic1 - ==> - instance Generic1 (P *) where - type Rep1 (P *) = (... (Rec0 k)) -- wrong! - -See Note [Unify kinds in deriving] in TcDeriv. - -In any such scenario, we must prevent a discrepancy between the LHS and RHS of -a Rep(1) instance. To do so, we create a type variable substitution that maps -the tyConTyVars of the TyCon to their counterparts in the fully instantiated -type. (For example, using T above as example, you'd map a :-> Int.) We then -apply the substitution to the RHS before generating the instance. - -A wrinkle in all of this: when forming the type variable substitution for -Generic1 instances, we map the last type variable of the tycon to Any. Why? -It's because of wily data types like this one (#15012): - - data T a = MkT (FakeOut a) - type FakeOut a = Int - -If we ignore a, then we'll produce the following Rep1 instance: - - instance Generic1 T where - type Rep1 T = ... (Rec0 (FakeOut a)) - ... - -Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we -ensure that `a` is mapped to Any: - - instance Generic1 T where - type Rep1 T = ... (Rec0 (FakeOut Any)) - ... - -And now all is good. - -Alternatively, we could have avoided this problem by expanding all type -synonyms on the RHSes of Rep1 instances. But we might blow up the size of -these types even further by doing this, so we choose not to do so. - -Note [Handling kinds in a Rep instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because Generic1 is poly-kinded, the representation types were generalized to -be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply -the kind of the instance being derived to all the representation type -constructors. For instance, if you have - - data Empty (a :: k) = Empty deriving Generic1 - -Then the generated code is now approximately (with -fprint-explicit-kinds -syntax): - - instance Generic1 k (Empty k) where - type Rep1 k (Empty k) = U1 k - -Most representation types have only one kind variable, making them easy to deal -with. The only non-trivial case is (:.:), which is only used in Generic1 -instances: - - newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) = - Comp1 { unComp1 :: f (g p) } - -Here, we do something a bit counter-intuitive: we make k1 be the kind of the -instance being derived, and we always make k2 be *. Why *? It's because -the code that GHC generates using (:.:) is always of the form x :.: Rec1 y -for some types x and y. In other words, the second type to which (:.:) is -applied always has kind k -> *, for some kind k, so k2 cannot possibly be -anything other than * in a generated Generic1 instance. - -Note [Generics compilation speed tricks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deriving Generic(1) is known to have a large constant factor during -compilation, which contributes to noticeable compilation slowdowns when -deriving Generic(1) for large datatypes (see #5642). - -To ease the pain, there is a trick one can play when generating definitions for -to(1) and from(1). If you have a datatype like: - - data Letter = A | B | C | D - -then a naïve Generic instance for Letter would be: - - instance Generic Letter where - type Rep Letter = D1 ('MetaData ...) ... - - to (M1 (L1 (L1 (M1 U1)))) = A - to (M1 (L1 (R1 (M1 U1)))) = B - to (M1 (R1 (L1 (M1 U1)))) = C - to (M1 (R1 (R1 (M1 U1)))) = D - - from A = M1 (L1 (L1 (M1 U1))) - from B = M1 (L1 (R1 (M1 U1))) - from C = M1 (R1 (L1 (M1 U1))) - from D = M1 (R1 (R1 (M1 U1))) - -Notice that in every LHS pattern-match of the 'to' definition, and in every RHS -expression in the 'from' definition, the topmost constructor is M1. This -corresponds to the datatype-specific metadata (the D1 in the Rep Letter -instance). But this is wasteful from a typechecking perspective, since this -definition requires GHC to typecheck an application of M1 in every single case, -leading to an O(n) increase in the number of coercions the typechecker has to -solve, which in turn increases allocations and degrades compilation speed. - -Luckily, since the topmost M1 has the exact same type across every case, we can -factor it out reduce the typechecker's burden: - - instance Generic Letter where - type Rep Letter = D1 ('MetaData ...) ... - - to (M1 x) = case x of - L1 (L1 (M1 U1)) -> A - L1 (R1 (M1 U1)) -> B - R1 (L1 (M1 U1)) -> C - R1 (R1 (M1 U1)) -> D - - from x = M1 (case x of - A -> L1 (L1 (M1 U1)) - B -> L1 (R1 (M1 U1)) - C -> R1 (L1 (M1 U1)) - D -> R1 (R1 (M1 U1))) - -A simple change, but one that pays off, since it goes turns an O(n) amount of -coercions to an O(1) amount. --} diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs deleted file mode 100644 --- a/compiler/typecheck/TcHoleErrors.hs +++ /dev/null @@ -1,1002 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits - , tcCheckHoleFit, tcSubsumes - , withoutUnification - , fromPureHFPlugin - -- Re-exports for convenience - , hfIsLcl - , pprHoleFit, debugHoleFitDispConfig - - -- Re-exported from TcHoleFitTypes - , TypedHole (..), HoleFit (..), HoleFitCandidate (..) - , CandPlugin, FitPlugin - , HoleFitPlugin (..), HoleFitPluginR (..) - ) where - -import GhcPrelude - -import TcRnTypes -import TcRnMonad -import Constraint -import TcOrigin -import TcMType -import TcEvidence -import TcType -import GHC.Core.Type -import GHC.Core.DataCon -import GHC.Types.Name -import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts ) -import PrelNames ( gHC_ERR ) -import GHC.Types.Id -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import Bag -import GHC.Core.ConLike ( ConLike(..) ) -import Util -import TcEnv (tcLookup) -import Outputable -import GHC.Driver.Session -import Maybes -import FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV ) - -import Control.Arrow ( (&&&) ) - -import Control.Monad ( filterM, replicateM, foldM ) -import Data.List ( partition, sort, sortOn, nubBy ) -import Data.Graph ( graphFromEdges, topSort ) - - -import TcSimplify ( simpl_top, runTcSDeriveds ) -import TcUnify ( tcSubType_NC ) - -import GHC.HsToCore.Docs ( extractDocs ) -import qualified Data.Map as Map -import GHC.Hs.Doc ( unpackHDS, DeclDocMap(..) ) -import GHC.Driver.Types ( ModIface_(..) ) -import GHC.Iface.Load ( loadInterfaceForNameMaybe ) - -import PrelInfo (knownKeyNames) - -import TcHoleFitTypes - - -{- -Note [Valid hole fits include ...] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -`findValidHoleFits` returns the "Valid hole fits include ..." message. -For example, look at the following definitions in a file called test.hs: - - import Data.List (inits) - - f :: [String] - f = _ "hello, world" - -The hole in `f` would generate the message: - - • Found hole: _ :: [Char] -> [String] - • In the expression: _ - In the expression: _ "hello, world" - In an equation for ‘f’: f = _ "hello, world" - • Relevant bindings include f :: [String] (bound at test.hs:6:1) - Valid hole fits include - lines :: String -> [String] - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘base-4.11.0.0:Data.OldList’)) - words :: String -> [String] - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘base-4.11.0.0:Data.OldList’)) - inits :: forall a. [a] -> [[a]] - with inits @Char - (imported from ‘Data.List’ at mpt.hs:4:19-23 - (and originally defined in ‘base-4.11.0.0:Data.OldList’)) - repeat :: forall a. a -> [a] - with repeat @String - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.List’)) - fail :: forall (m :: * -> *). Monad m => forall a. String -> m a - with fail @[] @String - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.Base’)) - return :: forall (m :: * -> *). Monad m => forall a. a -> m a - with return @[] @String - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.Base’)) - pure :: forall (f :: * -> *). Applicative f => forall a. a -> f a - with pure @[] @String - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.Base’)) - read :: forall a. Read a => String -> a - with read @[String] - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘Text.Read’)) - mempty :: forall a. Monoid a => a - with mempty @([Char] -> [String]) - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.Base’)) - -Valid hole fits are found by checking top level identifiers and local bindings -in scope for whether their type can be instantiated to the the type of the hole. -Additionally, we also need to check whether all relevant constraints are solved -by choosing an identifier of that type as well, see Note [Relevant Constraints] - -Since checking for subsumption results in the side-effect of type variables -being unified by the simplifier, we need to take care to restore them after -to being flexible type variables after we've checked for subsumption. -This is to avoid affecting the hole and later checks by prematurely having -unified one of the free unification variables. - -When outputting, we sort the hole fits by the size of the types we'd need to -apply by type application to the type of the fit to to make it fit. This is done -in order to display "more relevant" suggestions first. Another option is to -sort by building a subsumption graph of fits, i.e. a graph of which fits subsume -what other fits, and then outputting those fits which are are subsumed by other -fits (i.e. those more specific than other fits) first. This results in the ones -"closest" to the type of the hole to be displayed first. - -To help users understand how the suggested fit works, we also display the values -that the quantified type variables would take if that fit is used, like -`mempty @([Char] -> [String])` and `pure @[] @String` in the example above. -If -XTypeApplications is enabled, this can even be copied verbatim as a -replacement for the hole. - - -Note [Nested implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -For the simplifier to be able to use any givens present in the enclosing -implications to solve relevant constraints, we nest the wanted subsumption -constraints and relevant constraints within the enclosing implications. - -As an example, let's look at the following code: - - f :: Show a => a -> String - f x = show _ - -The hole will result in the hole constraint: - - [WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_)) - -Here the nested implications are just one level deep, namely: - - [Implic { - TcLevel = 2 - Skolems = a_a1pa[sk:2] - No-eqs = True - Status = Unsolved - Given = $dShow_a1pc :: Show a_a1pa[sk:2] - Wanted = - WC {wc_simple = - [WD] __a1ph {0}:: a_a1pd[tau:2] (CHoleCan: ExprHole(_)) - [WD] $dShow_a1pe {0}:: Show a_a1pd[tau:2] (CDictCan(psc))} - Binds = EvBindsVar - Needed inner = [] - Needed outer = [] - the type signature for: - f :: forall a. Show a => a -> String }] - -As we can see, the givens say that the information about the skolem -`a_a1pa[sk:2]` fulfills the Show constraint. - -The simples are: - - [[WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_)), - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)] - -I.e. the hole `a0_a1pd[tau:2]` and the constraint that the type of the hole must -fulfill `Show a0_a1pd[tau:2])`. - -So when we run the check, we need to make sure that the - - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical) - -Constraint gets solved. When we now check for whether `x :: a0_a1pd[tau:2]` fits -the hole in `tcCheckHoleFit`, the call to `tcSubType` will end up writing the -meta type variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted -constraints needed by tcSubType_NC and the relevant constraints (see -Note [Relevant Constraints] for more details) in the nested implications, we -can pass the information in the givens along to the simplifier. For our example, -we end up needing to check whether the following constraints are soluble. - - WC {wc_impl = - Implic { - TcLevel = 2 - Skolems = a_a1pa[sk:2] - No-eqs = True - Status = Unsolved - Given = $dShow_a1pc :: Show a_a1pa[sk:2] - Wanted = - WC {wc_simple = - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)} - Binds = EvBindsVar - Needed inner = [] - Needed outer = [] - the type signature for: - f :: forall a. Show a => a -> String }} - -But since `a0_a1pd[tau:2] := a_a1pa[sk:2]` and we have from the nested -implications that Show a_a1pa[sk:2] is a given, this is trivial, and we end up -with a final WC of WC {}, confirming x :: a0_a1pd[tau:2] as a match. - -To avoid side-effects on the nested implications, we create a new EvBindsVar so -that any changes to the ev binds during a check remains localised to that check. - - -Note [Valid refinement hole fits include ...] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the `-frefinement-level-hole-fits=N` flag is given, we additionally look -for "valid refinement hole fits"", i.e. valid hole fits with up to N -additional holes in them. - -With `-frefinement-level-hole-fits=0` (the default), GHC will find all -identifiers 'f' (top-level or nested) that will fit in the hole. - -With `-frefinement-level-hole-fits=1`, GHC will additionally find all -applications 'f _' that will fit in the hole, where 'f' is an in-scope -identifier, applied to single argument. It will also report the type of the -needed argument (a new hole). - -And similarly as the number of arguments increases - -As an example, let's look at the following code: - - f :: [Integer] -> Integer - f = _ - -with `-frefinement-level-hole-fits=1`, we'd get: - - Valid refinement hole fits include - - foldl1 (_ :: Integer -> Integer -> Integer) - with foldl1 @[] @Integer - where foldl1 :: forall (t :: * -> *). - Foldable t => - forall a. (a -> a -> a) -> t a -> a - foldr1 (_ :: Integer -> Integer -> Integer) - with foldr1 @[] @Integer - where foldr1 :: forall (t :: * -> *). - Foldable t => - forall a. (a -> a -> a) -> t a -> a - const (_ :: Integer) - with const @Integer @[Integer] - where const :: forall a b. a -> b -> a - ($) (_ :: [Integer] -> Integer) - with ($) @'GHC.Types.LiftedRep @[Integer] @Integer - where ($) :: forall a b. (a -> b) -> a -> b - fail (_ :: String) - with fail @((->) [Integer]) @Integer - where fail :: forall (m :: * -> *). - Monad m => - forall a. String -> m a - return (_ :: Integer) - with return @((->) [Integer]) @Integer - where return :: forall (m :: * -> *). Monad m => forall a. a -> m a - (Some refinement hole fits suppressed; - use -fmax-refinement-hole-fits=N or -fno-max-refinement-hole-fits) - -Which are hole fits with holes in them. This allows e.g. beginners to -discover the fold functions and similar, but also allows for advanced users -to figure out the valid functions in the Free monad, e.g. - - instance Functor f => Monad (Free f) where - Pure a >>= f = f a - Free f >>= g = Free (fmap _a f) - -Will output (with -frefinment-level-hole-fits=1): - Found hole: _a :: Free f a -> Free f b - Where: ‘a’, ‘b’ are rigid type variables bound by - the type signature for: - (>>=) :: forall a b. Free f a -> (a -> Free f b) -> Free f b - at fms.hs:25:12-14 - ‘f’ is a rigid type variable bound by - ... - Relevant bindings include - g :: a -> Free f b (bound at fms.hs:27:16) - f :: f (Free f a) (bound at fms.hs:27:10) - (>>=) :: Free f a -> (a -> Free f b) -> Free f b - (bound at fms.hs:25:12) - ... - Valid refinement hole fits include - ... - (=<<) (_ :: a -> Free f b) - with (=<<) @(Free f) @a @b - where (=<<) :: forall (m :: * -> *) a b. - Monad m => - (a -> m b) -> m a -> m b - (imported from ‘Prelude’ at fms.hs:5:18-22 - (and originally defined in ‘GHC.Base’)) - ... - -Where `(=<<) _` is precisely the function we want (we ultimately want `>>= g`). - -We find these refinement suggestions by considering hole fits that don't -fit the type of the hole, but ones that would fit if given an additional -argument. We do this by creating a new type variable with `newOpenFlexiTyVar` -(e.g. `t_a1/m[tau:1]`), and then considering hole fits of the type -`t_a1/m[tau:1] -> v` where `v` is the type of the hole. - -Since the simplifier is free to unify this new type variable with any type, we -can discover any identifiers that would fit if given another identifier of a -suitable type. This is then generalized so that we can consider any number of -additional arguments by setting the `-frefinement-level-hole-fits` flag to any -number, and then considering hole fits like e.g. `foldl _ _` with two additional -arguments. - -To make sure that the refinement hole fits are useful, we check that the types -of the additional holes have a concrete value and not just an invented type -variable. This eliminates suggestions such as `head (_ :: [t0 -> a]) (_ :: t0)`, -and limits the number of less than useful refinement hole fits. - -Additionally, to further aid the user in their implementation, we show the -types of the holes the binding would have to be applied to in order to work. -In the free monad example above, this is demonstrated with -`(=<<) (_ :: a -> Free f b)`, which tells the user that the `(=<<)` needs to -be applied to an expression of type `a -> Free f b` in order to match. -If -XScopedTypeVariables is enabled, this hole fit can even be copied verbatim. - - -Note [Relevant Constraints] -~~~~~~~~~~~~~~~~~~~ - -As highlighted by #14273, we need to check any relevant constraints as well -as checking for subsumption. Relevant constraints are the simple constraints -whose free unification variables are mentioned in the type of the hole. - -In the simplest case, these are all non-hole constraints in the simples, such -as is the case in - - f :: String - f = show _ - -Where the simples will be : - - [[WD] __a1kz {0}:: a0_a1kv[tau:1] (CHoleCan: ExprHole(_)), - [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)] - -However, when there are multiple holes, we need to be more careful. As an -example, Let's take a look at the following code: - - f :: Show a => a -> String - f x = show (_b (show _a)) - -Here there are two holes, `_a` and `_b`, and the simple constraints passed to -findValidHoleFits are: - - [[WD] _a_a1pi {0}:: String - -> a0_a1pd[tau:2] (CHoleCan: ExprHole(_b)), - [WD] _b_a1ps {0}:: a1_a1po[tau:2] (CHoleCan: ExprHole(_a)), - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical), - [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)] - - -Here we have the two hole constraints for `_a` and `_b`, but also additional -constraints that these holes must fulfill. When we are looking for a match for -the hole `_a`, we filter the simple constraints to the "Relevant constraints", -by throwing out all hole constraints and any constraints which do not mention -a variable mentioned in the type of the hole. For hole `_a`, we will then -only require that the `$dShow_a1pp` constraint is solved, since that is -the only non-hole constraint that mentions any free type variables mentioned in -the hole constraint for `_a`, namely `a_a1pd[tau:2]` , and similarly for the -hole `_b` we only require that the `$dShow_a1pe` constraint is solved. - -Note [Leaking errors] -~~~~~~~~~~~~~~~~~~~ - -When considering candidates, GHC believes that we're checking for validity in -actual source. However, As evidenced by #15321, #15007 and #15202, this can -cause bewildering error messages. The solution here is simple: if a candidate -would cause the type checker to error, it is not a valid hole fit, and thus it -is discarded. - --} - - -data HoleFitDispConfig = HFDC { showWrap :: Bool - , showWrapVars :: Bool - , showType :: Bool - , showProv :: Bool - , showMatches :: Bool } - -debugHoleFitDispConfig :: HoleFitDispConfig -debugHoleFitDispConfig = HFDC True True True False False - - --- We read the various -no-show-*-of-hole-fits flags --- and set the display config accordingly. -getHoleFitDispConfig :: TcM HoleFitDispConfig -getHoleFitDispConfig - = do { sWrap <- goptM Opt_ShowTypeAppOfHoleFits - ; sWrapVars <- goptM Opt_ShowTypeAppVarsOfHoleFits - ; sType <- goptM Opt_ShowTypeOfHoleFits - ; sProv <- goptM Opt_ShowProvOfHoleFits - ; sMatc <- goptM Opt_ShowMatchesOfHoleFits - ; return HFDC{ showWrap = sWrap, showWrapVars = sWrapVars - , showProv = sProv, showType = sType - , showMatches = sMatc } } - --- Which sorting algorithm to use -data SortingAlg = NoSorting -- Do not sort the fits at all - | BySize -- Sort them by the size of the match - | BySubsumption -- Sort by full subsumption - deriving (Eq, Ord) - -getSortingAlg :: TcM SortingAlg -getSortingAlg = - do { shouldSort <- goptM Opt_SortValidHoleFits - ; subsumSort <- goptM Opt_SortBySubsumHoleFits - ; sizeSort <- goptM Opt_SortBySizeHoleFits - -- We default to sizeSort unless it has been explicitly turned off - -- or subsumption sorting has been turned on. - ; return $ if not shouldSort - then NoSorting - else if subsumSort - then BySubsumption - else if sizeSort - then BySize - else NoSorting } - --- If enabled, we go through the fits and add any associated documentation, --- by looking it up in the module or the environment (for local fits) -addDocs :: [HoleFit] -> TcM [HoleFit] -addDocs fits = - do { showDocs <- goptM Opt_ShowDocsOfHoleFits - ; if showDocs - then do { (_, DeclDocMap lclDocs, _) <- extractDocs <$> getGblEnv - ; mapM (upd lclDocs) fits } - else return fits } - where - msg = text "TcHoleErrors addDocs" - lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap }) - = Map.lookup name dmap - upd lclDocs fit@(HoleFit {hfCand = cand}) = - do { let name = getName cand - ; doc <- if hfIsLcl fit - then pure (Map.lookup name lclDocs) - else do { mbIface <- loadInterfaceForNameMaybe msg name - ; return $ mbIface >>= lookupInIface name } - ; return $ fit {hfDoc = doc} } - upd _ fit = return fit - --- For pretty printing hole fits, we display the name and type of the fit, --- with added '_' to represent any extra arguments in case of a non-zero --- refinement level. -pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc -pprHoleFit _ (RawHoleFit sd) = sd -pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = - hang display 2 provenance - where name = getName hfCand - tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap - where pprArg b arg = case binderArgFlag b of - Specified -> text "@" <> pprParendType arg - -- Do not print type application for inferred - -- variables (#16456) - Inferred -> empty - Required -> pprPanic "pprHoleFit: bad Required" - (ppr b <+> ppr arg) - tyAppVars = sep $ punctuate comma $ - zipWithEqual "pprHoleFit" (\v t -> ppr (binderVar v) <+> - text "~" <+> pprParendType t) - vars hfWrap - - vars = unwrapTypeVars hfType - where - -- Attempts to get all the quantified type variables in a type, - -- e.g. - -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a) - -- into [m, a] - unwrapTypeVars :: Type -> [TyCoVarBinder] - unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of - Just (_, unfunned) -> unwrapTypeVars unfunned - _ -> [] - where (vars, unforalled) = splitForAllVarBndrs t - holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches - holeDisp = if sMs then holeVs - else sep $ replicate (length hfMatches) $ text "_" - occDisp = pprPrefixOcc name - tyDisp = ppWhen sTy $ dcolon <+> ppr hfType - has = not . null - wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars)) - $ text "with" <+> if sWrp || not sTy - then occDisp <+> tyApp - else tyAppVars - docs = case hfDoc of - Just d -> text "{-^" <> - (vcat . map text . lines . unpackHDS) d - <> text "-}" - _ -> empty - funcInfo = ppWhen (has hfMatches && sTy) $ - text "where" <+> occDisp <+> tyDisp - subDisp = occDisp <+> if has hfMatches then holeDisp else tyDisp - display = subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp) - provenance = ppWhen sProv $ parens $ - case hfCand of - GreHFCand gre -> pprNameProvenance gre - _ -> text "bound at" <+> ppr (getSrcLoc name) - -getLocalBindings :: TidyEnv -> Ct -> TcM [Id] -getLocalBindings tidy_orig ct - = do { (env1, _) <- zonkTidyOrigin tidy_orig (ctLocOrigin loc) - ; go env1 [] (removeBindingShadowing $ tcl_bndrs lcl_env) } - where - loc = ctEvLoc (ctEvidence ct) - lcl_env = ctLocEnv loc - - go :: TidyEnv -> [Id] -> [TcBinder] -> TcM [Id] - go _ sofar [] = return (reverse sofar) - go env sofar (tc_bndr : tc_bndrs) = - case tc_bndr of - TcIdBndr id _ -> keep_it id - _ -> discard_it - where - discard_it = go env sofar tc_bndrs - keep_it id = go env (id:sofar) tc_bndrs - - - --- See Note [Valid hole fits include ...] -findValidHoleFits :: TidyEnv -- ^ The tidy_env for zonking - -> [Implication] -- ^ Enclosing implications for givens - -> [Ct] - -- ^ The unsolved simple constraints in the implication for - -- the hole. - -> Ct -- ^ The hole constraint itself - -> TcM (TidyEnv, SDoc) -findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct = - do { rdr_env <- getGlobalRdrEnv - ; lclBinds <- getLocalBindings tidy_env ct - ; maxVSubs <- maxValidHoleFits <$> getDynFlags - ; hfdc <- getHoleFitDispConfig - ; sortingAlg <- getSortingAlg - ; dflags <- getDynFlags - ; hfPlugs <- tcg_hf_plugins <$> getGblEnv - ; let findVLimit = if sortingAlg > NoSorting then Nothing else maxVSubs - refLevel = refLevelHoleFits dflags - hole = TyH (listToBag relevantCts) implics (Just ct) - (candidatePlugins, fitPlugins) = - unzip $ map (\p-> ((candPlugin p) hole, (fitPlugin p) hole)) hfPlugs - ; traceTc "findingValidHoleFitsFor { " $ ppr hole - ; traceTc "hole_lvl is:" $ ppr hole_lvl - ; traceTc "simples are: " $ ppr simples - ; traceTc "locals are: " $ ppr lclBinds - ; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env) - -- We remove binding shadowings here, but only for the local level. - -- this is so we e.g. suggest the global fmap from the Functor class - -- even though there is a local definition as well, such as in the - -- Free monad example. - locals = removeBindingShadowing $ - map IdHFCand lclBinds ++ map GreHFCand lcl - globals = map GreHFCand gbl - syntax = map NameHFCand builtIns - to_check = locals ++ syntax ++ globals - ; cands <- foldM (flip ($)) to_check candidatePlugins - ; traceTc "numPlugins are:" $ ppr (length candidatePlugins) - ; (searchDiscards, subs) <- - tcFilterHoleFits findVLimit hole (hole_ty, []) cands - ; (tidy_env, tidy_subs) <- 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 - vDiscards = pVDisc || searchDiscards - ; subs_with_docs <- addDocs limited_subs - ; let vMsg = ppUnless (null subs_with_docs) $ - hang (text "Valid hole fits include") 2 $ - vcat (map (pprHoleFit hfdc) subs_with_docs) - $$ ppWhen vDiscards subsDiscardMsg - -- Refinement hole fits. See Note [Valid refinement hole fits include ...] - ; (tidy_env, refMsg) <- if refLevel >= Just 0 then - do { maxRSubs <- maxRefHoleFits <$> getDynFlags - -- We can use from just, since we know that Nothing >= _ is False. - ; let refLvls = [1..(fromJust refLevel)] - -- We make a new refinement type for each level of refinement, where - -- the level of refinement indicates number of additional arguments - -- to allow. - ; ref_tys <- mapM mkRefTy refLvls - ; traceTc "ref_tys are" $ ppr ref_tys - ; let findRLimit = if sortingAlg > NoSorting then Nothing - else maxRSubs - ; refDs <- mapM (flip (tcFilterHoleFits findRLimit hole) - cands) ref_tys - ; (tidy_env, tidy_rsubs) <- 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 - ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap - (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs - ; plugin_handled_rsubs <- foldM (flip ($)) - (not_exact ++ exact) fitPlugins - ; let (pRDisc, exact_last_rfits) = - possiblyDiscard maxRSubs $ plugin_handled_rsubs - rDiscards = pRDisc || any fst refDs - ; rsubs_with_docs <- addDocs exact_last_rfits - ; return (tidy_env, - ppUnless (null rsubs_with_docs) $ - hang (text "Valid refinement hole fits include") 2 $ - vcat (map (pprHoleFit hfdc) rsubs_with_docs) - $$ ppWhen rDiscards refSubsDiscardMsg) } - else return (tidy_env, empty) - ; traceTc "findingValidHoleFitsFor }" empty - ; return (tidy_env, vMsg $$ refMsg) } - where - -- We extract the type, the tcLevel and the types free variables - -- from from the constraint. - hole_ty :: TcPredType - hole_ty = ctPred ct - hole_fvs :: FV - hole_fvs = tyCoFVsOfType hole_ty - hole_lvl = ctLocLevel $ ctEvLoc $ ctEvidence ct - - -- BuiltInSyntax names like (:) and [] - builtIns :: [Name] - builtIns = filter isBuiltInSyntax knownKeyNames - - -- We make a refinement type by adding a new type variable in front - -- of the type of t h hole, going from e.g. [Integer] -> Integer - -- to t_a1/m[tau:1] -> [Integer] -> Integer. This allows the simplifier - -- to unify the new type variable with any type, allowing us - -- to suggest a "refinement hole fit", like `(foldl1 _)` instead - -- of only concrete hole fits like `sum`. - mkRefTy :: Int -> TcM (TcType, [TcTyVar]) - mkRefTy refLvl = (wrapWithVars &&& id) <$> newTyVars - where newTyVars = replicateM refLvl $ setLvl <$> - (newOpenTypeKind >>= newFlexiTyVar) - setLvl = flip setMetaTyVarTcLevel hole_lvl - wrapWithVars vars = mkVisFunTys (map mkTyVarTy vars) hole_ty - - sortFits :: SortingAlg -- How we should sort the hole fits - -> [HoleFit] -- The subs to sort - -> TcM [HoleFit] - sortFits NoSorting subs = return subs - sortFits BySize subs - = (++) <$> sortBySize (sort lclFits) - <*> sortBySize (sort gblFits) - where (lclFits, gblFits) = span hfIsLcl subs - - -- To sort by subsumption, we invoke the sortByGraph function, which - -- builds the subsumption graph for the fits and then sorts them using a - -- graph sort. Since we want locals to come first anyway, we can sort - -- them separately. The substitutions are already checked in local then - -- global order, so we can get away with using span here. - -- We use (<*>) to expose the parallelism, in case it becomes useful later. - sortFits BySubsumption subs - = (++) <$> sortByGraph (sort lclFits) - <*> sortByGraph (sort gblFits) - where (lclFits, gblFits) = span hfIsLcl subs - - -- See Note [Relevant Constraints] - relevantCts :: [Ct] - relevantCts = if isEmptyVarSet (fvVarSet hole_fvs) then [] - else filter isRelevant simples - where ctFreeVarSet :: Ct -> VarSet - ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred - hole_fv_set = fvVarSet hole_fvs - anyFVMentioned :: Ct -> Bool - anyFVMentioned ct = not $ isEmptyVarSet $ - ctFreeVarSet ct `intersectVarSet` hole_fv_set - -- We filter out those constraints that have no variables (since - -- they won't be solved by finding a type for the type variable - -- representing the hole) and also other holes, since we're not - -- trying to find hole fits for many holes at once. - isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct)) - && anyFVMentioned ct - && not (isHoleCt ct) - - -- We zonk the hole fits so that the output aligns with the rest - -- of the typed hole error message output. - zonkSubs :: TidyEnv -> [HoleFit] -> TcM (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 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, wrp') <- zonkTidyTcTypes env wrp - ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'} - ; return (env, zFit ) } - - -- Based on the flags, we might possibly discard some or all the - -- fits we've found. - possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit]) - possiblyDiscard (Just max) fits = (fits `lengthExceeds` max, take max fits) - possiblyDiscard Nothing fits = (False, fits) - - -- Sort by size uses as a measure for relevance the sizes of the - -- different types needed to instantiate the fit to the type of the hole. - -- This is much quicker than sorting by subsumption, and gives reasonable - -- results in most cases. - sortBySize :: [HoleFit] -> TcM [HoleFit] - sortBySize = return . sortOn sizeOfFit - where sizeOfFit :: HoleFit -> TypeSize - sizeOfFit = sizeTypes . nubBy tcEqType . hfWrap - - -- Based on a suggestion by phadej on #ghc, we can sort the found fits - -- by constructing a subsumption graph, and then do a topological sort of - -- the graph. This makes the most specific types appear first, which are - -- probably those most relevant. This takes a lot of work (but results in - -- much more useful output), and can be disabled by - -- '-fno-sort-valid-hole-fits'. - sortByGraph :: [HoleFit] -> TcM [HoleFit] - sortByGraph fits = go [] fits - where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool - tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty) - where fvs = tyCoFVsOfTypes [ht,ty] - go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit] - go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar - ; return $ uncurry (++) - $ partition hfIsLcl topSorted } - where toV (hf, adjs) = (hf, hfId hf, map hfId adjs) - (graph, fromV, _) = graphFromEdges $ map toV sofar - topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph - go sofar (hf:hfs) = - do { adjs <- - filterM (tcSubsumesWCloning (hfType hf) . hfType) fits - ; go ((hf, adjs):sofar) hfs } - --- We don't (as of yet) handle holes in types, only in expressions. -findValidHoleFits env _ _ _ = return (env, empty) - - --- | tcFilterHoleFits filters the candidates by whether, given the implications --- and the relevant constraints, they can be made to match the type by --- running the type checker. Stops after finding limit matches. -tcFilterHoleFits :: Maybe Int - -- ^ How many we should output, if limited - -> TypedHole -- ^ The hole to filter against - -> (TcType, [TcTyVar]) - -- ^ The type to check for fits and a list of refinement - -- variables (free type variables in the type) for emulating - -- additional holes. - -> [HoleFitCandidate] - -- ^ The candidates to check whether fit. - -> TcM (Bool, [HoleFit]) - -- ^ We return whether or not we stopped due to hitting the limit - -- and the fits we found. -tcFilterHoleFits (Just 0) _ _ _ = return (False, []) -- Stop right away on 0 -tcFilterHoleFits limit (TyH {..}) ht@(hole_ty, _) candidates = - do { traceTc "checkingFitsFor {" $ ppr hole_ty - ; (discards, subs) <- go [] emptyVarSet limit ht candidates - ; traceTc "checkingFitsFor }" empty - ; return (discards, subs) } - where - hole_fvs :: FV - hole_fvs = tyCoFVsOfType hole_ty - -- Kickoff the checking of the elements. - -- We iterate over the elements, checking each one in turn for whether - -- it fits, and adding it to the results if it does. - go :: [HoleFit] -- What we've found so far. - -> VarSet -- Ids we've already checked - -> Maybe Int -- How many we're allowed to find, if limited - -> (TcType, [TcTyVar]) -- The type, and its refinement variables. - -> [HoleFitCandidate] -- The elements we've yet to check. - -> TcM (Bool, [HoleFit]) - go subs _ _ _ [] = return (False, reverse subs) - go subs _ (Just 0) _ _ = return (True, reverse subs) - go subs seen maxleft ty (el:elts) = - -- See Note [Leaking errors] - tryTcDiscardingErrs discard_it $ - do { traceTc "lookingUp" $ ppr el - ; maybeThing <- lookup el - ; case maybeThing of - Just id | not_trivial id -> - do { fits <- fitsHole ty (idType id) - ; case fits of - Just (wrp, matches) -> keep_it id wrp matches - _ -> 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 - - lookup :: HoleFitCandidate -> TcM (Maybe Id) - lookup (IdHFCand id) = return (Just id) - lookup hfc = do { thing <- tcLookup name - ; return $ case thing of - ATcId {tct_id = id} -> Just id - AGlobal (AnId id) -> Just id - AGlobal (AConLike (RealDataCon con)) -> - Just (dataConWrapId con) - _ -> Nothing } - where name = case hfc of - IdHFCand id -> idName id - GreHFCand gre -> gre_name gre - NameHFCand name -> name - discard_it = go subs seen maxleft ty elts - keep_it eid wrp ms = go (fit:subs) (extendVarSet seen eid) - ((\n -> n - 1) <$> maxleft) ty elts - where - fit = HoleFit { hfId = eid, hfCand = el, hfType = (idType eid) - , hfRefLvl = length (snd ty) - , hfWrap = wrp, hfMatches = ms - , hfDoc = Nothing } - - - - - unfoldWrapper :: HsWrapper -> [Type] - unfoldWrapper = reverse . unfWrp' - where unfWrp' (WpTyApp ty) = [ty] - unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2 - unfWrp' _ = [] - - - -- The real work happens here, where we invoke the type checker using - -- tcCheckHoleFit to see whether the given type fits the hole. - fitsHole :: (TcType, [TcTyVar]) -- The type of the hole wrapped with the - -- refinement variables created to simulate - -- additional holes (if any), and the list - -- of those variables (possibly empty). - -- As an example: If the actual type of the - -- hole (as specified by the hole - -- constraint CHoleExpr passed to - -- findValidHoleFits) is t and we want to - -- simulate N additional holes, h_ty will - -- be r_1 -> ... -> r_N -> t, and - -- ref_vars will be [r_1, ... , r_N]. - -- In the base case with no additional - -- holes, h_ty will just be t and ref_vars - -- will be []. - -> TcType -- The type we're checking to whether it can be - -- instantiated to the type h_ty. - -> TcM (Maybe ([TcType], [TcType])) -- If it is not a match, we - -- return Nothing. Otherwise, - -- we Just return the list of - -- types that quantified type - -- variables in ty would take - -- if used in place of h_ty, - -- and the list types of any - -- additional holes simulated - -- with the refinement - -- variables in ref_vars. - fitsHole (h_ty, ref_vars) ty = - -- We wrap this with the withoutUnification to avoid having side-effects - -- beyond the check, but we rely on the side-effects when looking for - -- refinement hole fits, so we can't wrap the side-effects deeper than this. - withoutUnification fvs $ - do { traceTc "checkingFitOf {" $ ppr ty - ; (fits, wrp) <- tcCheckHoleFit hole h_ty ty - ; traceTc "Did it fit?" $ ppr fits - ; traceTc "wrap is: " $ ppr wrp - ; traceTc "checkingFitOf }" empty - ; z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp) - -- We'd like to avoid refinement suggestions like `id _ _` or - -- `head _ _`, and only suggest refinements where our all phantom - -- variables got unified during the checking. This can be disabled - -- with the `-fabstract-refinement-hole-fits` flag. - -- Here we do the additional handling when there are refinement - -- variables, i.e. zonk them to read their final value to check for - -- abstract refinements, and to report what the type of the simulated - -- holes must be for this to be a match. - ; if fits - then if null ref_vars - then return (Just (z_wrp_tys, [])) - else do { let -- To be concrete matches, matches have to - -- be more than just an invented type variable. - fvSet = fvVarSet fvs - notAbstract :: TcType -> Bool - notAbstract t = case getTyVar_maybe t of - Just tv -> tv `elemVarSet` fvSet - _ -> True - allConcrete = all notAbstract z_wrp_tys - ; z_vars <- zonkTcTyVars ref_vars - ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars - ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs - ; allowAbstract <- goptM Opt_AbstractRefHoleFits - ; if allowAbstract || (allFilled && allConcrete ) - then return $ Just (z_wrp_tys, z_vars) - else return Nothing } - else return Nothing } - where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty - hole = TyH tyHRelevantCts tyHImplics Nothing - - -subsDiscardMsg :: SDoc -subsDiscardMsg = - text "(Some hole fits suppressed;" <+> - text "use -fmax-valid-hole-fits=N" <+> - text "or -fno-max-valid-hole-fits)" - -refSubsDiscardMsg :: SDoc -refSubsDiscardMsg = - text "(Some refinement hole fits suppressed;" <+> - text "use -fmax-refinement-hole-fits=N" <+> - text "or -fno-max-refinement-hole-fits)" - - --- | Checks whether a MetaTyVar is flexible or not. -isFlexiTyVar :: TcTyVar -> TcM Bool -isFlexiTyVar tv | isMetaTyVar tv = isFlexi <$> readMetaTyVar tv -isFlexiTyVar _ = return False - --- | Takes a list of free variables and restores any Flexi type variables in --- free_vars after the action is run. -withoutUnification :: FV -> TcM a -> TcM a -withoutUnification free_vars action = - do { flexis <- filterM isFlexiTyVar fuvs - ; result <- action - -- Reset any mutated free variables - ; mapM_ restore flexis - ; return result } - where restore = flip writeTcRef Flexi . metaTyVarRef - fuvs = fvVarList free_vars - --- | Reports whether first type (ty_a) subsumes the second type (ty_b), --- discarding any errors. Subsumption here means that the ty_b can fit into the --- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a. -tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool -tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit dummyHole ty_a ty_b - where dummyHole = TyH emptyBag [] Nothing - --- | A tcSubsumes which takes into account relevant constraints, to fix trac --- #14273. This makes sure that when checking whether a type fits the hole, --- the type has to be subsumed by type of the hole as well as fulfill all --- constraints on the type of the hole. --- Note: The simplifier may perform unification, so make sure to restore any --- free type variables to avoid side-effects. -tcCheckHoleFit :: TypedHole -- ^ The hole to check against - -> TcSigmaType - -- ^ The type to check against (possibly modified, e.g. refined) - -> TcSigmaType -- ^ The type to check whether fits. - -> TcM (Bool, HsWrapper) - -- ^ Whether it was a match, and the wrapper from hole_ty to ty. -tcCheckHoleFit _ hole_ty ty | hole_ty `eqType` ty - = return (True, idHsWrapper) -tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $ - do { -- We wrap the subtype constraint in the implications to pass along the - -- givens, and so we must ensure that any nested implications and skolems - -- end up with the correct level. The implications are ordered so that - -- the innermost (the one with the highest level) is first, so it - -- suffices to get the level of the first one (or the current level, if - -- there are no implications involved). - innermost_lvl <- case tyHImplics of - [] -> getTcLevel - -- imp is the innermost implication - (imp:_) -> return (ic_tclvl imp) - ; (wrp, wanted) <- setTcLevel innermost_lvl $ captureConstraints $ - tcSubType_NC ExprSigCtxt ty hole_ty - ; traceTc "Checking hole fit {" empty - ; traceTc "wanteds are: " $ ppr wanted - ; if isEmptyWC wanted && isEmptyBag tyHRelevantCts - then traceTc "}" empty >> return (True, wrp) - else do { fresh_binds <- newTcEvBinds - -- The relevant constraints may contain HoleDests, so we must - -- take care to clone them as well (to avoid #15370). - ; cloned_relevants <- mapBagM cloneWanted tyHRelevantCts - -- We wrap the WC in the nested implications, see - -- Note [Nested Implications] - ; let outermost_first = reverse tyHImplics - setWC = setWCAndBinds fresh_binds - -- We add the cloned relevants to the wanteds generated by - -- the call to tcSubType_NC, see Note [Relevant Constraints] - -- There's no need to clone the wanteds, because they are - -- freshly generated by `tcSubtype_NC`. - w_rel_cts = addSimples wanted cloned_relevants - w_givens = foldr setWC w_rel_cts outermost_first - ; traceTc "w_givens are: " $ ppr w_givens - ; rem <- runTcSDeriveds $ simpl_top w_givens - -- We don't want any insoluble or simple constraints left, but - -- solved implications are ok (and necessary for e.g. undefined) - ; traceTc "rems was:" $ ppr rem - ; traceTc "}" empty - ; return (isSolvedWC rem, wrp) } } - where - setWCAndBinds :: EvBindsVar -- Fresh ev binds var. - -> Implication -- The implication to put WC in. - -> WantedConstraints -- The WC constraints to put implic. - -> WantedConstraints -- The new constraints. - setWCAndBinds binds imp wc - = WC { wc_simple = emptyBag - , wc_impl = unitBag $ imp { ic_wanted = wc , ic_binds = binds } } - --- | Maps a plugin that needs no state to one with an empty one. -fromPureHFPlugin :: HoleFitPlugin -> HoleFitPluginR -fromPureHFPlugin plug = - HoleFitPluginR { hfPluginInit = newTcRef () - , hfPluginRun = const plug - , hfPluginStop = const $ return () } diff --git a/compiler/typecheck/TcHoleErrors.hs-boot b/compiler/typecheck/TcHoleErrors.hs-boot deleted file mode 100644 --- a/compiler/typecheck/TcHoleErrors.hs-boot +++ /dev/null @@ -1,13 +0,0 @@ --- This boot file is in place to break the loop where: --- + TcSimplify calls 'TcErrors.reportUnsolved', --- + which calls 'TcHoleErrors.findValidHoleFits` --- + which calls 'TcSimplify.simpl_top' -module TcHoleErrors where - -import TcRnTypes ( TcM ) -import Constraint ( Ct, Implication ) -import Outputable ( SDoc ) -import GHC.Types.Var.Env ( TidyEnv ) - -findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct - -> TcM (TidyEnv, SDoc) diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs deleted file mode 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ /dev/null @@ -1,1921 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1996-1998 - - -TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker - -This module is an extension of @HsSyn@ syntax, for use in the type -checker. --} - -{-# LANGUAGE CPP, TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcHsSyn ( - -- * Extracting types from HsSyn - hsLitType, hsPatType, hsLPatType, - - -- * Other HsSyn functions - mkHsDictLet, mkHsApp, - mkHsAppTy, mkHsCaseAlt, - shortCutLit, hsOverLitName, - conLikeResTy, - - -- * re-exported from TcMonad - TcId, TcIdSet, - - -- * Zonking - -- | For a description of "zonking", see Note [What is zonking?] - -- in TcMType - zonkTopDecls, zonkTopExpr, zonkTopLExpr, - zonkTopBndrs, - ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv, - zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX, - zonkTyBndrs, zonkTyBndrsX, - zonkTcTypeToType, zonkTcTypeToTypeX, - zonkTcTypesToTypes, zonkTcTypesToTypesX, - zonkTyVarOcc, - zonkCoToCo, - zonkEvBinds, zonkTcEvBinds, - zonkTcMethInfoToMethInfoX, - lookupTyVarOcc - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Core.Predicate -import TcRnMonad -import PrelNames -import BuildTyCl ( TcMethInfo, MethInfo ) -import TcType -import TcMType -import TcEnv ( tcLookupGlobalOnly ) -import TcEvidence -import GHC.Core.TyCo.Ppr ( pprTyVar ) -import TysPrim -import GHC.Core.TyCon -import TysWiredIn -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Driver.Types -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Platform -import GHC.Types.Basic -import Maybes -import GHC.Types.SrcLoc -import Bag -import Outputable -import Util -import GHC.Types.Unique.FM -import GHC.Core - -import {-# SOURCE #-} TcSplice (runTopSplice) - -import Control.Monad -import Data.List ( partition ) -import Control.Arrow ( second ) - -{- -************************************************************************ -* * - Extracting the type from HsSyn -* * -************************************************************************ - --} - -hsLPatType :: LPat GhcTc -> Type -hsLPatType (L _ p) = hsPatType p - -hsPatType :: Pat GhcTc -> Type -hsPatType (ParPat _ pat) = hsLPatType pat -hsPatType (WildPat ty) = ty -hsPatType (VarPat _ lvar) = idType (unLoc lvar) -hsPatType (BangPat _ pat) = hsLPatType pat -hsPatType (LazyPat _ pat) = hsLPatType pat -hsPatType (LitPat _ lit) = hsLitType lit -hsPatType (AsPat _ var _) = idType (unLoc var) -hsPatType (ViewPat ty _ _) = ty -hsPatType (ListPat (ListPatTc ty Nothing) _) = mkListTy ty -hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty -hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys - -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make -hsPatType (SumPat tys _ _ _ ) = mkSumTy tys -hsPatType (ConPatOut { pat_con = lcon - , pat_arg_tys = tys }) - = conLikeResTy (unLoc lcon) tys -hsPatType (SigPat ty _ _) = ty -hsPatType (NPat ty _ _ _) = ty -hsPatType (NPlusKPat ty _ _ _ _ _) = ty -hsPatType (CoPat _ _ _ ty) = ty -hsPatType (XPat n) = noExtCon n -hsPatType ConPatIn{} = panic "hsPatType: ConPatIn" -hsPatType SplicePat{} = panic "hsPatType: SplicePat" - -hsLitType :: HsLit (GhcPass p) -> TcType -hsLitType (HsChar _ _) = charTy -hsLitType (HsCharPrim _ _) = charPrimTy -hsLitType (HsString _ _) = stringTy -hsLitType (HsStringPrim _ _) = addrPrimTy -hsLitType (HsInt _ _) = intTy -hsLitType (HsIntPrim _ _) = intPrimTy -hsLitType (HsWordPrim _ _) = wordPrimTy -hsLitType (HsInt64Prim _ _) = int64PrimTy -hsLitType (HsWord64Prim _ _) = word64PrimTy -hsLitType (HsInteger _ _ ty) = ty -hsLitType (HsRat _ _ ty) = ty -hsLitType (HsFloatPrim _ _) = floatPrimTy -hsLitType (HsDoublePrim _ _) = doublePrimTy -hsLitType (XLit nec) = noExtCon nec - --- Overloaded literals. Here mainly because it uses isIntTy etc - -shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId) -shortCutLit platform (HsIntegral int@(IL src neg i)) ty - | isIntTy ty && platformInIntRange platform i = Just (HsLit noExtField (HsInt noExtField int)) - | isWordTy ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i)) - | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty)) - | otherwise = shortCutLit platform (HsFractional (integralFractionalLit neg i)) ty - -- 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 - -shortCutLit _ (HsFractional f) ty - | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) - | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) - | otherwise = Nothing - -shortCutLit _ (HsIsString src s) ty - | isStringTy ty = Just (HsLit noExtField (HsString src s)) - | otherwise = Nothing - -mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc -mkLit con lit = HsApp noExtField (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 TcMType. - --- | See Note [The ZonkEnv] --- Confused by zonking? See Note [What is zonking?] in 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. --} - -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 - -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 -> Located TcId -> Located Id -zonkLIdOcc env = mapLoc (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 ty' <- zonkTcTypeToTypeX env (idType v) - ensureNotLevPoly ty' - (text "In the type of binder" <+> quotes (ppr v)) - - return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty')) - -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 GhcTcId -> TcM (FieldOcc GhcTc) -zonkFieldOcc env (FieldOcc sel lbl) - = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel -zonkFieldOcc _ (XFieldOcc nec) = noExtCon nec - -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 - = do { let var_ty = varType var - ; ty <- - {-# SCC "zonkEvBndr_zonkTcTypeToType" #-} - zonkTcTypeToTypeX env var_ty - ; return (setVarType var ty) } - -{- -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 - = ASSERT2( 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') } - -zonkTyVarBinders :: [VarBndr TcTyVar vis] - -> TcM (ZonkEnv, [VarBndr TyVar vis]) -zonkTyVarBinders tvbs = initZonkEnv $ \ ze -> zonkTyVarBindersX ze tvbs - -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 GhcTcId -> TcM (HsExpr GhcTc) -zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e - -zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc) -zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e - -zonkTopDecls :: Bag EvBind - -> LHsBinds GhcTcId - -> [LRuleDecl GhcTcId] -> [LTcSpecPrag] - -> [LForeignDecl GhcTcId] - -> 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 GhcTcId - -> 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 (wrapLocM zonk_ip_bind) binds - let - env1 = extendIdZonkEnvRec env - [ n | (L _ (IPBind _ (Right 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 x n e) - = do n' <- mapIPNameTc (zonkIdBndr env) n - e' <- zonkLExpr env e - return (IPBind x n' e') - zonk_ip_bind (XIPBind nec) = noExtCon nec - -zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds nec)) - = noExtCon nec -zonkLocalBinds _ (XHsLocalBindsLR nec) - = noExtCon nec - ---------------------------------------------- -zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc) -zonkRecMonoBinds env binds - = fixM (\ ~(_, new_binds) -> do - { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds) - ; binds' <- zonkMonoBinds env1 binds - ; return (env1, binds') }) - ---------------------------------------------- -zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc) -zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds - -zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc) -zonk_lbind env = wrapLocM (zonk_bind env) - -zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc) -zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss - , pat_ext = NPatBindTc fvs ty}) - = 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 = NPatBindTc fvs new_ty }) } - -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 }) - = 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 }) } - -zonk_bind env (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 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 (AbsBinds { abs_ext = noExtField - , 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 })) <- lbind - = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id - -- Specifically /not/ zonkIdBndr; we do not - -- want to complain about a levity-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 } } - | otherwise - = zonk_lbind env lbind -- The normal case - - zonk_export env (ABE{ abe_ext = x - , 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_ext = x - , abe_wrap = new_wrap - , abe_poly = new_poly_id - , abe_mono = zonkIdOcc env mono_id - , abe_prags = new_prags }) - zonk_export _ (XABExport nec) = noExtCon nec - -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 - ; let 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' } } - -zonk_bind _ (PatSynBind _ (XPatSynBind nec)) = noExtCon nec -zonk_bind _ (XHsBindsLR nec) = noExtCon nec - -zonkPatSynDetails :: ZonkEnv - -> HsPatSynDetails (Located TcId) - -> HsPatSynDetails (Located Id) -zonkPatSynDetails env (PrefixCon as) - = PrefixCon (map (zonkLIdOcc env) as) -zonkPatSynDetails env (InfixCon a1 a2) - = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2) -zonkPatSynDetails env (RecCon flds) - = RecCon (map (fmap (zonkLIdOcc env)) flds) - -zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId - -> 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 :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> MatchGroup GhcTcId (Located (body GhcTcId)) - -> TcM (MatchGroup GhcTc (Located (body GhcTc))) -zonkMatchGroup env zBody (MG { mg_alts = L l ms - , mg_ext = MatchGroupTc arg_tys res_ty - , mg_origin = origin }) - = do { ms' <- mapM (zonkMatch env zBody) ms - ; arg_tys' <- zonkTcTypesToTypesX env arg_tys - ; res_ty' <- zonkTcTypeToTypeX env res_ty - ; return (MG { mg_alts = L l ms' - , mg_ext = MatchGroupTc arg_tys' res_ty' - , mg_origin = origin }) } -zonkMatchGroup _ _ (XMatchGroup nec) = noExtCon nec - -zonkMatch :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> LMatch GhcTcId (Located (body GhcTcId)) - -> TcM (LMatch GhcTc (Located (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 })) } -zonkMatch _ _ (L _ (XMatch nec)) = noExtCon nec - -------------------------------------------------------------------------- -zonkGRHSs :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> GRHSs GhcTcId (Located (body GhcTcId)) - -> TcM (GRHSs GhcTc (Located (body GhcTc))) - -zonkGRHSs env zBody (GRHSs x grhss (L l 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) - zonk_grhs (XGRHS nec) = noExtCon nec - new_grhss <- mapM (wrapLocM zonk_grhs) grhss - return (GRHSs x new_grhss (L l new_binds)) -zonkGRHSs _ _ (XGRHSs nec) = noExtCon nec - -{- -************************************************************************ -* * -\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} -* * -************************************************************************ --} - -zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc] -zonkLExpr :: ZonkEnv -> LHsExpr GhcTcId -> TcM (LHsExpr GhcTc) -zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc) - -zonkLExprs env exprs = mapM (zonkLExpr env) exprs -zonkLExpr env expr = wrapLocM (zonkExpr env) expr - -zonkExpr env (HsVar x (L l id)) - = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) - return (HsVar x (L l (zonkIdOcc env id))) - -zonkExpr _ e@(HsConLikeOut {}) = return e - -zonkExpr _ (HsIPVar x id) - = return (HsIPVar x id) - -zonkExpr _ e@HsOverLabel{} = return e - -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 matches) - = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLamCase x 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 x e t) - = do new_e <- zonkLExpr env e - return (HsAppType x new_e t) - -- NB: the type is an HsType; can't zonk that! - -zonkExpr _ e@(HsRnBracketOut _ _ _) - = pprPanic "zonkExpr: HsRnBracketOut" (ppr e) - -zonkExpr env (HsTcBracketOut x wrap body bs) - = do wrap' <- traverse zonkQuoteWrap wrap - bs' <- mapM (zonk_b env) bs - return (HsTcBracketOut x wrap' body 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') - -zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) = - runTopSplice s >>= zonkExpr env - -zonkExpr _ e@(HsSpliceE _ _) = pprPanic "zonkExpr: HsSpliceE" (ppr e) - -zonkExpr env (OpApp fixity e1 op e2) - = do new_e1 <- zonkLExpr env e1 - new_op <- zonkLExpr env op - new_e2 <- zonkLExpr env e2 - return (OpApp fixity new_e1 new_op new_e2) - -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 e) - = do new_e <- zonkLExpr env e - return (HsPar x new_e) - -zonkExpr env (SectionL x expr op) - = do new_expr <- zonkLExpr env expr - new_op <- zonkLExpr env op - return (SectionL x new_expr new_op) - -zonkExpr env (SectionR x op expr) - = do new_op <- zonkLExpr env op - new_expr <- zonkLExpr env expr - return (SectionR x new_op new_expr) - -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 (L l (Present x e)) = do { e' <- zonkLExpr env e - ; return (L l (Present x e')) } - zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t - ; return (L l (Missing t')) } - zonk_tup_arg (L _ (XTupArg nec)) = noExtCon nec - - -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 fun e1 e2 e3) - = do (env1, new_fun) <- zonkSyntaxExpr env fun - new_e1 <- zonkLExpr env1 e1 - new_e2 <- zonkLExpr env1 e2 - new_e3 <- zonkLExpr env1 e3 - return (HsIf x new_fun new_e1 new_e2 new_e3) - -zonkExpr env (HsMultiIf ty alts) - = do { alts' <- mapM (wrapLocM 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' } - zonk_alt (XGRHS nec) = noExtCon nec - -zonkExpr env (HsLet x (L l binds) expr) - = do (new_env, new_binds) <- zonkLocalBinds env binds - new_expr <- zonkLExpr new_env expr - return (HsLet x (L l new_binds) 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 wit exprs) - = do (env1, new_wit) <- zonkWit env wit - new_ty <- zonkTcTypeToTypeX env1 ty - new_exprs <- zonkLExprs env1 exprs - return (ExplicitList new_ty new_wit new_exprs) - where zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln - -zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds }) - = do { new_con_expr <- zonkExpr env (rcon_con_expr ext) - ; new_rbinds <- zonkRecFields env rbinds - ; return (expr { rcon_ext = ext { rcon_con_expr = new_con_expr } - , rcon_flds = new_rbinds }) } - -zonkExpr env (RecordUpd { rupd_flds = rbinds - , rupd_expr = expr - , rupd_ext = RecordUpdTc - { rupd_cons = cons, rupd_in_tys = in_tys - , rupd_out_tys = out_tys, rupd_wrap = req_wrap }}) - = do { new_expr <- zonkLExpr env expr - ; new_in_tys <- mapM (zonkTcTypeToTypeX env) in_tys - ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys - ; new_rbinds <- zonkRecUpdFields env rbinds - ; (_, new_recwrap) <- zonkCoFn env req_wrap - ; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds - , rupd_ext = RecordUpdTc - { rupd_cons = cons, rupd_in_tys = new_in_tys - , rupd_out_tys = new_out_tys - , rupd_wrap = new_recwrap }}) } - -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 expr) - = HsStatic fvs <$> zonkLExpr env expr - -zonkExpr env (XExpr (HsWrap co_fn expr)) - = do (env1, new_co_fn) <- zonkCoFn env co_fn - new_expr <- zonkExpr env1 expr - return (XExpr (HsWrap new_co_fn new_expr)) - -zonkExpr _ e@(HsUnboundVar {}) - = return e - -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 TcMType.instSkolTyCoVarX.) -Now, we can safely just extend one environment. --} - --- See Note [Skolems in zonkSyntaxExpr] -zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId - -> 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 GhcTcId -> TcM (LHsCmd GhcTc) -zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc) - -zonkLCmd env cmd = wrapLocM (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 c) - = do new_c <- zonkLCmd env c - return (HsCmdPar x new_c) - -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 (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 (L l binds) cmd) - = do (new_env, new_binds) <- zonkLocalBinds env binds - new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet x (L l new_binds) 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 GhcTcId -> TcM (LHsCmdTop GhcTc) -zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd - -zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> 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 (tcTypeKind new_stack_tys) ) - -- desugarer assumes that this is not levity 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) -zonk_cmd_top _ (XCmdTop nec) = noExtCon nec - -------------------------------------------------------------------------- -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 d) = do { (env1, c1') <- zonkCoFn env c1 - ; (env2, c2') <- zonkCoFn env1 c2 - ; t1' <- zonkTcTypeToTypeX env2 t1 - ; return (env2, WpFun c1' c2' t1' d) } -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') } - -------------------------------------------------------------------------- -zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc) -zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e }) - = do { ty' <- zonkTcTypeToTypeX env ty - ; e' <- zonkExpr env e - ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) } - -zonkOverLit _ (XOverLit nec) = noExtCon nec - -------------------------------------------------------------------------- -zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> 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 :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> [LStmt GhcTcId (Located (body GhcTcId))] - -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))]) -zonkStmts env _ [] = return (env, []) -zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s - ; (env2, ss') <- zonkStmts env1 zBody ss - ; return (env2, s' : ss') } - -zonkStmt :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> Stmt GhcTcId (Located (body GhcTcId)) - -> TcM (ZonkEnv, Stmt GhcTc (Located (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 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) } - zonk_branch _ (XParStmtBlock nec) = noExtCon nec - -zonkStmt env zBody (RecStmt { recS_stmts = 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 = 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' <- fmapMaybeM (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 (L l binds)) - = do (env1, new_binds) <- zonkLocalBinds env binds - return (env1, LetStmt x (L l new_binds)) - -zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op) - = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op - ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty - ; new_body <- zBody env1 body - ; (env2, new_pat) <- zonkPat env1 pat - ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op - ; return ( env2 - , BindStmt new_bind_ty new_pat new_body new_bind new_fail) } - --- 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 (_, ApplicativeArgOne _ pat _ _ _) = pat - get_pat (_, ApplicativeArgMany _ _ _ pat) = pat - get_pat (_, XApplicativeArg nec) = noExtCon nec - - replace_pat pat (op, ApplicativeArgOne x _ a isBody fail_op) - = (op, ApplicativeArgOne x pat a isBody fail_op) - replace_pat pat (op, ApplicativeArgMany x a b _) - = (op, ApplicativeArgMany x a b pat) - replace_pat _ (_, XApplicativeArg nec) = noExtCon nec - - 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, zipWith 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 x pat expr isBody fail_op) - = do { new_expr <- zonkLExpr env expr - ; (_, new_fail) <- zonkSyntaxExpr env fail_op - ; return (ApplicativeArgOne x pat new_expr isBody new_fail) } - zonk_arg env (ApplicativeArgMany x stmts ret pat) - = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts - ; new_ret <- zonkExpr env1 ret - ; return (ApplicativeArgMany x new_stmts new_ret pat) } - zonk_arg _ (XApplicativeArg nec) = noExtCon nec - -zonkStmt _ _ (XStmtLR nec) = noExtCon nec - -------------------------------------------------------------------------- -zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId) -zonkRecFields env (HsRecFields flds dd) - = do { flds' <- mapM zonk_rbind flds - ; return (HsRecFields flds' dd) } - where - zonk_rbind (L l fld) - = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld) - ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldLbl = new_id - , hsRecFieldArg = new_expr })) } - -zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId] - -> TcM [LHsRecUpdField GhcTcId] -zonkRecUpdFields env = mapM zonk_rbind - where - zonk_rbind (L l fld) - = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld) - ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id - , hsRecFieldArg = new_expr })) } - -------------------------------------------------------------------------- -mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a - -> TcM (Either (Located HsIPName) b) -mapIPNameTc _ (Left x) = return (Left x) -mapIPNameTc f (Right x) = do r <- f x - return (Right r) - -{- -************************************************************************ -* * -\subsection[BackSubst-Pats]{Patterns} -* * -************************************************************************ --} - -zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat 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 = wrapLocSndM (zonk_pat env) pat - -zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc) -zonk_pat env (ParPat x p) - = do { (env', p') <- zonkPat env p - ; return (env', ParPat x p') } - -zonk_pat env (WildPat ty) - = do { ty' <- zonkTcTypeToTypeX env ty - ; ensureNotLevPoly ty' - (text "In a wildcard pattern") - ; 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) pat) - = do { v' <- zonkIdBndr env v - ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat - ; return (env', AsPat x (L loc v') 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 (ListPatTc ty Nothing) pats) - = do { ty' <- zonkTcTypeToTypeX env ty - ; (env', pats') <- zonkPats env pats - ; return (env', ListPat (ListPatTc ty' Nothing) pats') } - -zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats) - = do { (env', wit') <- zonkSyntaxExpr env wit - ; ty2' <- zonkTcTypeToTypeX env' ty2 - ; ty' <- zonkTcTypeToTypeX env' ty - ; (env'', pats') <- zonkPats env' pats - ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) 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@(ConPatOut { pat_arg_tys = tys - , pat_tvs = tyvars - , pat_dicts = evs - , pat_binds = binds - , pat_args = args - , pat_wrap = wrapper - , pat_con = L _ con }) - = ASSERT( all isImmutableTyVar tyvars ) - do { new_tys <- mapM (zonkTcTypeToTypeX env) tys - - -- an unboxed tuple pattern (but only an unboxed tuple pattern) - -- might have levity-polymorphic arguments. Check for this badness. - ; case con of - RealDataCon dc - | isUnboxedTupleTyCon (dataConTyCon dc) - -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys) - _ -> return () - - ; (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 - ; return (env', p { pat_arg_tys = new_tys, - pat_tvs = new_tyvars, - pat_dicts = new_evs, - pat_binds = new_binds, - pat_args = new_args, - pat_wrap = new_wrapper}) } - where - doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p - -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 (CoPat x co_fn pat ty) - = do { (env', co_fn') <- zonkCoFn env co_fn - ; (env'', pat') <- zonkPat env' (noLoc pat) - ; ty' <- zonkTcTypeToTypeX env'' ty - ; return (env'', CoPat x co_fn' (unLoc pat') ty') } - -zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) - ---------------------------- -zonkConStuff :: ZonkEnv - -> HsConDetails (OutPat GhcTcId) (HsRecFields id (OutPat GhcTcId)) - -> TcM (ZonkEnv, - HsConDetails (OutPat GhcTc) (HsRecFields id (OutPat GhcTc))) -zonkConStuff env (PrefixCon pats) - = do { (env', pats') <- zonkPats env pats - ; return (env', PrefixCon 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 (hsRecFieldArg . unLoc) rpats) - ; let rpats' = zipWith (\(L l rp) p' -> - L l (rp { hsRecFieldArg = p' })) - rpats pats' - ; return (env', RecCon (HsRecFields rpats' dd)) } - -- Field selectors have declared types; hence no zonking - ---------------------------- -zonkPats :: ZonkEnv -> [OutPat GhcTcId] -> TcM (ZonkEnv, [OutPat 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 GhcTcId] - -> TcM [LForeignDecl GhcTc] -zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls - -zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> 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 GhcTcId] -> TcM [LRuleDecl GhcTc] -zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs - -zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> 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 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_tm_bndr _ (L _ (XRuleBndr nec)) = noExtCon nec - - 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! -zonkRule _ (XRuleDecl nec) = noExtCon nec - -{- -************************************************************************ -* * - 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 (dc, bndrs, rhs) - = do (env1, bndrs') <- zonkCoreBndrsX env bndrs - rhs' <- zonkCoreExpr env1 rhs - return $ (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 t1 t2) - = do { t1' <- zonkEvTerm env t1 - ; t2' <- zonkEvTerm env t2 - ; return (EvTypeableTrFun 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 (mkTcReflCo 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 TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to - (Indirect zty), see Note [Sharing in zonking] in 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 - TcTyClsDecls. - - Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow - the same path as Note [Sharing in zonking] in 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!) - -Solution: (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 turns out to be viable from a perf point of view - - But the code 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.) - - Is the extra work worth it? Some non-sytematic perf measurements - suggest that compiler allocation is reduced overall (by 0.5% or so) - but compile time really doesn't change. --} - -zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType -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 mtv_env ref mtv_details } } - | otherwise - = 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 -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv - Just tv' -> return (mkTyVarTy tv') - - zonk_meta mtv_env ref Flexi - = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv) - ; ty <- commitFlexi flexi tv kind - ; writeMetaTyVarRef tv ref ty -- Belt and braces - ; finish_meta mtv_env ty } - - zonk_meta mtv_env _ (Indirect ty) - = do { zty <- zonkTcTypeToTypeX env ty - ; finish_meta mtv_env zty } - - finish_meta mtv_env ty - = do { let mtv_env' = extendVarEnv mtv_env tv ty - ; writeTcRef mtv_env_ref mtv_env' - ; return ty } - -lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar -lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv - = lookupVarEnv tv_env tv - -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 - | isRuntimeRepTy zonked_kind - -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) - ; return liftedRepTy } - | 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 - 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) - ; when debugIsOn $ - whenNoErrs $ - MASSERT2( False - , text "Type-correct 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 TcMType. -zonkTcTypeToType :: TcType -> TcM Type -zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty - -zonkTcTypesToTypes :: [TcType] -> TcM [Type] -zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys - -zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type -zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type] -zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion -(zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo, _) - = mapTyCoX zonk_tycomapper - -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/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs deleted file mode 100644 --- a/compiler/typecheck/TcHsType.hs +++ /dev/null @@ -1,3549 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcMonoType]{Typechecking user-specified @MonoTypes@} --} - -{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcHsType ( - -- Type signatures - kcClassSigType, tcClassSigType, - tcHsSigType, tcHsSigWcType, - tcHsPartialSigType, - tcStandaloneKindSig, - funsSigCtxt, addSigCtxt, pprSigCtxt, - - tcHsClsInstType, - tcHsDeriv, tcDerivStrategy, - tcHsTypeApp, - UserTypeCtxt(..), - bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol, - bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol, - bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol, - bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol, - ContextKind(..), - - -- Type checking type and class decls - bindTyClTyVars, - etaExpandAlgTyCon, tcbVisibilities, - - -- tyvars - zonkAndScopedSort, - - -- Kind-checking types - -- No kind generalisation, no checkValidType - InitialKindStrategy(..), - SAKS_or_CUSK(..), - kcDeclHeader, - tcNamedWildCardBinders, - tcHsLiftedType, tcHsOpenType, - tcHsLiftedTypeNC, tcHsOpenTypeNC, - tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType, - tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps, - failIfEmitsConstraints, - solveEqualities, -- useful re-export - - typeLevelMode, kindLevelMode, - - kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone, - - -- Sort-checking kinds - tcLHsKindSig, checkDataKindSig, DataSort(..), - checkClassKindSig, - - -- Pattern type signatures - tcHsPatSigType, tcPatSig, - - -- Error messages - funAppCtxt, addTyConFlavCtxt - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import TcRnMonad -import TcOrigin -import GHC.Core.Predicate -import Constraint -import TcEvidence -import TcEnv -import TcMType -import TcValidity -import TcUnify -import GHC.IfaceToCore -import TcSimplify -import TcHsSyn -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr -import TcErrors ( reportAllUnsolved ) -import TcType -import Inst ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder ) -import GHC.Core.Type -import TysPrim -import GHC.Types.Name.Reader( lookupLocalRdrOcc ) -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Core.TyCon -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.Class -import GHC.Types.Name --- import GHC.Types.Name.Set -import GHC.Types.Var.Env -import TysWiredIn -import GHC.Types.Basic -import GHC.Types.SrcLoc -import Constants ( mAX_CTUPLE_SIZE ) -import ErrUtils( MsgDoc ) -import GHC.Types.Unique -import GHC.Types.Unique.Set -import Util -import GHC.Types.Unique.Supply -import Outputable -import FastString -import PrelNames hiding ( wildCardName ) -import GHC.Driver.Session -import qualified GHC.LanguageExtensions as LangExt - -import Maybes -import Data.List ( find ) -import Control.Monad - -{- - ---------------------------- - General notes - ---------------------------- - -Unlike with expressions, type-checking types both does some checking and -desugars at the same time. This is necessary because we often want to perform -equality checks on the types right away, and it would be incredibly painful -to do this on un-desugared types. Luckily, desugared types are close enough -to HsTypes to make the error messages sane. - -During type-checking, we perform as little validity checking as possible. -Generally, after type-checking, you will want to do validity checking, say -with TcValidity.checkValidType. - -Validity checking -~~~~~~~~~~~~~~~~~ -Some of the validity check could in principle be done by the kind checker, -but not all: - -- During desugaring, we normalise by expanding type synonyms. Only - after this step can we check things like type-synonym saturation - e.g. type T k = k Int - type S a = a - Then (T S) is ok, because T is saturated; (T S) expands to (S Int); - and then S is saturated. This is a GHC extension. - -- Similarly, also a GHC extension, we look through synonyms before complaining - about the form of a class or instance declaration - -- Ambiguity checks involve functional dependencies - -Also, in a mutually recursive group of types, we can't look at the TyCon until we've -finished building the loop. So to keep things simple, we postpone most validity -checking until step (3). - -%************************************************************************ -%* * - Check types AND do validity checking -* * -************************************************************************ --} - -funsSigCtxt :: [Located Name] -> UserTypeCtxt --- Returns FunSigCtxt, with no redundant-context-reporting, --- form a list of located names -funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False -funsSigCtxt [] = panic "funSigCtxt" - -addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a -addSigCtxt ctxt hs_ty thing_inside - = setSrcSpan (getLoc hs_ty) $ - addErrCtxt (pprSigCtxt ctxt hs_ty) $ - thing_inside - -pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc --- (pprSigCtxt ctxt ) --- prints In the type signature for 'f': --- f :: --- The is either empty or "the ambiguity check for" -pprSigCtxt ctxt hs_ty - | Just n <- isSigMaybe ctxt - = hang (text "In the type signature:") - 2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty) - - | otherwise - = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon) - 2 (ppr hs_ty) - -tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type --- This one is used when we have a LHsSigWcType, but in --- a place where wildcards aren't allowed. The renamer has --- already checked this, so we can simply ignore it. -tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) - -kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM () --- This is a special form of tcClassSigType that is used during the --- kind-checking phase to infer the kind of class variables. Cf. tc_hs_sig_type. --- Importantly, this does *not* kind-generalize. Consider --- class SC f where --- 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. -kcClassSigType skol_info names (HsIB { hsib_ext = sig_vars - , hsib_body = hs_ty }) - = addSigCtxt (funsSigCtxt names) hs_ty $ - do { (tc_lvl, (wanted, (spec_tkvs, _))) - <- pushTcLevelM $ - solveLocalEqualitiesX "kcClassSigType" $ - bindImplicitTKBndrs_Skol sig_vars $ - tc_lhs_type typeLevelMode hs_ty liftedTypeKind - - ; emitResidualTvConstraint skol_info Nothing spec_tkvs - tc_lvl wanted } -kcClassSigType _ _ (XHsImplicitBndrs nec) = noExtCon nec - -tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type --- Does not do validity checking -tcClassSigType skol_info names sig_ty - = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $ - snd <$> tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind) - -- Do not zonk-to-Type, nor perform a validity check - -- We are in a knot with the class and associated types - -- Zonking and validity checking is done by tcClassDecl - -- No need to fail here if the type has an error: - -- If we're in the kind-checking phase, the solveEqualities - -- in kcTyClGroup catches the error - -- If we're in the type-checking phase, the solveEqualities - -- in tcClassDecl1 gets it - -- Failing fast here degrades the error message in, e.g., tcfail135: - -- class Foo f where - -- baa :: f a -> f - -- If we fail fast, we're told that f has kind `k1` when we wanted `*`. - -- It should be that f has kind `k2 -> *`, but we never get a chance - -- to run the solver where the kind of f is touchable. This is - -- painfully delicate. - -tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type --- Does validity checking --- See Note [Recipe for checking a signature] -tcHsSigType ctxt sig_ty - = addSigCtxt ctxt (hsSigType sig_ty) $ - do { traceTc "tcHsSigType {" (ppr sig_ty) - - -- Generalise here: see Note [Kind generalisation] - ; (insol, ty) <- tc_hs_sig_type skol_info sig_ty - (expectedKindInCtxt ctxt) - ; ty <- zonkTcType ty - - ; when insol failM - -- See Note [Fail fast if there are insoluble kind equalities] in TcSimplify - - ; checkValidType ctxt ty - ; traceTc "end tcHsSigType }" (ppr ty) - ; return ty } - where - skol_info = SigTypeSkol ctxt - --- Does validity checking and zonking. -tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind) -tcStandaloneKindSig (L _ kisig) = case kisig of - StandaloneKindSig _ (L _ name) ksig -> - let ctxt = StandaloneKindSigCtxt name in - addSigCtxt ctxt (hsSigType ksig) $ - do { kind <- tcTopLHsType kindLevelMode ksig (expectedKindInCtxt ctxt) - ; checkValidType ctxt kind - ; return (name, kind) } - XStandaloneKindSig nec -> noExtCon nec - -tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn - -> ContextKind -> TcM (Bool, TcType) --- Kind-checks/desugars an 'LHsSigType', --- solve equalities, --- and then kind-generalizes. --- This will never emit constraints, as it uses solveEqualities internally. --- No validity checking or zonking --- Returns also a Bool indicating whether the type induced an insoluble constraint; --- True <=> constraint is insoluble -tc_hs_sig_type skol_info hs_sig_type ctxt_kind - | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type - = do { (tc_lvl, (wanted, (spec_tkvs, ty))) - <- pushTcLevelM $ - solveLocalEqualitiesX "tc_hs_sig_type" $ - bindImplicitTKBndrs_Skol sig_vars $ - do { kind <- newExpectedKind ctxt_kind - ; tc_lhs_type typeLevelMode hs_ty kind } - -- Any remaining variables (unsolved in the solveLocalEqualities) - -- should be in the global tyvars, and therefore won't be quantified - - ; spec_tkvs <- zonkAndScopedSort spec_tkvs - ; let ty1 = mkSpecForAllTys spec_tkvs ty - - -- This bit is very much like decideMonoTyVars in TcSimplify, - -- but constraints are so much simpler in kinds, it is much - -- easier here. (In particular, we never quantify over a - -- constraint in a type.) - ; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted) - ; let should_gen = not . (`elemVarSet` constrained) - - ; kvs <- kindGeneralizeSome should_gen ty1 - ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs) - tc_lvl wanted - - ; return (insolubleWC wanted, mkInvForAllTys kvs ty1) } - -tc_hs_sig_type _ (XHsImplicitBndrs nec) _ = noExtCon nec - -tcTopLHsType :: TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type --- tcTopLHsType is used for kind-checking top-level HsType where --- we want to fully solve /all/ equalities, and report errors --- Does zonking, but not validity checking because it's used --- for things (like deriving and instances) that aren't --- ordinary types -tcTopLHsType mode hs_sig_type ctxt_kind - | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type - = do { traceTc "tcTopLHsType {" (ppr hs_ty) - ; (spec_tkvs, ty) - <- pushTcLevelM_ $ - solveEqualities $ - bindImplicitTKBndrs_Skol sig_vars $ - do { kind <- newExpectedKind ctxt_kind - ; tc_lhs_type mode hs_ty kind } - - ; spec_tkvs <- zonkAndScopedSort spec_tkvs - ; let ty1 = mkSpecForAllTys spec_tkvs ty - ; kvs <- kindGeneralizeAll ty1 -- "All" because it's a top-level type - ; final_ty <- zonkTcTypeToType (mkInvForAllTys kvs ty1) - ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty]) - ; return final_ty} - -tcTopLHsType _ (XHsImplicitBndrs nec) _ = noExtCon nec - ------------------ -tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) --- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause --- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments --- E.g. class C (a::*) (b::k->k) --- data T a b = ... deriving( C Int ) --- returns ([k], C, [k, Int], [k->k]) --- Return values are fully zonked -tcHsDeriv hs_ty - = do { ty <- checkNoErrs $ -- Avoid redundant error report - -- with "illegal deriving", below - tcTopLHsType typeLevelMode hs_ty AnyKind - ; let (tvs, pred) = splitForAllTys ty - (kind_args, _) = splitFunTys (tcTypeKind pred) - ; case getClassPredTys_maybe pred of - Just (cls, tys) -> return (tvs, cls, tys, kind_args) - Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } - --- | Typecheck a deriving strategy. For most deriving strategies, this is a --- no-op, but for the @via@ strategy, this requires typechecking the @via@ type. -tcDerivStrategy :: - Maybe (LDerivStrategy GhcRn) - -- ^ The deriving strategy - -> TcM (Maybe (LDerivStrategy GhcTc), [TyVar]) - -- ^ The typechecked deriving strategy and the tyvars that it binds - -- (if using 'ViaStrategy'). -tcDerivStrategy mb_lds - = case mb_lds of - Nothing -> boring_case Nothing - Just (L loc ds) -> - setSrcSpan loc $ do - (ds', tvs) <- tc_deriv_strategy ds - pure (Just (L loc ds'), tvs) - where - tc_deriv_strategy :: DerivStrategy GhcRn - -> TcM (DerivStrategy GhcTc, [TyVar]) - tc_deriv_strategy StockStrategy = boring_case StockStrategy - tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy - tc_deriv_strategy NewtypeStrategy = boring_case NewtypeStrategy - tc_deriv_strategy (ViaStrategy ty) = do - ty' <- checkNoErrs $ tcTopLHsType typeLevelMode ty AnyKind - let (via_tvs, via_pred) = splitForAllTys ty' - pure (ViaStrategy via_pred, via_tvs) - - boring_case :: ds -> TcM (ds, [TyVar]) - boring_case ds = pure (ds, []) - -tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt - -> LHsSigType GhcRn - -> TcM Type --- Like tcHsSigType, but for a class instance declaration -tcHsClsInstType user_ctxt hs_inst_ty - = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $ - do { -- Fail eagerly if tcTopLHsType fails. We are at top level so - -- these constraints will never be solved later. And failing - -- eagerly avoids follow-on errors when checkValidInstance - -- sees an unsolved coercion hole - inst_ty <- checkNoErrs $ - tcTopLHsType typeLevelMode hs_inst_ty (TheKind constraintKind) - ; checkValidInstance user_ctxt hs_inst_ty inst_ty - ; return inst_ty } - ----------------------------------------------- --- | Type-check a visible type application -tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type --- See Note [Recipe for checking a signature] in TcHsType -tcHsTypeApp wc_ty kind - | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty - = do { ty <- solveLocalEqualities "tcHsTypeApp" $ - -- We are looking at a user-written type, very like a - -- signature so we want to solve its equalities right now - unsetWOptM Opt_WarnPartialTypeSignatures $ - setXOptM LangExt.PartialTypeSignatures $ - -- See Note [Wildcards in visible type application] - tcNamedWildCardBinders sig_wcs $ \ _ -> - tcCheckLHsType hs_ty (TheKind kind) - -- We do not kind-generalize type applications: we just - -- instantiate with exactly what the user says. - -- See Note [No generalization in type application] - -- We still must call kindGeneralizeNone, though, according - -- to Note [Recipe for checking a signature] - ; kindGeneralizeNone ty - ; ty <- zonkTcType ty - ; checkValidType TypeAppCtxt ty - ; return ty } -tcHsTypeApp (XHsWildCardBndrs nec) _ = noExtCon nec - -{- Note [Wildcards in visible type application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so -any unnamed wildcards stay unchanged in hswc_body. When called in -tcHsTypeApp, tcCheckLHsType will call emitAnonWildCardHoleConstraint -on these anonymous wildcards. However, this would trigger -error/warning when an anonymous wildcard is passed in as a visible type -argument, which we do not want because users should be able to write -@_ to skip a instantiating a type variable variable without fuss. The -solution is to switch the PartialTypeSignatures flags here to let the -typechecker know that it's checking a '@_' and do not emit hole -constraints on it. See related Note [Wildcards in visible kind -application] and Note [The wildcard story for types] in GHC.Hs.Types - -Ugh! - -Note [No generalization in type application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not kind-generalize type applications. Imagine - - id @(Proxy Nothing) - -If we kind-generalized, we would get - - id @(forall {k}. Proxy @(Maybe k) (Nothing @k)) - -which is very sneakily impredicative instantiation. - -There is also the possibility of mentioning a wildcard -(`id @(Proxy _)`), which definitely should not be kind-generalized. - --} - -{- -************************************************************************ -* * - The main kind checker: no validity checks here -* * -************************************************************************ --} - ---------------------------- -tcHsOpenType, tcHsLiftedType, - tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType --- Used for type signatures --- Do not do validity checking -tcHsOpenType ty = addTypeCtxt ty $ tcHsOpenTypeNC ty -tcHsLiftedType ty = addTypeCtxt ty $ tcHsLiftedTypeNC ty - -tcHsOpenTypeNC ty = do { ek <- newOpenTypeKind - ; tc_lhs_type typeLevelMode ty ek } -tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind - --- Like tcHsType, but takes an expected kind -tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType -tcCheckLHsType hs_ty exp_kind - = addTypeCtxt hs_ty $ - do { ek <- newExpectedKind exp_kind - ; tc_lhs_type typeLevelMode hs_ty ek } - -tcLHsType :: LHsType GhcRn -> TcM (TcType, TcKind) --- Called from outside: set the context -tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty) - --- Like tcLHsType, but use it in a context where type synonyms and type families --- do not need to be saturated, like in a GHCi :kind call -tcLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind) -tcLHsTypeUnsaturated hs_ty - | Just (hs_fun_ty, hs_args) <- splitHsAppTys (unLoc hs_ty) - = addTypeCtxt hs_ty $ - do { (fun_ty, _ki) <- tcInferAppHead mode hs_fun_ty - ; tcInferApps_nosat mode hs_fun_ty fun_ty hs_args } - -- Notice the 'nosat'; do not instantiate trailing - -- invisible arguments of a type family. - -- See Note [Dealing with :kind] - - | otherwise - = addTypeCtxt hs_ty $ - tc_infer_lhs_type mode hs_ty - - where - mode = typeLevelMode - -{- Note [Dealing with :kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this GHCi command - ghci> type family F :: Either j k - ghci> :kind F - F :: forall {j,k}. Either j k - -We will only get the 'forall' if we /refrain/ from saturating those -invisible binders. But generally we /do/ saturate those invisible -binders (see tcInferApps), and we want to do so for nested application -even in GHCi. Consider for example (#16287) - ghci> type family F :: k - ghci> data T :: (forall k. k) -> Type - ghci> :kind T F -We want to reject this. It's just at the very top level that we want -to switch off saturation. - -So tcLHsTypeUnsaturated does a little special case for top level -applications. Actually the common case is a bare variable, as above. - - -************************************************************************ -* * - Type-checking modes -* * -************************************************************************ - -The kind-checker is parameterised by a TcTyMode, which contains some -information about where we're checking a type. - -The renamer issues errors about what it can. All errors issued here must -concern things that the renamer can't handle. - --} - --- | Info about the context in which we're checking a type. Currently, --- differentiates only between types and kinds, but this will likely --- grow, at least to include the distinction between patterns and --- not-patterns. --- --- To find out where the mode is used, search for 'mode_level' -data TcTyMode = TcTyMode { mode_level :: TypeOrKind } - -typeLevelMode :: TcTyMode -typeLevelMode = TcTyMode { mode_level = TypeLevel } - -kindLevelMode :: TcTyMode -kindLevelMode = TcTyMode { mode_level = KindLevel } - --- switch to kind level -kindLevel :: TcTyMode -> TcTyMode -kindLevel mode = mode { mode_level = KindLevel } - -instance Outputable TcTyMode where - ppr = ppr . mode_level - -{- -Note [Bidirectional type checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In expressions, whenever we see a polymorphic identifier, say `id`, we are -free to instantiate it with metavariables, knowing that we can always -re-generalize with type-lambdas when necessary. For example: - - rank2 :: (forall a. a -> a) -> () - x = rank2 id - -When checking the body of `x`, we can instantiate `id` with a metavariable. -Then, when we're checking the application of `rank2`, we notice that we really -need a polymorphic `id`, and then re-generalize over the unconstrained -metavariable. - -In types, however, we're not so lucky, because *we cannot re-generalize*! -There is no lambda. So, we must be careful only to instantiate at the last -possible moment, when we're sure we're never going to want the lost polymorphism -again. This is done in calls to tcInstInvisibleTyBinders. - -To implement this behavior, we use bidirectional type checking, where we -explicitly think about whether we know the kind of the type we're checking -or not. Note that there is a difference between not knowing a kind and -knowing a metavariable kind: the metavariables are TauTvs, and cannot become -forall-quantified kinds. Previously (before dependent types), there were -no higher-rank kinds, and so we could instantiate early and be sure that -no types would have polymorphic kinds, and so we could always assume that -the kind of a type was a fresh metavariable. Not so anymore, thus the -need for two algorithms. - -For HsType forms that can never be kind-polymorphic, we implement only the -"down" direction, where we safely assume a metavariable kind. For HsType forms -that *can* be kind-polymorphic, we implement just the "up" (functions with -"infer" in their name) version, as we gain nothing by also implementing the -"down" version. - -Note [Future-proofing the type checker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As discussed in Note [Bidirectional type checking], each HsType form is -handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions -are mutually recursive, so that either one can work for any type former. -But, we want to make sure that our pattern-matches are complete. So, -we have a bunch of repetitive code just so that we get warnings if we're -missing any patterns. - --} - ------------------------------------------- --- | Check and desugar a type, returning the core type and its --- possibly-polymorphic kind. Much like 'tcInferRho' at the expression --- level. -tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) -tc_infer_lhs_type mode (L span ty) - = setSrcSpan span $ - tc_infer_hs_type mode ty - ---------------------------- --- | Call 'tc_infer_hs_type' and check its result against an expected kind. -tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType -tc_infer_hs_type_ek mode hs_ty ek - = do { (ty, k) <- tc_infer_hs_type mode hs_ty - ; checkExpectedKind hs_ty ty k ek } - ---------------------------- --- | Infer the kind of a type and desugar. This is the "up" type-checker, --- as described in Note [Bidirectional type checking] -tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) - -tc_infer_hs_type mode (HsParTy _ t) - = tc_infer_lhs_type mode t - -tc_infer_hs_type mode ty - | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty - = do { (fun_ty, _ki) <- tcInferAppHead mode hs_fun_ty - ; tcInferApps mode hs_fun_ty fun_ty hs_args } - -tc_infer_hs_type mode (HsKindSig _ ty sig) - = do { sig' <- tcLHsKindSig KindSigCtxt sig - -- We must typecheck the kind signature, and solve all - -- its equalities etc; from this point on we may do - -- 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' - ; return (ty', sig') } - --- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate --- the splice location to the typechecker. Here we skip over it in order to have --- the same kind inferred for a given expression whether it was produced from --- splices or not. --- --- See Note [Delaying modFinalizers in untyped splices]. -tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty))) - = tc_infer_hs_type mode ty - -tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty -tc_infer_hs_type _ (XHsType (NHsCoreTy ty)) - = return (ty, tcTypeKind ty) - -tc_infer_hs_type _ (HsExplicitListTy _ _ tys) - | null tys -- this is so that we can use visible kind application with '[] - -- e.g ... '[] @Bool - = return (mkTyConTy promotedNilDataCon, - mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy) - -tc_infer_hs_type mode other_ty - = do { kv <- newMetaKindVar - ; ty' <- tc_hs_type mode other_ty kv - ; return (ty', kv) } - ------------------------------------------- -tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType -tc_lhs_type mode (L span ty) exp_kind - = setSrcSpan span $ - tc_hs_type mode ty exp_kind - -tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType --- See Note [Bidirectional type checking] - -tc_hs_type mode (HsParTy _ ty) exp_kind = tc_lhs_type mode ty exp_kind -tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind -tc_hs_type _ ty@(HsBangTy _ bang _) _ - -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), - -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of - -- bangs are invalid, so fail. (#7210, #14761) - = do { let bangError err = failWith $ - text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ - text err <+> text "annotation cannot appear nested inside a type" - ; case bang of - HsSrcBang _ SrcUnpack _ -> bangError "UNPACK" - HsSrcBang _ SrcNoUnpack _ -> bangError "NOUNPACK" - HsSrcBang _ NoSrcUnpack SrcLazy -> bangError "laziness" - HsSrcBang _ _ _ -> bangError "strictness" } -tc_hs_type _ ty@(HsRecTy {}) _ - -- Record types (which only show up temporarily in constructor - -- signatures) should have been removed by now - = failWithTc (text "Record syntax is illegal here:" <+> ppr 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 --- while capturing the local environment. --- --- See Note [Delaying modFinalizers in untyped splices]. -tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty))) - exp_kind - = do addModFinalizersWithLclEnv mod_finalizers - tc_hs_type mode ty exp_kind - --- This should never happen; type splices are expanded by the renamer -tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind - = failWithTc (text "Unexpected type splice:" <+> ppr ty) - ----------- Functions and applications -tc_hs_type mode (HsFunTy _ ty1 ty2) exp_kind - = tc_fun_type mode ty1 ty2 exp_kind - -tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind - | op `hasKey` funTyConKey - = tc_fun_type mode ty1 ty2 exp_kind - ---------- Foralls -tc_hs_type mode forall@(HsForAllTy { hst_fvf = fvf, hst_bndrs = hs_tvs - , hst_body = ty }) exp_kind - = do { (tclvl, wanted, (tvs', ty')) - <- pushLevelAndCaptureConstraints $ - bindExplicitTKBndrs_Skol hs_tvs $ - tc_lhs_type mode ty exp_kind - -- Do not kind-generalise here! See Note [Kind generalisation] - -- Why exp_kind? See Note [Body kind of HsForAllTy] - ; let argf = case fvf of - ForallVis -> Required - ForallInvis -> Specified - bndrs = mkTyVarBinders argf tvs' - skol_info = ForAllSkol (ppr forall) - m_telescope = Just (sep (map ppr hs_tvs)) - - ; emitResidualTvConstraint skol_info m_telescope tvs' tclvl wanted - - ; return (mkForAllTys bndrs ty') } - -tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind - | null (unLoc ctxt) - = tc_lhs_type mode rn_ty exp_kind - - -- See Note [Body kind of a HsQualTy] - | tcIsConstraintKind exp_kind - = do { ctxt' <- tc_hs_context mode ctxt - ; ty' <- tc_lhs_type mode rn_ty constraintKind - ; return (mkPhiTy ctxt' ty') } - - | otherwise - = do { ctxt' <- tc_hs_context mode ctxt - - ; ek <- newOpenTypeKind -- The body kind (result of the function) can - -- be TYPE r, for any r, hence newOpenTypeKind - ; ty' <- tc_lhs_type mode rn_ty ek - ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty') - liftedTypeKind exp_kind } - ---------- Lists, arrays, and tuples -tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind - = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind - ; checkWiredInTyCon listTyCon - ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } - --- See Note [Distinguishing tuple kinds] in GHC.Hs.Types --- See Note [Inferring tuple kinds] -tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind - -- (NB: not zonking before looking at exp_k, to avoid left-right bias) - | Just tup_sort <- tupKindSort_maybe exp_kind - = traceTc "tc_hs_type tuple" (ppr hs_tys) >> - tc_tuple rn_ty mode tup_sort hs_tys exp_kind - | 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 - -- 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 - -- "the second argument of a tuple should have kind *->*" - - ; let (arg_kind, tup_sort) - = case [ (k,s) | k <- kinds - , Just s <- [tupKindSort_maybe k] ] of - ((k,s) : _) -> (k,s) - [] -> (liftedTypeKind, BoxedTuple) - -- In the [] case, it's not clear what the kind is, so guess * - - ; tys' <- sequence [ setSrcSpan loc $ - checkExpectedKind hs_ty ty kind arg_kind - | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ] - - ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind } - - -tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind - = tc_tuple rn_ty mode tup_sort tys exp_kind - where - tup_sort = case hs_tup_sort of -- Fourth case dealt with above - HsUnboxedTuple -> UnboxedTuple - HsBoxedTuple -> BoxedTuple - HsConstraintTuple -> ConstraintTuple - _ -> panic "tc_hs_type HsTupleTy" - -tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind - = do { let arity = length hs_tys - ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys - ; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds - ; let arg_reps = map kindRep arg_kinds - arg_tys = arg_reps ++ tau_tys - sum_ty = mkTyConApp (sumTyCon arity) arg_tys - sum_kind = unboxedSumKind arg_reps - ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind - } - ---------- Promoted lists and tuples -tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind - = do { tks <- mapM (tc_infer_lhs_type mode) tys - ; (taus', kind) <- unifyKinds tys tks - ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') - ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind } - where - mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b] - mk_nil k = mkTyConApp (promoteDataCon nilDataCon) [k] - -tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind - -- using newMetaKindVar means that we force instantiations of any polykinded - -- types. At first, I just used tc_infer_lhs_type, but that led to #11255. - = do { ks <- replicateM arity newMetaKindVar - ; taus <- zipWithM (tc_lhs_type mode) tys ks - ; let kind_con = tupleTyCon Boxed arity - ty_con = promotedTupleDataCon Boxed arity - tup_k = mkTyConApp kind_con ks - ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind } - where - arity = length tys - ---------- Constraint types -tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind - = do { MASSERT( isTypeLevel (mode_level mode) ) - ; ty' <- tc_lhs_type mode ty liftedTypeKind - ; let n' = mkStrLitTy $ hsIPNameFS n - ; ipClass <- tcLookupClass ipClassName - ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty']) - constraintKind exp_kind } - -tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind - -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to - -- handle it in 'coreView' and 'tcView'. - = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind - ---------- Literals -tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind - = do { checkWiredInTyCon typeNatKindCon - ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind } - -tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind - = do { checkWiredInTyCon typeSymbolKindCon - ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind } - ---------- Potentially kind-polymorphic types: call the "up" checker --- See Note [Future-proofing the type checker] -tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsAppTy {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsAppKindTy{}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type _ wc@(HsWildCardTy _) ek = tcAnonWildCardOcc wc ek - ------------------------------------------- -tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind - -> TcM TcType -tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of - TypeLevel -> - do { arg_k <- newOpenTypeKind - ; res_k <- newOpenTypeKind - ; ty1' <- tc_lhs_type mode ty1 arg_k - ; ty2' <- tc_lhs_type mode ty2 res_k - ; checkExpectedKind (HsFunTy noExtField ty1 ty2) (mkVisFunTy ty1' ty2') - liftedTypeKind exp_kind } - KindLevel -> -- no representation polymorphism in kinds. yet. - do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind - ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind - ; checkExpectedKind (HsFunTy noExtField ty1 ty2) (mkVisFunTy ty1' ty2') - liftedTypeKind exp_kind } - ---------------------------- -tcAnonWildCardOcc :: HsType GhcRn -> Kind -> TcM TcType -tcAnonWildCardOcc wc exp_kind - = do { wc_tv <- newWildTyVar -- The wildcard's kind will be an un-filled-in meta tyvar - - ; part_tysig <- xoptM LangExt.PartialTypeSignatures - ; warning <- woptM Opt_WarnPartialTypeSignatures - - ; unless (part_tysig && not warning) $ - emitAnonWildCardHoleConstraint wc_tv - -- Why the 'unless' guard? - -- See Note [Wildcards in visible kind application] - - ; checkExpectedKind wc (mkTyVarTy wc_tv) - (tyVarKind wc_tv) exp_kind } - -{- Note [Wildcards in visible kind application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are cases where users might want to pass in a wildcard as a visible kind -argument, for instance: - -data T :: forall k1 k2. k1 → k2 → Type where - MkT :: T a b -x :: T @_ @Nat False n -x = MkT - -So we should allow '@_' without emitting any hole constraints, and -regardless of whether PartialTypeSignatures is enabled or not. But how would -the typechecker know which '_' is being used in VKA and which is not when it -calls emitNamedWildCardHoleConstraints in tcHsPartialSigType on all HsWildCardBndrs? -The solution then is to neither rename nor include unnamed wildcards in HsWildCardBndrs, -but instead give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc. -And whenever we see a '@', we automatically turn on PartialTypeSignatures and -turn off hole constraint warnings, and do not call emitAnonWildCardHoleConstraint -under these conditions. -See related Note [Wildcards in visible type application] here and -Note [The wildcard story for types] in GHC.Hs.Types - --} - -{- ********************************************************************* -* * - Tuples -* * -********************************************************************* -} - ---------------------------- -tupKindSort_maybe :: TcKind -> Maybe TupleSort -tupKindSort_maybe k - | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k' - | Just k' <- tcView k = tupKindSort_maybe k' - | tcIsConstraintKind k = Just ConstraintTuple - | tcIsLiftedTypeKind k = Just BoxedTuple - | otherwise = Nothing - -tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType -tc_tuple rn_ty mode tup_sort tys exp_kind - = do { arg_kinds <- case tup_sort of - BoxedTuple -> return (replicate arity liftedTypeKind) - UnboxedTuple -> replicateM arity newOpenTypeKind - ConstraintTuple -> return (replicate arity constraintKind) - ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds - ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind } - where - arity = length tys - -finish_tuple :: HsType GhcRn - -> TupleSort - -> [TcType] -- ^ argument types - -> [TcKind] -- ^ of these kinds - -> TcKind -- ^ expected kind of the whole tuple - -> TcM TcType -finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do - traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind) - case tup_sort of - ConstraintTuple - | [tau_ty] <- tau_tys - -- Drop any uses of 1-tuple constraints here. - -- See Note [Ignore unary constraint tuples] - -> check_expected_kind tau_ty constraintKind - | arity > mAX_CTUPLE_SIZE - -> failWith (bigConstraintTuple arity) - | otherwise - -> do tycon <- tcLookupTyCon (cTupleTyConName arity) - check_expected_kind (mkTyConApp tycon tau_tys) constraintKind - BoxedTuple -> do - let tycon = tupleTyCon Boxed arity - checkWiredInTyCon tycon - check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind - UnboxedTuple -> - let tycon = tupleTyCon Unboxed arity - tau_reps = map kindRep tau_kinds - -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - arg_tys = tau_reps ++ tau_tys - res_kind = unboxedTupleKind tau_reps in - check_expected_kind (mkTyConApp tycon arg_tys) res_kind - where - arity = length tau_tys - check_expected_kind ty act_kind = - checkExpectedKind rn_ty ty act_kind exp_kind - -bigConstraintTuple :: Arity -> MsgDoc -bigConstraintTuple arity - = hang (text "Constraint tuple arity too large:" <+> int arity - <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE)) - 2 (text "Instead, use a nested tuple") - -{- -Note [Ignore unary constraint tuples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in -TysWiredIn) but does *not* provide unary constraint tuples. Why? First, -recall the definition of a unary tuple data type: - - data Unit a = Unit a - -Note that `Unit a` is *not* the same thing as `a`, since Unit is boxed and -lazy. Therefore, the presence of `Unit` matters semantically. On the other -hand, suppose we had a unary constraint tuple: - - class a => Unit% a - -This compiles down a newtype (i.e., a cast) in Core, so `Unit% a` is -semantically equivalent to `a`. Therefore, a 1-tuple constraint would have -no user-visible impact, nor would it allow you to express anything that -you couldn't otherwise. - -We could simply add Unit% for consistency with tuples (Unit) and unboxed -tuples (Unit#), but that would require even more magic to wire in another -magical class, so we opt not to do so. We must be careful, however, since -one can try to sneak in uses of unary constraint tuples through Template -Haskell, such as in this program (from #17511): - - f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)] - (ConT ''String))) - -- f :: Unit% (Show Int) => String - f = "abc" - -This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1, -and since it is used in a Constraint position, GHC will attempt to treat -it as thought it were a constraint tuple, which can potentially lead to -trouble if one attempts to look up the name of a constraint tuple of arity -1 (as it won't exist). To avoid this trouble, we simply take any unary -constraint tuples discovered when typechecking and drop them—i.e., treat -"Unit% a" as though the user had written "a". This is always safe to do -since the two constraints should be semantically equivalent. --} - -{- ********************************************************************* -* * - Type applications -* * -********************************************************************* -} - -splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn]) -splitHsAppTys hs_ty - | is_app hs_ty = Just (go (noLoc hs_ty) []) - | otherwise = Nothing - where - is_app :: HsType GhcRn -> Bool - is_app (HsAppKindTy {}) = True - is_app (HsAppTy {}) = True - is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey) - -- I'm not sure why this funTyConKey test is necessary - -- Can it even happen? Perhaps for t1 `(->)` t2 - -- but then maybe it's ok to treat that like a normal - -- application rather than using the special rule for HsFunTy - is_app (HsTyVar {}) = True - is_app (HsParTy _ (L _ ty)) = is_app ty - is_app _ = False - - 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 sp (HsParTy _ f)) as = go f (HsArgPar sp : as) - go (L _ (HsOpTy _ l op@(L sp _) r)) as - = ( L sp (HsTyVar noExtField NotPromoted op) - , HsValArg l : HsValArg r : as ) - go f as = (f, as) - ---------------------------- -tcInferAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) --- Version of tc_infer_lhs_type specialised for the head of an --- application. In particular, for a HsTyVar (which includes type --- constructors, it does not zoom off into tcInferApps and family --- saturation -tcInferAppHead mode (L _ (HsTyVar _ _ (L _ tv))) - = tcTyVar mode tv -tcInferAppHead mode ty - = tc_infer_lhs_type mode ty - ---------------------------- --- | Apply a type of a given kind to a list of arguments. This instantiates --- invisible parameters as necessary. Always consumes all the arguments, --- using matchExpectedFunKind as necessary. --- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.- --- These kinds should be used to instantiate invisible kind variables; --- they come from an enclosing class for an associated type/data family. --- --- tcInferApps also arranges to saturate any trailing invisible arguments --- of a type-family application, which is usually the right thing to do --- tcInferApps_nosat does not do this saturation; it is used only --- by ":kind" in GHCi -tcInferApps, tcInferApps_nosat - :: TcTyMode - -> LHsType GhcRn -- ^ Function (for printing only) - -> TcType -- ^ Function - -> [LHsTypeArg GhcRn] -- ^ Args - -> TcM (TcType, TcKind) -- ^ (f args, args, result kind) -tcInferApps mode hs_ty fun hs_args - = do { (f_args, res_k) <- tcInferApps_nosat mode hs_ty fun hs_args - ; saturateFamApp f_args res_k } - -tcInferApps_nosat mode orig_hs_ty fun orig_hs_args - = do { traceTc "tcInferApps {" (ppr orig_hs_ty $$ ppr orig_hs_args) - ; (f_args, res_k) <- go_init 1 fun orig_hs_args - ; traceTc "tcInferApps }" (ppr f_args <+> dcolon <+> ppr res_k) - ; return (f_args, res_k) } - where - - -- go_init just initialises the auxiliary - -- arguments of the 'go' loop - go_init n fun all_args - = go n fun empty_subst fun_ki all_args - where - fun_ki = tcTypeKind fun - -- We do (tcTypeKind fun) here, even though the caller - -- knows the function kind, to absolutely guarantee - -- INVARIANT for 'go' - -- Note that in a typical application (F t1 t2 t3), - -- the 'fun' is just a TyCon, so tcTypeKind is fast - - empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfType fun_ki - - go :: Int -- The # of the next argument - -> TcType -- Function applied to some args - -> TCvSubst -- Applies to function kind - -> TcKind -- Function kind - -> [LHsTypeArg GhcRn] -- Un-type-checked args - -> TcM (TcType, TcKind) -- Result type and its kind - -- INVARIANT: in any call (go n fun subst fun_ki args) - -- tcTypeKind fun = subst(fun_ki) - -- So the 'subst' and 'fun_ki' arguments are simply - -- there to avoid repeatedly calling tcTypeKind. - -- - -- Reason for INVARIANT: to support the Purely Kinded Type Invariant - -- it's important that if fun_ki has a forall, then so does - -- (tcTypeKind fun), because the next thing we are going to do - -- is apply 'fun' to an argument type. - - -- Dispatch on all_args first, for performance reasons - go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of - - ---------------- No user-written args left. We're done! - ([], _) -> return (fun, substTy subst fun_ki) - - ---------------- HsArgPar: We don't care about parens here - (HsArgPar _ : args, _) -> go n fun subst fun_ki args - - ---------------- HsTypeArg: a kind application (fun @ki) - (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) -> - case ki_binder of - - -- FunTy with PredTy on LHS, or ForAllTy with Inferred - Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki - Anon InvisArg _ -> instantiate ki_binder inner_ki - - Named (Bndr _ Specified) -> -- Visible kind application - do { traceTc "tcInferApps (vis kind app)" - (vcat [ ppr ki_binder, ppr hs_ki_arg - , ppr (tyBinderType ki_binder) - , ppr subst ]) - - ; let exp_kind = substTy subst $ tyBinderType ki_binder - - ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $ - unsetWOptM Opt_WarnPartialTypeSignatures $ - setXOptM LangExt.PartialTypeSignatures $ - -- Urgh! see Note [Wildcards in visible kind application] - -- ToDo: must kill this ridiculous messing with DynFlags - tc_lhs_type (kindLevel mode) hs_ki_arg exp_kind - - ; traceTc "tcInferApps (vis kind app)" (ppr exp_kind) - ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg - ; go (n+1) fun' subst' inner_ki hs_args } - - -- Attempted visible kind application (fun @ki), but fun_ki is - -- forall k -> blah or k1 -> k2 - -- So we need a normal application. Error. - _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki - - -- No binder; try applying the substitution, or fail if that's not possible - (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $ - ty_app_err ki_arg substed_fun_ki - - ---------------- HsValArg: a normal argument (fun ty) - (HsValArg arg : args, Just (ki_binder, inner_ki)) - -- next binder is invisible; need to instantiate it - | isInvisibleBinder ki_binder -- FunTy with InvisArg on LHS; - -- or ForAllTy with Inferred or Specified - -> instantiate ki_binder inner_ki - - -- "normal" case - | otherwise - -> do { traceTc "tcInferApps (vis normal app)" - (vcat [ ppr ki_binder - , ppr arg - , ppr (tyBinderType ki_binder) - , ppr subst ]) - ; let exp_kind = substTy subst $ tyBinderType ki_binder - ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $ - tc_lhs_type mode arg exp_kind - ; traceTc "tcInferApps (vis normal app) 2" (ppr exp_kind) - ; (subst', fun') <- mkAppTyM subst fun ki_binder arg' - ; go (n+1) fun' subst' inner_ki args } - - -- no binder; try applying the substitution, or infer another arrow in fun kind - (HsValArg _ : _, Nothing) - -> try_again_after_substing_or $ - do { let arrows_needed = n_initial_val_args all_args - ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki - - ; fun' <- zonkTcType (fun `mkTcCastTy` co) - -- This zonk is essential, to expose the fruits - -- of matchExpectedFunKind to the 'go' loop - - ; traceTc "tcInferApps (no binder)" $ - vcat [ ppr fun <+> dcolon <+> ppr fun_ki - , ppr arrows_needed - , ppr co - , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')] - ; go_init n fun' all_args } - -- Use go_init to establish go's INVARIANT - where - instantiate ki_binder inner_ki - = do { traceTc "tcInferApps (need to instantiate)" - (vcat [ ppr ki_binder, ppr subst]) - ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder - ; go n (mkAppTy fun arg') subst' inner_ki all_args } - -- Because tcInvisibleTyBinder instantiate ki_binder, - -- the kind of arg' will have the same shape as the kind - -- of ki_binder. So we don't need mkAppTyM here. - - try_again_after_substing_or fallthrough - | not (isEmptyTCvSubst subst) - = go n fun zapped_subst substed_fun_ki all_args - | otherwise - = fallthrough - - zapped_subst = zapTCvSubst subst - 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 - -- 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 - n_initial_val_args _ = 0 - - ty_app_err arg ty - = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty) - $$ text "to visible kind argument" <+> quotes (ppr arg) - - -mkAppTyM :: TCvSubst - -> TcType -> TyCoBinder -- fun, plus its top-level binder - -> TcType -- arg - -> TcM (TCvSubst, TcType) -- Extended subst, plus (fun arg) --- Precondition: the application (fun arg) is well-kinded after zonking --- That is, the application makes sense --- --- Precondition: for (mkAppTyM subst fun bndr arg) --- tcTypeKind fun = Pi bndr. body --- That is, fun always has a ForAllTy or FunTy at the top --- and 'bndr' is fun's pi-binder --- --- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type --- invariant, then so does the result type (fun arg) --- --- We do not require that --- tcTypeKind arg = tyVarKind (binderVar bndr) --- This must be true after zonking (precondition 1), but it's not --- required for the (PKTI). -mkAppTyM subst fun ki_binder arg - | -- See Note [mkAppTyM]: Nasty case 2 - TyConApp tc args <- fun - , 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 - ; let subst' = case ki_binder of - Anon {} -> subst - Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg' - ; return (subst', mkTyConApp tc (args' ++ [arg'])) } - - -mkAppTyM subst fun (Anon {}) arg - = return (subst, mk_app_ty fun arg) - -mkAppTyM subst fun (Named (Bndr tv _)) arg - = do { arg' <- if isTrickyTvBinder tv - then -- See Note [mkAppTyM]: Nasty case 1 - zonkTcType arg - else return arg - ; return ( extendTvSubstAndInScope subst tv arg' - , mk_app_ty fun arg' ) } - -mk_app_ty :: TcType -> TcType -> TcType --- This function just adds an ASSERT for mkAppTyM's precondition -mk_app_ty fun arg - = ASSERT2( isPiTy fun_kind - , ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg ) - mkAppTy fun arg - where - fun_kind = tcTypeKind fun - -isTrickyTvBinder :: TcTyVar -> Bool --- NB: isTrickyTvBinder is just an optimisation --- It would be absolutely sound to return True always -isTrickyTvBinder tv = isPiTy (tyVarKind tv) - -{- Note [The Purely Kinded Type Invariant (PKTI)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During type inference, we maintain this invariant - - (PKTI) It is legal to call 'tcTypeKind' on any Type ty, - on any sub-term of ty, /without/ zonking ty - - Moreover, any such returned kind - will itself satisfy (PKTI) - -By "legal to call tcTypeKind" we mean "tcTypeKind will not crash". -The way in which tcTypeKind can crash is in applications - (a t1 t2 .. tn) -if 'a' is a type variable whose kind doesn't have enough arrows -or foralls. (The crash is in piResultTys.) - -The loop in tcInferApps has to be very careful to maintain the (PKTI). -For example, suppose - kappa is a unification variable - We have already unified kappa := Type - yielding co :: Refl (Type -> Type) - a :: kappa -then consider the type - (a Int) -If we call tcTypeKind on that, we'll crash, because the (un-zonked) -kind of 'a' is just kappa, not an arrow kind. So we must zonk first. - -So the type inference engine is very careful when building applications. -This happens in tcInferApps. Suppose we are kind-checking the type (a Int), -where (a :: kappa). Then in tcInferApps we'll run out of binders on -a's kind, so we'll call matchExpectedFunKind, and unify - kappa := kappa1 -> kappa2, with evidence co :: kappa ~ (kappa1 ~ kappa2) -At this point we must zonk the function type to expose the arrrow, so -that (a Int) will satisfy (PKTI). - -The absence of this caused #14174 and #14520. - -The calls to mkAppTyM is the other place we are very careful. - -Note [mkAppTyM] -~~~~~~~~~~~~~~~ -mkAppTyM is trying to guarantee the Purely Kinded Type Invariant -(PKTI) for its result type (fun arg). There are two ways it can go wrong: - -* Nasty case 1: forall types (polykinds/T14174a) - T :: forall (p :: *->*). p Int -> p Bool - Now kind-check (T x), where x::kappa. - Well, T and x both satisfy the PKTI, but - T x :: x Int -> x Bool - and (x Int) does /not/ satisfy the PKTI. - -* Nasty case 2: type synonyms - type S f a = f a - Even though (S ff aa) would satisfy the (PKTI) if S was a data type - (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI) - if S is a type synonym, because the /expansion/ of (S ff aa) is - (ff aa), and /that/ does not satisfy (PKTI). E.g. perhaps - (ff :: kappa), where 'kappa' has already been unified with (*->*). - - We check for nasty case 2 on the final argument of a type synonym. - -Notice that in both cases the trickiness only happens if the -bound variable has a pi-type. Hence isTrickyTvBinder. --} - - -saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) --- Precondition for (saturateFamApp ty kind): --- tcTypeKind ty = kind --- --- If 'ty' is an unsaturated family application with trailing --- invisible arguments, instanttiate them. --- See Note [saturateFamApp] - -saturateFamApp ty kind - | Just (tc, args) <- tcSplitTyConApp_maybe ty - , mustBeSaturated tc - , let n_to_inst = tyConArity tc - length args - = do { (extra_args, ki') <- tcInstInvisibleTyBinders n_to_inst kind - ; return (ty `mkTcAppTys` extra_args, ki') } - | otherwise - = return (ty, kind) - -{- Note [saturateFamApp] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type family F :: Either j k - type instance F @Type = Right Maybe - type instance F @Type = Right Either``` - -Then F :: forall {j,k}. Either j k - -The two type instances do a visible kind application that instantiates -'j' but not 'k'. But we want to end up with instances that look like - type instance F @Type @(*->*) = Right @Type @(*->*) Maybe - -so that F has arity 2. We must instantiate that trailing invisible -binder. In general, Invisible binders precede Specified and Required, -so this is only going to bite for apparently-nullary families. - -Note that - type family F2 :: forall k. k -> * -is quite different and really does have arity 0. - -It's not just type instances where we need to saturate those -unsaturated arguments: see #11246. Hence doing this in tcInferApps. --} - -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 - - -{- ********************************************************************* -* * - checkExpectedKind -* * -********************************************************************* -} - --- | This instantiates invisible arguments for the type being checked if it must --- be saturated and is not yet saturated. It then calls and uses the result --- from checkExpectedKindX to build the final type -checkExpectedKind :: HasDebugCallStack - => HsType GhcRn -- ^ type we're checking (for printing) - -> TcType -- ^ type we're checking - -> TcKind -- ^ the known kind of that type - -> TcKind -- ^ the expected kind - -> TcM TcType --- Just a convenience wrapper to save calls to 'ppr' -checkExpectedKind hs_ty ty act_kind exp_kind - = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind) - - ; (new_args, act_kind') <- tcInstInvisibleTyBinders n_to_inst act_kind - - ; let origin = TypeEqOrigin { uo_actual = act_kind' - , uo_expected = exp_kind - , uo_thing = Just (ppr hs_ty) - , uo_visible = True } -- the hs_ty is visible - - ; traceTc "checkExpectedKindX" $ - vcat [ ppr hs_ty - , text "act_kind':" <+> ppr act_kind' - , text "exp_kind:" <+> ppr exp_kind ] - - ; let res_ty = ty `mkTcAppTys` new_args - - ; 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 - ; traceTc "checkExpectedKind" (vcat [ ppr act_kind - , ppr exp_kind - , ppr co_k ]) - ; return (res_ty `mkTcCastTy` co_k) } } - where - -- We need to make sure that both kinds have the same number of implicit - -- foralls out front. If the actual kind has more, instantiate accordingly. - -- Otherwise, just pass the type & kind through: the errors are caught - -- in unifyType. - n_exp_invis_bndrs = invisibleTyBndrCount exp_kind - n_act_invis_bndrs = invisibleTyBndrCount act_kind - n_to_inst = n_act_invis_bndrs - n_exp_invis_bndrs - ---------------------------- -tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType] -tcHsMbContext Nothing = return [] -tcHsMbContext (Just cxt) = tcHsContext cxt - -tcHsContext :: LHsContext GhcRn -> TcM [PredType] -tcHsContext = tc_hs_context typeLevelMode - -tcLHsPredType :: LHsType GhcRn -> TcM PredType -tcLHsPredType = tc_lhs_pred typeLevelMode - -tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType] -tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt) - -tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType -tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind - ---------------------------- -tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind) --- See Note [Type checking recursive type and class declarations] --- in TcTyClsDecls -tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon - = do { traceTc "lk1" (ppr name) - ; thing <- tcLookup name - ; case thing of - ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) - - ATcTyCon tc_tc - -> do { -- See Note [GADT kind self-reference] - unless (isTypeLevel (mode_level mode)) - (promotionErr name TyConPE) - ; check_tc tc_tc - ; return (mkTyConTy tc_tc, tyConKind tc_tc) } - - AGlobal (ATyCon tc) - -> do { check_tc tc - ; return (mkTyConTy tc, tyConKind tc) } - - AGlobal (AConLike (RealDataCon dc)) - -> do { data_kinds <- xoptM LangExt.DataKinds - ; unless (data_kinds || specialPromotedDc dc) $ - promotionErr name NoDataKindsDC - ; when (isFamInstTyCon (dataConTyCon dc)) $ - -- 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 () - ; let tc = promoteDataCon dc - ; return (mkTyConApp tc [], tyConKind tc) } - - APromotionErr err -> promotionErr name err - - _ -> wrongThingErr "type" thing name } - where - check_tc :: TyCon -> TcM () - check_tc tc = do { data_kinds <- xoptM LangExt.DataKinds - ; unless (isTypeLevel (mode_level mode) || - data_kinds || - isKindTyCon tc) $ - promotionErr name NoDataKindsTC } - - -- 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) - -{- -Note [GADT kind self-reference] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A promoted type cannot be used in the body of that type's declaration. -#11554 shows this example, which made GHC loop: - - import Data.Kind - data P (x :: k) = Q - data A :: Type where - B :: forall (a :: A). P a -> A - -In order to check the constructor B, we need to have the promoted type A, but in -order to get that promoted type, B must first be checked. To prevent looping, a -TyConPE promotion error is given when tcTyVar checks an ATcTyCon in kind mode. -Any ATcTyCon is a TyCon being defined in the current recursive group (see data -type decl for TcTyThing), and all such TyCons are illegal in kinds. - -#11962 proposes checking the head of a data declaration separately from -its constructors. This would allow the example above to pass. - -Note [Body kind of a HsForAllTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The body of a forall is usually a type, but in principle -there's no reason to prohibit *unlifted* types. -In fact, GHC can itself construct a function with an -unboxed tuple inside a for-all (via CPR analysis; see -typecheck/should_compile/tc170). - -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 -wrong. For example: - - class C a b - newtype N = Mk Foo deriving (C a) - -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. - -Note [Body kind of a HsQualTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If ctxt is non-empty, the HsQualTy really is a /function/, so the -kind of the result really is '*', and in that case the kind of the -body-type can be lifted or unlifted. - -However, consider - instance Eq a => Eq [a] where ... -or - f :: (Eq a => Eq [a]) => blah -Here both body-kind of the HsQualTy is Constraint rather than *. -Rather crudely we tell the difference by looking at exp_kind. It's -very convenient to typecheck instance types like any other HsSigType. - -Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's -better to reject in checkValidType. If we say that the body kind -should be '*' we risk getting TWO error messages, one saying that Eq -[a] doesn't have kind '*', and one saying that we need a Constraint to -the left of the outer (=>). - -How do we figure out the right body kind? Well, it's a bit of a -kludge: I just look at the expected kind. If it's Constraint, we -must be in this instance situation context. It's a kludge because it -wouldn't work if any unification was involved to compute that result -kind -- but it isn't. (The true way might be to use the 'mode' -parameter, but that seemed like a sledgehammer to crack a nut.) - -Note [Inferring tuple kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple, -we try to figure out whether it's a tuple of kind * or Constraint. - Step 1: look at the expected kind - Step 2: infer argument kinds - -If after Step 2 it's not clear from the arguments that it's -Constraint, then it must be *. Once having decided that we re-check -the arguments to give good error messages in - e.g. (Maybe, Maybe) - -Note that we will still fail to infer the correct kind in this case: - - type T a = ((a,a), D a) - type family D :: Constraint -> Constraint - -While kind checking T, we do not yet know the kind of D, so we will default the -kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. - -Note [Desugaring types] -~~~~~~~~~~~~~~~~~~~~~~~ -The type desugarer is phase 2 of dealing with HsTypes. Specifically: - - * It transforms from HsType to Type - - * 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 TcHsSyn. - - 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 - it will never subsequently be zonked. - -You might worry about nested scopes: - ..a:kappa in scope.. - let f :: forall b. T '[a,b] -> Int -In this case, f's type could have a mutable kind variable kappa in it; -and we might then default it to (Any *) when dealing with f's type -signature. But we don't expect this to happen because we can't get a -lexically scoped type variable with a mutable kind variable in it. A -delicate point, this. If it becomes an issue we might need to -distinguish top-level from nested uses. - -Moreover - * it cannot fail, - * it does no unifications - * it does no validity checking, except for structural matters, such as - (a) spurious ! annotations. - (b) a class used as a type - -Note [Kind of a type splice] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider these terms, each with TH type splice inside: - [| e1 :: Maybe $(..blah..) |] - [| e2 :: $(..blah..) |] -When kind-checking the type signature, we'll kind-check the splice -$(..blah..); we want to give it a kind that can fit in any context, -as if $(..blah..) :: forall k. k. - -In the e1 example, the context of the splice fixes kappa to *. But -in the e2 example, we'll desugar the type, zonking the kind unification -variables as we go. When we encounter the unconstrained kappa, we -want to default it to '*', not to (Any *). - -Help functions for type applications -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --} - -addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a - -- Wrap a context around only if we want to show that contexts. - -- Omit invisible ones and ones user's won't grok -addTypeCtxt (L _ (HsWildCardTy _)) thing = thing -- "In the type '_'" just isn't helpful. -addTypeCtxt (L _ ty) thing - = addErrCtxt doc thing - where - doc = text "In the type" <+> quotes (ppr ty) - -{- -************************************************************************ -* * - Type-variable binders -%* * -%************************************************************************ - -Note [Keeping implicitly quantified variables in order] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the user implicitly quantifies over variables (say, in a type -signature), we need to come up with some ordering on these variables. -This is done by bumping the TcLevel, bringing the tyvars into scope, -and then type-checking the thing_inside. The constraints are all -wrapped in an implication, which is then solved. Finally, we can -zonk all the binders and then order them with scopedSort. - -It's critical to solve before zonking and ordering in order to uncover -any unifications. You might worry that this eager solving could cause -trouble elsewhere. I don't think it will. Because it will solve only -in an increased TcLevel, it can't unify anything that was mentioned -elsewhere. Additionally, we require that the order of implicitly -quantified variables is manifest by the scope of these variables, so -we're not going to learn more information later that will help order -these variables. - -Note [Recipe for checking a signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Checking a user-written signature requires several steps: - - 1. Generate constraints. - 2. Solve constraints. - 3. Promote tyvars and/or kind-generalize. - 4. Zonk. - 5. Check validity. - -There may be some surprises in here: - -Step 2 is necessary for two reasons: most signatures also bring -implicitly quantified variables into scope, and solving is necessary -to get these in the right order (see Note [Keeping implicitly -quantified variables in order]). Additionally, solving is necessary in -order to kind-generalize correctly: otherwise, we do not know which -metavariables are left unsolved. - -Step 3 is done by a call to candidateQTyVarsOfType, followed by a call to -kindGeneralize{All,Some,None}. Here, we have to deal with the fact that -metatyvars generated in the type may have a bumped TcLevel, because explicit -foralls raise the TcLevel. To avoid these variables from ever being visible in -the surrounding context, we must obey the following dictum: - - Every metavariable in a type must either be - (A) generalized, or - (B) promoted, or See Note [Promotion in signatures] - (C) a cause to error See Note [Naughty quantification candidates] in TcMType - -The kindGeneralize functions do not require pre-zonking; they zonk as they -go. - -If you are actually doing kind-generalization, you need to bump the level -before generating constraints, as we will only generalize variables with -a TcLevel higher than the ambient one. - -After promoting/generalizing, we need to zonk again because both -promoting and generalizing fill in metavariables. - -Note [Promotion in signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If an unsolved metavariable in a signature is not generalized -(because we're not generalizing the construct -- e.g., pattern -sig -- or because the metavars are constrained -- see kindGeneralizeSome) -we need to promote to maintain (WantedTvInv) of Note [TcLevel and untouchable type variables] -in TcType. Note that promotion is identical in effect to generalizing -and the reinstantiating with a fresh metavariable at the current level. -So in some sense, we generalize *all* variables, but then re-instantiate -some of them. - -Here is an example of why we must promote: - foo (x :: forall a. a -> Proxy b) = ... - -In the pattern signature, `b` is unbound, and will thus be brought into -scope. We do not know its kind: it will be assigned kappa[2]. Note that -kappa is at TcLevel 2, because it is invented under a forall. (A priori, -the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel -than the surrounding context.) This kappa cannot be solved for while checking -the pattern signature (which is not kind-generalized). When we are checking -the *body* of foo, though, we need to unify the type of x with the argument -type of bar. At this point, the ambient TcLevel is 1, and spotting a -matavariable with level 2 would violate the (WantedTvInv) invariant of -Note [TcLevel and untouchable type variables]. So, instead of kind-generalizing, -we promote the metavariable to level 1. This is all done in kindGeneralizeNone. - --} - -tcNamedWildCardBinders :: [Name] - -> ([(Name, TcTyVar)] -> TcM a) - -> TcM a --- Bring into scope the /named/ wildcard binders. Remember that --- plain wildcards _ are anonymous and dealt with by HsWildCardTy --- Soe Note [The wildcard story for types] in GHC.Hs.Types -tcNamedWildCardBinders wc_names thing_inside - = do { wcs <- mapM (const newWildTyVar) wc_names - ; let wc_prs = wc_names `zip` wcs - ; tcExtendNameTyVarEnv wc_prs $ - thing_inside wc_prs } - -newWildTyVar :: TcM TcTyVar --- ^ New unification variable '_' for a wildcard -newWildTyVar - = do { kind <- newMetaKindVar - ; uniq <- newUnique - ; details <- newMetaDetails TauTv - ; let name = mkSysTvName uniq (fsLit "_") - tyvar = mkTcTyVar name kind details - ; traceTc "newWildTyVar" (ppr tyvar) - ; return tyvar } - -{- ********************************************************************* -* * - Kind inference for type declarations -* * -********************************************************************* -} - --- See Note [kcCheckDeclHeader vs kcInferDeclHeader] -data InitialKindStrategy - = InitialKindCheck SAKS_or_CUSK - | InitialKindInfer - --- Does the declaration have a standalone kind signature (SAKS) or a complete --- user-specified kind (CUSK)? -data SAKS_or_CUSK - = SAKS Kind -- Standalone kind signature, fully zonked! (zonkTcTypeToType) - | CUSK -- Complete user-specified kind (CUSK) - -instance Outputable SAKS_or_CUSK where - ppr (SAKS k) = text "SAKS" <+> ppr k - ppr CUSK = text "CUSK" - --- 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 -kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig -kcDeclHeader InitialKindInfer = kcInferDeclHeader - -{- Note [kcCheckDeclHeader vs kcInferDeclHeader] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind -of a type constructor. - -* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that - case, find the full, final, poly-kinded kind of the TyCon. It's very like a - term-level binding where we have a complete type signature for the function. - -* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a - CUSK. Find a monomorphic kind, with unification variables in it; they will be - generalised later. It's very like a term-level binding where we do not have a - type signature (or, more accurately, where we have a partial type signature), - so we infer the type and generalise. --} - ------------------------------- -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 TcTyCon -- ^ 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 TcTyCon -- ^ A suitably-kinded generalized TcTyCon -kcCheckDeclHeader_cusk name flav - (HsQTvs { hsq_ext = kv_ns - , hsq_explicit = hs_tvs }) kc_res_ki - -- CUSK case - -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls - = addTyConFlavCtxt name flav $ - do { (scoped_kvs, (tc_tvs, res_kind)) - <- pushTcLevelM_ $ - solveEqualities $ - bindImplicitTKBndrs_Q_Skol kv_ns $ - bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $ - newExpectedKind =<< kc_res_ki - - -- Now, because we're in a CUSK, - -- we quantify over the mentioned kind vars - ; let spec_req_tkvs = scoped_kvs ++ tc_tvs - all_kinds = res_kind : map tyVarKind spec_req_tkvs - - ; candidates' <- candidateQTyVarsOfKinds all_kinds - -- 'candidates' are all the variables that we are going to - -- skolemise and then quantify over. We do not include spec_req_tvs - -- because they are /already/ skolems - - ; let non_tc_candidates = filter (not . isTcTyVar) (nonDetEltsUniqSet (tyCoVarsOfTypes all_kinds)) - candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates } - inf_candidates = candidates `delCandidates` spec_req_tkvs - - ; inferred <- quantifyTyVars inf_candidates - -- NB: 'inferred' comes back sorted in dependency order - - ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs - ; tc_tvs <- mapM zonkTyCoVarKind tc_tvs - ; res_kind <- zonkTcType res_kind - - ; let mentioned_kv_set = candidateKindVars candidates - specified = scopedSort scoped_kvs - -- NB: maintain the L-R order of scoped_kvs - - final_tc_binders = mkNamedTyConBinders Inferred inferred - ++ mkNamedTyConBinders Specified specified - ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs - - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) - tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs - True -- it is generalised - flav - -- If the ordering from - -- Note [Required, Specified, and Inferred for types] in TcTyClsDecls - -- doesn't work, we catch it here, before an error cascade - ; checkTyConTelescope tycon - - ; traceTc "kcCheckDeclHeader_cusk " $ - vcat [ text "name" <+> ppr name - , text "kv_ns" <+> ppr kv_ns - , text "hs_tvs" <+> ppr hs_tvs - , text "scoped_kvs" <+> ppr scoped_kvs - , text "tc_tvs" <+> ppr tc_tvs - , text "res_kind" <+> ppr res_kind - , text "candidates" <+> ppr candidates - , text "inferred" <+> ppr inferred - , text "specified" <+> ppr specified - , text "final_tc_binders" <+> ppr final_tc_binders - , text "mkTyConKind final_tc_bndrs res_kind" - <+> ppr (mkTyConKind final_tc_binders res_kind) - , text "all_tv_prs" <+> ppr all_tv_prs ] - - ; return tycon } - where - ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind - | otherwise = AnyKind -kcCheckDeclHeader_cusk _ _ (XLHsQTyVars nec) _ = noExtCon nec - --- | 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 - -> LHsQTyVars GhcRn - -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded non-generalized TcTyCon -kcInferDeclHeader name flav - (HsQTvs { hsq_ext = kv_ns - , hsq_explicit = hs_tvs }) kc_res_ki - -- No standalane kind signature and no CUSK. - -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls - = addTyConFlavCtxt name flav $ - do { (scoped_kvs, (tc_tvs, res_kind)) - -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar? - -- See Note [Inferring kinds for type declarations] in TcTyClsDecls - <- bindImplicitTKBndrs_Q_Tv kv_ns $ - bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $ - newExpectedKind =<< kc_res_ki - -- Why "_Tv" not "_Skol"? See third wrinkle in - -- Note [Inferring kinds for type declarations] in TcTyClsDecls, - - ; let -- NB: Don't add scoped_kvs to tyConTyVars, because they - -- might unify with kind vars in other types in a mutually - -- recursive group. - -- See Note [Inferring kinds for type declarations] in TcTyClsDecls - - tc_binders = mkAnonTyConBinders VisArg tc_tvs - -- Also, note that tc_binders has the tyvars from only the - -- user-written tyvarbinders. See S1 in Note [How TcTyCons work] - -- in TcTyClsDecls - -- - -- mkAnonTyConBinder: see Note [No polymorphic recursion] - - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) - -- NB: bindExplicitTKBndrs_Q_Tv does not clone; - -- ditto Implicit - -- See Note [Non-cloning for tyvar binders] - - tycon = mkTcTyCon name tc_binders res_kind all_tv_prs - False -- not yet generalised - flav - - ; traceTc "kcInferDeclHeader: not-cusk" $ - vcat [ ppr name, ppr kv_ns, ppr hs_tvs - , ppr scoped_kvs - , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ] - ; return tycon } - where - ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind - | otherwise = AnyKind - -kcInferDeclHeader _ _ (XLHsQTyVars nec) _ = noExtCon nec - --- | Kind-check a declaration header against a standalone kind signature. --- See Note [Arity inference in 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 TcTyCon -- ^ A suitably-kinded TcTyCon -kcCheckDeclHeader_sig kisig name flav - (HsQTvs { hsq_ext = implicit_nms - , hsq_explicit = explicit_nms }) kc_res_ki - = addTyConFlavCtxt name flav $ - do { -- Step 1: zip user-written binders with quantifiers from the kind signature. - -- For example: - -- - -- type F :: forall k -> k -> forall j. j -> Type - -- data F i a b = ... - -- - -- Results in the following 'zipped_binders': - -- - -- TyBinder LHsTyVarBndr - -- --------------------------------------- - -- ZippedBinder forall k -> i - -- ZippedBinder k -> a - -- ZippedBinder forall j. - -- ZippedBinder j -> b - -- - let (zipped_binders, excess_bndrs, kisig') = zipBinders kisig explicit_nms - - -- Report binders that don't have a corresponding quantifier. - -- For example: - -- - -- type T :: Type -> Type - -- data T b1 b2 b3 = ... - -- - -- Here, b1 is zipped with Type->, while b2 and b3 are excess binders. - -- - ; unless (null excess_bndrs) $ failWithTc (tooManyBindersErr kisig' excess_bndrs) - - -- Convert each ZippedBinder to TyConBinder for tyConBinders - -- and to [(Name, TcTyVar)] for tcTyConScopedTyVars - ; (vis_tcbs, concat -> explicit_tv_prs) <- mapAndUnzipM zipped_to_tcb zipped_binders - - ; (implicit_tvs, (invis_binders, r_ki)) - <- pushTcLevelM_ $ - solveEqualities $ -- #16687 - bindImplicitTKBndrs_Tv implicit_nms $ - tcExtendNameTyVarEnv explicit_tv_prs $ - do { -- Check that inline kind annotations on binders are valid. - -- For example: - -- - -- type T :: Maybe k -> Type - -- data T (a :: Maybe j) = ... - -- - -- Here we unify Maybe k ~ Maybe j - mapM_ check_zipped_binder zipped_binders - - -- 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'. - ; ctx_k <- kc_res_ki - ; m_res_ki <- case ctx_k of - AnyKind -> return Nothing - _ -> Just <$> newExpectedKind ctx_k - - -- Step 2: split off invisible binders. - -- For example: - -- - -- type F :: forall k1 k2. (k1, k2) -> Type - -- type family F - -- - -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'? - -- See Note [Arity inference in kcCheckDeclHeader_sig] - ; let (invis_binders, r_ki) = split_invis kisig' m_res_ki - - -- Check that the inline result kind annotation is valid. - -- For example: - -- - -- type T :: Type -> Maybe k - -- type family T a :: Maybe j where - -- - -- Here we unify Maybe k ~ Maybe j - ; whenIsJust m_res_ki $ \res_ki -> - discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] - unifyKind Nothing r_ki res_ki - - ; return (invis_binders, r_ki) } - - -- Zonk the implicitly quantified variables. - ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs - - -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders. - ; invis_tcbs <- mapM invis_to_tcb invis_binders - - -- Build the final, generalized TcTyCon - ; let tcbs = vis_tcbs ++ invis_tcbs - implicit_tv_prs = implicit_nms `zip` implicit_tvs - all_tv_prs = implicit_tv_prs ++ explicit_tv_prs - tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav - - ; traceTc "kcCheckDeclHeader_sig done:" $ vcat - [ text "tyConName = " <+> ppr (tyConName tc) - , text "kisig =" <+> debugPprType kisig - , text "tyConKind =" <+> debugPprType (tyConKind tc) - , text "tyConBinders = " <+> ppr (tyConBinders tc) - , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc) - , text "tyConResKind" <+> debugPprType (tyConResKind tc) - ] - ; return tc } - where - -- Consider this declaration: - -- - -- type T :: forall a. forall b -> (a~b) => Proxy a -> Type - -- data T x p = MkT - -- - -- Here, we have every possible variant of ZippedBinder: - -- - -- TyBinder LHsTyVarBndr - -- ---------------------------------------------- - -- ZippedBinder forall {k}. - -- ZippedBinder forall (a::k). - -- ZippedBinder forall (b::k) -> x - -- ZippedBinder (a~b) => - -- ZippedBinder Proxy a -> p - -- - -- Given a ZippedBinder zipped_to_tcb produces: - -- - -- * TyConBinder for tyConBinders - -- * (Name, TcTyVar) for tcTyConScopedTyVars, if there's a user-written LHsTyVarBndr - -- - zipped_to_tcb :: ZippedBinder -> TcM (TyConBinder, [(Name, TcTyVar)]) - zipped_to_tcb zb = case zb of - - -- Inferred variable, no user-written binder. - -- Example: forall {k}. - ZippedBinder (Named (Bndr v Specified)) Nothing -> - return (mkNamedTyConBinder Specified v, []) - - -- Specified variable, no user-written binder. - -- Example: forall (a::k). - ZippedBinder (Named (Bndr v Inferred)) Nothing -> - return (mkNamedTyConBinder Inferred v, []) - - -- Constraint, no user-written binder. - -- Example: (a~b) => - ZippedBinder (Anon InvisArg bndr_ki) Nothing -> do - name <- newSysName (mkTyVarOccFS (fsLit "ev")) - let tv = mkTyVar name bndr_ki - return (mkAnonTyConBinder InvisArg tv, []) - - -- Non-dependent visible argument with a user-written binder. - -- Example: Proxy a -> - ZippedBinder (Anon VisArg bndr_ki) (Just b) -> - return $ - let v_name = getName b - tv = mkTyVar v_name bndr_ki - tcb = mkAnonTyConBinder VisArg tv - in (tcb, [(v_name, tv)]) - - -- Dependent visible argument with a user-written binder. - -- Example: forall (b::k) -> - ZippedBinder (Named (Bndr v Required)) (Just b) -> - return $ - let v_name = getName b - tcb = mkNamedTyConBinder Required v - in (tcb, [(v_name, v)]) - - -- 'zipBinders' does not produce any other variants of ZippedBinder. - _ -> panic "goVis: invalid ZippedBinder" - - -- Given an invisible binder that comes from 'split_invis', - -- convert it to TyConBinder. - invis_to_tcb :: TyCoBinder -> TcM TyConBinder - invis_to_tcb tb = do - (tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing) - MASSERT(null stv) - return tcb - - -- Check that the inline kind annotation on a binder is valid - -- by unifying it with the kind of the quantifier. - check_zipped_binder :: ZippedBinder -> TcM () - check_zipped_binder (ZippedBinder _ Nothing) = return () - check_zipped_binder (ZippedBinder tb (Just b)) = - case unLoc b of - UserTyVar _ _ -> return () - KindedTyVar _ v v_hs_ki -> do - v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki - discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] - unifyKind (Just (HsTyVar noExtField NotPromoted v)) - (tyBinderType tb) - v_ki - XTyVarBndr nec -> noExtCon nec - - -- Split the invisible binders that should become a part of 'tyConBinders' - -- rather than 'tyConResKind'. - -- See Note [Arity inference in kcCheckDeclHeader_sig] - split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind) - split_invis sig_ki Nothing = - -- instantiate all invisible binders - splitPiTysInvisible sig_ki - split_invis sig_ki (Just res_ki) = - -- subtraction a la checkExpectedKind - let n_res_invis_bndrs = invisibleTyBndrCount res_ki - n_sig_invis_bndrs = invisibleTyBndrCount sig_ki - n_inst = n_sig_invis_bndrs - n_res_invis_bndrs - in splitPiTysInvisibleN n_inst sig_ki - -kcCheckDeclHeader_sig _ _ _ (XLHsQTyVars nec) _ = noExtCon nec - --- A quantifier from a kind signature zipped with a user-written binder for it. -data ZippedBinder = - ZippedBinder TyBinder (Maybe (LHsTyVarBndr GhcRn)) - --- See Note [Arity inference in kcCheckDeclHeader_sig] -zipBinders - :: Kind -- kind signature - -> [LHsTyVarBndr GhcRn] -- user-written binders - -> ([ZippedBinder], -- zipped binders - [LHsTyVarBndr GhcRn], -- remaining user-written binders - Kind) -- remainder of the kind signature -zipBinders = zip_binders [] - where - zip_binders acc ki [] = (reverse acc, [], ki) - zip_binders acc ki (b:bs) = - case tcSplitPiTy_maybe ki of - Nothing -> (reverse acc, b:bs, ki) - Just (tb, ki') -> - let - (zb, bs') | zippable = (ZippedBinder tb (Just b), bs) - | otherwise = (ZippedBinder tb Nothing, b:bs) - zippable = - case tb of - Named (Bndr _ Specified) -> False - Named (Bndr _ Inferred) -> False - Named (Bndr _ Required) -> True - Anon InvisArg _ -> False - Anon VisArg _ -> True - in - zip_binders (zb:acc) ki' bs' - -tooManyBindersErr :: Kind -> [LHsTyVarBndr GhcRn] -> SDoc -tooManyBindersErr ki bndrs = - hang (text "Not a function kind:") - 4 (ppr ki) $$ - hang (text "but extra binders found:") - 4 (fsep (map ppr bndrs)) - -{- Note [Arity inference in kcCheckDeclHeader_sig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig -verifies that the declaration conforms to the signature. The end result is a -TcTyCon 'tc' such that: - - tyConKind tc == kisig - -This TcTyCon would be rather easy to produce if we didn't have to worry about -arity. Consider these declarations: - - type family S1 :: forall k. k -> Type - type family S2 (a :: k) :: Type - -Both S1 and S2 can be given the same standalone kind signature: - - type S2 :: forall k. k -> Type - -And, indeed, tyConKind S1 == tyConKind S2. However, tyConKind is built from -tyConBinders and tyConResKind, such that - - tyConKind tc == mkTyConKind (tyConBinders tc) (tyConResKind tc) - -For S1 and S2, tyConBinders and tyConResKind are different: - - tyConBinders S1 == [] - tyConResKind S1 == forall k. k -> Type - tyConKind S1 == forall k. k -> Type - - tyConBinders S2 == [spec k, anon-vis (a :: k)] - tyConResKind S2 == Type - tyConKind S1 == forall k. k -> Type - -This difference determines the arity: - - tyConArity tc == length (tyConBinders tc) - -That is, the arity of S1 is 0, while the arity of S2 is 2. - -'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone -kind signature into binders and the result kind. It does so in two rounds: - -1. zip user-written binders (vis_tcbs) -2. split off invisible binders (invis_tcbs) - -Consider the following declarations: - - type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type - type family F a b - - type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type - type family G a b :: forall r2. (r1, r2) -> Type - -In step 1 (zip user-written binders), we zip the quantifiers in the signature -with the binders in the header using 'zipBinders'. In both F and G, this results in -the following zipped binders: - - TyBinder LHsTyVarBndr - --------------------------------------- - ZippedBinder Type -> a - ZippedBinder forall j. - ZippedBinder j -> b - - -At this point, we have accumulated three zipped binders which correspond to a -prefix of the standalone kind signature: - - Type -> forall j. j -> ... - -In step 2 (split off invisible binders), we have to decide how much remaining -invisible binders of the standalone kind signature to split off: - - forall k1 k2. (k1, k2) -> Type - ^^^^^^^^^^^^^ - split off or not? - -This decision is made in 'split_invis': - -* If a user-written result kind signature is not provided, as in F, - then split off all invisible binders. This is why we need special treatment - for AnyKind. -* If a user-written result kind signature is provided, as in G, - then do as checkExpectedKind does and split off (n_sig - n_res) binders. - That is, split off such an amount of binders that the remainder of the - standalone kind signature and the user-written result kind signature have the - same amount of invisible quantifiers. - -For F, split_invis splits away all invisible binders, and we have 2: - - forall k1 k2. (k1, k2) -> Type - ^^^^^^^^^^^^^ - split away both binders - -The resulting arity of F is 3+2=5. (length vis_tcbs = 3, - length invis_tcbs = 2, - length tcbs = 5) - -For G, split_invis decides to split off 1 invisible binder, so that we have the -same amount of invisible quantifiers left: - - res_ki = forall r2. (r1, r2) -> Type - kisig = forall k1 k2. (k1, k2) -> Type - ^^^ - split off this one. - -The resulting arity of G is 3+1=4. (length vis_tcbs = 3, - length invis_tcbs = 1, - length tcbs = 4) - --} - -{- Note [discardResult in kcCheckDeclHeader_sig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use 'unifyKind' to check inline kind annotations in declaration headers -against the signature. - - type T :: [i] -> Maybe j -> Type - data T (a :: [k1]) (b :: Maybe k2) :: Type where ... - -Here, we will unify: - - [k1] ~ [i] - Maybe k2 ~ Maybe j - Type ~ Type - -The end result is that we fill in unification variables k1, k2: - - k1 := i - k2 := j - -We also validate that the user isn't confused: - - type T :: Type -> Type - data T (a :: Bool) = ... - -This will report that (Type ~ Bool) failed to unify. - -Now, consider the following example: - - type family Id a where Id x = x - type T :: Bool -> Type - type T (a :: Id Bool) = ... - -We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion. -However, we are free to discard it, as the kind of 'T' is determined by the -signature, not by the inline kind annotation: - - we have T :: Bool -> Type - rather than T :: Id Bool -> Type - -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-checking tyvar binders for associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When kind-checking the type-variable binders for associated - data/newtype decls - family decls -we behave specially for type variables that are already in scope; -that is, bound by the enclosing class decl. This is done in -kcLHsQTyVarBndrs: - * The use of tcImplicitQTKBndrs - * The tcLookupLocal_maybe code in kc_hs_tv - -See Note [Associated type tyvar names] in GHC.Core.Class and - Note [TyVar binders for associated decls] in GHC.Hs.Decls - -We must do the same for family instance decls, where the in-scope -variables may be bound by the enclosing class instance decl. -Hence the use of tcImplicitQTKBndrs in tcFamTyPatsAndGen. - -Note [Kind variable ordering for associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should be the kind of `T` in the following example? (#15591) - - class C (a :: Type) where - type T (x :: f a) - -As per Note [Ordering of implicit variables] in GHC.Rename.Types, we want to quantify -the kind variables in left-to-right order of first occurrence in order to -support visible kind application. But we cannot perform this analysis on just -T alone, since its variable `a` actually occurs /before/ `f` if you consider -the fact that `a` was previously bound by the parent class `C`. That is to say, -the kind of `T` should end up being: - - T :: forall a f. f a -> Type - -(It wouldn't necessarily be /wrong/ if the kind ended up being, say, -forall f a. f a -> Type, but that would not be as predictable for users of -visible kind application.) - -In contrast, if `T` were redefined to be a top-level type family, like `T2` -below: - - type family T2 (x :: f (a :: Type)) - -Then `a` first appears /after/ `f`, so the kind of `T2` should be: - - T2 :: forall f a. f a -> Type - -In order to make this distinction, we need to know (in kcCheckDeclHeader) which -type variables have been bound by the parent class (if there is one). With -the class-bound variables in hand, we can ensure that we always quantify -these first. --} - - -{- ********************************************************************* -* * - Expected kinds -* * -********************************************************************* -} - --- | Describes the kind expected in a certain context. -data ContextKind = TheKind Kind -- ^ a specific kind - | AnyKind -- ^ any kind will do - | OpenKind -- ^ something of the form @TYPE _@ - ------------------------ -newExpectedKind :: ContextKind -> TcM Kind -newExpectedKind (TheKind k) = return k -newExpectedKind AnyKind = newMetaKindVar -newExpectedKind OpenKind = newOpenTypeKind - ------------------------ -expectedKindInCtxt :: UserTypeCtxt -> ContextKind --- Depending on the context, we might accept any kind (for instance, in a TH --- splice), or only certain kinds (like in type signatures). -expectedKindInCtxt (TySynCtxt _) = AnyKind -expectedKindInCtxt ThBrackCtxt = AnyKind -expectedKindInCtxt (GhciCtxt {}) = AnyKind --- The types in a 'default' decl can have varying kinds --- See Note [Extended defaults]" in TcEnv -expectedKindInCtxt DefaultDeclCtxt = AnyKind -expectedKindInCtxt TypeAppCtxt = AnyKind -expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind -expectedKindInCtxt (InstDeclCtxt {}) = TheKind constraintKind -expectedKindInCtxt SpecInstCtxt = TheKind constraintKind -expectedKindInCtxt _ = OpenKind - - -{- ********************************************************************* -* * - Bringing type variables into scope -* * -********************************************************************* -} - -{- Note [Non-cloning for tyvar binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -bindExplictTKBndrs_Q_Skol, bindExplictTKBndrs_Skol, do not clone; -and nor do the Implicit versions. There is no need. - -bindExplictTKBndrs_Q_Tv does not clone; and similarly Implicit. -We take advantage of this in kcInferDeclHeader: - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) -If we cloned, we'd need to take a bit more care here; not hard. - -The main payoff is that avoidng gratuitious cloning means that we can -almost always take the fast path in swizzleTcTyConBndrs. "Almost -always" means not the case of mutual recursion with polymorphic kinds. - - -Note [Cloning for tyvar binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -bindExplicitTKBndrs_Tv does cloning, making up a Name with a fresh Unique, -unlike bindExplicitTKBndrs_Q_Tv. (Nor do the Skol variants clone.) -And similarly for bindImplicit... - -This for a narrow and tricky reason which, alas, I couldn't find a -simpler way round. #16221 is the poster child: - - data SameKind :: k -> k -> * - data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int - -When kind-checking T, we give (a :: kappa1). Then: - -- In kcConDecl we make a TyVarTv unification variable kappa2 for k2 - (as described in Note [Kind-checking for GADTs], even though this - example is an existential) -- So we get (b :: kappa2) via bindExplicitTKBndrs_Tv -- We end up unifying kappa1 := kappa2, because of the (SameKind a b) - -Now we generalise over kappa2. But if kappa2's Name is precisely k2 -(i.e. we did not clone) we'll end up giving T the utterlly final kind - T :: forall k2. k2 -> * -Nothing directly wrong with that but when we typecheck the data constructor -we have k2 in scope; but then it's brought into scope /again/ when we find -the forall k2. This is chaotic, and we end up giving it the type - MkT :: forall k2 (a :: k2) k2 (b :: k2). - SameKind @k2 a b -> Int -> T @{k2} a -which is bogus -- because of the shadowing of k2, we can't -apply T to the kind or a! - -And there no reason /not/ to clone the Name when making a unification -variable. So that's what we do. --} - --------------------------------------- --- Implicit binders --------------------------------------- - -bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv, - bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv - :: [Name] -> TcM a -> TcM ([TcTyVar], a) -bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedSkolemTyVar) -bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedTyVarTyVar) -bindImplicitTKBndrs_Skol = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar -bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX cloneFlexiKindedTyVarTyVar - -- newFlexiKinded... see Note [Non-cloning for tyvar binders] - -- cloneFlexiKindedTyVarTyVar: see Note [Cloning for tyvar binders] - -bindImplicitTKBndrsX - :: (Name -> TcM TcTyVar) -- new_tv function - -> [Name] - -> TcM a - -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence - -- with the passed in [Name] -bindImplicitTKBndrsX new_tv tv_names thing_inside - = do { tkvs <- mapM new_tv tv_names - ; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs) - ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs) - thing_inside - ; return (tkvs, res) } - -newImplicitTyVarQ :: (Name -> TcM TcTyVar) -> Name -> TcM TcTyVar --- Behave like new_tv, except that if the tyvar is in scope, use it -newImplicitTyVarQ new_tv name - = do { mb_tv <- tcLookupLcl_maybe name - ; case mb_tv of - Just (ATyVar _ tv) -> return tv - _ -> new_tv name } - -newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar -newFlexiKindedTyVar new_tv name - = do { kind <- newMetaKindVar - ; new_tv name kind } - -newFlexiKindedSkolemTyVar :: Name -> TcM TyVar -newFlexiKindedSkolemTyVar = newFlexiKindedTyVar newSkolemTyVar - -newFlexiKindedTyVarTyVar :: Name -> TcM TyVar -newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar - -cloneFlexiKindedTyVarTyVar :: Name -> TcM TyVar -cloneFlexiKindedTyVarTyVar = newFlexiKindedTyVar cloneTyVarTyVar - -- See Note [Cloning for tyvar binders] - --------------------------------------- --- Explicit binders --------------------------------------- - -bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv - :: [LHsTyVarBndr GhcRn] - -> TcM a - -> TcM ([TcTyVar], a) - -bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar) -bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (tcHsTyVarBndr cloneTyVarTyVar) - -- newSkolemTyVar: see Note [Non-cloning for tyvar binders] - -- cloneTyVarTyVar: see Note [Cloning for tyvar binders] - -bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv - :: ContextKind - -> [LHsTyVarBndr GhcRn] - -> TcM a - -> TcM ([TcTyVar], a) - -bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar) -bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar) - -- See Note [Non-cloning for tyvar binders] - - -bindExplicitTKBndrsX - :: (HsTyVarBndr GhcRn -> TcM TcTyVar) - -> [LHsTyVarBndr GhcRn] - -> TcM a - -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence - -- with the passed-in [LHsTyVarBndr] -bindExplicitTKBndrsX tc_tv hs_tvs thing_inside - = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs) - ; go hs_tvs } - where - go [] = do { res <- thing_inside - ; return ([], res) } - go (L _ hs_tv : hs_tvs) - = do { tv <- tc_tv hs_tv - -- Extend the environment as we go, in case a binder - -- is mentioned in the kind of a later binder - -- e.g. forall k (a::k). blah - -- NB: tv's Name may differ from hs_tv's - -- See TcMType Note [Cloning for tyvar binders] - ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $ - go hs_tvs - ; return (tv:tvs, res) } - ------------------ -tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar) - -> HsTyVarBndr GhcRn -> TcM TcTyVar -tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm)) - = do { kind <- newMetaKindVar - ; new_tv tv_nm kind } -tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) - = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind - ; new_tv tv_nm kind } -tcHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec - ------------------ -tcHsQTyVarBndr :: ContextKind - -> (Name -> Kind -> TcM TyVar) - -> HsTyVarBndr GhcRn -> TcM TcTyVar --- Just like tcHsTyVarBndr, but also --- - uses the in-scope TyVar from class, if it exists --- - takes a ContextKind to use for the no-sig case -tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ (L _ tv_nm)) - = do { mb_tv <- tcLookupLcl_maybe tv_nm - ; case mb_tv of - Just (ATyVar _ tv) -> return tv - _ -> do { kind <- newExpectedKind ctxt_kind - ; new_tv tv_nm kind } } - -tcHsQTyVarBndr _ new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) - = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind - ; mb_tv <- tcLookupLcl_maybe tv_nm - ; case mb_tv of - Just (ATyVar _ tv) - -> do { discardResult $ unifyKind (Just hs_tv) - kind (tyVarKind tv) - -- This unify rejects: - -- class C (m :: * -> *) where - -- type F (m :: *) = ... - ; return tv } - - _ -> new_tv tv_nm kind } - where - hs_tv = HsTyVar noExtField NotPromoted (noLoc tv_nm) - -- Used for error messages only - -tcHsQTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec - --------------------------------------- --- Binding type/class variables in the --- kind-checking and typechecking phases --------------------------------------- - -bindTyClTyVars :: Name - -> (TcTyCon -> [TyConBinder] -> Kind -> TcM a) -> TcM a --- ^ Used for the type variables of a type or class decl --- in the "kind checking" and "type checking" pass, --- but not in the initial-kind run. -bindTyClTyVars tycon_name thing_inside - = do { tycon <- tcLookupTcTyCon tycon_name - ; let scoped_prs = tcTyConScopedTyVars tycon - res_kind = tyConResKind tycon - binders = tyConBinders tycon - ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs) - ; tcExtendNameTyVarEnv scoped_prs $ - thing_inside tycon binders res_kind } - - -{- ********************************************************************* -* * - Kind generalisation -* * -********************************************************************* -} - -zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] -zonkAndScopedSort spec_tkvs - = do { spec_tkvs <- mapM zonkAndSkolemise spec_tkvs - -- Use zonkAndSkolemise because a skol_tv might be a TyVarTv - - -- Do a stable topological sort, following - -- Note [Ordering of implicit variables] in GHC.Rename.Types - ; return (scopedSort spec_tkvs) } - --- | Generalize some of the free variables in the given type. --- All such variables should be *kind* variables; any type variables --- should be explicitly quantified (with a `forall`) before now. --- The supplied predicate says which free variables to quantify. --- But in all cases, --- generalize only those variables whose TcLevel is strictly greater --- than the ambient level. This "strictly greater than" means that --- you likely need to push the level before creating whatever type --- gets passed here. Any variable whose level is greater than the --- ambient level but is not selected to be generalized will be --- promoted. (See [Promoting unification variables] in TcSimplify --- and Note [Recipe for checking a signature].) --- The resulting KindVar are the variables to --- quantify over, in the correct, well-scoped order. They should --- generally be Inferred, not Specified, but that's really up to --- the caller of this function. -kindGeneralizeSome :: (TcTyVar -> Bool) - -> TcType -- ^ needn't be zonked - -> TcM [KindVar] -kindGeneralizeSome should_gen kind_or_type - = do { traceTc "kindGeneralizeSome {" (ppr kind_or_type) - - -- use the "Kind" variant here, as any types we see - -- here will already have all type variables quantified; - -- thus, every free variable is really a kv, never a tv. - ; dvs <- candidateQTyVarsOfKind kind_or_type - - -- So 'dvs' are the variables free in kind_or_type, with a level greater - -- than the ambient level, hence candidates for quantification - -- Next: filter out the ones we don't want to generalize (specified by should_gen) - -- and promote them instead - - ; let (to_promote, dvs') = partitionCandidates dvs (not . should_gen) - - ; (_, promoted) <- promoteTyVarSet (dVarSetToVarSet to_promote) - ; qkvs <- quantifyTyVars dvs' - - ; traceTc "kindGeneralizeSome }" $ - vcat [ text "Kind or type:" <+> ppr kind_or_type - , text "dvs:" <+> ppr dvs - , text "dvs':" <+> ppr dvs' - , text "to_promote:" <+> pprTyVars (dVarSetElems to_promote) - , text "promoted:" <+> pprTyVars (nonDetEltsUniqSet promoted) - , text "qkvs:" <+> pprTyVars qkvs ] - - ; return qkvs } - --- | Specialized version of 'kindGeneralizeSome', but where all variables --- can be generalized. Use this variant when you can be sure that no more --- constraints on the type's metavariables will arise or be solved. -kindGeneralizeAll :: TcType -- needn't be zonked - -> TcM [KindVar] -kindGeneralizeAll ty = do { traceTc "kindGeneralizeAll" empty - ; kindGeneralizeSome (const True) ty } - --- | Specialized version of 'kindGeneralizeSome', but where no variables --- can be generalized. Use this variant when it is unknowable whether metavariables --- might later be constrained. --- See Note [Recipe for checking a signature] for why and where this --- function is needed. -kindGeneralizeNone :: TcType -- needn't be zonked - -> TcM () -kindGeneralizeNone ty - = do { traceTc "kindGeneralizeNone" empty - ; kvs <- kindGeneralizeSome (const False) ty - ; MASSERT( null kvs ) - } - -{- Note [Levels and generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = e -with no type signature. We are currently at level i. -We must - * Push the level to level (i+1) - * Allocate a fresh alpha[i+1] for the result type - * Check that e :: alpha[i+1], gathering constraint WC - * Solve WC as far as possible - * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i] - * Find the free variables with level > i, in this case gamma[i] - * Skolemise those free variables and quantify over them, giving - f :: forall g. beta[i-1] -> g - * Emit the residiual constraint wrapped in an implication for g, - thus forall g. WC - -All of this happens for types too. Consider - f :: Int -> (forall a. Proxy a -> Int) - -Note [Kind generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do kind generalisation only at the outer level of a type signature. -For example, consider - T :: forall k. k -> * - f :: (forall a. T a -> Int) -> Int -When kind-checking f's type signature we generalise the kind at -the outermost level, thus: - f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES! -and *not* at the inner forall: - f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO! -Reason: same as for HM inference on value level declarations, -we want to infer the most general type. The f2 type signature -would be *less applicable* than f1, because it requires a more -polymorphic argument. - -NB: There are no explicit kind variables written in f's signature. -When there are, the renamer adds these kind variables to the list of -variables bound by the forall, so you can indeed have a type that's -higher-rank in its kind. But only by explicit request. - -Note [Kinds of quantified type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcTyVarBndrsGen quantifies over a specified list of type variables, -*and* over the kind variables mentioned in the kinds of those tyvars. - -Note that we must zonk those kinds (obviously) but less obviously, we -must return type variables whose kinds are zonked too. Example - (a :: k7) where k7 := k9 -> k9 -We must return - [k9, a:k9->k9] -and NOT - [k9, a:k7] -Reason: we're going to turn this into a for-all type, - forall k9. forall (a:k7). blah -which the type checker will then instantiate, and instantiate does not -look through unification variables! - -Hence using zonked_kinds when forming tvs'. - --} - ------------------------------------ -etaExpandAlgTyCon :: [TyConBinder] - -> Kind -- must be zonked - -> TcM ([TyConBinder], Kind) --- GADT decls can have a (perhaps partial) kind signature --- e.g. data T a :: * -> * -> * where ... --- This function makes up suitable (kinded) TyConBinders for the --- argument kinds. E.g. in this case it might return --- ([b::*, c::*], *) --- Never emits constraints. --- It's a little trickier than you might think: see --- Note [TyConBinders for the result kind signature of a data type] --- See Note [Datatype return kinds] in TcTyClsDecls -etaExpandAlgTyCon tc_bndrs kind - = do { loc <- getSrcSpanM - ; uniqs <- newUniqueSupply - ; rdr_env <- getLocalRdrEnv - ; let new_occs = [ occ - | str <- allNameStrings - , let occ = mkOccName tvName str - , isNothing (lookupLocalRdrOcc rdr_env occ) - -- Note [Avoid name clashes for associated data types] - , not (occ `elem` lhs_occs) ] - new_uniqs = uniqsFromSupply uniqs - subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs)) - ; return (go loc new_occs new_uniqs subst [] kind) } - where - lhs_tvs = map binderVar tc_bndrs - lhs_occs = map getOccName lhs_tvs - - go loc occs uniqs subst acc kind - = case splitPiTy_maybe kind of - Nothing -> (reverse acc, substTy subst kind) - - Just (Anon af arg, kind') - -> go loc occs' uniqs' subst' (tcb : acc) kind' - where - arg' = substTy subst arg - tv = mkTyVar (mkInternalName uniq occ loc) arg' - subst' = extendTCvInScope subst tv - tcb = Bndr tv (AnonTCB af) - (uniq:uniqs') = uniqs - (occ:occs') = occs - - Just (Named (Bndr tv vis), kind') - -> go loc occs uniqs subst' (tcb : acc) kind' - where - (subst', tv') = substTyVarBndr subst tv - tcb = Bndr tv' (NamedTCB vis) - --- | A description of whether something is a --- --- * @data@ or @newtype@ ('DataDeclSort') --- --- * @data instance@ or @newtype instance@ ('DataInstanceSort') --- --- * @data family@ ('DataFamilySort') --- --- At present, this data type is only consumed by 'checkDataKindSig'. -data DataSort - = DataDeclSort NewOrData - | DataInstanceSort NewOrData - | DataFamilySort - --- | Checks that the return kind in a data declaration's kind signature is --- permissible. There are three cases: --- --- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@ --- declaration, check that the return kind is @Type@. --- --- If the declaration is a @newtype@ or @newtype instance@ and the --- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so --- that a return kind of the form @TYPE r@ (for some @r@) is permitted. --- See @Note [Implementation of UnliftedNewtypes]@ in "TcTyClsDecls". --- --- If dealing with a @data family@ declaration, check that the return kind is --- either of the form: --- --- 1. @TYPE r@ (for some @r@), or --- --- 2. @k@ (where @k@ is a bare kind variable; see #12369) --- --- See also Note [Datatype return kinds] in TcTyClsDecls -checkDataKindSig :: DataSort -> Kind -> TcM () -checkDataKindSig data_sort kind = do - dflags <- getDynFlags - checkTc (is_TYPE_or_Type dflags || is_kind_var) (err_msg dflags) - where - pp_dec :: SDoc - pp_dec = text $ - case data_sort of - DataDeclSort DataType -> "Data type" - DataDeclSort NewType -> "Newtype" - DataInstanceSort DataType -> "Data instance" - DataInstanceSort NewType -> "Newtype instance" - DataFamilySort -> "Data family" - - is_newtype :: Bool - is_newtype = - case data_sort of - DataDeclSort new_or_data -> new_or_data == NewType - DataInstanceSort new_or_data -> new_or_data == NewType - DataFamilySort -> False - - is_data_family :: Bool - is_data_family = - case data_sort of - DataDeclSort{} -> False - DataInstanceSort{} -> False - DataFamilySort -> True - - tYPE_ok :: DynFlags -> Bool - tYPE_ok dflags = - (is_newtype && xopt LangExt.UnliftedNewtypes dflags) - -- With UnliftedNewtypes, we allow kinds other than Type, but they - -- must still be of the form `TYPE r` since we don't want to accept - -- Constraint or Nat. - -- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls. - || is_data_family - -- If this is a `data family` declaration, we don't need to check if - -- UnliftedNewtypes is enabled, since data family declarations can - -- have return kind `TYPE r` unconditionally (#16827). - - is_TYPE :: Bool - is_TYPE = tcIsRuntimeTypeKind kind - - is_TYPE_or_Type :: DynFlags -> Bool - is_TYPE_or_Type dflags | tYPE_ok dflags = is_TYPE - | otherwise = tcIsLiftedTypeKind kind - - -- In the particular case of a data family, permit a return kind of the - -- form `:: k` (where `k` is a bare kind variable). - is_kind_var :: Bool - is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe kind) - | otherwise = False - - err_msg :: DynFlags -> SDoc - err_msg dflags = - sep [ (sep [ pp_dec <+> - text "has non-" <> - (if tYPE_ok dflags then text "TYPE" else ppr liftedTypeKind) - , (if is_data_family then text "and non-variable" else empty) <+> - text "return kind" <+> quotes (ppr kind) ]) - , if not (tYPE_ok dflags) && is_TYPE && is_newtype && - not (xopt LangExt.UnliftedNewtypes dflags) - then text "Perhaps you intended to use UnliftedNewtypes" - else empty ] - --- | Checks that the result kind of a class is exactly `Constraint`, rejecting --- type synonyms and type families that reduce to `Constraint`. See #16826. -checkClassKindSig :: Kind -> TcM () -checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg - where - err_msg :: SDoc - err_msg = - text "Kind signature on a class must end with" <+> ppr constraintKind $$ - text "unobscured by type families" - -tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] --- Result is in 1-1 correspondence with orig_args -tcbVisibilities tc orig_args - = go (tyConKind tc) init_subst orig_args - where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args)) - go _ _ [] - = [] - - 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 - Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args - where - subst' = extendTCvSubst subst tv arg - - | not (isEmptyTCvSubst subst) - = go (substTy subst fun_kind) init_subst all_args - - | otherwise - = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args) - - -{- Note [TyConBinders for the result kind signature of a data type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given - data T (a::*) :: * -> forall k. k -> * -we want to generate the extra TyConBinders for T, so we finally get - (a::*) (b::*) (k::*) (c::k) -The function etaExpandAlgTyCon generates these extra TyConBinders from -the result kind signature. - -We need to take care to give the TyConBinders - (a) OccNames that are fresh (because the TyConBinders of a TyCon - must have distinct OccNames - - (b) Uniques that are fresh (obviously) - -For (a) we need to avoid clashes with the tyvars declared by -the user before the "::"; in the above example that is 'a'. -And also see Note [Avoid name clashes for associated data types]. - -For (b) suppose we have - data T :: forall k. k -> forall k. k -> * -where the two k's are identical even up to their uniques. Surprisingly, -this can happen: see #14515. - -It's reasonably easy to solve all this; just run down the list with a -substitution; hence the recursive 'go' function. But it has to be -done. - -Note [Avoid name clashes for associated data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider class C a b where - data D b :: * -> * -When typechecking the decl for D, we'll invent an extra type variable -for D, to fill out its kind. Ideally we don't want this type variable -to be 'a', because when pretty printing we'll get - class C a b where - data D b a0 -(NB: the tidying happens in the conversion to Iface syntax, which happens -as part of pretty-printing a TyThing.) - -That's why we look in the LocalRdrEnv to see what's in scope. This is -important only to get nice-looking output when doing ":info C" in GHCi. -It isn't essential for correctness. - - -************************************************************************ -* * - Partial signatures -* * -************************************************************************ - --} - -tcHsPartialSigType - :: UserTypeCtxt - -> LHsSigWcType GhcRn -- The type signature - -> TcM ( [(Name, TcTyVar)] -- Wildcards - , Maybe TcType -- Extra-constraints wildcard - , [(Name,TcTyVar)] -- Original tyvar names, in correspondence with - -- the implicitly and explicitly bound type variables - , TcThetaType -- Theta part - , TcType ) -- Tau part --- See Note [Checking partial type signatures] -tcHsPartialSigType ctxt sig_ty - | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty - , HsIB { hsib_ext = implicit_hs_tvs - , hsib_body = hs_ty } <- ib_ty - , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTyInvis hs_ty - = addSigCtxt ctxt hs_ty $ - do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau))) - <- solveLocalEqualities "tcHsPartialSigType" $ - -- This solveLocalEqualiltes fails fast if there are - -- insoluble equalities. See TcSimplify - -- Note [Fail fast if there are insoluble kind equalities] - tcNamedWildCardBinders sig_wcs $ \ wcs -> - bindImplicitTKBndrs_Tv implicit_hs_tvs $ - bindExplicitTKBndrs_Tv explicit_hs_tvs $ - do { -- Instantiate the type-class context; but if there - -- is an extra-constraints wildcard, just discard it here - (theta, wcx) <- tcPartialContext hs_ctxt - - ; tau <- tcHsOpenType hs_tau - - ; return (wcs, wcx, theta, tau) } - - -- No kind-generalization here: - ; kindGeneralizeNone (mkSpecForAllTys implicit_tvs $ - mkSpecForAllTys explicit_tvs $ - mkPhiTy theta $ - tau) - - -- Spit out the wildcards (including the extra-constraints one) - -- as "hole" constraints, so that they'll be reported if necessary - -- See Note [Extra-constraint holes in partial type signatures] - ; emitNamedWildCardHoleConstraints wcs - - -- We return a proper (Name,TyVar) environment, to be sure that - -- we bring the right name into scope in the function body. - -- Test case: partial-sigs/should_compile/LocalDefinitionBug - ; let tv_prs = (implicit_hs_tvs `zip` implicit_tvs) - ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvs) - - -- NB: checkValidType on the final inferred type will be - -- done later by checkInferredPolyId. We can't do it - -- here because we don't have a complete tuype to check - - ; traceTc "tcHsPartialSigType" (ppr tv_prs) - ; return (wcs, wcx, tv_prs, theta, tau) } - -tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec -tcHsPartialSigType _ (XHsWildCardBndrs nec) = noExtCon nec - -tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType) -tcPartialContext hs_theta - | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta - , L wc_loc wc@(HsWildCardTy _) <- ignoreParens hs_ctxt_last - = do { wc_tv_ty <- setSrcSpan wc_loc $ - tcAnonWildCardOcc wc constraintKind - ; theta <- mapM tcLHsPredType hs_theta1 - ; return (theta, Just wc_tv_ty) } - | otherwise - = do { theta <- mapM tcLHsPredType hs_theta - ; return (theta, Nothing) } - -{- Note [Checking partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Recipe for checking a signature] - -When we have a partial signature like - f,g :: forall a. a -> _ -we do the following - -* In TcSigs.tcUserSigType we return a PartialSig, which (unlike - the companion CompleteSig) contains the original, as-yet-unchecked - source-code LHsSigWcType - -* Then, for f and g /separately/, we call tcInstSig, which in turn - call tchsPartialSig (defined near this Note). It kind-checks the - LHsSigWcType, creating fresh unification variables for each "_" - wildcard. It's important that the wildcards for f and g are distinct - because they might get instantiated completely differently. E.g. - f,g :: forall a. a -> _ - f x = a - g x = True - It's really as if we'd written two distinct signatures. - -* Note that we don't make quantified type (forall a. blah) and then - instantiate it -- it makes no sense to instantiate a type with - wildcards in it. Rather, tcHsPartialSigType just returns the - 'a' and the 'blah' separately. - - Nor, for the same reason, do we push a level in tcHsPartialSigType. - -Note [Extra-constraint holes in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: (_) => a -> a - f x = ... - -* The renamer leaves '_' untouched. - -* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in - tcWildCardBinders. - -* TcBinds.chooseInferredQuantifiers fills in that hole TcTyVar - with the inferred constraints, e.g. (Eq a, Show a) - -* TcErrors.mkHoleError finally reports the error. - -An annoying difficulty happens if there are more than 62 inferred -constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple. -Where do we find the TyCon? For good reasons we only have constraint -tuples up to 62 (see Note [How tuples work] in TysWiredIn). So how -can we make a 70-tuple? This was the root cause of #14217. - -It's incredibly tiresome, because we only need this type to fill -in the hole, to communicate to the error reporting machinery. Nothing -more. So I use a HACK: - -* I make an /ordinary/ tuple of the constraints, in - TcBinds.chooseInferredQuantifiers. This is ill-kinded because - ordinary tuples can't contain constraints, but it works fine. And for - ordinary tuples we don't have the same limit as for constraint - tuples (which need selectors and an associated class). - -* Because it is ill-kinded, it trips an assert in writeMetaTyVar, - so now I disable the assertion if we are writing a type of - kind Constraint. (That seldom/never normally happens so we aren't - losing much.) - -Result works fine, but it may eventually bite us. - - -************************************************************************ -* * - Pattern signatures (i.e signatures that occur in patterns) -* * -********************************************************************* -} - -tcHsPatSigType :: UserTypeCtxt - -> LHsSigWcType GhcRn -- The type signature - -> TcM ( [(Name, TcTyVar)] -- Wildcards - , [(Name, TcTyVar)] -- The new bit of type environment, binding - -- the scoped type variables - , TcType) -- The type --- Used for type-checking type signatures in --- (a) patterns e.g f (x::Int) = e --- (b) RULE forall bndrs e.g. forall (x::Int). f x = x --- --- This may emit constraints --- See Note [Recipe for checking a signature] -tcHsPatSigType ctxt sig_ty - | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty - , HsIB { hsib_ext = sig_ns - , hsib_body = hs_ty } <- ib_ty - = addSigCtxt ctxt hs_ty $ - do { sig_tkv_prs <- mapM new_implicit_tv sig_ns - ; (wcs, sig_ty) - <- solveLocalEqualities "tcHsPatSigType" $ - -- Always solve local equalities if possible, - -- else casts get in the way of deep skolemisation - -- (#16033) - tcNamedWildCardBinders sig_wcs $ \ wcs -> - tcExtendNameTyVarEnv sig_tkv_prs $ - do { sig_ty <- tcHsOpenType hs_ty - ; return (wcs, sig_ty) } - - ; emitNamedWildCardHoleConstraints wcs - - -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty - -- contains a forall). Promote these. - -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ... - -- When we instantiate x, we have to compare the kind of the argument - -- to a's kind, which will be a metavariable. - -- kindGeneralizeNone does this: - ; kindGeneralizeNone sig_ty - ; sig_ty <- zonkTcType sig_ty - ; checkValidType ctxt sig_ty - - ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs) - ; return (wcs, sig_tkv_prs, sig_ty) } - where - new_implicit_tv name - = do { kind <- newMetaKindVar - ; tv <- case ctxt of - RuleSigCtxt {} -> newSkolemTyVar name kind - _ -> newPatSigTyVar name kind - -- See Note [Pattern signature binders] - -- NB: tv's Name may be fresh (in the case of newPatSigTyVar) - ; return (name, tv) } - -tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec -tcHsPatSigType _ (XHsWildCardBndrs nec) = noExtCon nec - -tcPatSig :: Bool -- True <=> pattern binding - -> LHsSigWcType GhcRn - -> ExpSigmaType - -> TcM (TcType, -- The type to use for "inside" the signature - [(Name,TcTyVar)], -- The new bit of type environment, binding - -- the scoped type variables - [(Name,TcTyVar)], -- The wildcards - HsWrapper) -- Coercion due to unification with actual ty - -- Of shape: res_ty ~ sig_ty -tcPatSig in_pat_bind sig res_ty - = do { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig - -- sig_tvs are the type variables free in 'sig', - -- and not already in scope. These are the ones - -- that should be brought into scope - - ; if null sig_tvs then do { - -- Just do the subsumption check and return - wrap <- addErrCtxtM (mk_msg sig_ty) $ - tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty - ; return (sig_ty, [], sig_wcs, wrap) - } else do - -- Type signature binds at least one scoped type variable - - -- A pattern binding cannot bind scoped type variables - -- It is more convenient to make the test here - -- than in the renamer - { when in_pat_bind (addErr (patBindSigErr sig_tvs)) - - -- Now do a subsumption check of the pattern signature against res_ty - ; wrap <- addErrCtxtM (mk_msg sig_ty) $ - tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty - - -- Phew! - ; return (sig_ty, sig_tvs, sig_wcs, wrap) - } } - where - mk_msg sig_ty tidy_env - = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty - ; res_ty <- readExpType res_ty -- should be filled in by now - ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty - ; let msg = vcat [ hang (text "When checking that the pattern signature:") - 4 (ppr sig_ty) - , nest 2 (hang (text "fits the type of its context:") - 2 (ppr res_ty)) ] - ; return (tidy_env, msg) } - -patBindSigErr :: [(Name,TcTyVar)] -> SDoc -patBindSigErr sig_tvs - = hang (text "You cannot bind scoped type variable" <> plural sig_tvs - <+> pprQuotedList (map fst sig_tvs)) - 2 (text "in a pattern binding signature") - -{- Note [Pattern signature binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Type variables in the type environment] in TcRnTypes. -Consider - - data T where - MkT :: forall a. a -> (a -> Int) -> T - - f :: T -> ... - f (MkT x (f :: b -> c)) = - -Here - * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk', - It must be a skolem so that that it retains its identity, and - TcErrors.getSkolemInfo can thereby find the binding site for the skolem. - - * The type signature pattern (f :: b -> c) makes freshs meta-tyvars - beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the - environment - - * Then unification makes beta := a_sk, gamma := Int - That's why we must make beta and gamma a MetaTv, - not a SkolemTv, so that it can unify to a_sk (or Int, respectively). - - * Finally, in '' we have the envt "b" :-> beta, "c" :-> gamma, - so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType, - -Another example (#13881): - fl :: forall (l :: [a]). Sing l -> Sing l - fl (SNil :: Sing (l :: [y])) = SNil -When we reach the pattern signature, 'l' is in scope from the -outer 'forall': - "a" :-> a_sk :: * - "l" :-> l_sk :: [a_sk] -We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check -the pattern signature - Sing (l :: [y]) -That unifies y_sig := a_sk. We return from tcHsPatSigType with -the pair ("y" :-> y_sig). - -For RULE binders, though, things are a bit different (yuk). - RULE "foo" forall (x::a) (y::[a]). f x y = ... -Here this really is the binding site of the type variable so we'd like -to use a skolem, so that we get a complaint if we unify two of them -together. Hence the new_tv function in tcHsPatSigType. - - -************************************************************************ -* * - Checking kinds -* * -************************************************************************ - --} - -unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind) -unifyKinds rn_tys act_kinds - = do { kind <- newMetaKindVar - ; let check rn_ty (ty, act_kind) - = checkExpectedKind (unLoc rn_ty) ty act_kind kind - ; tys' <- zipWithM check rn_tys act_kinds - ; return (tys', kind) } - -{- -************************************************************************ -* * - Sort checking kinds -* * -************************************************************************ - -tcLHsKindSig converts a user-written kind to an internal, sort-checked kind. -It does sort checking and desugaring at the same time, in one single pass. --} - -tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind -tcLHsKindSig ctxt hs_kind --- See Note [Recipe for checking a signature] in TcHsType --- Result is zonked - = do { kind <- solveLocalEqualities "tcLHsKindSig" $ - tc_lhs_kind kindLevelMode hs_kind - ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind) - -- No generalization: - ; kindGeneralizeNone kind - ; kind <- zonkTcType kind - -- This zonk is very important in the case of higher rank kinds - -- E.g. #13879 f :: forall (p :: forall z (y::z). ). - -- - -- When instantiating p's kind at occurrences of p in - -- it's crucial that the kind we instantiate is fully zonked, - -- else we may fail to substitute properly - - ; checkValidType ctxt kind - ; traceTc "tcLHsKindSig2" (ppr kind) - ; return kind } - -tc_lhs_kind :: TcTyMode -> LHsKind GhcRn -> TcM Kind -tc_lhs_kind mode k - = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $ - tc_lhs_type (kindLevel mode) k liftedTypeKind - -promotionErr :: Name -> PromotionErr -> TcM a -promotionErr name err - = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") - 2 (parens reason)) - where - reason = case err of - ConstrainedDataConPE pred - -> text "it has an unpromotable context" - <+> quotes (ppr pred) - FamDataConPE -> text "it comes from a data family instance" - NoDataKindsTC -> text "perhaps you intended to use DataKinds" - NoDataKindsDC -> text "perhaps you intended to use DataKinds" - PatSynPE -> text "pattern synonyms cannot be promoted" - _ -> text "it is defined and used in the same recursive group" - -{- -************************************************************************ -* * - Error messages and such -* * -************************************************************************ --} - - --- | If the inner action emits constraints, report them as errors and fail; --- otherwise, propagates the return value. Useful as a wrapper around --- 'tcImplicitTKBndrs', which uses solveLocalEqualities, when there won't be --- another chance to solve constraints -failIfEmitsConstraints :: TcM a -> TcM a -failIfEmitsConstraints thing_inside - = checkNoErrs $ -- We say that we fail if there are constraints! - -- c.f same checkNoErrs in solveEqualities - do { (res, lie) <- captureConstraints thing_inside - ; reportAllUnsolved lie - ; return res - } - --- | Make an appropriate message for an error in a function argument. --- Used for both expressions and types. -funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc -funAppCtxt fun arg arg_no - = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"), - quotes (ppr fun) <> text ", namely"]) - 2 (quotes (ppr arg)) - --- | Add a "In the data declaration for T" or some such. -addTyConFlavCtxt :: Name -> TyConFlavour -> TcM a -> TcM a -addTyConFlavCtxt name flav - = addErrCtxt $ hsep [ text "In the", ppr flav - , text "declaration for", quotes (ppr name) ] diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs deleted file mode 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ /dev/null @@ -1,2172 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcInstDecls: Typechecking instance declarations --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import TcBinds -import TcTyClsDecls -import TcTyDecls ( addTyConsToGblEnv ) -import TcClassDcl( tcClassDecl2, tcATDefault, - HsSigFun, mkHsSigFun, badMethodErr, - findMethodBind, instantiateMethod ) -import TcSigs -import TcRnMonad -import TcValidity -import TcHsSyn -import TcMType -import TcType -import Constraint -import TcOrigin -import BuildTyCl -import Inst -import ClsInst( AssocInstInfo(..), isNotAssociated ) -import GHC.Core.InstEnv -import FamInst -import GHC.Core.FamInstEnv -import TcDeriv -import TcEnv -import TcHsType -import TcUnify -import GHC.Core ( Expr(..), mkApps, mkVarApps, mkLams ) -import GHC.Core.Make ( nO_METHOD_BINDING_ERROR_ID ) -import GHC.Core.Unfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding ) -import GHC.Core.Type -import TcEvidence -import GHC.Core.TyCon -import GHC.Core.Coercion.Axiom -import GHC.Core.DataCon -import GHC.Core.ConLike -import GHC.Core.Class -import GHC.Types.Var as Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import Bag -import GHC.Types.Basic -import GHC.Driver.Session -import ErrUtils -import FastString -import GHC.Types.Id -import ListSetOps -import GHC.Types.Name -import GHC.Types.Name.Set -import Outputable -import GHC.Types.SrcLoc -import Util -import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Maybes -import Data.List( mapAccumL ) - - -{- -Typechecking instance declarations is done in two passes. The first -pass, made by @tcInstDecls1@, collects information to be used in the -second pass. - -This pre-processed info includes the as-yet-unprocessed bindings -inside the instance declaration. These are type-checked in the second -pass, when the class-instance envs and GVE contain all the info from -all the instance and value decls. Indeed that's the reason we need -two passes over the instance decls. - - -Note [How instance declarations are translated] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is how we translate instance declarations into Core - -Running example: - class C a where - op1, op2 :: Ix b => a -> b -> b - op2 = - - instance C a => C [a] - {-# INLINE [2] op1 #-} - op1 = -===> - -- Method selectors - op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b - op1 = ... - op2 = ... - - -- Default methods get the 'self' dictionary as argument - -- so they can call other methods at the same type - -- Default methods get the same type as their method selector - $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b - $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). - -- NB: type variables 'a' and 'b' are *both* in scope in - -- Note [Tricky type variable scoping] - - -- A top-level definition for each instance method - -- Here op1_i, op2_i are the "instance method Ids" - -- The INLINE pragma comes from the user pragma - {-# INLINE [2] op1_i #-} -- From the instance decl bindings - op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b - op1_i = /\a. \(d:C a). - let this :: C [a] - this = df_i a d - -- Note [Subtle interaction of recursion and overlap] - - local_op1 :: forall b. Ix b => [a] -> b -> b - local_op1 = - -- Source code; run the type checker on this - -- NB: Type variable 'a' (but not 'b') is in scope in - -- Note [Tricky type variable scoping] - - in local_op1 a d - - op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) - - -- The dictionary function itself - {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions - df_i :: forall a. C a -> C [a] - df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d) - -- But see Note [Default methods in instances] - -- We can't apply the type checker to the default-method call - - -- Use a RULE to short-circuit applications of the class ops - {-# RULE "op1@C[a]" forall a, d:C a. - op1 [a] (df_i d) = op1_i a d #-} - -Note [Instances and loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Note that df_i may be mutually recursive with both op1_i and op2_i. - It's crucial that df_i is not chosen as the loop breaker, even - though op1_i has a (user-specified) INLINE pragma. - -* Instead the idea is to inline df_i into op1_i, which may then select - methods from the MkC record, and thereby break the recursion with - df_i, leaving a *self*-recursive op1_i. (If op1_i doesn't call op at - the same type, it won't mention df_i, so there won't be recursion in - the first place.) - -* If op1_i is marked INLINE by the user there's a danger that we won't - inline df_i in it, and that in turn means that (since it'll be a - loop-breaker because df_i isn't), op1_i will ironically never be - inlined. But this is OK: the recursion breaking happens by way of - a RULE (the magic ClassOp rule above), and RULES work inside InlineRule - unfoldings. See Note [RULEs enabled in InitialPhase] in GHC.Core.Op.Simplify.Utils - -Note [ClassOp/DFun selection] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One thing we see a lot is stuff like - op2 (df d1 d2) -where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both* -'op2' and 'df' to get - case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of - MkD _ op2 _ _ _ -> op2 -And that will reduce to ($cop2 d1 d2) which is what we wanted. - -But it's tricky to make this work in practice, because it requires us to -inline both 'op2' and 'df'. But neither is keen to inline without having -seen the other's result; and it's very easy to get code bloat (from the -big intermediate) if you inline a bit too much. - -Instead we use a cunning trick. - * We arrange that 'df' and 'op2' NEVER inline. - - * We arrange that 'df' is ALWAYS defined in the sylised form - df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ... - - * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..]) - that lists its methods. - - * We make GHC.Core.Unfold.exprIsConApp_maybe spot a DFunUnfolding and return - a suitable constructor application -- inlining df "on the fly" as it - were. - - * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that - extracts the right piece iff its argument satisfies - exprIsConApp_maybe. This is done in GHC.Types.Id.Make.mkDictSelId - - * We make 'df' CONLIKE, so that shared uses still match; eg - let d = df d1 d2 - in ...(op2 d)...(op1 d)... - -Note [Single-method classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the class has just one method (or, more accurately, just one element -of {superclasses + methods}), then we use a different strategy. - - class C a where op :: a -> a - instance C a => C [a] where op = - -We translate the class decl into a newtype, which just gives a -top-level axiom. The "constructor" MkC expands to a cast, as does the -class-op selector. - - axiom Co:C a :: C a ~ (a->a) - - op :: forall a. C a -> (a -> a) - op a d = d |> (Co:C a) - - MkC :: forall a. (a->a) -> C a - MkC = /\a.\op. op |> (sym Co:C a) - -The clever RULE stuff doesn't work now, because ($df a d) isn't -a constructor application, so exprIsConApp_maybe won't return -Just . - -Instead, we simply rely on the fact that casts are cheap: - - $df :: forall a. C a => C [a] - {-# INLINE df #-} -- NB: INLINE this - $df = /\a. \d. MkC [a] ($cop_list a d) - = $cop_list |> forall a. C a -> (sym (Co:C [a])) - - $cop_list :: forall a. C a => [a] -> [a] - $cop_list = - -So if we see - (op ($df a d)) -we'll inline 'op' and '$df', since both are simply casts, and -good things happen. - -Why do we use this different strategy? Because otherwise we -end up with non-inlined dictionaries that look like - $df = $cop |> blah -which adds an extra indirection to every use, which seems stupid. See -#4138 for an example (although the regression reported there -wasn't due to the indirection). - -There is an awkward wrinkle though: we want to be very -careful when we have - instance C a => C [a] where - {-# INLINE op #-} - op = ... -then we'll get an INLINE pragma on $cop_list but it's important that -$cop_list only inlines when it's applied to *two* arguments (the -dictionary and the list argument). So we must not eta-expand $df -above. We ensure that this doesn't happen by putting an INLINE -pragma on the dfun itself; after all, it ends up being just a cast. - -There is one more dark corner to the INLINE story, even more deeply -buried. Consider this (#3772): - - class DeepSeq a => C a where - gen :: Int -> a - - instance C a => C [a] where - gen n = ... - - class DeepSeq a where - deepSeq :: a -> b -> b - - instance DeepSeq a => DeepSeq [a] where - {-# INLINE deepSeq #-} - deepSeq xs b = foldr deepSeq b xs - -That gives rise to these defns: - - $cdeepSeq :: DeepSeq a -> [a] -> b -> b - -- User INLINE( 3 args )! - $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ... - - $fDeepSeq[] :: DeepSeq a -> DeepSeq [a] - -- DFun (with auto INLINE pragma) - $fDeepSeq[] a d = $cdeepSeq a d |> blah - - $cp1 a d :: C a => DeepSep [a] - -- We don't want to eta-expand this, lest - -- $cdeepSeq gets inlined in it! - $cp1 a d = $fDeepSep[] a (scsel a d) - - $fC[] :: C a => C [a] - -- Ordinary DFun - $fC[] a d = MkC ($cp1 a d) ($cgen a d) - -Here $cp1 is the code that generates the superclass for C [a]. The -issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[] -and then $cdeepSeq will inline there, which is definitely wrong. Like -on the dfun, we solve this by adding an INLINE pragma to $cp1. - -Note [Subtle interaction of recursion and overlap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - class C a where { op1,op2 :: a -> a } - instance C a => C [a] where - op1 x = op2 x ++ op2 x - op2 x = ... - instance C [Int] where - ... - -When type-checking the C [a] instance, we need a C [a] dictionary (for -the call of op2). If we look up in the instance environment, we find -an overlap. And in *general* the right thing is to complain (see Note -[Overlapping instances] in GHC.Core.InstEnv). But in *this* case it's wrong to -complain, because we just want to delegate to the op2 of this same -instance. - -Why is this justified? Because we generate a (C [a]) constraint in -a context in which 'a' cannot be instantiated to anything that matches -other overlapping instances, or else we would not be executing this -version of op1 in the first place. - -It might even be a bit disguised: - - nullFail :: C [a] => [a] -> [a] - nullFail x = op2 x ++ op2 x - - instance C a => C [a] where - op1 x = nullFail x - -Precisely this is used in package 'regex-base', module Context.hs. -See the overlapping instances for RegexContext, and the fact that they -call 'nullFail' just like the example above. The DoCon package also -does the same thing; it shows up in module Fraction.hs. - -Conclusion: when typechecking the methods in a C [a] instance, we want to -treat the 'a' as an *existential* type variable, in the sense described -by Note [Binding when looking up instances]. That is why isOverlappableTyVar -responds True to an InstSkol, which is the kind of skolem we use in -tcInstDecl2. - - -Note [Tricky type variable scoping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In our example - class C a where - op1, op2 :: Ix b => a -> b -> b - op2 = - - instance C a => C [a] - {-# INLINE [2] op1 #-} - op1 = - -note that 'a' and 'b' are *both* in scope in , but only 'a' is -in scope in . In particular, we must make sure that 'b' is in -scope when typechecking . This is achieved by subFunTys, -which brings appropriate tyvars into scope. This happens for both - and for , but that doesn't matter: the *renamer* will have -complained if 'b' is mentioned in . - - - -************************************************************************ -* * -\subsection{Extracting instance decls} -* * -************************************************************************ - -Gather up the instance declarations from their various sources --} - -tcInstDecls1 -- Deal with both source-code and imported instance decls - :: [LInstDecl GhcRn] -- Source code instance decls - -> TcM (TcGblEnv, -- The full inst env - [InstInfo GhcRn], -- Source-code instance decls to process; - -- contains all dfuns for this module - [DerivInfo]) -- From data family instances - -tcInstDecls1 inst_decls - = do { -- Do class and family instance declarations - ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls - - ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff - fam_insts = concat fam_insts_s - local_infos = concat local_infos_s - - ; gbl_env <- addClsInsts local_infos $ - addFamInsts fam_insts $ - getGblEnv - - ; return ( gbl_env - , local_infos - , concat datafam_deriv_infos ) } - --- | Use DerivInfo for data family instances (produced by tcInstDecls1), --- datatype declarations (TyClDecl), and standalone deriving declarations --- (DerivDecl) to check and process all derived class instances. -tcInstDeclsDeriv - :: [DerivInfo] - -> [LDerivDecl GhcRn] - -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn) -tcInstDeclsDeriv deriv_infos derivds - = do th_stage <- getStage -- See Note [Deriving inside TH brackets] - if isBrackStage th_stage - then do { gbl_env <- getGblEnv - ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) } - else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds - ; return (tcg_env, bagToList info_bag, valbinds) } - -addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a -addClsInsts infos thing_inside - = tcExtendLocalInstEnv (map iSpec infos) thing_inside - -addFamInsts :: [FamInst] -> TcM a -> TcM a --- Extend (a) the family instance envt --- (b) the type envt with stuff from data type decls -addFamInsts fam_insts thing_inside - = tcExtendLocalFamInstEnv fam_insts $ - tcExtendGlobalEnv axioms $ - do { traceTc "addFamInsts" (pprFamInsts fam_insts) - ; gbl_env <- addTyConsToGblEnv data_rep_tycons - -- Does not add its axiom; that comes - -- from adding the 'axioms' above - ; setGblEnv gbl_env thing_inside } - where - axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts - data_rep_tycons = famInstsRepTyCons fam_insts - -- The representation tycons for 'data instances' declarations - -{- -Note [Deriving inside TH brackets] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a declaration bracket - [d| data T = A | B deriving( Show ) |] - -there is really no point in generating the derived code for deriving( -Show) and then type-checking it. This will happen at the call site -anyway, and the type check should never fail! Moreover (#6005) -the scoping of the generated code inside the bracket does not seem to -work out. - -The easy solution is simply not to generate the derived instances at -all. (A less brutal solution would be to generate them with no -bindings.) This will become moot when we shift to the new TH plan, so -the brutal solution will do. --} - -tcLocalInstDecl :: LInstDecl GhcRn - -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) - -- A source-file instance declaration - -- Type-check all the stuff before the "where" - -- - -- We check for respectable instance type, and context -tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl })) - = do { fam_inst <- tcTyFamInstDecl NotAssociated (L loc decl) - ; return ([], [fam_inst], []) } - -tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl })) - = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated (L loc decl) - ; return ([], [fam_inst], maybeToList m_deriv_info) } - -tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) - = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl) - ; return (insts, fam_insts, deriv_infos) } - -tcLocalInstDecl (L _ (XInstDecl nec)) = noExtCon nec - -tcClsInstDecl :: LClsInstDecl GhcRn - -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) --- The returned DerivInfos are for any associated data families -tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds - , cid_sigs = uprags, cid_tyfam_insts = ats - , cid_overlap_mode = overlap_mode - , cid_datafam_insts = adts })) - = setSrcSpan loc $ - addErrCtxt (instDeclCtxt1 hs_ty) $ - do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty - ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty - -- NB: tcHsClsInstType does checkValidInstance - - ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars - ; let tv_skol_prs = [ (tyVarName tv, skol_tv) - | (tv, skol_tv) <- tyvars `zip` skol_tvs ] - n_inferred = countWhile ((== Inferred) . binderArgFlag) $ - fst $ splitForAllVarBndrs dfun_ty - visible_skol_tvs = drop n_inferred skol_tvs - - ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs) - - -- Next, process any associated types. - ; (datafam_stuff, tyfam_insts) - <- tcExtendNameTyVarEnv tv_skol_prs $ - do { let mini_env = mkVarEnv (classTyVars clas `zip` substTys subst inst_tys) - mini_subst = mkTvSubst (mkInScopeSet (mkVarSet skol_tvs)) mini_env - mb_info = InClsInst { ai_class = clas - , ai_tyvars = visible_skol_tvs - , ai_inst_env = mini_env } - ; df_stuff <- mapAndRecoverM (tcDataFamInstDecl mb_info) adts - ; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info) ats - - -- Check for missing associated types and build them - -- from their defaults (if available) - ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats) - (classATItems clas) - - ; return (df_stuff, tf_insts1 ++ concat tf_insts2) } - - - -- Finally, construct the Core representation of the instance. - -- (This no longer includes the associated types.) - ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType hs_ty)) - -- Dfun location is that of instance *header* - - ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name - tyvars theta clas inst_tys - - ; let inst_binds = InstBindings - { ib_binds = binds - , ib_tyvars = map Var.varName tyvars -- Scope over bindings - , ib_pragmas = uprags - , ib_extensions = [] - , ib_derived = False } - inst_info = InstInfo { iSpec = ispec, iBinds = inst_binds } - - (datafam_insts, m_deriv_infos) = unzip datafam_stuff - deriv_infos = catMaybes m_deriv_infos - all_insts = tyfam_insts ++ datafam_insts - - -- In hs-boot files there should be no bindings - ; is_boot <- tcIsHsBootOrSig - ; let no_binds = isEmptyLHsBinds binds && null uprags - ; failIfTc (is_boot && not no_binds) badBootDeclErr - - ; return ( [inst_info], all_insts, deriv_infos ) } - where - defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) - `unionNameSet` - mkNameSet (map (unLoc . feqn_tycon - . hsib_body - . dfid_eqn - . unLoc) adts) - -tcClsInstDecl (L _ (XClsInstDecl nec)) = noExtCon nec - -{- -************************************************************************ -* * - Type family instances -* * -************************************************************************ - -Family instances are somewhat of a hybrid. They are processed together with -class instance heads, but can contain data constructors and hence they share a -lot of kinding and type checking code with ordinary algebraic data types (and -GADTs). --} - -tcTyFamInstDecl :: AssocInstInfo - -> LTyFamInstDecl GhcRn -> TcM FamInst - -- "type instance" - -- See Note [Associated type instances] -tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) - = setSrcSpan loc $ - tcAddTyFamInstCtxt decl $ - do { let fam_lname = feqn_tycon (hsib_body eqn) - ; fam_tc <- tcLookupLocatedTyCon fam_lname - ; tcFamInstDeclChecks mb_clsinfo fam_tc - - -- (0) Check it's an open type family - ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc) - - -- (1) do the work of verifying the synonym group - ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo - (L (getLoc fam_lname) eqn) - - - -- (2) check for validity - ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch - ; checkValidCoAxBranch fam_tc co_ax_branch - - -- (3) construct coercion axiom - ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch] - ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch - ; newFamInst SynFamilyInst axiom } - - ---------------------- -tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM () --- Used for both type and data families -tcFamInstDeclChecks mb_clsinfo 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 $ badFamInstDecl fam_tc - ; checkTc (not is_boot) $ badBootFamInstDeclErr - - -- Check that it is a family TyCon, and that - -- oplevel type instances are not for associated types. - ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) - - ; when (isNotAssociated mb_clsinfo && -- Not in a class decl - isTyConAssoc fam_tc) -- but an associated type - (addErr $ assocInClassErr fam_tc) - } - -{- Note [Associated type instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow this: - class C a where - type T x a - instance C Int where - type T (S y) Int = y - type T Z Int = Char - -Note that - a) The variable 'x' is not bound by the class decl - b) 'x' is instantiated to a non-type-variable in the instance - c) There are several type instance decls for T in the instance - -All this is fine. Of course, you can't give any *more* instances -for (T ty Int) elsewhere, because it's an *associated* type. - - -************************************************************************ -* * - Data family instances -* * -************************************************************************ - -For some reason data family instances are a lot more complicated -than type family instances --} - -tcDataFamInstDecl :: AssocInstInfo - -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo) - -- "newtype instance" and "data instance" -tcDataFamInstDecl mb_clsinfo - (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = imp_vars - , hsib_body = - FamEqn { feqn_bndrs = mb_bndrs - , feqn_pats = hs_pats - , feqn_tycon = lfam_name@(L _ fam_name) - , feqn_fixity = fixity - , feqn_rhs = HsDataDefn { dd_ND = new_or_data - , dd_cType = cType - , dd_ctxt = hs_ctxt - , dd_cons = hs_cons - , dd_kindSig = m_ksig - , dd_derivs = derivs } }}})) - = setSrcSpan loc $ - tcAddDataFamInstCtxt decl $ - do { fam_tc <- tcLookupLocatedTyCon lfam_name - - ; tcFamInstDeclChecks mb_clsinfo fam_tc - - -- Check that the family declaration is for the right kind - ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons - -- Do /not/ check that the number of patterns = tyConArity fam_tc - -- See [Arity of data families] in GHC.Core.FamInstEnv - ; (qtvs, pats, res_kind, stupid_theta) - <- tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs - fixity hs_ctxt hs_pats m_ksig hs_cons - new_or_data - - -- Eta-reduce the axiom if possible - -- Quite tricky: see Note [Eta-reduction for data families] - ; let (eta_pats, eta_tcbs) = eta_reduce fam_tc pats - eta_tvs = map binderVar eta_tcbs - post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs - - full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs - (tyCoVarsOfType (mkSpecForAllTys eta_tvs res_kind)) - ++ eta_tcbs - -- Put the eta-removed tyvars at the end - -- Remember, qtvs is in arbitrary order, except kind vars are - -- first, so there is no reason to suppose that the eta_tvs - -- (obtained from the pats) are at the end (#11148) - - -- Eta-expand the representation tycon until it has result - -- kind `TYPE r`, for some `r`. If UnliftedNewtypes is not enabled, we - -- go one step further and ensure that it has kind `TYPE 'LiftedRep`. - -- - -- See also Note [Arity of data families] in GHC.Core.FamInstEnv - -- NB: we can do this after eta-reducing the axiom, because if - -- we did it before the "extra" tvs from etaExpandAlgTyCon - -- would always be eta-reduced - -- - -- See also Note [Datatype return kinds] in TcTyClsDecls - ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind - ; checkDataKindSig (DataInstanceSort new_or_data) final_res_kind - ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs - all_pats = pats `chkAppend` extra_pats - orig_res_ty = mkTyConApp fam_tc all_pats - ty_binders = full_tcbs `chkAppend` extra_tcbs - - ; traceTc "tcDataFamInstDecl" $ - vcat [ text "Fam tycon:" <+> ppr fam_tc - , text "Pats:" <+> ppr pats - , text "visibliities:" <+> ppr (tcbVisibilities fam_tc pats) - , text "all_pats:" <+> ppr all_pats - , text "ty_binders" <+> ppr ty_binders - , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc) - , text "eta_pats" <+> ppr eta_pats - , text "eta_tcbs" <+> ppr eta_tcbs ] - - ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) -> - do { data_cons <- tcExtendTyVarEnv qtvs $ - -- For H98 decls, the tyvars scope - -- over the data constructors - tcConDecls rec_rep_tc new_or_data ty_binders final_res_kind - orig_res_ty hs_cons - - ; rep_tc_name <- newFamInstTyConName lfam_name pats - ; axiom_name <- newFamInstAxiomName lfam_name [pats] - ; tc_rhs <- case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) - - ; let axiom = mkSingleCoAxiom Representational axiom_name - post_eta_qtvs eta_tvs [] fam_tc eta_pats - (mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs)) - parent = DataFamInstTyCon axiom fam_tc all_pats - - -- NB: Use the full ty_binders from the pats. See bullet toward - -- the end of Note [Data type families] in GHC.Core.TyCon - rep_tc = mkAlgTyCon rep_tc_name - ty_binders final_res_kind - (map (const Nominal) ty_binders) - (fmap unLoc cType) stupid_theta - tc_rhs parent - gadt_syntax - -- We always assume that indexed types are recursive. Why? - -- (1) Due to their open nature, we can never be sure that a - -- further instance might not introduce a new recursive - -- dependency. (2) They are always valid loop breakers as - -- they involve a coercion. - ; return (rep_tc, axiom) } - - -- Remember to check validity; no recursion to worry about here - -- Check that left-hand sides are ok (mono-types, no type families, - -- consistent instantiations, etc) - ; let ax_branch = coAxiomSingleBranch axiom - ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch - ; checkValidCoAxBranch fam_tc ax_branch - ; checkValidTyCon rep_tc - - ; let m_deriv_info = case derivs of - L _ [] -> Nothing - L _ preds -> - Just $ DerivInfo { di_rep_tc = rep_tc - , di_scoped_tvs = mkTyVarNamePairs (tyConTyVars rep_tc) - , di_clauses = preds - , di_ctxt = tcMkDataFamInstCtxt decl } - - ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom - ; return (fam_inst, m_deriv_info) } - where - eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder]) - -- See Note [Eta reduction for data families] in GHC.Core.FamInstEnv - -- Splits the incoming patterns into two: the [TyVar] - -- are the patterns that can be eta-reduced away. - -- e.g. T [a] Int a d c ==> (T [a] Int a, [d,c]) - -- - -- NB: quadratic algorithm, but types are small here - eta_reduce fam_tc pats - = go (reverse (zip3 pats fvs_s vis_s)) [] - where - vis_s :: [TyConBndrVis] - vis_s = tcbVisibilities fam_tc pats - - fvs_s :: [TyCoVarSet] -- 1-1 correspondence with pats - -- Each elt is the free vars of all /earlier/ pats - (_, fvs_s) = mapAccumL add_fvs emptyVarSet pats - add_fvs fvs pat = (fvs `unionVarSet` tyCoVarsOfType pat, fvs) - - go ((pat, fvs_to_the_left, tcb_vis):pats) etad_tvs - | Just tv <- getTyVar_maybe pat - , not (tv `elemVarSet` fvs_to_the_left) - = go pats (Bndr tv tcb_vis : etad_tvs) - go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs) - -tcDataFamInstDecl _ _ = panic "tcDataFamInstDecl" - ------------------------ -tcDataFamInstHeader - :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn] - -> LexicalFixity -> LHsContext GhcRn - -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn] - -> NewOrData - -> TcM ([TyVar], [Type], Kind, ThetaType) --- The "header" of a data family instance is the part other than --- the data constructors themselves --- e.g. data instance D [a] :: * -> * where ... --- Here the "header" is the bit before the "where" -tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity - hs_ctxt hs_pats m_ksig hs_cons new_or_data - = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, lhs_applied_kind))) - <- pushTcLevelM_ $ - solveEqualities $ - bindImplicitTKBndrs_Q_Skol imp_vars $ - bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ - do { stupid_theta <- tcHsContext hs_ctxt - ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats - - -- Ensure that the instance is consistent - -- with its parent class - ; addConsistencyConstraints mb_clsinfo lhs_ty - - -- Add constraints from the result signature - ; res_kind <- tc_kind_sig m_ksig - - -- Add constraints from the data constructors - ; kcConDecls new_or_data res_kind hs_cons - - -- See Note [Datatype return kinds] in TcTyClsDecls, point (7). - ; (lhs_extra_args, lhs_applied_kind) - <- tcInstInvisibleTyBinders (invisibleTyBndrCount lhs_kind) - lhs_kind - ; let lhs_applied_ty = lhs_ty `mkTcAppTys` lhs_extra_args - hs_lhs = nlHsTyConApp fixity (getName fam_tc) hs_pats - ; _ <- unifyKind (Just (unLoc hs_lhs)) lhs_applied_kind res_kind - - ; return ( stupid_theta - , lhs_applied_ty - , lhs_applied_kind ) } - - -- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts] - -- This code (and the stuff immediately above) is very similar - -- to that in tcTyFamInstEqnGuts. Maybe we should abstract the - -- common code; but for the moment I concluded that it's - -- clearer to duplicate it. Still, if you fix a bug here, - -- check there too! - ; let scoped_tvs = imp_tvs ++ exp_tvs - ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) - ; qtvs <- quantifyTyVars dvs - - -- Zonk the patterns etc into the Type world - ; (ze, qtvs) <- zonkTyBndrs qtvs - ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty - ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta - ; lhs_applied_kind <- zonkTcTypeToTypeX ze lhs_applied_kind - - -- Check that type patterns match the class instance head - -- The call to splitTyConApp_maybe here is just an inlining of - -- the body of unravelFamInstPats. - ; pats <- case splitTyConApp_maybe lhs_ty of - Just (_, pats) -> pure pats - Nothing -> pprPanic "tcDataFamInstHeader" (ppr lhs_ty) - ; return (qtvs, pats, lhs_applied_kind, stupid_theta) } - where - fam_name = tyConName fam_tc - data_ctxt = DataKindCtxt fam_name - exp_bndrs = mb_bndrs `orElse` [] - - -- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls, wrinkle (2). - tc_kind_sig Nothing - = do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - ; if unlifted_newtypes && new_or_data == NewType - then newOpenTypeKind - else pure liftedTypeKind - } - - -- See Note [Result kind signature for a data family instance] - tc_kind_sig (Just hs_kind) - = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind - ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind - ; lvl <- getTcLevel - ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs - -- Perhaps surprisingly, we don't need the skolemised tvs themselves - ; let final_kind = substTy subst inner_kind - ; checkDataKindSig (DataInstanceSort new_or_data) $ - snd $ tcSplitPiTys final_kind - -- See Note [Datatype return kinds], end of point (4) - ; return final_kind } - -{- Note [Result kind signature for a data family instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The expected type might have a forall at the type. Normally, we -can't skolemise in kinds because we don't have type-level lambda. -But here, we're at the top-level of an instance declaration, so -we actually have a place to put the regeneralised variables. -Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise -Examples in indexed-types/should_compile/T12369 - -Note [Eta-reduction for data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data D :: * -> * -> * -> * -> * - - data instance D [(a,b)] p q :: * -> * where - D1 :: blah1 - D2 :: blah2 - -Then we'll generate a representation data type - data Drep a b p q z where - D1 :: blah1 - D2 :: blah2 - -and an axiom to connect them - axiom AxDrep forall a b p q z. D [(a,b]] p q z = Drep a b p q z - -except that we'll eta-reduce the axiom to - axiom AxDrep forall a b. D [(a,b]] = Drep a b -There are several fiddly subtleties lurking here - -* The representation tycon Drep is parameterised over the free - variables of the pattern, in no particular order. So there is no - guarantee that 'p' and 'q' will come last in Drep's parameters, and - in the right order. So, if the /patterns/ of the family insatance - are eta-reducible, we re-order Drep's parameters to put the - eta-reduced type variables last. - -* Although we eta-reduce the axiom, we eta-/expand/ the representation - tycon Drep. The kind of D says it takes four arguments, but the - data instance header only supplies three. But the AlgTyCon for Drep - itself must have enough TyConBinders so that its result kind is Type. - So, with etaExpandAlgTyCon we make up some extra TyConBinders. - See point (3) in Note [Datatype return kinds] in TcTyClsDecls. - -* The result kind in the instance might be a polykind, like this: - data family DP a :: forall k. k -> * - data instance DP [b] :: forall k1 k2. (k1,k2) -> * - - So in type-checking the LHS (DP Int) we need to check that it is - more polymorphic than the signature. To do that we must skolemise - the signature and instantiate the call of DP. So we end up with - data instance DP [b] @(k1,k2) (z :: (k1,k2)) where - - Note that we must parameterise the representation tycon DPrep over - 'k1' and 'k2', as well as 'b'. - - The skolemise bit is done in tc_kind_sig, while the instantiate bit - is done by tcFamTyPats. - -* Very fiddly point. When we eta-reduce to - axiom AxDrep forall a b. D [(a,b]] = Drep a b - - we want the kind of (D [(a,b)]) to be the same as the kind of - (Drep a b). This ensures that applying the axiom doesn't change the - kind. Why is that hard? Because the kind of (Drep a b) depends on - the TyConBndrVis on Drep's arguments. In particular do we have - (forall (k::*). blah) or (* -> blah)? - - We must match whatever D does! In #15817 we had - data family X a :: forall k. * -> * -- Note: a forall that is not used - data instance X Int b = MkX - - So the data instance is really - data istance X Int @k b = MkX - - The axiom will look like - axiom X Int = Xrep - - and it's important that XRep :: forall k * -> *, following X. - - To achieve this we get the TyConBndrVis flags from tcbVisibilities, - and use those flags for any eta-reduced arguments. Sigh. - -* The final turn of the knife is that tcbVisibilities is itself - tricky to sort out. Consider - data family D k :: k - Then consider D (forall k2. k2 -> k2) Type Type - The visibility flags on an application of D may affected by the arguments - themselves. Heavy sigh. But not truly hard; that's what tcbVisibilities - does. - --} - - -{- ********************************************************************* -* * - Class instance declarations, pass 2 -* * -********************************************************************* -} - -tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] - -> TcM (LHsBinds GhcTc) --- (a) From each class declaration, --- generate any default-method bindings --- (b) From each instance decl --- generate the dfun binding - -tcInstDecls2 tycl_decls inst_decls - = do { -- (a) Default methods from class decls - let class_decls = filter (isClassDecl . unLoc) tycl_decls - ; dm_binds_s <- mapM tcClassDecl2 class_decls - ; let dm_binds = unionManyBags dm_binds_s - - -- (b) instance declarations - ; let dm_ids = collectHsBindsBinders dm_binds - -- Add the default method Ids (again) - -- (they were arready added in TcTyDecls.tcAddImplicits) - -- See Note [Default methods in the type environment] - ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $ - mapM tcInstDecl2 inst_decls - - -- Done - ; return (dm_binds `unionBags` unionManyBags inst_binds_s) } - -{- Note [Default methods in the type environment] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The default method Ids are already in the type environment (see Note -[Default method Ids and Template Haskell] in TcTyDcls), BUT they -don't have their InlinePragmas yet. Usually that would not matter, -because the simplifier propagates information from binding site to -use. But, unusually, when compiling instance decls we *copy* the -INLINE pragma from the default method to the method for that -particular operation (see Note [INLINE and default methods] below). - -So right here in tcInstDecls2 we must re-extend the type envt with -the default method Ids replete with their INLINE pragmas. Urk. --} - -tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc) - -- Returns a binding for the dfun -tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) - = recoverM (return emptyLHsBinds) $ - setSrcSpan loc $ - addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ - do { -- Instantiate the instance decl with skolem constants - ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id - ; dfun_ev_vars <- newEvVars dfun_theta - -- We instantiate the dfun_id with superSkolems. - -- See Note [Subtle interaction of recursion and overlap] - -- and Note [Binding when looking up instances] - - ; let (clas, inst_tys) = tcSplitDFunHead inst_head - (class_tyvars, sc_theta, _, op_items) = classBigSig clas - sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta - - ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta']) - - -- Deal with 'SPECIALISE instance' pragmas - -- See Note [SPECIALISE instance pragmas] - ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds - - -- Typecheck superclasses and methods - -- See Note [Typechecking plan for instance declarations] - ; dfun_ev_binds_var <- newTcEvBinds - ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var - ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics)) - <- pushTcLevelM $ - do { (sc_ids, sc_binds, sc_implics) - <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars - inst_tys dfun_ev_binds - sc_theta' - - -- Typecheck the methods - ; (meth_ids, meth_binds, meth_implics) - <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars - inst_tys dfun_ev_binds spec_inst_info - op_items ibinds - - ; return ( sc_ids ++ meth_ids - , sc_binds `unionBags` meth_binds - , sc_implics `unionBags` meth_implics ) } - - ; imp <- newImplication - ; emitImplication $ - imp { ic_tclvl = tclvl - , ic_skols = inst_tyvars - , ic_given = dfun_ev_vars - , ic_wanted = mkImplicWC sc_meth_implics - , ic_binds = dfun_ev_binds_var - , ic_info = InstSkol } - - -- Create the result bindings - ; self_dict <- newDict clas inst_tys - ; let class_tc = classTyCon clas - [dict_constr] = tyConDataCons class_tc - dict_bind = mkVarBind self_dict (L loc con_app_args) - - -- We don't produce a binding for the dict_constr; instead we - -- rely on the simplifier to unfold this saturated application - -- We do this rather than generate an HsCon directly, because - -- it means that the special cases (e.g. dictionary with only one - -- member) are dealt with by the common MkId.mkDataConWrapId - -- code rather than needing to be repeated here. - -- con_app_tys = MkD ty1 ty2 - -- con_app_scs = MkD ty1 ty2 sc1 sc2 - -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 - con_app_tys = mkHsWrap (mkWpTyApps inst_tys) - (HsConLikeOut noExtField (RealDataCon dict_constr)) - -- NB: We *can* have covars in inst_tys, in the case of - -- promoted GADT constructors. - - con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids - - app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc - app_to_meth fun meth_id = HsApp noExtField (L loc fun) - (L loc (wrapId arg_wrapper meth_id)) - - inst_tv_tys = mkTyVarTys inst_tyvars - arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys - - is_newtype = isNewTyCon class_tc - dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids - dfun_spec_prags - | is_newtype = SpecPrags [] - | otherwise = SpecPrags spec_inst_prags - -- Newtype dfuns just inline unconditionally, - -- so don't attempt to specialise them - - export = ABE { abe_ext = noExtField - , abe_wrap = idHsWrapper - , abe_poly = dfun_id_w_prags - , abe_mono = self_dict - , abe_prags = dfun_spec_prags } - -- NB: see Note [SPECIALISE instance pragmas] - main_bind = AbsBinds { abs_ext = noExtField - , abs_tvs = inst_tyvars - , abs_ev_vars = dfun_ev_vars - , abs_exports = [export] - , abs_ev_binds = [] - , abs_binds = unitBag dict_bind - , abs_sig = True } - - ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds) - } - where - dfun_id = instanceDFunId ispec - loc = getSrcSpan dfun_id - -addDFunPrags :: DFunId -> [Id] -> DFunId --- DFuns need a special Unfolding and InlinePrag --- See Note [ClassOp/DFun selection] --- and Note [Single-method classes] --- It's easiest to create those unfoldings right here, where --- have all the pieces in hand, even though we are messing with --- Core at this point, which the typechecker doesn't usually do --- However we take care to build the unfolding using the TyVars from --- the DFunId rather than from the skolem pieces that the typechecker --- is messing with. -addDFunPrags dfun_id sc_meth_ids - | is_newtype - = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 con_app - `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } - | otherwise - = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args - `setInlinePragma` dfunInlinePragma - where - con_app = mkLams dfun_bndrs $ - mkApps (Var (dataConWrapId dict_con)) dict_args - -- mkApps is OK because of the checkForLevPoly call in checkValidClass - -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad - dict_args = map Type inst_tys ++ - [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] - - (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id) - ev_ids = mkTemplateLocalsNum 1 dfun_theta - dfun_bndrs = dfun_tvs ++ ev_ids - clas_tc = classTyCon clas - [dict_con] = tyConDataCons clas_tc - is_newtype = isNewTyCon clas_tc - -wrapId :: HsWrapper -> Id -> HsExpr GhcTc -wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLoc id)) - -{- Note [Typechecking plan for instance declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For instance declarations we generate the following bindings and implication -constraints. Example: - - instance Ord a => Ord [a] where compare = - -generates this: - - Bindings: - -- Method bindings - $ccompare :: forall a. Ord a => a -> a -> Ordering - $ccompare = /\a \(d:Ord a). let in ... - - -- Superclass bindings - $cp1Ord :: forall a. Ord a => Eq [a] - $cp1Ord = /\a \(d:Ord a). let - in dfEqList (dw :: Eq a) - - Constraints: - forall a. Ord a => - -- Method constraint - (forall. (empty) => ) - -- Superclass constraint - /\ (forall. (empty) => dw :: Eq a) - -Notice that - - * Per-meth/sc implication. There is one inner implication per - superclass or method, with no skolem variables or givens. The only - reason for this one is to gather the evidence bindings privately - for this superclass or method. This implication is generated - by checkInstConstraints. - - * Overall instance implication. There is an overall enclosing - implication for the whole instance declaration, with the expected - skolems and givens. We need this to get the correct "redundant - constraint" warnings, gathering all the uses from all the methods - and superclasses. See TcSimplify Note [Tracking redundant - constraints] - - * The given constraints in the outer implication may generate - evidence, notably by superclass selection. Since the method and - superclass bindings are top-level, we want that evidence copied - into *every* method or superclass definition. (Some of it will - be usused in some, but dead-code elimination will drop it.) - - We achieve this by putting the evidence variable for the overall - instance implication into the AbsBinds for each method/superclass. - Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses. - (And that in turn is why the abs_ev_binds field of AbBinds is a - [TcEvBinds] rather than simply TcEvBinds. - - This is a bit of a hack, but works very nicely in practice. - - * Note that if a method has a locally-polymorphic binding, there will - be yet another implication for that, generated by tcPolyCheck - in tcMethodBody. E.g. - class C a where - foo :: forall b. Ord b => blah - - -************************************************************************ -* * - Type-checking superclasses -* * -************************************************************************ --} - -tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] - -> TcEvBinds - -> TcThetaType - -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication) --- Make a new top-level function binding for each superclass, --- something like --- $Ordp1 :: forall a. Ord a => Eq [a] --- $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d) --- --- See Note [Recursive superclasses] for why this is so hard! --- In effect, we build a special-purpose solver for the first step --- of solving each superclass constraint -tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta - = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..]) - ; return (ids, listToBag binds, listToBag implics) } - where - loc = getSrcSpan dfun_id - size = sizeTypes inst_tys - tc_super (sc_pred, n) - = do { (sc_implic, ev_binds_var, sc_ev_tm) - <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred - - ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) - ; sc_ev_id <- newEvVar sc_pred - ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm - ; let sc_top_ty = mkInvForAllTys tyvars $ - mkPhiTy (map idType dfun_evs) sc_pred - sc_top_id = mkLocalId sc_top_name sc_top_ty - export = ABE { abe_ext = noExtField - , abe_wrap = idHsWrapper - , abe_poly = sc_top_id - , abe_mono = sc_ev_id - , abe_prags = noSpecPrags } - local_ev_binds = TcEvBinds ev_binds_var - bind = AbsBinds { abs_ext = noExtField - , abs_tvs = tyvars - , abs_ev_vars = dfun_evs - , abs_exports = [export] - , abs_ev_binds = [dfun_ev_binds, local_ev_binds] - , abs_binds = emptyBag - , abs_sig = False } - ; return (sc_top_id, L loc bind, sc_implic) } - -------------------- -checkInstConstraints :: TcM result - -> TcM (Implication, EvBindsVar, result) --- See Note [Typechecking plan for instance declarations] -checkInstConstraints thing_inside - = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $ - thing_inside - - ; ev_binds_var <- newTcEvBinds - ; implic <- newImplication - ; let implic' = implic { ic_tclvl = tclvl - , ic_wanted = wanted - , ic_binds = ev_binds_var - , ic_info = InstSkol } - - ; return (implic', ev_binds_var, result) } - -{- -Note [Recursive superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #3731, #4809, #5751, #5913, #6117, #6161, which all -describe somewhat more complicated situations, but ones -encountered in practice. - -See also tests tcrun020, tcrun021, tcrun033, and #11427. - ------ THE PROBLEM -------- -The problem is that it is all too easy to create a class whose -superclass is bottom when it should not be. - -Consider the following (extreme) situation: - class C a => D a where ... - instance D [a] => D [a] where ... (dfunD) - instance C [a] => C [a] where ... (dfunC) -Although this looks wrong (assume D [a] to prove D [a]), it is only a -more extreme case of what happens with recursive dictionaries, and it -can, just about, make sense because the methods do some work before -recursing. - -To implement the dfunD we must generate code for the superclass C [a], -which we had better not get by superclass selection from the supplied -argument: - dfunD :: forall a. D [a] -> D [a] - dfunD = \d::D [a] -> MkD (scsel d) .. - -Otherwise if we later encounter a situation where -we have a [Wanted] dw::D [a] we might solve it thus: - dw := dfunD dw -Which is all fine except that now ** the superclass C is bottom **! - -The instance we want is: - dfunD :: forall a. D [a] -> D [a] - dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ... - ------ THE SOLUTION -------- -The basic solution is simple: be very careful about using superclass -selection to generate a superclass witness in a dictionary function -definition. More precisely: - - Superclass Invariant: in every class dictionary, - every superclass dictionary field - is non-bottom - -To achieve the Superclass Invariant, in a dfun definition we can -generate a guaranteed-non-bottom superclass witness from: - (sc1) one of the dictionary arguments itself (all non-bottom) - (sc2) an immediate superclass of a smaller dictionary - (sc3) a call of a dfun (always returns a dictionary constructor) - -The tricky case is (sc2). We proceed by induction on the size of -the (type of) the dictionary, defined by TcValidity.sizeTypes. -Let's suppose we are building a dictionary of size 3, and -suppose the Superclass Invariant holds of smaller dictionaries. -Then if we have a smaller dictionary, its immediate superclasses -will be non-bottom by induction. - -What does "we have a smaller dictionary" mean? It might be -one of the arguments of the instance, or one of its superclasses. -Here is an example, taken from CmmExpr: - class Ord r => UserOfRegs r a where ... -(i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where -(i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where - -For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a), -since it is smaller than the thing we are building (UserOfRegs r (Maybe a). - -But for (i2) that isn't the case, so we must add an explicit, and -perhaps surprising, (Ord r) argument to the instance declaration. - -Here's another example from #6161: - - class Super a => Duper a where ... - class Duper (Fam a) => Foo a where ... -(i3) instance Foo a => Duper (Fam a) where ... -(i4) instance Foo Float where ... - -It would be horribly wrong to define - dfDuperFam :: Foo a -> Duper (Fam a) -- from (i3) - dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ... - - dfFooFloat :: Foo Float -- from (i4) - dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ... - -Now the Super superclass of Duper is definitely bottom! - -This won't happen because when processing (i3) we can use the -superclasses of (Foo a), which is smaller, namely Duper (Fam a). But -that is *not* smaller than the target so we can't take *its* -superclasses. As a result the program is rightly rejected, unless you -add (Super (Fam a)) to the context of (i3). - -Note [Solving superclass constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -How do we ensure that every superclass witness is generated by -one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses]. -Answer: - - * Superclass "wanted" constraints have CtOrigin of (ScOrigin size) - where 'size' is the size of the instance declaration. e.g. - class C a => D a where... - instance blah => D [a] where ... - The wanted superclass constraint for C [a] has origin - ScOrigin size, where size = size( D [a] ). - - * (sc1) When we rewrite such a wanted constraint, it retains its - origin. But if we apply an instance declaration, we can set the - origin to (ScOrigin infinity), thus lifting any restrictions by - making prohibitedSuperClassSolve return False. - - * (sc2) ScOrigin wanted constraints can't be solved from a - superclass selection, except at a smaller type. This test is - implemented by TcInteract.prohibitedSuperClassSolve - - * The "given" constraints of an instance decl have CtOrigin - GivenOrigin InstSkol. - - * When we make a superclass selection from InstSkol we use - a SkolemInfo of (InstSC size), where 'size' is the size of - the constraint whose superclass we are taking. A similarly - when taking the superclass of an InstSC. This is implemented - in TcCanonical.newSCWorkFromFlavored - -Note [Silent superclass arguments] (historical interest only) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB1: this note describes our *old* solution to the - recursive-superclass problem. I'm keeping the Note - for now, just as institutional memory. - However, the code for silent superclass arguments - was removed in late Dec 2014 - -NB2: the silent-superclass solution introduced new problems - of its own, in the form of instance overlap. Tests - SilentParametersOverlapping, T5051, and T7862 are examples - -NB3: the silent-superclass solution also generated tons of - extra dictionaries. For example, in monad-transformer - code, when constructing a Monad dictionary you had to pass - an Applicative dictionary; and to construct that you need - a Functor dictionary. Yet these extra dictionaries were - often never used. Test T3064 compiled *far* faster after - silent superclasses were eliminated. - -Our solution to this problem "silent superclass arguments". We pass -to each dfun some ``silent superclass arguments’’, which are the -immediate superclasses of the dictionary we are trying to -construct. In our example: - dfun :: forall a. C [a] -> D [a] -> D [a] - dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ... -Notice the extra (dc :: C [a]) argument compared to the previous version. - -This gives us: - - ----------------------------------------------------------- - DFun Superclass Invariant - ~~~~~~~~~~~~~~~~~~~~~~~~ - In the body of a DFun, every superclass argument to the - returned dictionary is - either * one of the arguments of the DFun, - or * constant, bound at top level - ----------------------------------------------------------- - -This net effect is that it is safe to treat a dfun application as -wrapping a dictionary constructor around its arguments (in particular, -a dfun never picks superclasses from the arguments under the -dictionary constructor). No superclass is hidden inside a dfun -application. - -The extra arguments required to satisfy the DFun Superclass Invariant -always come first, and are called the "silent" arguments. You can -find out how many silent arguments there are using Id.dfunNSilent; -and then you can just drop that number of arguments to see the ones -that were in the original instance declaration. - -DFun types are built (only) by MkId.mkDictFunId, so that is where we -decide what silent arguments are to be added. --} - -{- -************************************************************************ -* * - Type-checking an instance method -* * -************************************************************************ - -tcMethod -- Make the method bindings, as a [(NonRec, HsBinds)], one per method -- Remembering to use fresh Name (the instance method Name) as the binder -- Bring the instance method Ids into scope, for the benefit of tcInstSig -- Use sig_fn mapping instance method Name -> instance tyvars -- Ditto prag_fn -- Use tcValBinds to do the checking --} - -tcMethods :: DFunId -> Class - -> [TcTyVar] -> [EvVar] - -> [TcType] - -> TcEvBinds - -> ([Located TcSpecPrag], TcPragEnv) - -> [ClassOpItem] - -> InstBindings GhcRn - -> TcM ([Id], LHsBinds GhcTc, Bag Implication) - -- The returned inst_meth_ids all have types starting - -- forall tvs. theta => ... -tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds (spec_inst_prags, prag_fn) op_items - (InstBindings { ib_binds = binds - , ib_tyvars = lexical_tvs - , ib_pragmas = sigs - , ib_extensions = exts - , ib_derived = is_derived }) - = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $ - -- The lexical_tvs scope over the 'where' part - do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) - ; checkMinimalDefinition - ; checkMethBindMembership - ; (ids, binds, mb_implics) <- set_exts exts $ - unset_warnings_deriving $ - mapAndUnzip3M tc_item op_items - ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) } - where - set_exts :: [LangExt.Extension] -> TcM a -> TcM a - set_exts es thing = foldr setXOptM thing es - - -- See Note [Avoid -Winaccessible-code when deriving] - unset_warnings_deriving :: TcM a -> TcM a - unset_warnings_deriving - | is_derived = unsetWOptM Opt_WarnInaccessibleCode - | otherwise = id - - hs_sig_fn = mkHsSigFun sigs - inst_loc = getSrcSpan dfun_id - - ---------------------- - tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication) - tc_item (sel_id, dm_info) - | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn - = tcMethodBody clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds is_derived hs_sig_fn - spec_inst_prags prags - sel_id user_bind bndr_loc - | otherwise - = do { traceTc "tc_def" (ppr sel_id) - ; tc_default sel_id dm_info } - - ---------------------- - tc_default :: Id -> DefMethInfo - -> TcM (TcId, LHsBind GhcTc, Maybe Implication) - - tc_default sel_id (Just (dm_name, _)) - = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name - ; tcMethodBody 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) - ; (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) - ; return (meth_id, meth_bind, Nothing) } - where - error_rhs dflags = L inst_loc $ HsApp noExtField error_fun (error_msg dflags) - error_fun = L inst_loc $ - wrapId (mkWpTyApps - [ getRuntimeRep meth_tau, meth_tau]) - nO_METHOD_BINDING_ERROR_ID - error_msg dflags = L inst_loc (HsLit noExtField (HsStringPrim NoSourceText - (unsafeMkByteString (error_string dflags)))) - meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys) - error_string dflags = showSDoc dflags - (hcat [ppr inst_loc, vbar, ppr sel_id ]) - lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars - - ---------------------- - -- Check if one of the minimal complete definitions is satisfied - checkMinimalDefinition - = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $ - warnUnsatisfiedMinimalDefinition - - methodExists meth = isJust (findMethodBind meth binds prag_fn) - - ---------------------- - -- Check if any method bindings do not correspond to the class. - -- See Note [Mismatched class methods and associated type families]. - checkMethBindMembership - = mapM_ (addErrTc . badMethodErr clas) mismatched_meths - where - bind_nms = map unLoc $ collectMethodBinders binds - cls_meth_nms = map (idName . fst) op_items - mismatched_meths = bind_nms `minusList` cls_meth_nms - -{- -Note [Mismatched class methods and associated type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's entirely possible for someone to put methods or associated type family -instances inside of a class in which it doesn't belong. For instance, we'd -want to fail if someone wrote this: - - instance Eq () where - type Rep () = Maybe - compare = undefined - -Since neither the type family `Rep` nor the method `compare` belong to the -class `Eq`. Normally, this is caught in the renamer when resolving RdrNames, -since that would discover that the parent class `Eq` is incorrect. - -However, there is a scenario in which the renamer could fail to catch this: -if the instance was generated through Template Haskell, as in #12387. In that -case, Template Haskell will provide fully resolved names (e.g., -`GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going -on. For this reason, we also put an extra validity check for this in the -typechecker as a last resort. - -Note [Avoid -Winaccessible-code when deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --Winaccessible-code can be particularly noisy when deriving instances for -GADTs. Consider the following example (adapted from #8128): - - data T a where - MkT1 :: Int -> T Int - MkT2 :: T Bool - MkT3 :: T Bool - deriving instance Eq (T a) - deriving instance Ord (T a) - -In the derived Ord instance, GHC will generate the following code: - - instance Ord (T a) where - compare x y - = case x of - MkT2 - -> case y of - MkT1 {} -> GT - MkT2 -> EQ - _ -> LT - ... - -However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2 -differ, so if -Winaccessible-code is enabled, then deriving this instance will -result in unwelcome warnings. - -One conceivable approach to fixing this issue would be to change `deriving Ord` -such that it becomes smarter about not generating unreachable cases. This, -however, would be a highly nontrivial refactor, as we'd have to propagate -through typing information everywhere in the algorithm that generates Ord -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: - -1. In tcMethods (which typechecks method bindings), disable - -Winaccessible-code. -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! --} - ------------------------- -tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType] - -> TcEvBinds -> Bool - -> HsSigFun - -> [LTcSpecPrag] -> [LSig GhcRn] - -> Id -> LHsBind GhcRn -> SrcSpan - -> TcM (TcId, LHsBind GhcTc, Maybe Implication) -tcMethodBody clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds is_derived - sig_fn spec_inst_prags prags - sel_id (L bind_loc meth_bind) bndr_loc - = add_meth_ctxt $ - do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc) - ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $ - mkMethIds clas tyvars dfun_ev_vars - inst_tys sel_id - - ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) } - -- Substitute the local_meth_name for the binder - -- NB: the binding is always a FunBind - - -- taking instance signature into account might change the type of - -- the local_meth_id - ; (meth_implic, ev_binds_var, tc_bind) - <- checkInstConstraints $ - tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind) - - ; global_meth_id <- addInlinePrags global_meth_id prags - ; spec_prags <- tcSpecPrags global_meth_id prags - - ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags - export = ABE { abe_ext = noExtField - , abe_poly = global_meth_id - , abe_mono = local_meth_id - , abe_wrap = idHsWrapper - , abe_prags = specs } - - local_ev_binds = TcEvBinds ev_binds_var - full_bind = AbsBinds { abs_ext = noExtField - , abs_tvs = tyvars - , abs_ev_vars = dfun_ev_vars - , abs_exports = [export] - , abs_ev_binds = [dfun_ev_binds, local_ev_binds] - , abs_binds = tc_bind - , abs_sig = True } - - ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) } - where - -- For instance decls that come from deriving clauses - -- we want to print out the full source code if there's an error - -- because otherwise the user won't see the code at all - add_meth_ctxt thing - | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing - | otherwise = thing - -tcMethodBodyHelp :: HsSigFun -> Id -> TcId - -> LHsBind GhcRn -> TcM (LHsBinds GhcTcId) -tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind - | Just hs_sig_ty <- hs_sig_fn sel_name - -- There is a signature in the instance - -- See Note [Instance method signatures] - = do { let ctxt = FunSigCtxt sel_name True - ; (sig_ty, hs_wrap) - <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $ - do { inst_sigs <- xoptM LangExt.InstanceSigs - ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty) - ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty - ; let local_meth_ty = idType local_meth_id - ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $ - tcSubType_NC ctxt sig_ty local_meth_ty - ; return (sig_ty, hs_wrap) } - - ; inner_meth_name <- newName (nameOccName sel_name) - ; let inner_meth_id = mkLocalId inner_meth_name sig_ty - inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id - , sig_ctxt = ctxt - , sig_loc = getLoc (hsSigType hs_sig_ty) } - - - ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind - - ; let export = ABE { abe_ext = noExtField - , abe_poly = local_meth_id - , abe_mono = inner_id - , abe_wrap = hs_wrap - , abe_prags = noSpecPrags } - - ; return (unitBag $ L (getLoc meth_bind) $ - AbsBinds { abs_ext = noExtField, abs_tvs = [], abs_ev_vars = [] - , abs_exports = [export] - , abs_binds = tc_bind, abs_ev_binds = [] - , abs_sig = True }) } - - | otherwise -- No instance signature - = do { let ctxt = FunSigCtxt sel_name False - -- False <=> don't report redundant constraints - -- The signature is not under the users control! - tc_sig = completeSigFromId ctxt local_meth_id - -- Absent a type sig, there are no new scoped type variables here - -- Only the ones from the instance decl itself, which are already - -- in scope. Example: - -- class C a where { op :: forall b. Eq b => ... } - -- instance C [c] where { op = } - -- In , 'c' is scope but 'b' is not! - - ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind - ; return tc_bind } - - where - sel_name = idName sel_id - no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; - -- they are all for meth_id - - ------------------------- -mkMethIds :: Class -> [TcTyVar] -> [EvVar] - -> [TcType] -> Id -> TcM (TcId, TcId) - -- returns (poly_id, local_id), but ignoring any instance signature - -- See Note [Instance method signatures] -mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id - = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ) - ; local_meth_name <- newName sel_occ - -- Base the local_meth_name on the selector name, because - -- type errors from tcMethodBody come from here - ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty - local_meth_id = mkLocalId local_meth_name local_meth_ty - - ; return (poly_meth_id, local_meth_id) } - where - sel_name = idName sel_id - sel_occ = nameOccName sel_name - local_meth_ty = instantiateMethod clas sel_id inst_tys - poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty - theta = map idType dfun_ev_vars - -methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) -methSigCtxt sel_name sig_ty meth_ty env0 - = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty - ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty - ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name)) - 2 (vcat [ text "is more general than its signature in the class" - , text "Instance sig:" <+> ppr sig_ty - , text " Class sig:" <+> ppr meth_ty ]) - ; return (env2, msg) } - -misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc -misplacedInstSig name hs_ty - = vcat [ hang (text "Illegal type signature in instance declaration:") - 2 (hang (pprPrefixName name) - 2 (dcolon <+> ppr hs_ty)) - , text "(Use InstanceSigs to allow this)" ] - -{- Note [Instance method signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With -XInstanceSigs we allow the user to supply a signature for the -method in an instance declaration. Here is an artificial example: - - data T a = MkT a - instance Ord a => Ord (T a) where - (>) :: forall b. b -> b -> Bool - (>) = error "You can't compare Ts" - -The instance signature can be *more* polymorphic than the instantiated -class method (in this case: Age -> Age -> Bool), but it cannot be less -polymorphic. Moreover, if a signature is given, the implementation -code should match the signature, and type variables bound in the -singature should scope over the method body. - -We achieve this by building a TcSigInfo for the method, whether or not -there is an instance method signature, and using that to typecheck -the declaration (in tcMethodBody). That means, conveniently, -that the type variables bound in the signature will scope over the body. - -What about the check that the instance method signature is more -polymorphic than the instantiated class method type? We just do a -tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like -this (for the example above - - AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a] - , abs_exports - = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool - , gr_lcl :: T a -> T a -> Bool } - , abs_binds - = AbsBind { abs_tvs = [], abs_ev_vars = [] - , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool - , gr_inner :: forall b. b -> b -> Bool } - , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = [] - , ..etc.. } - } } - -Wow! Three nested AbsBinds! - * The outer one abstracts over the tyvars and dicts for the instance - * The middle one is only present if there is an instance signature, - and does the impedance matching for that signature - * The inner one is for the method binding itself against either the - signature from the class, or the instance signature. --} - ----------------------- -mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags - -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id - -- There are two sources: - -- * spec_prags_for_me: {-# SPECIALISE op :: #-} - -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: #-} - -- These ones have the dfun inside, but [perhaps surprisingly] - -- the correct wrapper. - -- See Note [Handling SPECIALISE pragmas] in TcBinds -mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me - = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst) - where - spec_prags_from_inst - | isInlinePragma (idInlinePragma meth_id) - = [] -- Do not inherit SPECIALISE from the instance if the - -- method is marked INLINE, because then it'll be inlined - -- and the specialisation would do nothing. (Indeed it'll provoke - -- a warning from the desugarer - | otherwise - = [ L inst_loc (SpecPrag meth_id wrap inl) - | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] - - -mkDefMethBind :: Class -> [Type] -> Id -> Name - -> TcM (LHsBind GhcRn, [LSig GhcRn]) --- The is a default method (vanailla or generic) defined in the class --- So make a binding op = $dmop @t1 @t2 --- where $dmop is the name of the default method in the class, --- and t1,t2 are the instance types. --- See Note [Default methods in instances] for why we use --- visible type application here -mkDefMethBind clas inst_tys sel_id dm_name - = do { dflags <- getDynFlags - ; dm_id <- tcLookupId dm_name - ; let inline_prag = idInlinePragma dm_id - inline_prags | isAnyInlinePragma inline_prag - = [noLoc (InlineSig noExtField fn inline_prag)] - | otherwise - = [] - -- Copy the inline pragma (if any) from the default method - -- to this version. Note [INLINE and default methods] - - fn = noLoc (idName sel_id) - visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys - , tyConBinderArgFlag tcb /= Inferred ] - rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys - bind = noLoc $ mkTopFunBind Generated fn $ - [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] - - ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" - FormatHaskell - (vcat [ppr clas <+> ppr inst_tys, - nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) - - ; return (bind, inline_prags) } - where - mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn - mk_vta fun ty = noLoc (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy - $ noLoc $ XHsType $ NHsCoreTy ty)) - -- NB: use visible type application - -- See Note [Default methods in instances] - ----------------------- -derivBindCtxt :: Id -> Class -> [Type ] -> SDoc -derivBindCtxt sel_id clas tys - = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id) - , nest 2 (text "in a derived instance for" - <+> quotes (pprClassPred clas tys) <> colon) - , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ] - -warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () -warnUnsatisfiedMinimalDefinition mindef - = do { warn <- woptM Opt_WarnMissingMethods - ; warnTc (Reason Opt_WarnMissingMethods) warn message - } - where - message = vcat [text "No explicit implementation for" - ,nest 2 $ pprBooleanFormulaNice mindef - ] - -{- -Note [Export helper functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We arrange to export the "helper functions" of an instance declaration, -so that they are not subject to preInlineUnconditionally, even if their -RHS is trivial. Reason: they are mentioned in the DFunUnfolding of -the dict fun as Ids, not as CoreExprs, so we can't substitute a -non-variable for them. - -We could change this by making DFunUnfoldings have CoreExprs, but it -seems a bit simpler this way. - -Note [Default methods in instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - - class Baz v x where - foo :: x -> x - foo y = - - instance Baz Int Int - -From the class decl we get - - $dmfoo :: forall v x. Baz v x => x -> x - $dmfoo y = - -Notice that the type is ambiguous. So we use Visible Type Application -to disambiguate: - - $dBazIntInt = MkBaz fooIntInt - fooIntInt = $dmfoo @Int @Int - -Lacking VTA we'd get ambiguity errors involving the default method. This applies -equally to vanilla default methods (#1061) and generic default methods -(#12220). - -Historical note: before we had VTA we had to generate -post-type-checked code, which took a lot more code, and didn't work for -generic default methods. - -Note [INLINE and default methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Default methods need special case. They are supposed to behave rather like -macros. For example - - class Foo a where - op1, op2 :: Bool -> a -> a - - {-# INLINE op1 #-} - op1 b x = op2 (not b) x - - instance Foo Int where - -- op1 via default method - op2 b x = - -The instance declaration should behave - - just as if 'op1' had been defined with the - code, and INLINE pragma, from its original - definition. - -That is, just as if you'd written - - instance Foo Int where - op2 b x = - - {-# INLINE op1 #-} - op1 b x = op2 (not b) x - -So for the above example we generate: - - {-# INLINE $dmop1 #-} - -- $dmop1 has an InlineCompulsory unfolding - $dmop1 d b x = op2 d (not b) x - - $fFooInt = MkD $cop1 $cop2 - - {-# INLINE $cop1 #-} - $cop1 = $dmop1 $fFooInt - - $cop2 = - -Note carefully: - -* We *copy* any INLINE pragma from the default method $dmop1 to the - instance $cop1. Otherwise we'll just inline the former in the - latter and stop, which isn't what the user expected - -* Regardless of its pragma, we give the default method an - unfolding with an InlineCompulsory source. That means - that it'll be inlined at every use site, notably in - each instance declaration, such as $cop1. This inlining - must happen even though - a) $dmop1 is not saturated in $cop1 - b) $cop1 itself has an INLINE pragma - - It's vital that $dmop1 *is* inlined in this way, to allow the mutual - recursion between $fooInt and $cop1 to be broken - -* To communicate the need for an InlineCompulsory to the desugarer - (which makes the Unfoldings), we use the IsDefaultMethod constructor - in TcSpecPrags. - - -************************************************************************ -* * - Specialise instance pragmas -* * -************************************************************************ - -Note [SPECIALISE instance pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - instance (Ix a, Ix b) => Ix (a,b) where - {-# SPECIALISE instance Ix (Int,Int) #-} - range (x,y) = ... - -We make a specialised version of the dictionary function, AND -specialised versions of each *method*. Thus we should generate -something like this: - - $dfIxPair :: (Ix a, Ix b) => Ix (a,b) - {-# DFUN [$crangePair, ...] #-} - {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-} - $dfIxPair da db = Ix ($crangePair da db) (...other methods...) - - $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] - {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} - $crange da db = - -The SPECIALISE pragmas are acted upon by the desugarer, which generate - - dii :: Ix Int - dii = ... - - $s$dfIxPair :: Ix ((Int,Int),(Int,Int)) - {-# DFUN [$crangePair di di, ...] #-} - $s$dfIxPair = Ix ($crangePair di di) (...) - - {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-} - - $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)] - $c$crangePair = ...specialised RHS of $crangePair... - - {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-} - -Note that - - * The specialised dictionary $s$dfIxPair is very much needed, in case we - call a function that takes a dictionary, but in a context where the - specialised dictionary can be used. See #7797. - - * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because - it still has a DFunUnfolding. See Note [ClassOp/DFun selection] - - * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways: - --> {ClassOp rule for range} $crangePair Int Int d1 d2 - --> {SPEC rule for $crangePair} $s$crangePair - or thus: - --> {SPEC rule for $dfIxPair} range $s$dfIxPair - --> {ClassOpRule for range} $s$crangePair - It doesn't matter which way. - - * We want to specialise the RHS of both $dfIxPair and $crangePair, - but the SAME HsWrapper will do for both! We can call tcSpecPrag - just once, and pass the result (in spec_inst_info) to tcMethods. --} - -tcSpecInstPrags :: DFunId -> InstBindings GhcRn - -> TcM ([Located TcSpecPrag], TcPragEnv) -tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) - = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ - filter isSpecInstLSig uprags - -- The filter removes the pragmas for methods - ; return (spec_inst_prags, mkPragEnv uprags binds) } - ------------------------------- -tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag -tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty) - = addErrCtxt (spec_ctxt prag) $ - do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty - ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty - ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } - where - spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) - -tcSpecInst _ _ = panic "tcSpecInst" - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -instDeclCtxt1 :: LHsSigType GhcRn -> SDoc -instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) - -instDeclCtxt2 :: Type -> SDoc -instDeclCtxt2 dfun_ty - = inst_decl_ctxt (ppr (mkClassPred cls tys)) - where - (_,_,cls,tys) = tcSplitDFunTy dfun_ty - -inst_decl_ctxt :: SDoc -> SDoc -inst_decl_ctxt doc = hang (text "In the instance declaration for") - 2 (quotes doc) - -badBootFamInstDeclErr :: SDoc -badBootFamInstDeclErr - = text "Illegal family instance in hs-boot file" - -notFamily :: TyCon -> SDoc -notFamily tycon - = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) - , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] - -assocInClassErr :: TyCon -> SDoc -assocInClassErr name - = text "Associated type" <+> quotes (ppr name) <+> - text "must be inside a class instance" - -badFamInstDecl :: TyCon -> SDoc -badFamInstDecl tc_name - = vcat [ text "Illegal family instance for" <+> - quotes (ppr tc_name) - , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ] - -notOpenFamily :: TyCon -> SDoc -notOpenFamily tc - = text "Illegal instance for closed family" <+> quotes (ppr tc) diff --git a/compiler/typecheck/TcInstDcls.hs-boot b/compiler/typecheck/TcInstDcls.hs-boot deleted file mode 100644 --- a/compiler/typecheck/TcInstDcls.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -module TcInstDcls ( tcInstDecls1 ) where - -import GHC.Hs -import TcRnTypes -import TcEnv( InstInfo ) -import TcDeriv - --- We need this because of the mutual recursion --- between TcTyClsDecls and TcInstDcls -tcInstDecls1 :: [LInstDecl GhcRn] - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs deleted file mode 100644 --- a/compiler/typecheck/TcInteract.hs +++ /dev/null @@ -1,2700 +0,0 @@ -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcInteract ( - solveSimpleGivens, -- Solves [Ct] - solveSimpleWanteds, -- Solves Cts - ) where - -#include "HsVersions.h" - -import GhcPrelude -import GHC.Types.Basic ( SwapFlag(..), isSwapped, - infinity, IntWithInf, intGtLimit ) -import TcCanonical -import TcFlatten -import TcUnify( canSolveByUnification ) -import GHC.Types.Var.Set -import GHC.Core.Type as Type -import GHC.Core.Coercion ( BlockSubstFlag(..) ) -import GHC.Core.InstEnv ( DFunInstType ) -import GHC.Core.Coercion.Axiom ( sfInteractTop, sfInteractInert ) - -import GHC.Types.Var -import TcType -import PrelNames ( coercibleTyConKey, - heqTyConKey, eqTyConKey, ipClassKey ) -import GHC.Core.Coercion.Axiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches ) -import GHC.Core.Class -import GHC.Core.TyCon -import FunDeps -import FamInst -import ClsInst( InstanceWhat(..), safeOverlap ) -import GHC.Core.FamInstEnv -import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) - -import TcEvidence -import Outputable - -import TcRnTypes -import Constraint -import GHC.Core.Predicate -import TcOrigin -import TcSMonad -import Bag -import MonadUtils ( concatMapM, foldlM ) - -import GHC.Core -import Data.List( partition, deleteFirstsBy ) -import GHC.Types.SrcLoc -import GHC.Types.Var.Env - -import Control.Monad -import Maybes( isJust ) -import Pair (Pair(..)) -import GHC.Types.Unique( hasKey ) -import GHC.Driver.Session -import Util -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe - -{- -********************************************************************** -* * -* 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 sideffected - 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 him 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. - -Note [Unflatten after solving the simple wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We unflatten after solving the wc_simples of an implication, and before attempting -to float. This means that - - * The fsk/fmv flatten-skolems only survive during solveSimples. We don't - need to worry about them across successive passes over the constraint tree. - (E.g. we don't need the old ic_fsk field of an implication. - - * When floating an equality outwards, we don't need to worry about floating its - associated flattening constraints. - - * Another tricky case becomes easy: #4935 - type instance F True a b = a - type instance F False a b = b - - [w] F c a b ~ gamma - (c ~ True) => a ~ gamma - (c ~ False) => b ~ gamma - - Obviously this is soluble with gamma := F c a b, and unflattening - will do exactly that after solving the simple constraints and before - attempting the implications. Before, when we were not unflattening, - we had to push Wanted funeqs in as new givens. Yuk! - - Another example that becomes easy: indexed_types/should_fail/T7786 - [W] BuriedUnder sub k Empty ~ fsk - [W] Intersect fsk inv ~ s - [w] xxx[1] ~ s - [W] forall[2] . (xxx[1] ~ Empty) - => Intersect (BuriedUnder sub k Empty) inv ~ Empty - -Note [Running plugins on unflattened wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is an annoying mismatch between solveSimpleGivens and -solveSimpleWanteds, because the latter needs to fiddle with the inert -set, unflatten and zonk the wanteds. It passes the zonked wanteds -to runTcPluginsWanteds, which produces a replacement set of wanteds, -some additional insolubles and a flag indicating whether to go round -the loop again. If so, prepareInertsForImplications is used to remove -the previous wanteds (which will still be in the inert set). Note -that prepareInertsForImplications will discard the insolubles, so we -must keep track of them separately. --} - -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 --- NB: 'simples' may contain /derived/ equalities, floated --- out from a nested implication. So don't discard deriveds! --- 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 (hang (text "solveSimpleWanteds: too many iterations" - <+> parens (text "limit =" <+> ppr limit)) - 2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" - , text "Simples =" <+> ppr simples - , text "WC =" <+> ppr wc ])) - - | isEmptyBag (wc_simple wc) - = return (n,wc) - - | otherwise - = do { -- Solve - (unif_count, wc1) <- solve_simple_wanteds wc - - -- Run plugins - ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1 - -- See Note [Running plugins on unflattened wanteds] - - ; if unif_count == 0 && not rerun_plugin - then return (n, wc2) -- Done - else do { traceTcS "solveSimple going round again:" $ - ppr unif_count $$ ppr rerun_plugin - ; go (n+1) limit wc2 } } -- Loop - - -solve_simple_wanteds :: WantedConstraints -> TcS (Int, 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 }) - = nestTcS $ - do { solveSimples simples1 - ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts - ; (unif_count, unflattened_eqs) <- reportUnifications $ - unflattenWanteds tv_eqs fun_eqs - -- See Note [Unflatten after solving the simple wanteds] - ; return ( unif_count - , WC { wc_simple = others `andCts` unflattened_eqs - , wc_impl = implics1 `unionBags` implics2 }) } - -{- 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; unflattening may lead to improvement that - was not exploitable during solving - 2. Try the plugin - 3. If step 1 did improvement during unflattening; or if the plugin - wants to run again, go back to step 1 - -Non-obviously, improvement can also take place during -the unflattening that takes place in step (1). See TcFlatten, -See Note [Unflattening can force the solver to iterate] --} - --- 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 { plugins <- getTcPlugins - ; if null plugins then return [] else - do { givens <- getInertGivens - ; if null givens then return [] else - do { p <- runTcPlugins plugins (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 (flattened, 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, wc_impl = implics1 }) - | isEmptyBag simples1 - = return (False, wc) - | otherwise - = do { plugins <- getTcPlugins - ; if null plugins then return (False, wc) else - - do { given <- getInertGivens - ; simples1 <- zonkSimples simples1 -- Plugin requires zonked inputs - ; let (wanted, derived) = partition isWantedCt (bagToList simples1) - ; p <- runTcPlugins plugins (given, derived, wanted) - ; let (_, _, solved_wanted) = pluginSolvedCts p - (_, unsolved_derived, unsolved_wanted) = pluginInputCts p - new_wanted = pluginNewCts p - insols = pluginBadCts p - --- SLPJ: I'm deeply suspicious of this --- ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds) - - ; mapM_ setEv solved_wanted - ; return ( notNull (pluginNewCts p) - , WC { wc_simple = listToBag new_wanted `andCts` - listToBag unsolved_wanted `andCts` - listToBag unsolved_derived `andCts` - listToBag insols - , wc_impl = implics1 } ) } } - 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 triple of (given, derived, wanted) constraints to pass to plugins -type SplitCts = ([Ct], [Ct], [Ct]) - --- | A solved triple of constraints, with evidence for wanteds -type SolvedCts = ([Ct], [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 - } - -getTcPlugins :: TcS [TcPluginSolver] -getTcPlugins = do { tcg_env <- getGblEnv; return (tcg_tc_plugins tcg_env) } - --- | Starting from a triple of (given, derived, wanted) constraints, --- invoke each of the typechecker 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. -runTcPlugins :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress -runTcPlugins plugins all_cts - = foldM do_plugin initialProgress plugins - where - do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress - do_plugin p solver = do - result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p)) - return $ progress p result - - progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress - progress p (TcPluginContradiction bad_cts) = - p { pluginInputCts = discard bad_cts (pluginInputCts p) - , pluginBadCts = bad_cts ++ pluginBadCts p - } - progress p (TcPluginOk solved_cts new_cts) = - p { pluginInputCts = discard (map snd solved_cts) (pluginInputCts p) - , pluginSolvedCts = add solved_cts (pluginSolvedCts p) - , pluginNewCts = new_cts ++ pluginNewCts p - } - - initialProgress = TcPluginProgress all_cts ([], [], []) [] [] - - discard :: [Ct] -> SplitCts -> SplitCts - discard cts (xs, ys, zs) = - (xs `without` cts, ys `without` cts, zs `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, deriveds, wanteds) (ev,ct) = case ctEvidence ct of - CtGiven {} -> (ct:givens, deriveds, wanteds) - CtDerived{} -> (givens, ct:deriveds, wanteds) - CtWanted {} -> (givens, deriveds, (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", TcCanonical.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/Derived - then there is no reaction --} - --- Interaction result of WorkItem <~> Ct - -interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct) --- Precondition: if the workitem is a CTyEqCan then it will not be able to --- react with anything at this stage. - -interactWithInertsStage wi - = do { inerts <- getTcSInerts - ; let ics = inert_cans inerts - ; case wi of - CTyEqCan {} -> interactTyVarEq ics wi - CFunEqCan {} -> interactFunEq ics wi - CIrredCan {} -> interactIrred ics wi - CDictCan {} -> interactDict ics wi - _ -> pprPanic "interactWithInerts" (ppr wi) } - -- CHoleCan are put straight into inert_frozen, so never get here - -- CNonCanonical have been canonicalised - -data InteractResult - = 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 intert item from it - -instance Outputable InteractResult where - ppr KeepInert = text "keep inert" - ppr KeepWork = text "keep work-item" - -solveOneFromTheOther :: CtEvidence -- Inert - -> CtEvidence -- WorkItem - -> TcS InteractResult --- Precondition: --- * inert and work item represent evidence for the /same/ predicate --- --- 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 ev_i ev_w - | isDerived ev_w -- Work item is Derived; just discard it - = return KeepInert - - | isDerived ev_i -- The inert item is Derived, we can just throw it away, - = return KeepWork -- The ev_w is inert wrt earlier inert-set items, - -- so it's safe to continue on from this point - - | CtWanted { ctev_loc = loc_w } <- ev_w - , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w - = -- inert must be Given - do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w) - ; return KeepWork } - - | CtWanted {} <- ev_w - -- Inert is Given or Wanted - = return KeepInert - - -- From here on the work-item is Given - - | CtWanted { ctev_loc = loc_i } <- ev_i - , prohibitedSuperClassSolve (ctEvLoc ev_w) loc_i - = do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w) - ; return KeepInert } -- Just discard the un-usable Given - -- This never actually happens because - -- Givens get processed first - - | CtWanted {} <- ev_i - = return KeepWork - - -- From here on both are Given - -- See Note [Replacement vs keeping] - - | lvl_i == lvl_w - = do { ev_binds_var <- getTcEvBindsVar - ; binds <- getTcEvBindsMap ev_binds_var - ; return (same_level_strategy binds) } - - | otherwise -- Both are Given, levels differ - = return different_level_strategy - where - pred = ctEvPred ev_i - loc_i = ctEvLoc ev_i - loc_w = ctEvLoc ev_w - lvl_i = ctLocLevel loc_i - lvl_w = ctLocLevel loc_w - ev_id_i = ctEvEvId ev_i - ev_id_w = ctEvEvId ev_w - - different_level_strategy -- Both Given - | isIPPred 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] (the different-level bullet) - -- For the isIPPred case see Note [Shadowing of Implicit Parameters] - - same_level_strategy binds -- Both Given - | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i - = case ctLocOrigin loc_w of - GivenOrigin (InstSC s_w) | s_w < s_i -> KeepWork - | otherwise -> KeepInert - _ -> KeepWork - - | GivenOrigin (InstSC {}) <- ctLocOrigin loc_w - = KeepInert - - | has_binding binds ev_id_w - , not (has_binding binds ev_id_i) - , not (ev_id_i `elemVarSet` findNeededEvVars binds (unitVarSet ev_id_w)) - = KeepWork - - | otherwise - = KeepInert - - has_binding binds ev_id = isJust (lookupEvBind binds ev_id) - -{- -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! - - * 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 TcSimplify. - - 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. - - * Constraints coming from the same level (i.e. same implication) - - (a) Always get rid of InstSC ones if possible, since they are less - useful for solving. If both are InstSC, choose the one with - the smallest TypeSize - See Note [Solving superclass constraints] in TcInstDcls - - (b) Keep the one that has a non-trivial evidence binding. - Example: f :: (Eq a, Ord a) => blah - then we may find [G] d3 :: Eq a - [G] d2 :: Eq a - with bindings d3 = sc_sel (d1::Ord a) - We want to discard d2 in favour of the superclass selection from - the Ord dictionary. - Why? See Note [Tracking redundant constraints] in TcSimplify again. - - (c) But don't do (b) if the evidence binding depends transitively on the - one without a binding. Example (with RecursiveSuperClasses) - class C a => D a - class D a => C a - Inert: d1 :: C a, d2 :: D a - Binds: d3 = sc_sel d2, d2 = sc_sel d1 - Work item: d3 :: C a - Then it'd be ridiculous to replace d1 with d3 in the inert set! - Hence the findNeedEvVars test. See #14774. - - * 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 TcCanonical - -Doing the depth-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 depth-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 workItem@(CIrredCan { cc_ev = ev_w, cc_status = status }) - | InsolubleCIS <- status - -- 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 - -- See Note [Do not add duplicate derived insolubles] - , not (isDroppableCt workItem) - = continueWith workItem - - | 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 { what_next <- solveOneFromTheOther ev_i ev_w - ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i) - ; case what_next of - KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i) - ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) } - KeepWork -> do { setEvBindIfWanted ev_i (swap_me swap ev_w) - ; updInertIrreds (\_ -> others) - ; continueWith workItem } } - - | otherwise - = continueWith workItem - - where - swap_me :: SwapFlag -> CtEvidence -> EvTerm - swap_me swap ev - = case swap of - NotSwapped -> ctEvTerm ev - IsSwapped -> evCoercion (mkTcSymCo (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. - -Note [Do not add duplicate derived insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we *must* add an insoluble (Int ~ Bool) even if there is -one such there already, because they may come from distinct call -sites. Not only do we want an error message for each, but with --fdefer-type-errors we must generate evidence for each. But for -*derived* insolubles, we only want to report each one once. Why? - -(a) A constraint (C r s t) where r -> s, say, may generate the same fundep - equality many times, as the original constraint is successively rewritten. - -(b) Ditto the successive iterations of the main solver itself, as it traverses - the constraint tree. See example below. - -Also for *given* insolubles we may get repeated errors, as we -repeatedly traverse the constraint tree. These are relatively rare -anyway, so removing duplicates seems ok. (Alternatively we could take -the SrcLoc into account.) - -Note that the test does not need to be particularly efficient because -it is only used if the program has a type error anyway. - -Example of (b): assume a top-level class and instance declaration: - - class D a b | a -> b - instance D [a] [a] - -Assume we have started with an implication: - - forall c. Eq c => { wc_simple = D [c] c [W] } - -which we have simplified to: - - forall c. Eq c => { wc_simple = D [c] c [W] - (c ~ [c]) [D] } - -For some reason, e.g. because we floated an equality somewhere else, -we might try to re-solve this implication. If we do not do a -dropDerivedWC, then we will end up trying to solve the following -constraints the second time: - - (D [c] c) [W] - (c ~ [c]) [D] - -which will result in two Deriveds to end up in the insoluble set: - - wc_simple = D [c] c [W] - (c ~ [c]) [D], (c ~ [c]) [D] --} - -{- -********************************************************************************* -* * - 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 flatten 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 MultiParamTypeClasses, FlexibleInstances #-} - module B where - - import A - - instance A a where - int _ = 1 - - instance C a [b] where - m _ = id - -######### - {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} - {-# LANGUAGE IncoherentInstances #-} - 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 augmennt 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. --} - -interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) -interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) - | Just ev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys - = -- 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" - else - - do { -- Ths short-cut solver didn't fire, so we - -- solve ev_w from the matching inert ev_i we found - what_next <- solveOneFromTheOther ev_i ev_w - ; traceTcS "lookupInertDict" (ppr what_next) - ; case what_next of - KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i) - ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) } - KeepWork -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w) - ; updInertDicts $ \ ds -> delDict ds cls tys - ; continueWith workItem } } } - - | cls `hasKey` ipClassKey - , isGiven ev_w - = interactGivenIP inerts workItem - - | otherwise - = do { addFunDepWork inerts ev_w cls - ; continueWith workItem } - -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 (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 <- ASSERT2( 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 - - ; evc_vs <- mapM (new_wanted_cached 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 :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew - new_wanted_cached 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 pty - | otherwise = mzero - -addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS () --- Add derived constraints from type-class functional dependencies. -addFunDepWork inerts work_ev cls - | isImprovable work_ev - = 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) - | otherwise - = return () - where - work_pred = ctEvPred work_ev - work_loc = ctEvLoc work_ev - - add_fds inert_ct - | isImprovable inert_ev - = 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) ]) ; - - emitFunDepDeriveds $ - improveFromAnother derived_loc inert_pred work_pred - -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok - -- NB: We do create FDs for given to report insoluble equations that arise - -- from pairs of Givens, and also because of floating when we approximate - -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs - } - | otherwise - = return () - where - inert_ev = ctEvidence inert_ct - inert_pred = ctEvPred inert_ev - inert_loc = ctEvLoc 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) } - -{- -********************************************************************** -* * - 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 -* * -********************************************************************** --} - -interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- Try interacting the work item with the inert set -interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc - , cc_tyargs = args, cc_fsk = fsk }) - | Just inert_ct@(CFunEqCan { cc_ev = ev_i - , cc_fsk = fsk_i }) - <- findFunEq (inert_funeqs inerts) tc args - , pr@(swap_flag, upgrade_flag) <- ev_i `funEqCanDischarge` ev - = do { traceTcS "reactFunEq (rewrite inert item):" $ - vcat [ text "work_item =" <+> ppr work_item - , text "inertItem=" <+> ppr ev_i - , text "(swap_flag, upgrade)" <+> ppr pr ] - ; if isSwapped swap_flag - then do { -- Rewrite inert using work-item - let work_item' | upgrade_flag = upgradeWanted work_item - | otherwise = work_item - ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args work_item' - -- Do the updInertFunEqs before the reactFunEq, so that - -- we don't kick out the inertItem as well as consuming it! - ; reactFunEq ev fsk ev_i fsk_i - ; stopWith ev "Work item rewrites inert" } - else do { -- Rewrite work-item using inert - ; when upgrade_flag $ - updInertFunEqs $ \ feqs -> insertFunEq feqs tc args - (upgradeWanted inert_ct) - ; reactFunEq ev_i fsk_i ev fsk - ; stopWith ev "Inert rewrites work item" } } - - | otherwise -- Try improvement - = do { improveLocalFunEqs ev inerts tc args fsk - ; continueWith work_item } - -interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item) - -upgradeWanted :: Ct -> Ct --- We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2 --- so upgrade the [W] to [WD] before putting it in the inert set -upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) } - where - upgrade_ev ev = ASSERT2( isWanted ev, ppr ct ) - ev { ctev_nosh = WDeriv } - -improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar - -> TcS () --- Generate derived improvement equalities, by comparing --- the current work item with inert CFunEqs --- E.g. x + y ~ z, x + y' ~ z => [D] y ~ y' --- --- See Note [FunDep and implicit parameter reactions] -improveLocalFunEqs work_ev inerts fam_tc args fsk - | isGiven work_ev -- See Note [No FunEq improvement for Givens] - || not (isImprovable work_ev) - = return () - - | otherwise - = do { eqns <- improvement_eqns - ; if not (null eqns) - then do { traceTcS "interactFunEq improvements: " $ - vcat [ text "Eqns:" <+> ppr eqns - , text "Candidates:" <+> ppr funeqs_for_tc - , text "Inert eqs:" <+> ppr (inert_eqs inerts) ] - ; emitFunDepDeriveds eqns } - else return () } - - where - funeqs = inert_funeqs inerts - funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc - work_loc = ctEvLoc work_ev - work_pred = ctEvPred work_ev - fam_inj_info = tyConInjectivityInfo fam_tc - - -------------------- - improvement_eqns :: TcS [FunDepEqn CtLoc] - improvement_eqns - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = -- Try built-in families, notably for arithmethic - do { rhs <- rewriteTyVar fsk - ; concatMapM (do_one_built_in ops rhs) funeqs_for_tc } - - | Injective injective_args <- fam_inj_info - = -- Try improvement from type families with injectivity annotations - do { rhs <- rewriteTyVar fsk - ; concatMapM (do_one_injective injective_args rhs) funeqs_for_tc } - - | otherwise - = return [] - - -------------------- - do_one_built_in ops rhs (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev }) - = do { inert_rhs <- rewriteTyVar ifsk - ; return $ mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs inert_rhs) } - - 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 (CFunEqCan { cc_tyargs = inert_args - , cc_fsk = ifsk, cc_ev = inert_ev }) - | isImprovable inert_ev - = do { inert_rhs <- rewriteTyVar ifsk - ; return $ if rhs `tcEqType` inert_rhs - then mk_fd_eqns inert_ev $ - [ Pair arg iarg - | (arg, iarg, True) <- zip3 args inert_args inj_args ] - else [] } - | otherwise - = return [] - - do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) - - -------------------- - mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc] - mk_fd_eqns inert_ev eqns - | null eqns = [] - | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns - , fd_pred1 = work_pred - , fd_pred2 = ctEvPred inert_ev - , fd_loc = loc } ] - where - inert_loc = ctEvLoc inert_ev - loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` - ctl_depth work_loc } - -------------- -reactFunEq :: CtEvidence -> TcTyVar -- From this :: F args1 ~ fsk1 - -> CtEvidence -> TcTyVar -- Solve this :: F args2 ~ fsk2 - -> TcS () -reactFunEq from_this fsk1 solve_this fsk2 - = do { traceTcS "reactFunEq" - (vcat [ppr from_this, ppr fsk1, ppr solve_this, ppr fsk2]) - ; dischargeFunEq solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1) - ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$ - ppr solve_this $$ ppr fsk2) } - -{- 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 two CFunEqCan constraints for F with the same RHS - F s1 t1 ~ rhs - F s2 t2 ~ rhs -then we can use the injectivity to get a new Derived constraint on -the injective argument - [D] 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 simply *Derived* constraints; they have no 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). - -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. - - -Note [Efficient Orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are interacting two FunEqCans with the same LHS: - (inert) ci :: (F ty ~ xi_i) - (work) cw :: (F ty ~ xi_w) -We prefer to keep the inert (else we pass the work item on down -the pipeline, which is a bit silly). If we keep the inert, we -will (a) discharge 'cw' - (b) produce a new equality work-item (xi_w ~ xi_i) -Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w): - new_work :: xi_w ~ xi_i - cw := ci ; sym new_work -Why? Consider the simplest case when xi1 is a type variable. If -we generate xi1~xi2, processing that constraint will kick out 'ci'. -If we generate xi2~xi1, there is less chance of that happening. -Of course it can and should still happen if xi1=a, xi1=Int, say. -But we want to avoid it happening needlessly. - -Similarly, if we *can't* keep the inert item (because inert is Wanted, -and work is Given, say), we prefer to orient the new equality (xi_i ~ -xi_w). - -Note [Carefully solve the right CFunEqCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ---- OLD COMMENT, NOW NOT NEEDED - ---- because we now allow multiple - ---- wanted FunEqs with the same head -Consider the constraints - c1 :: F Int ~ a -- Arising from an application line 5 - c2 :: F Int ~ Bool -- Arising from an application line 10 -Suppose that 'a' is a unification variable, arising only from -flattening. So there is no error on line 5; it's just a flattening -variable. But there is (or might be) an error on line 10. - -Two ways to combine them, leaving either (Plan A) - c1 :: F Int ~ a -- Arising from an application line 5 - c3 :: a ~ Bool -- Arising from an application line 10 -or (Plan B) - c2 :: F Int ~ Bool -- Arising from an application line 10 - c4 :: a ~ Bool -- Arising from an application line 5 - -Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error -on the *totally innocent* line 5. An example is test SimpleFail16 -where the expected/actual message comes out backwards if we use -the wrong plan. - -The second is the right thing to do. Hence the isMetaTyVarTy -test when solving pairwise CFunEqCan. - - -********************************************************************** -* * - interactTyVarEq -* * -********************************************************************** --} - -inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtFlavourRole - -> Maybe ( CtEvidence -- The evidence for the inert - , SwapFlag -- Whether we need mkSymCo - , Bool) -- True <=> keep a [D] version - -- of the [WD] constraint -inertsCanDischarge inerts tv rhs fr - | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i - , cc_eq_rel = eq_rel } - <- findTyEqs inerts tv - , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr - , rhs_i `tcEqType` rhs ] - = -- Inert: a ~ ty - -- Work item: a ~ ty - Just (ev_i, NotSwapped, keep_deriv ev_i) - - | Just tv_rhs <- getTyVar_maybe rhs - , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i - , cc_eq_rel = eq_rel } - <- findTyEqs inerts tv_rhs - , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr - , rhs_i `tcEqType` mkTyVarTy tv ] - = -- Inert: a ~ b - -- Work item: b ~ a - Just (ev_i, IsSwapped, keep_deriv ev_i) - - | otherwise - = Nothing - - where - keep_deriv ev_i - | Wanted WOnly <- ctEvFlavour ev_i -- inert is [W] - , (Wanted WDeriv, _) <- fr -- work item is [WD] - = True -- Keep a derived version of the work item - | otherwise - = False -- Work item is fully discharged - -interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- CTyEqCans are always consumed, so always returns Stop -interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv - , cc_rhs = rhs - , cc_ev = ev - , cc_eq_rel = eq_rel }) - | Just (ev_i, swapped, keep_deriv) - <- inertsCanDischarge inerts tv rhs (ctEvFlavour ev, eq_rel) - = do { setEvBindIfWanted ev $ - evCoercion (maybeSym swapped $ - tcDowngradeRole (eqRelRole eq_rel) - (ctEvRole ev_i) - (ctEvCoercion ev_i)) - - ; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev - , ctev_loc = ctEvLoc ev } - ; when keep_deriv $ - emitWork [workItem { cc_ev = deriv_ev }] - -- As a Derived it might not be fully rewritten, - -- so we emit it as new work - - ; 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 } - - | isGiven ev -- See Note [Touchables and givens] - = continueWith workItem - - | otherwise - = do { tclvl <- getTcLevel - ; if canSolveByUnification tclvl tv rhs - then do { solveByUnification ev tv rhs - ; n_kicked <- kickOutAfterUnification tv - ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) } - - else continueWith workItem } - -interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi) - -solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS () --- Solve with the identity coercion --- Precondition: kind(xi) equals kind(tv) --- Precondition: CtEvidence is Wanted or Derived --- 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 CTyEqCan, a *canonical* constraint. Its invariant (TyEq:OC) --- says that in (a ~ xi), the type variable a does not appear in xi. --- See 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 (tcTypeKind tv_ty), - text "Right Kind is:" <+> ppr (tcTypeKind xi) ] - - ; unifyTyVar tv xi - ; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi)) } - -{- 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 he 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 TcSMonad; 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 (in the unflattener). - - -************************************************************************ -* * -* 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 FunDeps.hs (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 Derived 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 :d 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, but that requires those equalities to carry -evidence and derived do not carry evidence. - -If that were the case with the same inert set and work item we might dischard -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 [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; - [D] K Bool ~ K [a] - [D] 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. --} - -emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS () --- See Note [FunDep and implicit parameter reactions] -emitFunDepDeriveds fd_eqns - = mapM_ do_one_FDEqn fd_eqns - where - do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc }) - | null tvs -- Common shortcut - = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc)) - ; mapM_ (unifyDerived loc Nominal) eqs } - | otherwise - = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs) - ; subst <- instFlexi tvs -- Takes account of kind substitution - ; mapM_ (do_one_eq loc subst) eqs } - - do_one_eq loc subst (Pair ty1 ty2) - = unifyDerived loc Nominal $ - Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2) - -{- -********************************************************************** -* * - 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. Note: -topReactionsStage work_item - = do { traceTcS "doTopReact" (ppr work_item) - ; case work_item of - CDictCan {} -> do { inerts <- getTcSInerts - ; doTopReactDict inerts work_item } - CFunEqCan {} -> doTopReactFunEq work_item - CIrredCan {} -> doTopReactOther work_item - CTyEqCan {} -> 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 --- CTyEqCan e.g. (a ~# ty) --- and CIrredCan e.g. (c a) --- --- Why equalities? See TcCanonical --- 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 work_item res - _ -> continueWith work_item } - - where - ev = ctEvidence work_item - loc = ctEvLoc ev - pred = ctEvPred ev - -doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct) -doTopReactEqPred work_item eq_rel t1 t2 - -- See Note [Looking up primitive equalities in quantified constraints] - | Just (cls, tys) <- boxEqPred eq_rel t1 t2 - = do { res <- matchLocalInst (mkClassPred cls tys) loc - ; case res of - OneInst { cir_mk_ev = mk_ev } - -> chooseInstance work_item - (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) - _ -> continueWith work_item } - - | otherwise - = continueWith work_item - where - ev = ctEvidence work_item - loc = ctEvLoc ev - - 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 TcCanonical - -Note [Flatten when discharging CFunEqCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have the following scenario (#16512): - -type family LV (as :: [Type]) (b :: Type) = (r :: Type) | r -> as b where - LV (a ': as) b = a -> LV as b - -[WD] w1 :: LV as0 (a -> b) ~ fmv1 (CFunEqCan) -[WD] w2 :: fmv1 ~ (a -> fmv2) (CTyEqCan) -[WD] w3 :: LV as0 b ~ fmv2 (CFunEqCan) - -We start with w1. Because LV is injective, we wish to see if the RHS of the -equation matches the RHS of the CFunEqCan. The RHS of a CFunEqCan is always an -fmv, so we "look through" to get (a -> fmv2). Then we run tcUnifyTyWithTFs. -That performs the match, but it allows a type family application (such as the -LV in the RHS of the equation) to match with anything. (See "Injective type -families" by Stolarek et al., HS'15, Fig. 2) The matching succeeds, which -means we can improve as0 (and b, but that's not interesting here). However, -because the RHS of w1 can't see through fmv2 (we have no way of looking up a -LHS of a CFunEqCan from its RHS, and this use case isn't compelling enough), -we invent a new unification variable here. We thus get (as0 := a : as1). -Rewriting: - -[WD] w1 :: LV (a : as1) (a -> b) ~ fmv1 -[WD] w2 :: fmv1 ~ (a -> fmv2) -[WD] w3 :: LV (a : as1) b ~ fmv2 - -We can now reduce both CFunEqCans, using the equation for LV. We get - -[WD] w2 :: (a -> LV as1 (a -> b)) ~ (a -> a -> LV as1 b) - -Now we decompose (and flatten) to - -[WD] w4 :: LV as1 (a -> b) ~ fmv3 -[WD] w5 :: fmv3 ~ (a -> fmv1) -[WD] w6 :: LV as1 b ~ fmv4 - -which is exactly where we started. These goals really are insoluble, but -we would prefer not to loop. We thus need to find a way to bump the reduction -depth, so that we can detect the loop and abort. - -The key observation is that we are performing a reduction. We thus wish -to bump the level when discharging a CFunEqCan. Where does this bumped -level go, though? It can't just go on the reduct, as that's a type. Instead, -it must go on any CFunEqCans produced after flattening. We thus flatten -when discharging, making sure that the level is bumped in the new -fun-eqs. The flattening happens in reduce_top_fun_eq and the level -is bumped when setting up the FlatM monad in TcFlatten.runFlatten. -(This bumping will happen for call sites other than this one, but that -makes sense -- any constraints emitted by the flattener are offshoots -the work item and should have a higher level. We don't have any test -cases that require the bumping in this other cases, but it's convenient -and causes no harm to bump at every flatten.) - -Test case: typecheck/should_fail/T16512a - --} - --------------------- -doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct) -doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc - , cc_tyargs = args, cc_fsk = fsk }) - - | fsk `elemVarSet` tyCoVarsOfTypes args - = no_reduction -- See Note [FunEq occurs-check principle] - - | otherwise -- Note [Reduction for Derived CFunEqCans] - = do { match_res <- matchFam fam_tc args - -- Look up in top-level instances, or built-in axiom - -- See Note [MATCHING-SYNONYMS] - ; case match_res of - Nothing -> no_reduction - Just match_info -> reduce_top_fun_eq old_ev fsk match_info } - where - no_reduction - = do { improveTopFunEqs old_ev fam_tc args fsk - ; continueWith work_item } - -doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w) - -reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType) - -> TcS (StopOrContinue Ct) --- We have found an applicable top-level axiom: use it to reduce --- Precondition: fsk is not free in rhs_ty --- ax_co :: F tys ~ rhs_ty, where F tys is the LHS of the old_ev -reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty) - | not (isDerived old_ev) -- Precondition of shortCutReduction - , Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty - , isTypeFamilyTyCon tc - , tc_args `lengthIs` tyConArity tc -- Short-cut - = -- RHS is another type-family application - -- Try shortcut; see Note [Top-level reductions for type functions] - do { shortCutReduction old_ev fsk ax_co tc tc_args - ; stopWith old_ev "Fun/Top (shortcut)" } - - | otherwise - = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty) - , ppr old_ev $$ ppr rhs_ty ) - -- Guaranteed by Note [FunEq occurs-check principle] - do { (rhs_xi, flatten_co) <- flatten FM_FlattenAll old_ev rhs_ty - -- flatten_co :: rhs_xi ~ rhs_ty - -- See Note [Flatten when discharging CFunEqCan] - ; let total_co = ax_co `mkTcTransCo` mkTcSymCo flatten_co - ; dischargeFunEq old_ev fsk total_co rhs_xi - ; traceTcS "doTopReactFunEq" $ - vcat [ text "old_ev:" <+> ppr old_ev - , nest 2 (text ":=") <+> ppr ax_co ] - ; stopWith old_ev "Fun/Top" } - -improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS () --- See Note [FunDep and implicit parameter reactions] -improveTopFunEqs ev fam_tc args fsk - | isGiven ev -- See Note [No FunEq improvement for Givens] - || not (isImprovable ev) - = return () - - | otherwise - = do { fam_envs <- getFamInstEnvs - ; rhs <- rewriteTyVar fsk - ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs - ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs - , ppr eqns ]) - ; mapM_ (unifyDerived loc Nominal) eqns } - where - loc = bumpCtLocDepth (ctEvLoc ev) - -- 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 - 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], TCvSubst, [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 - , Just subst <- [tcUnifyTyWithTFs False 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], TCvSubst, [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 (substTyUnchecked 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 ] } - - -shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion - -> TyCon -> [TcType] -> TcS () --- See Note [Top-level reductions for type functions] --- Previously, we flattened the tc_args here, but there's no need to do so. --- And, if we did, this function would have all the complication of --- TcCanonical.canCFunEqCan. See Note [canCFunEqCan] -shortCutReduction old_ev fsk ax_co fam_tc tc_args - = ASSERT( ctEvEqRel old_ev == NomEq) - -- ax_co :: F args ~ G tc_args - -- old_ev :: F args ~ fsk - do { new_ev <- case ctEvFlavour old_ev of - Given -> newGivenEvVar deeper_loc - ( mkPrimEqPred (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk) - , evCoercion (mkTcSymCo ax_co - `mkTcTransCo` ctEvCoercion old_ev) ) - - Wanted {} -> - -- See TcCanonical Note [Equalities with incompatible kinds] about NoBlockSubst - do { (new_ev, new_co) <- newWantedEq_SI NoBlockSubst WDeriv deeper_loc Nominal - (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk) - ; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co - ; return new_ev } - - Derived -> pprPanic "shortCutReduction" (ppr old_ev) - - ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc - , cc_tyargs = tc_args, cc_fsk = fsk } - ; updWorkListTcS (extendWorkListFunEq new_ct) } - where - deeper_loc = bumpCtLocDepth (ctEvLoc old_ev) - -{- Note [Top-level reductions for type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -c.f. Note [The flattening story] in TcFlatten - -Suppose we have a CFunEqCan F tys ~ fmv/fsk, and a matching axiom. -Here is what we do, in four cases: - -* Wanteds: general firing rule - (work item) [W] x : F tys ~ fmv - instantiate axiom: ax_co : F tys ~ rhs - - Then: - Discharge fmv := rhs - Discharge x := ax_co ; sym x2 - This is *the* way that fmv's get unified; even though they are - "untouchable". - - NB: Given Note [FunEq occurs-check principle], fmv does not appear - in tys, and hence does not appear in the instantiated RHS. So - the unification can't make an infinite type. - -* Wanteds: short cut firing rule - Applies when the RHS of the axiom is another type-function application - (work item) [W] x : F tys ~ fmv - instantiate axiom: ax_co : F tys ~ G rhs_tys - - It would be a waste to create yet another fmv for (G rhs_tys). - Instead (shortCutReduction): - - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis) - - Add G rhs_xis ~ fmv to flat cache (note: the same old fmv) - - New canonical wanted [W] x2 : G rhs_xis ~ fmv (CFunEqCan) - - Discharge x := ax_co ; G cos ; x2 - -* Givens: general firing rule - (work item) [G] g : F tys ~ fsk - instantiate axiom: ax_co : F tys ~ rhs - - Now add non-canonical given (since rhs is not flat) - [G] (sym g ; ax_co) : fsk ~ rhs (Non-canonical) - -* Givens: short cut firing rule - Applies when the RHS of the axiom is another type-function application - (work item) [G] g : F tys ~ fsk - instantiate axiom: ax_co : F tys ~ G rhs_tys - - It would be a waste to create yet another fsk for (G rhs_tys). - Instead (shortCutReduction): - - Flatten rhs_tys: flat_cos : tys ~ flat_tys - - Add new Canonical given - [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk (CFunEqCan) - -Note [FunEq occurs-check principle] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -I have spent a lot of time finding a good way to deal with -CFunEqCan constraints like - F (fuv, a) ~ fuv -where flatten-skolem occurs on the LHS. Now in principle we -might may progress by doing a reduction, but in practice its -hard to find examples where it is useful, and easy to find examples -where we fall into an infinite reduction loop. A rule that works -very well is this: - - *** FunEq occurs-check principle *** - - Do not reduce a CFunEqCan - F tys ~ fsk - if fsk appears free in tys - Instead we treat it as stuck. - -Examples: - -* #5837 has [G] a ~ TF (a,Int), with an instance - type instance TF (a,b) = (TF a, TF b) - This readily loops when solving givens. But with the FunEq occurs - check principle, it rapidly gets stuck which is fine. - -* #12444 is a good example, explained in comment:2. We have - type instance F (Succ x) = Succ (F x) - [W] alpha ~ Succ (F alpha) - If we allow the reduction to happen, we get an infinite loop - -Note [Cached solved FunEqs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When trying to solve, say (FunExpensive big-type ~ ty), it's important -to see if we have reduced (FunExpensive big-type) before, lest we -simply repeat it. Hence the lookup in inert_solved_funeqs. Moreover -we must use `funEqCanDischarge` because both uses might (say) be Wanteds, -and we *still* want to save the re-computation. - -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] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A very delicate point is the orientation of derived 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 derived constraints - - [D] gamma1 ~ alpha - [D] 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 - [D] 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 derived -equality with the template on the left. Delicate, but it works. - -Note [No FunEq improvement for Givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't do improvements (injectivity etc) for Givens. Why? - -* It generates Derived constraints on skolems, which don't do us - much good, except perhaps identify inaccessible branches. - (They'd be perfectly valid though.) - -* For type-nat stuff the derived constraints include type families; - e.g. (a < b), (b < c) ==> a < c If we generate a Derived for this, - we'll generate a Derived/Wanted CFunEqCan; and, since the same - InertCans (after solving Givens) are used for each iteration, that - massively confused the unflattening step (TcFlatten.unflatten). - - In fact it led to some infinite loops: - indexed-types/should_compile/T10806 - indexed-types/should_compile/T10507 - polykinds/T10742 - -Note [Reduction for Derived CFunEqCans] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You may wonder if it's important to use top-level instances to -simplify [D] CFunEqCan's. But it is. Here's an example (T10226). - - type instance F Int = Int - type instance FInv Int = Int - -Suppose we have to solve - [WD] FInv (F alpha) ~ alpha - [WD] F alpha ~ Int - - --> flatten - [WD] F alpha ~ fuv0 - [WD] FInv fuv0 ~ fuv1 -- (A) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int -- (B) - - --> Rewwrite (A) with (B), splitting it - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] FInv Int ~ fuv1 -- (C) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int - - --> Reduce (C) with top-level instance - **** This is the key step *** - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] fuv1 ~ Int -- (D) - [WD] fuv1 ~ alpha -- (E) - [WD] fuv0 ~ Int - - --> Rewrite (D) with (E) - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] alpha ~ Int -- (F) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int - - --> unify (F) alpha := Int, and that solves it - -Another example is indexed-types/should_compile/T10634 --} - -{- ******************************************************************* -* * - 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 - = do { try_fundep_improvement - ; continueWith work_item } - - | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis -- Cached - = do { setEvBindIfWanted ev (ctEvTerm solved_ev) - ; stopWith ev "Dict/Top (cached)" } - - | otherwise -- Wanted or Derived, 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 work_item lkup_res } - _ -> -- NoInstance or NotSure - do { when (isImprovable ev) $ - try_fundep_improvement - ; continueWith work_item } } - where - dict_pred = mkClassPred cls xis - dict_loc = ctEvLoc ev - dict_origin = ctLocOrigin dict_loc - - -- We didn't solve it; so try functional dependencies with - -- the instance environment, and return - -- See also Note [Weird fundeps] - try_fundep_improvement - = do { traceTcS "try_fundeps" (ppr work_item) - ; instEnvs <- getInstEnvs - ; emitFunDepDeriveds $ - improveFromInstEnv instEnvs mk_ct_loc dict_pred } - - mk_ct_loc :: PredType -- From instance decl - -> SrcSpan -- also from instance deol - -> CtLoc - mk_ct_loc inst_pred inst_loc - = dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin - inst_pred inst_loc } - -doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w) - - -chooseInstance :: Ct -> 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 ev - ; deeper_loc <- checkInstanceOK loc what pred - ; if isDerived ev then finish_derived deeper_loc theta - else finish_wanted deeper_loc theta mk_ev } - where - ev = ctEvidence work_item - pred = ctEvPred ev - loc = ctEvLoc ev - - finish_wanted :: CtLoc -> [TcPredType] - -> ([EvExpr] -> EvTerm) -> TcS (StopOrContinue Ct) - -- Precondition: evidence term matches the predicate workItem - finish_wanted loc theta mk_ev - = do { evb <- getTcEvBindsVar - ; if isCoEvBindsVar evb - then -- See Note [Instances in no-evidence implications] - continueWith work_item - else - do { evc_vars <- mapM (newWanted loc) theta - ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars)) - ; emitWorkNC (freshGoals evc_vars) - ; stopWith ev "Dict/Top (solved wanted)" } } - - finish_derived loc theta - = -- Use type-class instances for Deriveds, in the hope - -- of generating some improvements - -- C.f. Example 3 of Note [The improvement story] - -- It's easy because no evidence is involved - do { emitNewDeriveds loc theta - ; traceTcS "finish_derived" (ppr (ctl_depth loc)) - ; stopWith ev "Dict/Top (solved derived)" } - -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 insstance: --- (a) the use is well staged in the Template Haskell sense --- (b) we have not recursed too deep --- Returns the CtLoc to used for sub-goals -checkInstanceOK loc what pred - = do { checkWellStagedDFun loc what pred - ; checkReductionDepth deeper_loc 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 - -- infinity, so that prohibitedSuperClassSolve never fires - | ScOrigin {} <- origin - = setCtLocOrigin loc (ScOrigin infinity) - | 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. --- ee Note [Instance and Given overlap] - | not (xopt LangExt.IncoherentInstances dflags) - , not (naturallyCoherentClass clas) - , let matchable_givens = matchableGivens loc pred inerts - , not (isEmptyBag matchable_givens) - = do { traceTcS "Delaying instance application" $ - vcat [ text "Work item=" <+> pprClassPred clas tys - , text "Potential matching givens:" <+> ppr matchable_givens ] - ; 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 class story] in TysPrim. -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 -#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 - -* Flatten-skolems: we do not treat a flatten-skolem as unifiable - for this purpose. - E.g. f :: Eq (F a) => [a] -> [a] - f xs = ....(xs==xs)..... - Here we get [W] Eq [a], and we don't want to refrain from solving - it because of the given (Eq (F a)) constraint! - -* 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 TcValidity 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 TysPrim.) - -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 TcSMonad - 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 - -Exammples: 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. - -Consdider 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 { ics <- getInertCans - ; case match_local_inst (inert_insts ics) of - ([], False) -> do { traceTcS "No local instance for" (ppr pred) - ; return NoInstance } - ([(dfun_ev, inst_tys)], unifs) - | not unifs - -> do { let dfun_id = ctEvEvId dfun_ev - ; (tys, theta) <- instDFunType dfun_id inst_tys - ; let result = OneInst { cir_new_theta = theta - , cir_mk_ev = evDFunApp dfun_id tys - , cir_what = LocalInstance } - ; traceTcS "Local inst found:" (ppr result) - ; return result } - _ -> do { traceTcS "Multiple local instances for" (ppr pred) - ; return NotSure }} - where - pred_tv_set = tyCoVarsOfType pred - - match_local_inst :: [QCInst] - -> ( [(CtEvidence, [DFunInstType])] - , Bool ) -- True <=> Some unify but do not match - match_local_inst [] - = ([], False) - match_local_inst (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred - , qci_ev = ev }) - : 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 = (ev, map (lookupVarEnv tv_subst) qtvs) - = (match:matches, unif) - - | otherwise - = ASSERT2( disjointVarSet qtv_set (tyCoVarsOfType pred) - , ppr qci $$ ppr pred ) - -- ASSERT: unification relies on the - -- quantified variables being fresh - (matches, unif || this_unif) - where - qtv_set = mkVarSet qtvs - this_unif = mightMatchLater qpred (ctEvLoc ev) pred loc - (matches, unif) = match_local_inst qcis diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs deleted file mode 100644 --- a/compiler/typecheck/TcMType.hs +++ /dev/null @@ -1,2420 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Monadic type operations - -This module contains monadic operations over types that contain -mutable type variables. --} - -{-# LANGUAGE CPP, TupleSections, MultiWayIf #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcMType ( - TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet, - - -------------------------------- - -- Creating new mutable type variables - newFlexiTyVar, - newNamedFlexiTyVar, - newFlexiTyVarTy, -- Kind -> TcM TcType - newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] - newOpenFlexiTyVarTy, newOpenTypeKind, - newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel, - cloneMetaTyVar, - newFmvTyVar, newFskTyVar, - - readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, - newMetaDetails, isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, - - -------------------------------- - -- Expected types - ExpType(..), ExpSigmaType, ExpRhoType, - mkCheckExpType, - newInferExpType, newInferExpTypeInst, newInferExpTypeNoInst, - readExpType, readExpType_maybe, - expTypeToType, checkingExpType_maybe, checkingExpType, - tauifyExpType, inferResultToType, - - -------------------------------- - -- Creating new evidence variables - newEvVar, newEvVars, newDict, - newWanted, newWanteds, newHoleCt, cloneWanted, cloneWC, - emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, - emitDerivedEqs, - newTcEvBinds, newNoTcEvBinds, addTcEvBind, - - newCoercionHole, fillCoercionHole, isFilledCoercionHole, - unpackCoercionHole, unpackCoercionHole_maybe, - checkCoercionHole, - - newImplication, - - -------------------------------- - -- Instantiation - newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, - newMetaTyVarTyVars, newMetaTyVarTyVarX, - newTyVarTyVar, cloneTyVarTyVar, - newPatSigTyVar, newSkolemTyVar, newWildCardX, - tcInstType, - tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt, - tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, - - freshenTyVarBndrs, freshenCoVarBndrsX, - - -------------------------------- - -- Zonking and tidying - zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, - tidyEvVar, tidyCt, tidySkolemInfo, - zonkTcTyVar, zonkTcTyVars, - zonkTcTyVarToTyVar, zonkTyVarTyVarPairs, - zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV, - zonkTyCoVarsAndFVList, - candidateQTyVarsOfType, candidateQTyVarsOfKind, - candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, - CandidatesQTvs(..), delCandidates, candidateKindVars, partitionCandidates, - zonkAndSkolemise, skolemiseQuantifiedTyVar, - defaultTyVar, quantifyTyVars, isQuantifiableTv, - zonkTcType, zonkTcTypes, zonkCo, - zonkTyCoVarKind, - - zonkEvVar, zonkWC, zonkSimples, - zonkId, zonkCoVar, - zonkCt, zonkSkolemInfo, - - skolemiseUnboundMetaTyVar, - - ------------------------------ - -- Levity polymorphism - ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr - ) where - -#include "HsVersions.h" - --- friends: -import GhcPrelude - -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr -import TcType -import GHC.Core.Type -import GHC.Core.TyCon -import GHC.Core.Coercion -import GHC.Core.Class -import GHC.Types.Var -import GHC.Core.Predicate -import TcOrigin - --- others: -import TcRnMonad -- TcType, amongst others -import Constraint -import TcEvidence -import GHC.Types.Id as Id -import GHC.Types.Name -import GHC.Types.Var.Set -import TysWiredIn -import TysPrim -import GHC.Types.Var.Env -import GHC.Types.Name.Env -import PrelNames -import Util -import Outputable -import FastString -import Bag -import Pair -import GHC.Types.Unique.Set -import GHC.Driver.Session -import qualified GHC.LanguageExtensions as LangExt -import GHC.Types.Basic ( TypeOrKind(..) ) - -import Control.Monad -import Maybes -import Data.List ( mapAccumL ) -import Control.Arrow ( second ) -import qualified Data.Semigroup as Semi - -{- -************************************************************************ -* * - Kind variables -* * -************************************************************************ --} - -mkKindName :: Unique -> Name -mkKindName unique = mkSystemName unique kind_var_occ - -kind_var_occ :: OccName -- Just one for all MetaKindVars - -- They may be jiggled by tidying -kind_var_occ = mkOccName tvName "k" - -newMetaKindVar :: TcM TcKind -newMetaKindVar - = do { details <- newMetaDetails TauTv - ; uniq <- newUnique - ; let kv = mkTcTyVar (mkKindName uniq) 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 ty) } - -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 - d <- if isEqPrimPred pty then HoleDest <$> newCoercionHole YesBlockSubst pty - else EvVarDest <$> newEvVar pty - return $ CtWanted { ctev_dest = d - , ctev_pred = pty - , ctev_nosh = WDeriv - , ctev_loc = loc } - -newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] -newWanteds orig = mapM (newWanted orig Nothing) - --- | Create a new 'CHoleCan' 'Ct'. -newHoleCt :: HoleSort -> Id -> Type -> TcM Ct -newHoleCt hole ev ty = do - loc <- getCtLocM HoleOrigin Nothing - pure $ CHoleCan { cc_ev = CtWanted { ctev_pred = ty - , ctev_dest = EvVarDest ev - , ctev_nosh = WDeriv - , ctev_loc = loc } - , cc_occ = getOccName ev - , cc_hole = hole } - ----------------------------------------------- --- Cloning constraints ----------------------------------------------- - -cloneWanted :: Ct -> TcM Ct -cloneWanted ct - | ev@(CtWanted { ctev_dest = HoleDest old_hole, ctev_pred = pty }) <- ctEvidence ct - = do { co_hole <- newCoercionHole (ch_blocker old_hole) pty - ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) } - | otherwise - = return 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 } - -emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM () --- Emit some new derived nominal equalities -emitDerivedEqs origin pairs - | null pairs - = return () - | otherwise - = do { loc <- getCtLocM origin Nothing - ; emitSimples (listToBag (map (mk_one loc) pairs)) } - where - mk_one loc (ty1, ty2) - = mkNonCanonical $ - CtDerived { ctev_pred = mkPrimEqPred ty1 ty2 - , ctev_loc = loc } - --- | Emits a new equality constraint -emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion -emitWantedEq origin t_or_k role ty1 ty2 - = do { hole <- newCoercionHole YesBlockSubst pty - ; loc <- getCtLocM origin (Just t_or_k) - ; emitSimple $ mkNonCanonical $ - CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole - , ctev_nosh = WDeriv, ctev_loc = loc } - ; 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_nosh = WDeriv - , ctev_loc = loc } - ; emitSimple $ mkNonCanonical ctev - ; return new_cv } - -emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar] -emitWantedEvVars orig = mapM (emitWantedEvVar orig) - -newDict :: Class -> [TcType] -> TcM DictId -newDict cls tys - = do { name <- newSysName (mkDictOcc (getOccName cls)) - ; return (mkLocalId name (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 TcInstDcls. -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 :: BlockSubstFlag -- should the presence of this hole block substitution? - -- See sub-wrinkle in TcCanonical - -- Note [Equalities with incompatible kinds] - -> TcPredType -> TcM CoercionHole -newCoercionHole blocker pred_ty - = do { co_var <- newEvVar pred_ty - ; traceTc "New coercion hole:" (ppr co_var <+> ppr blocker) - ; ref <- newMutVar Nothing - ; return $ CoercionHole { ch_co_var = co_var, ch_blocker = blocker - , 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 { -#if defined(DEBUG) - ; cts <- readTcRef ref - ; whenIsJust cts $ \old_co -> - pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co) -#endif - ; 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 $ - ASSERT2( 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 - -{- -************************************************************************ -* - Expected types -* -************************************************************************ - -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. -And, because there is only one branch of the case, we won't trigger -Note [Case branches must never infer a non-tau type] of TcMatches. -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. This is triggered in -test gadt/gadt-escape1. - --} - --- actual data definition is in TcType - --- | Make an 'ExpType' suitable for inferring a type of kind * or #. -newInferExpTypeNoInst :: TcM ExpSigmaType -newInferExpTypeNoInst = newInferExpType False - -newInferExpTypeInst :: TcM ExpRhoType -newInferExpTypeInst = newInferExpType True - -newInferExpType :: Bool -> TcM ExpType -newInferExpType inst - = do { u <- newUnique - ; tclvl <- getTcLevel - ; traceTc "newOpenInferExpType" (ppr u <+> ppr inst <+> ppr tclvl) - ; ref <- newMutVar Nothing - ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl - , ir_ref = ref, ir_inst = inst })) } - --- | 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 - --- | 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 _ = 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) - -tauifyExpType :: ExpType -> TcM ExpType --- ^ Turn a (Infer hole) type into a (Check alpha), --- where alpha is a fresh unification variable -tauifyExpType (Check ty) = return (Check ty) -- No-op for (Check ty) -tauifyExpType (Infer inf_res) = do { ty <- inferResultToType inf_res - ; return (Check 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 }) - = do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy - ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr) - -- See Note [TcLevel of ExpType] - ; writeMutVar ref (Just tau) - ; traceTc "Forcing ExpType to be monomorphic:" - (ppr u <+> text ":=" <+> ppr tau) - ; return tau } - - -{- ********************************************************************* -* * - SkolemTvs (immutable) -* * -********************************************************************* -} - -tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar])) - -- ^ How to instantiate the type variables - -> Id -- ^ Type to instantiate - -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result - -- (type vars, preds (incl equalities), rho) -tcInstType inst_tyvars id - = case tcSplitForAllTys (idType id) of - ([], rho) -> let -- There may be overloading despite no type variables; - -- (?x :: Int) => Int -> Int - (theta, tau) = tcSplitPhiTy rho - in - return ([], theta, tau) - - (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars - ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho) - tv_prs = map tyVarName tyvars `zip` tyvars' - ; return (tv_prs, theta, tau) } - -tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType) --- Instantiate a type signature with skolem constants. --- We could give them fresh names, but no need to do so -tcSkolDFunType dfun - = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun - ; return (map snd tv_prs, theta, tau) } - -tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar]) --- Make skolem constants, but do *not* give them new names, as above --- Moreover, make them "super skolems"; see comments with superSkolemTv --- see Note [Kind substitution when instantiating] --- Precondition: tyvars should be ordered by scoping -tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst - -tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar) -tcSuperSkolTyVar subst tv - = (extendTvSubstWithClone subst tv new_tv, new_tv) - where - kind = substTyUnchecked subst (tyVarKind tv) - new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv - --- | Given a list of @['TyVar']@, skolemize the type variables, --- returning a substitution mapping the original tyvars to the --- skolems, and the list of newly bound skolems. -tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- See Note [Skolemising type variables] -tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst - -tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- See Note [Skolemising type variables] -tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False - -tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- See Note [Skolemising type variables] -tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst - -tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- See Note [Skolemising type variables] -tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst - -tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar] - -> TcM (TCvSubst, [TcTyVar]) --- Skolemise one level deeper, hence pushTcLevel --- See Note [Skolemising type variables] -tcInstSkolTyVarsPushLevel overlappable subst tvs - = do { tc_lvl <- getTcLevel - ; let pushed_lvl = pushTcLevel tc_lvl - ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs } - -tcInstSkolTyVarsAt :: TcLevel -> Bool - -> TCvSubst -> [TyVar] - -> TcM (TCvSubst, [TcTyVar]) -tcInstSkolTyVarsAt lvl overlappable subst tvs - = freshenTyCoVarsX new_skol_tv subst tvs - where - details = SkolemTv lvl overlappable - new_skol_tv name kind = mkTcTyVar name kind details - ------------------- -freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar]) --- ^ Give fresh uniques to a bunch of TyVars, but they stay --- as TyVars, rather than becoming TcTyVars --- Used in FamInst.newFamInst, and Inst.newClsInst -freshenTyVarBndrs = freshenTyCoVars mkTyVar - -freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar]) --- ^ Give fresh uniques to a bunch of CoVars --- Used in FamInst.newFamInst -freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst - ------------------- -freshenTyCoVars :: (Name -> Kind -> TyCoVar) - -> [TyVar] -> TcM (TCvSubst, [TyCoVar]) -freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst - -freshenTyCoVarsX :: (Name -> Kind -> TyCoVar) - -> TCvSubst -> [TyCoVar] - -> TcM (TCvSubst, [TyCoVar]) -freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv) - -freshenTyCoVarX :: (Name -> Kind -> TyCoVar) - -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar) --- This a complete freshening operation: --- the skolems have a fresh unique, and a location from the monad --- See Note [Skolemising type variables] -freshenTyCoVarX mk_tcv subst tycovar - = do { loc <- getSrcSpanM - ; uniq <- newUnique - ; let old_name = tyVarName tycovar - new_name = mkInternalName uniq (getOccName old_name) loc - new_kind = substTyUnchecked subst (tyVarKind tycovar) - new_tcv = mk_tcv new_name new_kind - subst1 = extendTCvSubstWithClone subst tycovar new_tcv - ; return (subst1, new_tcv) } - -{- Note [Skolemising type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The tcInstSkolTyVars family of functions instantiate a list of TyVars -to fresh skolem TcTyVars. Important notes: - -a) Level allocation. We generally skolemise /before/ calling - pushLevelAndCaptureConstraints. So we want their level to the level - of the soon-to-be-created implication, which has a level ONE HIGHER - than the current level. Hence the pushTcLevel. It feels like a - slight hack. - -b) The [TyVar] should be ordered (kind vars first) - See Note [Kind substitution when instantiating] - -c) It's a complete freshening operation: the skolems have a fresh - unique, and a location from the monad - -d) The resulting skolems are - non-overlappable for tcInstSkolTyVars, - but overlappable for tcInstSuperSkolTyVars - See TcDerivInfer Note [Overlap and deriving] for an example - of where this matters. - -Note [Kind substitution when instantiating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we instantiate a bunch of kind and type variables, first we -expect them to be topologically sorted. -Then we have to instantiate the kind variables, build a substitution -from old variables to the new variables, then instantiate the type -variables substituting the original kind. - -Exemple: If we want to instantiate - [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)] -we want - [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)] -instead of the buggous - [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)] - - -************************************************************************ -* * - MetaTvs (meta type variables; mutable) -* * -************************************************************************ --} - -{- -Note [TyVarTv] -~~~~~~~~~~~~ - -A TyVarTv can unify with type *variables* only, including other TyVarTvs and -skolems. 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 (say, with a call to findDubTyVarTvs). - -Before #15050 this (under the name SigTv) was 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). - -The remaining uses of newTyVarTyVars are -* In kind signatures, see - TcTyClsDecls Note [Inferring kinds for type declarations] - and Note [Kind checking for GADTs] -* In partial type signatures, see Note [Quantified variables in partial type signatures] --} - -newMetaTyVarName :: FastString -> TcM Name --- Makes a /System/ Name, which is eagerly eliminated by --- the unifier; see TcUnify.nicer_to_update_tv1, and --- TcCanonical.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" - FlatMetaTv -> fsLit "fmv" - FlatSkolTv -> fsLit "fsk" - TyVarTv -> fsLit "a" - -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 :: Name -> Kind -> TcM TcTyVar -newSkolemTyVar name kind - = do { lvl <- getTcLevel - ; return (mkTcTyVar name kind (SkolemTv 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 } - -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 } - -newFskTyVar :: TcType -> TcM TcTyVar -newFskTyVar fam_ty - = do { details <- newMetaDetails FlatSkolTv - ; name <- newMetaTyVarName (fsLit "fsk") - ; return (mkTcTyVar name (tcTypeKind fam_ty) details) } - -newFmvTyVar :: TcType -> TcM TcTyVar --- Very like newMetaTyVar, except sets mtv_tclvl to one less --- so that the fmv is untouchable. -newFmvTyVar fam_ty - = do { details <- newMetaDetails FlatMetaTv - ; name <- newMetaTyVarName (fsLit "s") - ; return (mkTcTyVar name (tcTypeKind fam_ty) details) } - -newMetaDetails :: MetaInfo -> TcM TcTyVarDetails -newMetaDetails info - = do { ref <- newMutVar Flexi - ; tclvl <- getTcLevel - ; return (MetaTv { mtv_info = info - , 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 = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) - readMutVar (metaTyVarRef tyvar) - -isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type) -isFilledMetaTyVar_maybe 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 :: 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) - = ASSERT2( False, text "Writing to non-tc tyvar" <+> ppr tyvar ) - return () - - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar - = writeMetaTyVarRef tyvar ref ty - - | otherwise - = ASSERT2( False, text "Writing to non-meta tyvar" <+> ppr tyvar ) - return () - --------------------- -writeMetaTyVarRef :: 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 - | otherwise - = do { meta_details <- readMutVar ref; - -- Zonk kinds to allow the error check to work - ; zonked_tv_kind <- zonkTcType tv_kind - ; zonked_ty_kind <- zonkTcType ty_kind - ; let kind_check_ok = tcIsConstraintKind zonked_tv_kind - || tcEqKind zonked_ty_kind zonked_tv_kind - -- Hack alert! tcIsConstraintKind: see TcHsType - -- Note [Extra-constraint holes in partial type signatures] - - 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 - ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details ) - - -- Check for level OK - -- See Note [Level check when unifying] - ; MASSERT2( level_check_ok, level_check_msg ) - - -- Check Kinds ok - ; MASSERT2( kind_check_ok, kind_msg ) - - -- Do the write - ; writeMutVar ref (Indirect ty) } - where - tv_kind = tyVarKind tyvar - ty_kind = tcTypeKind ty - - tv_lvl = tcTyVarLevel tyvar - ty_lvl = tcTypeLevel ty - - level_check_ok = not (ty_lvl `strictlyDeeperThan` tv_lvl) - level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty - - double_upd_msg details = hang (text "Double update of meta tyvar") - 2 (ppr tyvar $$ ppr details) - -{- Note [Level check when unifying] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When unifying - alpha:lvl := ty -we expect that the TcLevel of 'ty' will be <= lvl. -However, during unflatting we do - fuv:l := ty:(l+1) -which is usually wrong; hence the check isFmmvTyVar in level_check_ok. -See Note [TcLevel assignment] in TcType. --} - -{- -% Generating fresh variables for pattern match check --} - - -{- -************************************************************************ -* * - 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! --} - - -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 (tYPE 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 { kind <- newOpenTypeKind - ; newFlexiTyVarTy kind } - -newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [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 emptyTCvSubst - -- emptyTCvSubst 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 :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- Just like newMetaTyVars, but start with an existing substitution. -newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst - -newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) --- Make a new unification variable tyvar whose Name and Kind come from --- an existing TyVar. We substitute kind variables in the kind. -newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar - -newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst - -newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) --- Just like newMetaTyVarX, but make a TyVarTv -newMetaTyVarTyVarX subst tyvar = new_meta_tv_x TyVarTv subst tyvar - -newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, 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 -> TCvSubst -> TyVar -> TcM (TCvSubst, 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 tcInferApps - -- 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 { ref <- newMutVar Flexi - ; name <- newMetaTyVarName (fsLit "p") - ; let details = MetaTv { mtv_info = TauTv - , mtv_ref = ref - , mtv_tclvl = tc_lvl } - ; 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 TcHsType). - - * 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'). - -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 ]) - - -candidateKindVars :: CandidatesQTvs -> TyVarSet -candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) - -partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (DTyVarSet, CandidatesQTvs) -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 = extracted_kvs `unionDVarSet` extracted_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 - -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 } - -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 _ tys) = foldlM go dv tys - go dv (FunTy _ arg res) = foldlM go dv [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 } - - ----------------- - 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 ofor quantification] - - | 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 _ co1 co2) = foldlM go_co dv [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 (NthCo _ _ 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_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 of 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 and untouchable type variables] -in 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 TcSimplify.decideMonoTyVars and in -TcHsType.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 - :: 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 dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs }) - -- short-circuit common case - | isEmptyDVarSet dep_tkvs - , isEmptyDVarSet nondep_tkvs - = do { traceTc "quantifyTyVars has nothing to quantify" empty - ; return [] } - - | otherwise - = do { traceTc "quantifyTyVars 1" (ppr dvs) - - ; let dep_kvs = scopedSort $ dVarSetElems dep_tkvs - -- scopedSort: put the kind variables into - -- well-scoped order. - -- E.g. [k, (a::k)] not the other way round - - nondep_tvs = dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs) - -- 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 zonked by zonkTyCoVarsAndFV - - -- In the non-PolyKinds case, default the kind variables - -- to *, and zonk the tyvars as usual. Notice that this - -- may make quantifyTyVars return a shorter list - -- than it was passed, but that's ok - ; poly_kinds <- xoptM LangExt.PolyKinds - ; dep_kvs' <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs - ; nondep_tvs' <- mapMaybeM (zonk_quant False) nondep_tvs - ; let final_qtvs = dep_kvs' ++ nondep_tvs' - -- Because of the order, any kind variables - -- mentioned in the kinds of the nondep_tvs' - -- now refer to the dep_kvs' - - ; traceTc "quantifyTyVars 2" - (vcat [ text "nondep:" <+> pprTyVars nondep_tvs - , text "dep:" <+> pprTyVars dep_kvs - , text "dep_kvs'" <+> pprTyVars dep_kvs' - , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ]) - - -- We should never quantify over coercion variables; check this - ; let co_vars = filter isCoVar final_qtvs - ; MASSERT2( 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 - -- * Kind variables, with -XNoPolyKinds: don't quantify over these - -- * RuntimeRep variables: we never quantify over these - zonk_quant default_kind 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 - - | not (isTcTyVar tkv) - = return (Just tkv) -- For associated types in a class with a standalone - -- kind signature, we have the class variables in - -- scope, and they are TyVars not TcTyVars - | otherwise - = do { deflt_done <- defaultTyVar default_kind tkv - ; case deflt_done of - True -> return Nothing - False -> do { tv <- skolemiseQuantifiedTyVar tkv - ; return (Just tv) } } - -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 :: 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 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 <- zonkTcTyVarToTyVar tyvar - ; skolemiseQuantifiedTyVar zonked_tyvar } - - | otherwise - = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar ) - zonkTyCoVarKind tyvar - -skolemiseQuantifiedTyVar :: 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 tv - = case tcTyVarDetails tv of - SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv) - ; return (setTyVarKind tv kind) } - -- It might be a skolem type variable, - -- for example from a user type signature - - MetaTv {} -> skolemiseUnboundMetaTyVar tv - - _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk - -defaultTyVar :: Bool -- True <=> please default this kind variable to * - -> TcTyVar -- If it's a MetaTyVar then it is unbound - -> TcM Bool -- True <=> defaulted away altogether - -defaultTyVar default_kind tv - | not (isMetaTyVar tv) - = return False - - | isTyVarTyVar tv - -- Do not default TyVarTvs. Doing so would violate the invariants - -- on TyVarTvs; see Note [Signature skolems] in TcType. - -- #13343 is an example; #14555 is another - -- See Note [Inferring kinds for type declarations] in TcTyClsDecls - = return False - - - | isRuntimeRepVar tv -- Do not quantify over a RuntimeRep var - -- unless it is a TyVarTv, handled earlier - = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) - ; writeMetaTyVar tv liftedRepTy - ; return True } - - | default_kind -- -XNoPolyKinds and this is a kind var - = default_kind_var tv -- so default it to * if possible - - | otherwise - = return False - - where - 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 (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 TcHsType - -- 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 - -skolemiseUnboundMetaTyVar :: 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] -skolemiseUnboundMetaTyVar tv - = ASSERT2( isMetaTyVar tv, ppr tv ) - do { when debugIsOn (check_empty tv) - ; here <- getSrcSpanM -- Get the location from "here" - -- ie 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 - final_tv = mkTcTyVar final_name kind details - - ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) - ; writeMetaTyVar tv (mkTyVarTy final_tv) - ; return final_tv } - - where - details = SkolemTv (metaTyVarTcLevel tv) False - check_empty tv -- [Sept 04] Check for non-empty. - = when debugIsOn $ -- See note [Silly Type Synonym] - do { cts <- readMetaTyVar tv - ; case cts of - Flexi -> return () - Indirect ty -> WARN( True, ppr tv $$ ppr ty ) - return () } - -{- 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 TcSimplify.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 TcRnDriver.tcRnSrcDecls calling TcSimplify.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 TcTyClsDecls.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 () - -************************************************************************ -* * - 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 = ASSERT2( isCoVar tv, ppr tv ) - mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv - -- Hackily, when typechecking type and class decls - -- we have TyVars in scope added (only) in - -- TcHsType.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' <- zonkSkolemInfo info - ; wanted' <- zonkWCRec wanted - ; return (implic { ic_skols = skols' - , ic_given = given' - , ic_wanted = wanted' - , ic_info = info' }) } - -zonkEvVar :: EvVar -> TcM EvVar -zonkEvVar var = do { ty' <- zonkTcType (varType var) - ; return (setVarType var ty') } - - -zonkWC :: WantedConstraints -> TcM WantedConstraints -zonkWC wc = zonkWCRec wc - -zonkWCRec :: WantedConstraints -> TcM WantedConstraints -zonkWCRec (WC { wc_simple = simple, wc_impl = implic }) - = do { simple' <- zonkSimples simple - ; implic' <- mapBagM zonkImplication implic - ; return (WC { wc_simple = simple', wc_impl = implic' }) } - -zonkSimples :: Cts -> TcM Cts -zonkSimples cts = do { cts' <- mapBagM zonkCt cts - ; traceTc "zonkSimples done:" (ppr cts') - ; return cts' } - -{- Note [zonkCt behaviour] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -zonkCt tries to maintain the canonical form of a Ct. For example, - - a CDictCan should stay a CDictCan; - - a CHoleCan should stay a CHoleCan - - a CIrredCan should stay a CIrredCan with its cc_status flag intact - -Why?, for example: -- For CDictCan, the @TcSimplify.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 CHoleCan, once we forget that it's a hole, we can never recover that info. - -- For CIrredCan we want to see if a constraint is insoluble with insolubleWC - -On the other hand, we change CTyEqCan to CNonCanonical, because of all of -CTyEqCan's invariants, which can break during zonking. Besides, the constraint -will be canonicalised again, so there is little benefit in keeping the -CTyEqCan structure. - -NB: we do not expect to see any CFunEqCans, because zonkCt is only -called on unflattened constraints. - -NB: Constraints are always re-flattened etc by the canonicaliser in -@TcCanonical@ 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/ function free. --} - -zonkCt :: Ct -> TcM Ct --- See Note [zonkCt behaviour] -zonkCt ct@(CHoleCan { cc_ev = ev }) - = do { ev' <- zonkCtEvidence ev - ; return $ ct { cc_ev = ev' } } - -zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args }) - = do { ev' <- zonkCtEvidence ev - ; args' <- mapM zonkTcType args - ; return $ ct { cc_ev = ev', cc_tyargs = args' } } - -zonkCt (CTyEqCan { cc_ev = ev }) - = mkNonCanonical <$> zonkCtEvidence ev - -zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_status flag - = do { ev' <- zonkCtEvidence ev - ; return (ct { cc_ev = ev' }) } - -zonkCt ct - = ASSERT( not (isCFunEqCan ct) ) - -- We do not expect to see any CFunEqCans, because zonkCt is only called on - -- unflattened constraints. - do { fl' <- zonkCtEvidence (ctEvidence ct) - ; return (mkNonCanonical fl') } - -zonkCtEvidence :: CtEvidence -> TcM CtEvidence -zonkCtEvidence ctev@(CtGiven { ctev_pred = pred }) - = do { pred' <- zonkTcType pred - ; return (ctev { ctev_pred = pred'}) } -zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest }) - = do { pred' <- zonkTcType pred - ; let dest' = case dest of - EvVarDest ev -> EvVarDest $ setVarType ev pred' - -- necessary in simplifyInfer - HoleDest h -> HoleDest h - ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) } -zonkCtEvidence ctev@(CtDerived { ctev_pred = pred }) - = do { pred' <- zonkTcType pred - ; return (ctev { ctev_pred = pred' }) } - -zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo -zonkSkolemInfo (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty - ; return (SigSkol cx ty' tv_prs) } -zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys - ; return (InferSkol ntys') } - where - do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } -zonkSkolemInfo skol_info = return skol_info - -{- -%************************************************************************ -%* * -\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar} -* * -* For internal use only! * -* * -************************************************************************ - --} - --- 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 - | tcTyConIsPoly tc = return tc - | otherwise = do { tck' <- zonkTcType (tyConKind tc) - ; return (setTcTyConKind tc tck') } - -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 -zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar -zonkTcTyVarToTyVar tv - = do { ty <- zonkTcTyVar tv - ; let tv' = case tcGetTyVar_maybe ty of - Just tv' -> tv' - Nothing -> pprPanic "zonkTcTyVarToTyVar" - (ppr tv $$ ppr ty) - ; return tv' } - -zonkTyVarTyVarPairs :: [(Name,TcTyVar)] -> TcM [(Name,TcTyVar)] -zonkTyVarTyVarPairs prs - = mapM do_one prs - where - do_one (nm, tv) = do { tv' <- zonkTcTyVarToTyVar tv - ; return (nm, tv') } - --- zonkId is used *during* typechecking just to zonk the Id's type -zonkId :: TcId -> TcM TcId -zonkId id - = do { ty' <- zonkTcType (idType id) - ; return (Id.setIdType id ty') } - -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 TcHsSyn. - -%************************************************************************ -%* * - 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 <- zonkSkolemInfo skol_info - ; let skol_info2 = tidySkolemInfo env skol_info1 - ; return (env, GivenOrigin skol_info2) } -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 m_ty2 orig t_or_k) - = do { (env1, ty1') <- zonkTidyTcType env ty1 - ; (env2, m_ty2') <- case m_ty2 of - Just ty2 -> second Just <$> zonkTidyTcType env1 ty2 - Nothing -> return (env1, Nothing) - ; (env3, orig') <- zonkTidyOrigin env2 orig - ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) } -zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2) - = do { (env1, p1') <- zonkTidyTcType env p1 - ; (env2, p2') <- zonkTidyTcType env1 p2 - ; return (env2, 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 orig = return (env, orig) - ----------------- -tidyCt :: TidyEnv -> Ct -> Ct --- Used only in error reporting -tidyCt env ct - = ct { cc_ev = tidy_ev env (ctEvidence ct) } - where - tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence - -- NB: we do not tidy the ctev_evar field because we don't - -- show it in error messages - tidy_ev env ctev@(CtGiven { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } - tidy_ev env ctev@(CtWanted { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } - tidy_ev env ctev@(CtDerived { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } - ----------------- -tidyEvVar :: TidyEnv -> EvVar -> EvVar -tidyEvVar env var = setVarType var (tidyType env (varType var)) - ----------------- -tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo -tidySkolemInfo env (DerivSkol ty) = DerivSkol (tidyType env ty) -tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs -tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) -tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) -tidySkolemInfo _ info = info - -tidySigSkol :: TidyEnv -> UserTypeCtxt - -> TcType -> [(Name,TcTyVar)] -> SkolemInfo --- We need to take special care when tidying SigSkol --- See Note [SigSkol SkolemInfo] in Origin -tidySigSkol env cx ty tv_prs - = SigSkol cx (tidy_ty env ty) tv_prs' - where - tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs - inst_env = mkNameEnv tv_prs' - - tidy_ty env (ForAllTy (Bndr tv vis) ty) - = ForAllTy (Bndr tv' vis) (tidy_ty env' ty) - where - (env', tv') = tidy_tv_bndr env tv - - tidy_ty env ty@(FunTy _ arg res) - = ty { ft_arg = tidyType env arg, ft_res = tidy_ty env res } - - tidy_ty env ty = tidyType env ty - - tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) - tidy_tv_bndr env@(occ_env, subst) tv - | Just tv' <- lookupNameEnv inst_env (tyVarName tv) - = ((occ_env, extendVarEnv subst tv tv'), tv') - - | otherwise - = tidyVarBndr env tv - -------------------------------------------------------------------------- -{- -%************************************************************************ -%* * - Levity polymorphism checks -* * -************************************************************************* - -See Note [Levity polymorphism checking] in GHC.HsToCore.Monad - --} - --- | According to the rules around representation polymorphism --- (see https://gitlab.haskell.org/ghc/ghc/wikis/no-sub-kinds), no binder --- can have a representation-polymorphic type. This check ensures --- that we respect this rule. It is a bit regrettable that this error --- occurs in zonking, after which we should have reported all errors. --- But it's hard to see where else to do it, because this can be discovered --- only after all solving is done. And, perhaps most importantly, this --- isn't really a compositional property of a type system, so it's --- not a terrible surprise that the check has to go in an awkward spot. -ensureNotLevPoly :: Type -- its zonked type - -> SDoc -- where this happened - -> TcM () -ensureNotLevPoly ty doc - = whenNoErrs $ -- sometimes we end up zonking bogus definitions of type - -- forall a. a. See, for example, test ghci/scripts/T9140 - checkForLevPoly doc ty - - -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad -checkForLevPoly :: SDoc -> Type -> TcM () -checkForLevPoly = checkForLevPolyX addErr - -checkForLevPolyX :: Monad m - => (SDoc -> m ()) -- how to report an error - -> SDoc -> Type -> m () -checkForLevPolyX add_err extra ty - | isTypeLevPoly ty - = add_err (formatLevPolyErr ty $$ extra) - | otherwise - = return () - -formatLevPolyErr :: Type -- levity-polymorphic type - -> SDoc -formatLevPolyErr ty - = hang (text "A levity-polymorphic type is not allowed here:") - 2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty - , text "Kind:" <+> pprWithTYPE tidy_ki ]) - where - (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty - tidy_ki = tidyType tidy_env (tcTypeKind ty) - -{- -%************************************************************************ -%* * - 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' <- mapM zonkTcTyVarToTyVar $ - 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) - doc = 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, doc) } diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs deleted file mode 100644 --- a/compiler/typecheck/TcMatches.hs +++ /dev/null @@ -1,1113 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcMatches: Typecheck some @Matches@ --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda, - TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker, - tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, - tcDoStmt, tcGuardStmt - ) where - -import GhcPrelude - -import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho - , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr ) - -import GHC.Types.Basic (LexicalFixity(..)) -import GHC.Hs -import TcRnMonad -import TcEnv -import TcPat -import TcMType -import TcType -import TcBinds -import TcUnify -import TcOrigin -import GHC.Types.Name -import TysWiredIn -import GHC.Types.Id -import GHC.Core.TyCon -import TysPrim -import TcEvidence -import Outputable -import Util -import GHC.Types.SrcLoc - --- Create chunkified tuple tybes for monad comprehensions -import GHC.Core.Make - -import Control.Monad -import Control.Arrow ( second ) - -#include "HsVersions.h" - -{- -************************************************************************ -* * -\subsection{tcMatchesFun, tcMatchesCase} -* * -************************************************************************ - -@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a -@FunMonoBind@. The second argument is the name of the function, which -is used in error messages. It checks that all the equations have the -same number of arguments before using @tcMatches@ to do the work. - -Note [Polymorphic expected type for tcMatchesFun] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcMatchesFun may be given a *sigma* (polymorphic) type -so it must be prepared to use tcSkolemise to skolemise it. -See Note [sig_tau may be polymorphic] in TcPat. --} - -tcMatchesFun :: Located Name - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpSigmaType -- Expected type of function - -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)) - -- Returns type of body -tcMatchesFun fn@(L _ fun_name) matches exp_ty - = do { -- Check that they all have the same no of arguments - -- Location is in the monad, set the caller so that - -- any inter-equation error messages get some vaguely - -- sensible location. Note: we have to do this odd - -- ann-grabbing, because we don't always have annotations in - -- hand when we call tcMatchesFun... - traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty) - ; checkArgs fun_name matches - - ; (wrap_gen, (wrap_fun, group)) - <- tcSkolemiseET (FunSigCtxt fun_name True) exp_ty $ \ exp_rho -> - -- Note [Polymorphic expected type for tcMatchesFun] - do { (matches', wrap_fun) - <- matchExpectedFunTys herald arity exp_rho $ - \ pat_tys rhs_ty -> - tcMatches match_ctxt pat_tys rhs_ty matches - ; return (wrap_fun, matches') } - ; return (wrap_gen <.> wrap_fun, group) } - where - arity = matchGroupArity matches - herald = text "The equation(s) for" - <+> quotes (ppr fun_name) <+> text "have" - what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness } - match_ctxt = MC { mc_what = what, mc_body = tcBody } - strictness - | [L _ match] <- unLoc $ mg_alts matches - , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match - = SrcStrict - | otherwise - = NoSrcStrict - -{- -@tcMatchesCase@ doesn't do the argument-count check because the -parser guarantees that each equation has exactly one argument. --} - -tcMatchesCase :: (Outputable (body GhcRn)) => - TcMatchCtxt body -- Case context - -> TcSigmaType -- Type of scrutinee - -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives - -> ExpRhoType -- Type of whole case expressions - -> TcM (MatchGroup GhcTcId (Located (body GhcTcId))) - -- Translated alternatives - -- wrapper goes from MatchGroup's ty to expected ty - -tcMatchesCase ctxt scrut_ty matches res_ty - = tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches - -tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify - -> TcMatchCtxt HsExpr - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpRhoType -- deeply skolemised - -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper) -tcMatchLambda herald match_ctxt match res_ty - = matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty -> - tcMatches match_ctxt pat_tys rhs_ty match - where - n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case - | otherwise = matchGroupArity match - --- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. - -tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType - -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId)) --- Used for pattern bindings -tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty) - where - match_ctxt = MC { mc_what = PatBindRhs, - mc_body = tcBody } - -{- -************************************************************************ -* * -\subsection{tcMatch} -* * -************************************************************************ - -Note [Case branches must never infer a non-tau type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - case ... of - ... -> \(x :: forall a. a -> a) -> x - ... -> \y -> y - -Should that type-check? The problem is that, if we check the second branch -first, then we'll get a type (b -> b) for the branches, which won't unify -with the polytype in the first branch. If we check the first branch first, -then everything is OK. This order-dependency is terrible. So we want only -proper tau-types in branches (unless a sigma-type is pushed down). -This is what expTypeToType ensures: it replaces an Infer with a fresh -tau-type. - -An even trickier case looks like - - f x True = x undefined - f x False = x () - -Here, we see that the arguments must also be non-Infer. Thus, we must -use expTypeToType on the output of matchExpectedFunTys, not the input. - -But we make a special case for a one-branch case. This is so that - - f = \(x :: forall a. a -> a) -> x - -still gets assigned a polytype. --} - --- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the --- expected type into TauTvs. --- See Note [Case branches must never infer a non-tau type] -tauifyMultipleMatches :: [LMatch id body] - -> [ExpType] -> TcM [ExpType] -tauifyMultipleMatches group exp_tys - | isSingletonMatchGroup group = return exp_tys - | otherwise = mapM tauifyExpType exp_tys - -- NB: In the empty-match case, this ensures we fill in the ExpType - --- | Type-check a MatchGroup. -tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body - -> [ExpSigmaType] -- Expected pattern types - -> ExpRhoType -- Expected result-type of the Match. - -> MatchGroup GhcRn (Located (body GhcRn)) - -> TcM (MatchGroup GhcTcId (Located (body GhcTcId))) - -data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module - = MC { mc_what :: HsMatchContext GhcRn, -- What kind of thing this is - mc_body :: Located (body GhcRn) -- Type checker for a body of - -- an alternative - -> ExpRhoType - -> TcM (Located (body GhcTcId)) } - -tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches - , mg_origin = origin }) - = do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys) - -- See Note [Case branches must never infer a non-tau type] - - ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches - ; pat_tys <- mapM readExpType pat_tys - ; rhs_ty <- readExpType rhs_ty - ; return (MG { mg_alts = L l matches' - , mg_ext = MatchGroupTc pat_tys rhs_ty - , mg_origin = origin }) } -tcMatches _ _ _ (XMatchGroup nec) = noExtCon nec - -------------- -tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body - -> [ExpSigmaType] -- Expected pattern types - -> ExpRhoType -- Expected result-type of the Match. - -> LMatch GhcRn (Located (body GhcRn)) - -> TcM (LMatch GhcTcId (Located (body GhcTcId))) - -tcMatch ctxt pat_tys rhs_ty match - = wrapLocM (tc_match ctxt pat_tys rhs_ty) match - where - tc_match ctxt pat_tys rhs_ty - match@(Match { m_pats = pats, m_grhss = grhss }) - = add_match_ctxt match $ - do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ - tcGRHSs ctxt grhss rhs_ty - ; return (Match { m_ext = noExtField - , m_ctxt = mc_what ctxt, m_pats = pats' - , m_grhss = grhss' }) } - tc_match _ _ _ (XMatch nec) = noExtCon nec - - -- For (\x -> e), tcExpr has already said "In the expression \x->e" - -- so we don't want to add "In the lambda abstraction \x->e" - add_match_ctxt match thing_inside - = case mc_what ctxt of - LambdaExpr -> thing_inside - _ -> addErrCtxt (pprMatchInCtxt match) thing_inside - -------------- -tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType - -> TcM (GRHSs GhcTcId (Located (body GhcTcId))) - --- Notice that we pass in the full res_ty, so that we get --- good inference from simple things like --- f = \(x::forall a.a->a) -> --- We used to force it to be a monotype when there was more than one guard --- but we don't need to do that any more - -tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty - = do { (binds', grhss') - <- tcLocalBinds binds $ - mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss - - ; return (GRHSs noExtField grhss' (L l binds')) } -tcGRHSs _ (XGRHSs nec) _ = noExtCon nec - -------------- -tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn)) - -> TcM (GRHS GhcTcId (Located (body GhcTcId))) - -tcGRHS ctxt res_ty (GRHS _ guards rhs) - = do { (guards', rhs') - <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ - mc_body ctxt rhs - ; return (GRHS noExtField guards' rhs') } - where - stmt_ctxt = PatGuard (mc_what ctxt) -tcGRHS _ _ (XGRHS nec) = noExtCon nec - -{- -************************************************************************ -* * -\subsection{@tcDoStmts@ typechecks a {\em list} of do statements} -* * -************************************************************************ --} - -tcDoStmts :: HsStmtContext GhcRn - -> Located [LStmt GhcRn (LHsExpr GhcRn)] - -> ExpRhoType - -> TcM (HsExpr GhcTcId) -- Returns a HsDo -tcDoStmts ListComp (L l stmts) res_ty - = do { res_ty <- expTypeToType res_ty - ; (co, elt_ty) <- matchExpectedListTy res_ty - ; let list_ty = mkListTy elt_ty - ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts - (mkCheckExpType elt_ty) - ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) } - -tcDoStmts DoExpr (L l stmts) res_ty - = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo res_ty DoExpr (L l stmts')) } - -tcDoStmts MDoExpr (L l stmts) res_ty - = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo res_ty MDoExpr (L l stmts')) } - -tcDoStmts MonadComp (L l stmts) res_ty - = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo res_ty MonadComp (L l stmts')) } - -tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) - -tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId) -tcBody body res_ty - = do { traceTc "tcBody" (ppr res_ty) - ; tcMonoExpr body res_ty - } - -{- -************************************************************************ -* * -\subsection{tcStmts} -* * -************************************************************************ --} - -type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType -type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType - -type TcStmtChecker body rho_type - = forall thing. HsStmtContext GhcRn - -> Stmt GhcRn (Located (body GhcRn)) - -> rho_type -- Result type for comprehension - -> (rho_type -> TcM thing) -- Checker for what follows the stmt - -> TcM (Stmt GhcTcId (Located (body GhcTcId)), thing) - -tcStmts :: (Outputable (body GhcRn)) => HsStmtContext GhcRn - -> TcStmtChecker body rho_type -- NB: higher-rank type - -> [LStmt GhcRn (Located (body GhcRn))] - -> rho_type - -> TcM [LStmt GhcTcId (Located (body GhcTcId))] -tcStmts ctxt stmt_chk stmts res_ty - = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ - const (return ()) - ; return stmts' } - -tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext GhcRn - -> TcStmtChecker body rho_type -- NB: higher-rank type - -> [LStmt GhcRn (Located (body GhcRn))] - -> rho_type - -> (rho_type -> TcM thing) - -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing) - --- Note the higher-rank type. stmt_chk is applied at different --- types in the equations for tcStmts - -tcStmtsAndThen _ _ [] res_ty thing_inside - = do { thing <- thing_inside res_ty - ; return ([], thing) } - --- LetStmts are handled uniformly, regardless of context -tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts) - res_ty thing_inside - = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ - tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside - ; return (L loc (LetStmt x (L l binds')) : stmts', thing) } - --- Don't set the error context for an ApplicativeStmt. It ought to be --- possible to do this with a popErrCtxt in the tcStmt case for --- ApplicativeStmt, but it did something strange and broke a test (ado002). -tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside - | ApplicativeStmt{} <- stmt - = do { (stmt', (stmts', thing)) <- - stmt_chk ctxt stmt res_ty $ \ res_ty' -> - tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ - thing_inside - ; return (L loc stmt' : stmts', thing) } - - -- For the vanilla case, handle the location-setting part - | otherwise - = do { (stmt', (stmts', thing)) <- - setSrcSpan loc $ - addErrCtxt (pprStmtInCtxt ctxt stmt) $ - stmt_chk ctxt stmt res_ty $ \ res_ty' -> - popErrCtxt $ - tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ - thing_inside - ; return (L loc stmt' : stmts', thing) } - ---------------------------------------------------- --- Pattern guards ---------------------------------------------------- - -tcGuardStmt :: TcExprStmtChecker -tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside - = do { guard' <- tcMonoExpr guard (mkCheckExpType boolTy) - ; thing <- thing_inside res_ty - ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) } - -tcGuardStmt ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside - = do { (rhs', rhs_ty) <- tcInferRhoNC rhs - -- Stmt has a context already - ; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) - pat (mkCheckExpType rhs_ty) $ - thing_inside res_ty - ; return (mkTcBindStmt pat' rhs', thing) } - -tcGuardStmt _ stmt _ _ - = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt) - - ---------------------------------------------------- --- List comprehensions --- (no rebindable syntax) ---------------------------------------------------- - --- Dealt with separately, rather than by tcMcStmt, because --- a) We have special desugaring rules for list comprehensions, --- which avoid creating intermediate lists. They in turn --- assume that the bind/return operations are the regular --- polymorphic ones, and in particular don't have any --- coercion matching stuff in them. It's hard to avoid the --- potential for non-trivial coercions in tcMcStmt - -tcLcStmt :: TyCon -- The list type constructor ([]) - -> TcExprStmtChecker - -tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside - = do { body' <- tcMonoExprNC body elt_ty - ; thing <- thing_inside (panic "tcLcStmt: thing_inside") - ; return (LastStmt x body' noret noSyntaxExpr, thing) } - --- A generator, pat <- rhs -tcLcStmt m_tc ctxt (BindStmt _ pat rhs _ _) elt_ty thing_inside - = do { pat_ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty]) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - thing_inside elt_ty - ; return (mkTcBindStmt pat' rhs', thing) } - --- A boolean guard -tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside - = do { rhs' <- tcMonoExpr rhs (mkCheckExpType boolTy) - ; thing <- thing_inside elt_ty - ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) } - --- ParStmt: See notes with tcMcStmt -tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside - = do { (pairs', thing) <- loop bndr_stmts_s - ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) } - where - -- loop :: [([LStmt GhcRn], [GhcRn])] - -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing) - loop [] = do { thing <- thing_inside elt_ty - ; return ([], thing) } -- matching in the branches - - loop (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 - ; return (ids, pairs', thing) } - ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) } - loop (XParStmtBlock nec:_) = noExtCon nec - -tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts - , trS_bndrs = bindersMap - , trS_by = by, trS_using = using }) elt_ty thing_inside - = do { let (bndr_names, n_bndr_names) = unzip bindersMap - unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap) - -- The inner 'stmts' lack a LastStmt, so the element type - -- passed in to tcStmtsAndThen is never looked at - ; (stmts', (bndr_ids, by')) - <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do - { by' <- traverse tcInferRho by - ; bndr_ids <- tcLookupLocalIds bndr_names - ; return (bndr_ids, by') } - - ; let m_app ty = mkTyConApp m_tc [ty] - - --------------- Typecheck the 'using' function ------------- - -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm) - -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm) - - -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm - ; let n_app = case form of - ThenForm -> (\ty -> ty) - _ -> m_app - - by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present - by_arrow = case by' of - Nothing -> \ty -> ty - Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTy` e_ty) `mkVisFunTy` ty - - tup_ty = mkBigCoreVarTupTy bndr_ids - poly_arg_ty = m_app alphaTy - poly_res_ty = m_app (n_app alphaTy) - using_poly_ty = mkInvForAllTy alphaTyVar $ - by_arrow $ - poly_arg_ty `mkVisFunTy` poly_res_ty - - ; using' <- tcPolyExpr using using_poly_ty - ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' - - -- 'stmts' returns a result of type (m1_ty tuple_ty), - -- typically something like [(Int,Bool,Int)] - -- We don't know what tuple_ty is yet, so we use a variable - ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) - - -- Ensure that every old binder of type `b` is linked up with its - -- new binder which should have type `n b` - -- See Note [GroupStmt binder map] in GHC.Hs.Expr - n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids - bindersMap' = bndr_ids `zip` n_bndr_ids - - -- Type check the thing in the environment with - -- these new binders and return the result - ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty) - - ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' - , trS_by = fmap fst by', trS_using = final_using - , trS_ret = noSyntaxExpr - , trS_bind = noSyntaxExpr - , trS_fmap = noExpr - , trS_ext = unitTy - , trS_form = form }, thing) } - -tcLcStmt _ _ stmt _ _ - = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) - - ---------------------------------------------------- --- Monad comprehensions --- (supports rebindable syntax) ---------------------------------------------------- - -tcMcStmt :: TcExprStmtChecker - -tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside - = do { (body', return_op') - <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $ - \ [a_ty] -> - tcMonoExprNC body (mkCheckExpType a_ty) - ; thing <- thing_inside (panic "tcMcStmt: thing_inside") - ; return (LastStmt x body' noret return_op', thing) } - --- Generators for monad comprehensions ( pat <- rhs ) --- --- [ body | q <- gen ] -> gen :: m a --- q :: a --- - -tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside - -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty - = do { ((rhs', pat', thing, new_res_ty), bind_op') - <- tcSyntaxOp MCompOrigin bind_op - [SynRho, SynFun SynAny SynRho] res_ty $ - \ [rhs_ty, pat_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat - (mkCheckExpType pat_ty) $ - thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', pat', thing, new_res_ty) } - - -- If (but only if) the pattern can fail, typecheck the 'fail' operator - ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty - - ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) } - --- Boolean expressions. --- --- [ body | stmts, expr ] -> expr :: m Bool --- -tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside - = do { -- Deal with rebindable syntax: - -- guard_op :: test_ty -> rhs_ty - -- then_op :: rhs_ty -> new_res_ty -> res_ty - -- Where test_ty is, for example, Bool - ; ((thing, rhs', rhs_ty, guard_op'), then_op') - <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $ - \ [rhs_ty, new_res_ty] -> - do { (rhs', guard_op') - <- tcSyntaxOp MCompOrigin guard_op [SynAny] - (mkCheckExpType rhs_ty) $ - \ [test_ty] -> - tcMonoExpr rhs (mkCheckExpType test_ty) - ; thing <- thing_inside (mkCheckExpType new_res_ty) - ; return (thing, rhs', rhs_ty, guard_op') } - ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) } - --- Grouping statements --- --- [ body | stmts, then group by e using f ] --- -> e :: t --- f :: forall a. (a -> t) -> m a -> m (m a) --- [ body | stmts, then group using f ] --- -> f :: forall a. m a -> m (m a) - --- We type [ body | (stmts, group by e using f), ... ] --- f [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body.... --- --- We type the functions as follows: --- f :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm) --- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm) --- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm) --- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm) --- -tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap - , trS_by = by, trS_using = using, trS_form = form - , trS_ret = return_op, trS_bind = bind_op - , trS_fmap = fmap_op }) res_ty thing_inside - = do { m1_ty <- newFlexiTyVarTy typeToTypeKind - ; m2_ty <- newFlexiTyVarTy typeToTypeKind - ; tup_ty <- newFlexiTyVarTy liftedTypeKind - ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any) - - -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm - ; n_app <- case form of - ThenForm -> return (\ty -> ty) - _ -> do { n_ty <- newFlexiTyVarTy typeToTypeKind - ; return (n_ty `mkAppTy`) } - ; let by_arrow :: Type -> Type - -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present) - -- or res ('by' absent) - by_arrow = case by of - Nothing -> \res -> res - Just {} -> \res -> (alphaTy `mkVisFunTy` by_e_ty) `mkVisFunTy` res - - poly_arg_ty = m1_ty `mkAppTy` alphaTy - using_arg_ty = m1_ty `mkAppTy` tup_ty - poly_res_ty = m2_ty `mkAppTy` n_app alphaTy - using_res_ty = m2_ty `mkAppTy` n_app tup_ty - using_poly_ty = mkInvForAllTy alphaTyVar $ - by_arrow $ - poly_arg_ty `mkVisFunTy` poly_res_ty - - -- 'stmts' returns a result of type (m1_ty tuple_ty), - -- typically something like [(Int,Bool,Int)] - -- We don't know what tuple_ty is yet, so we use a variable - ; let (bndr_names, n_bndr_names) = unzip bindersMap - ; (stmts', (bndr_ids, by', return_op')) <- - tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts - (mkCheckExpType using_arg_ty) $ \res_ty' -> do - { by' <- case by of - Nothing -> return Nothing - Just e -> do { e' <- tcMonoExpr e - (mkCheckExpType by_e_ty) - ; return (Just e') } - - -- Find the Ids (and hence types) of all old binders - ; bndr_ids <- tcLookupLocalIds bndr_names - - -- 'return' is only used for the binders, so we know its type. - -- return :: (a,b,c,..) -> m (a,b,c,..) - ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op - [synKnownType (mkBigCoreVarTupTy bndr_ids)] - res_ty' $ \ _ -> return () - - ; return (bndr_ids, by', return_op') } - - --------------- Typecheck the 'bind' function ------------- - -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty - ; new_res_ty <- newFlexiTyVarTy liftedTypeKind - ; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op - [ synKnownType using_res_ty - , synKnownType (n_app tup_ty `mkVisFunTy` new_res_ty) ] - res_ty $ \ _ -> return () - - --------------- Typecheck the 'fmap' function ------------- - ; fmap_op' <- case form of - ThenForm -> return noExpr - _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $ - mkInvForAllTy alphaTyVar $ - mkInvForAllTy betaTyVar $ - (alphaTy `mkVisFunTy` betaTy) - `mkVisFunTy` (n_app alphaTy) - `mkVisFunTy` (n_app betaTy) - - --------------- Typecheck the 'using' function ------------- - -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c)) - - ; using' <- tcPolyExpr using using_poly_ty - ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' - - --------------- Building the bindersMap ---------------- - ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) - - -- Ensure that every old binder of type `b` is linked up with its - -- new binder which should have type `n b` - -- See Note [GroupStmt binder map] in GHC.Hs.Expr - n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids - bindersMap' = bndr_ids `zip` n_bndr_ids - - -- Type check the thing in the environment with - -- these new binders and return the result - ; thing <- tcExtendIdEnv n_bndr_ids $ - thing_inside (mkCheckExpType new_res_ty) - - ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' - , trS_by = by', trS_using = final_using - , trS_ret = return_op', trS_bind = bind_op' - , trS_ext = n_app tup_ty - , trS_fmap = fmap_op', trS_form = form }, thing) } - --- A parallel set of comprehensions --- [ (g x, h x) | ... ; let g v = ... --- | ... ; let h v = ... ] --- --- It's possible that g,h are overloaded, so we need to feed the LIE from the --- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods). --- Similarly if we had an existential pattern match: --- --- data T = forall a. Show a => C a --- --- [ (show x, show y) | ... ; C x <- ... --- | ... ; C y <- ... ] --- --- Then we need the LIE from (show x, show y) to be simplified against --- the bindings for x and y. --- --- It's difficult to do this in parallel, so we rely on the renamer to --- ensure that g,h and x,y don't duplicate, and simply grow the environment. --- So the binders of the first parallel group will be in scope in the second --- group. But that's fine; there's no shadowing to worry about. --- --- Note: The `mzip` function will get typechecked via: --- --- ParStmt [st1::t1, st2::t2, st3::t3] --- --- mzip :: m st1 --- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call --- -> m (st1, (st2, st3)) --- -tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside - = do { m_ty <- newFlexiTyVarTy typeToTypeKind - - ; let mzip_ty = mkInvForAllTys [alphaTyVar, betaTyVar] $ - (m_ty `mkAppTy` alphaTy) - `mkVisFunTy` - (m_ty `mkAppTy` betaTy) - `mkVisFunTy` - (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) - ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty - - -- type dummies since we don't know all binder types yet - ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind)) - [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ] - - -- Typecheck bind: - ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ] - tuple_ty = mk_tuple_ty tup_tys - - ; (((blocks', thing), inner_res_ty), bind_op') - <- tcSyntaxOp MCompOrigin bind_op - [ synKnownType (m_ty `mkAppTy` tuple_ty) - , SynFun (synKnownType tuple_ty) SynRho ] res_ty $ - \ [inner_res_ty] -> - do { stuff <- loop m_ty (mkCheckExpType inner_res_ty) - tup_tys bndr_stmts_s - ; return (stuff, inner_res_ty) } - - ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) } - - where - mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys - - -- loop :: Type -- m_ty - -- -> ExpRhoType -- inner_res_ty - -- -> [TcType] -- tup_tys - -- -> [ParStmtBlock Name] - -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing) - loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty - ; return ([], thing) } - -- matching in the branches - - loop m_ty inner_res_ty (tup_ty_in : tup_tys_in) - (ParStmtBlock x stmts names return_op : pairs) - = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in - ; (stmts', (ids, return_op', pairs', thing)) - <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $ - \m_tup_ty' -> - do { ids <- tcLookupLocalIds names - ; let tup_ty = mkBigCoreVarTupTy ids - ; (_, return_op') <- - tcSyntaxOp MCompOrigin return_op - [synKnownType tup_ty] m_tup_ty' $ - \ _ -> return () - ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs - ; return (ids, return_op', pairs', thing) } - ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) } - loop _ _ _ _ = panic "tcMcStmt.loop" - -tcMcStmt _ stmt _ _ - = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) - - ---------------------------------------------------- --- Do-notation --- (supports rebindable syntax) ---------------------------------------------------- - -tcDoStmt :: TcExprStmtChecker - -tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside - = do { body' <- tcMonoExprNC body res_ty - ; thing <- thing_inside (panic "tcDoStmt: thing_inside") - ; return (LastStmt x body' noret noSyntaxExpr, thing) } - -tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside - = do { -- Deal with rebindable syntax: - -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty - -- This level of generality is needed for using do-notation - -- in full generality; see #1537 - - ((rhs', pat', new_res_ty, thing), bind_op') - <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $ - \ [rhs_ty, pat_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat - (mkCheckExpType pat_ty) $ - thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', pat', new_res_ty, thing) } - - -- If (but only if) the pattern can fail, typecheck the 'fail' operator - ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty - - ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) } - -tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside - = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $ - thing_inside . mkCheckExpType - ; ((pairs', body_ty, thing), mb_join') <- case mb_join of - Nothing -> (, Nothing) <$> tc_app_stmts res_ty - Just join_op -> - second Just <$> - (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $ - \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty)) - - ; return (ApplicativeStmt body_ty pairs' mb_join', thing) } - -tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside - = do { -- Deal with rebindable syntax; - -- (>>) :: rhs_ty -> new_res_ty -> res_ty - ; ((rhs', rhs_ty, thing), then_op') - <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $ - \ [rhs_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) - ; thing <- thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', rhs_ty, thing) } - ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } - -tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names - , recS_rec_ids = rec_names, recS_ret_fn = ret_op - , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) - res_ty thing_inside - = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names - ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind - ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys - tup_ty = mkBigCoreTupTy tup_elt_tys - - ; tcExtendIdEnv tup_ids $ do - { ((stmts', (ret_op', tup_rets)), stmts_ty) - <- tcInferInst $ \ exp_ty -> - tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty -> - do { tup_rets <- zipWithM tcCheckId tup_names - (map mkCheckExpType tup_elt_tys) - -- Unify the types of the "final" Ids (which may - -- be polymorphic) with those of "knot-tied" Ids - ; (_, ret_op') - <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty] - inner_res_ty $ \_ -> return () - ; return (ret_op', tup_rets) } - - ; ((_, mfix_op'), mfix_res_ty) - <- tcInferInst $ \ exp_ty -> - tcSyntaxOp DoOrigin mfix_op - [synKnownType (mkVisFunTy tup_ty stmts_ty)] exp_ty $ - \ _ -> return () - - ; ((thing, new_res_ty), bind_op') - <- tcSyntaxOp DoOrigin bind_op - [ synKnownType mfix_res_ty - , synKnownType tup_ty `SynFun` SynRho ] - res_ty $ - \ [new_res_ty] -> - do { thing <- thing_inside (mkCheckExpType new_res_ty) - ; return (thing, new_res_ty) } - - ; let rec_ids = takeList rec_names tup_ids - ; later_ids <- tcLookupLocalIds later_names - ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids), - ppr later_ids <+> ppr (map idType later_ids)] - ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids - , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' - , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' - , recS_ext = RecStmtTc - { recS_bind_ty = new_res_ty - , recS_later_rets = [] - , recS_rec_rets = tup_rets - , recS_ret_ty = stmts_ty} }, thing) - }} - -tcDoStmt _ stmt _ _ - = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt) - - - ---------------------------------------------------- --- MonadFail Proposal warnings ---------------------------------------------------- - --- The idea behind issuing MonadFail warnings is that we add them whenever a --- failable pattern is encountered. However, instead of throwing a type error --- when the constraint cannot be satisfied, we only issue a warning in --- TcErrors.hs. - -tcMonadFailOp :: CtOrigin - -> LPat GhcTcId - -> SyntaxExpr GhcRn -- The fail op - -> TcType -- Type of the whole do-expression - -> TcRn (SyntaxExpr GhcTcId) -- Typechecked fail op --- Get a 'fail' operator expression, to use if the pattern --- match fails. If the pattern is irrefutatable, just return --- noSyntaxExpr; it won't be used -tcMonadFailOp orig pat fail_op res_ty - | isIrrefutableHsPat pat - = return noSyntaxExpr - - | otherwise - = snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] - (mkCheckExpType res_ty) $ \_ -> return ()) - -{- -Note [Treat rebindable syntax first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When typechecking - do { bar; ... } :: IO () -we want to typecheck 'bar' in the knowledge that it should be an IO thing, -pushing info from the context into the RHS. To do this, we check the -rebindable syntax first, and push that information into (tcMonoExprNC rhs). -Otherwise the error shows up when checking the rebindable syntax, and -the expected/inferred stuff is back to front (see #3613). - -Note [typechecking ApplicativeStmt] - -join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en) - -fresh type variables: - pat_ty_1..pat_ty_n - exp_ty_1..exp_ty_n - t_1..t_(n-1) - -body :: body_ty -(\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty -pat_i :: pat_ty_i -e_i :: exp_ty_i -<$> :: (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 --} - -tcApplicativeStmts - :: HsStmtContext GhcRn - -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)] - -> ExpRhoType -- rhs_ty - -> (TcRhoType -> TcM t) -- thing_inside - -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t) - -tcApplicativeStmts ctxt pairs rhs_ty thing_inside - = do { body_ty <- newFlexiTyVarTy liftedTypeKind - ; let arity = length pairs - ; ts <- replicateM (arity-1) $ newInferExpTypeInst - ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind - ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind - ; let fun_ty = mkVisFunTys pat_tys body_ty - - -- NB. do the <$>,<*> operators first, we don't want type errors here - -- i.e. goOps before goArgs - -- See Note [Treat rebindable syntax first] - ; let (ops, args) = unzip pairs - ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys) - - -- Typecheck each ApplicativeArg separately - -- See Note [ApplicativeDo and constraints] - ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys) - - -- Bring into scope all the things bound by the args, - -- and typecheck the thing_inside - -- See Note [ApplicativeDo and constraints] - ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $ - thing_inside body_ty - - ; return (zip ops' args', body_ty, res) } - where - goOps _ [] = return [] - goOps t_left ((op,t_i,exp_ty) : ops) - = do { (_, op') - <- tcSyntaxOp DoOrigin op - [synKnownType t_left, synKnownType exp_ty] t_i $ - \ _ -> return () - ; t_i <- readExpType t_i - ; ops' <- goOps t_i ops - ; return (op' : ops') } - - goArg :: Type -> (ApplicativeArg GhcRn, Type, Type) - -> TcM (ApplicativeArg GhcTcId) - - goArg body_ty (ApplicativeArgOne - { app_arg_pattern = pat - , arg_expr = rhs - , fail_operator = fail_op - , .. - }, pat_ty, exp_ty) - = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ - addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs)) $ - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty) - ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - return () - ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op body_ty - - ; return (ApplicativeArgOne - { app_arg_pattern = pat' - , arg_expr = rhs' - , fail_operator = fail_op' - , .. } - ) } - - goArg _body_ty (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty) - = do { (stmts', (ret',pat')) <- - tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $ - \res_ty -> do - { L _ ret' <- tcMonoExprNC (noLoc ret) res_ty - ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - return () - ; return (ret', pat') - } - ; return (ApplicativeArgMany x stmts' ret' pat') } - - goArg _body_ty (XApplicativeArg nec, _, _) = noExtCon nec - - get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id] - get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat - get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat - get_arg_bndrs (XApplicativeArg nec) = noExtCon nec - -{- Note [ApplicativeDo and constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An applicative-do is supposed to take place in parallel, so -constraints bound in one arm can't possibly be available in another -(#13242). Our current rule is this (more details and discussion -on the ticket). Consider - - ...stmts... - ApplicativeStmts [arg1, arg2, ... argN] - ...more stmts... - -where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts. -Now, we say that: - -* Constraints required by the argi can be solved from - constraint bound by ...stmts... - -* Constraints and existentials bound by the argi are not available - to solve constraints required either by argj (where i /= j), - or by ...more stmts.... - -* Within the stmts of each 'argi' individually, however, constraints bound - by earlier stmts can be used to solve later ones. - -To achieve this, we just typecheck each 'argi' separately, bring all -the variables they bind into scope, and typecheck the thing_inside. - -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ - -@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same -number of args are used in each equation. --} - -checkArgs :: Name -> MatchGroup GhcRn body -> TcM () -checkArgs _ (MG { mg_alts = L _ [] }) - = return () -checkArgs fun (MG { mg_alts = L _ (match1:matches) }) - | null bad_matches - = return () - | otherwise - = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+> - text "have different numbers of arguments" - , nest 2 (ppr (getLoc match1)) - , nest 2 (ppr (getLoc (head bad_matches)))]) - where - n_args1 = args_in_match match1 - bad_matches = [m | m <- matches, args_in_match m /= n_args1] - - args_in_match :: LMatch GhcRn body -> Int - args_in_match (L _ (Match { m_pats = pats })) = length pats - args_in_match (L _ (XMatch nec)) = noExtCon nec -checkArgs _ (XMatchGroup nec) = noExtCon nec diff --git a/compiler/typecheck/TcMatches.hs-boot b/compiler/typecheck/TcMatches.hs-boot deleted file mode 100644 --- a/compiler/typecheck/TcMatches.hs-boot +++ /dev/null @@ -1,17 +0,0 @@ -module TcMatches where -import GHC.Hs ( GRHSs, MatchGroup, LHsExpr ) -import TcEvidence ( HsWrapper ) -import GHC.Types.Name ( Name ) -import TcType ( ExpSigmaType, TcRhoType ) -import TcRnTypes ( TcM ) -import GHC.Types.SrcLoc ( Located ) -import GHC.Hs.Extension ( GhcRn, GhcTcId ) - -tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) - -> TcRhoType - -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId)) - -tcMatchesFun :: Located Name - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpSigmaType - -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)) diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs deleted file mode 100644 --- a/compiler/typecheck/TcPat.hs +++ /dev/null @@ -1,1206 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcPat: Typechecking patterns --} - -{-# LANGUAGE CPP, RankNTypes, TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcPat ( tcLetPat, newLetBndr, LetBndrSpec(..) - , tcPat, tcPat_O, tcPats - , addDataConStupidTheta, badFieldCon, polyPatSig ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma ) - -import GHC.Hs -import TcHsSyn -import TcSigs( TcPragEnv, lookupPragEnv, addInlinePrags ) -import TcRnMonad -import Inst -import GHC.Types.Id -import GHC.Types.Var -import GHC.Types.Name -import GHC.Types.Name.Reader -import TcEnv -import TcMType -import TcValidity( arityErr ) -import GHC.Core.TyCo.Ppr ( pprTyVars ) -import TcType -import TcUnify -import TcHsType -import TysWiredIn -import TcEvidence -import TcOrigin -import GHC.Core.TyCon -import GHC.Core.DataCon -import GHC.Core.PatSyn -import GHC.Core.ConLike -import PrelNames -import GHC.Types.Basic hiding (SuccessFlag(..)) -import GHC.Driver.Session -import GHC.Types.SrcLoc -import GHC.Types.Var.Set -import Util -import Outputable -import qualified GHC.LanguageExtensions as LangExt -import Control.Arrow ( second ) -import ListSetOps ( getNth ) - -{- -************************************************************************ -* * - External interface -* * -************************************************************************ --} - -tcLetPat :: (Name -> Maybe TcId) - -> LetBndrSpec - -> LPat GhcRn -> ExpSigmaType - -> TcM a - -> TcM (LPat GhcTcId, a) -tcLetPat sig_fn no_gen pat pat_ty thing_inside - = do { bind_lvl <- getTcLevel - ; let ctxt = LetPat { pc_lvl = bind_lvl - , pc_sig_fn = sig_fn - , pc_new = no_gen } - penv = PE { pe_lazy = True - , pe_ctxt = ctxt - , pe_orig = PatOrigin } - - ; tc_lpat pat pat_ty penv thing_inside } - ------------------ -tcPats :: HsMatchContext GhcRn - -> [LPat GhcRn] -- Patterns, - -> [ExpSigmaType] -- and their types - -> TcM a -- and the checker for the body - -> TcM ([LPat GhcTcId], a) - --- This is the externally-callable wrapper function --- Typecheck the patterns, extend the environment to bind the variables, --- do the thing inside, use any existentially-bound dictionaries to --- discharge parts of the returning LIE, and deal with pattern type --- signatures - --- 1. Initialise the PatState --- 2. Check the patterns --- 3. Check the body --- 4. Check that no existentials escape - -tcPats ctxt pats pat_tys thing_inside - = tc_lpats penv pats pat_tys thing_inside - where - penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } - -tcPat :: HsMatchContext GhcRn - -> LPat GhcRn -> ExpSigmaType - -> TcM a -- Checker for body - -> TcM (LPat GhcTcId, a) -tcPat ctxt = tcPat_O ctxt PatOrigin - --- | A variant of 'tcPat' that takes a custom origin -tcPat_O :: HsMatchContext GhcRn - -> CtOrigin -- ^ origin to use if the type needs inst'ing - -> LPat GhcRn -> ExpSigmaType - -> TcM a -- Checker for body - -> TcM (LPat GhcTcId, a) -tcPat_O ctxt orig pat pat_ty thing_inside - = tc_lpat pat pat_ty penv thing_inside - where - penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig } - - -{- -************************************************************************ -* * - PatEnv, PatCtxt, LetBndrSpec -* * -************************************************************************ --} - -data PatEnv - = PE { pe_lazy :: Bool -- True <=> lazy context, so no existentials allowed - , pe_ctxt :: PatCtxt -- Context in which the whole pattern appears - , pe_orig :: CtOrigin -- origin to use if the pat_ty needs inst'ing - } - -data PatCtxt - = LamPat -- Used for lambdas, case etc - (HsMatchContext GhcRn) - - | LetPat -- Used only for let(rec) pattern bindings - -- See Note [Typing patterns in pattern bindings] - { pc_lvl :: TcLevel - -- Level of the binding group - - , pc_sig_fn :: Name -> Maybe TcId - -- Tells the expected type - -- for binders with a signature - - , pc_new :: LetBndrSpec - -- How to make a new binder - } -- for binders without signatures - -data LetBndrSpec - = LetLclBndr -- We are going to generalise, and wrap in an AbsBinds - -- so clone a fresh binder for the local monomorphic Id - - | LetGblBndr TcPragEnv -- Generalisation plan is NoGen, so there isn't going - -- to be an AbsBinds; So we must bind the global version - -- of the binder right away. - -- And here is the inline-pragma information - -instance Outputable LetBndrSpec where - ppr LetLclBndr = text "LetLclBndr" - ppr (LetGblBndr {}) = text "LetGblBndr" - -makeLazy :: PatEnv -> PatEnv -makeLazy penv = penv { pe_lazy = True } - -inPatBind :: PatEnv -> Bool -inPatBind (PE { pe_ctxt = LetPat {} }) = True -inPatBind (PE { pe_ctxt = LamPat {} }) = False - -{- ********************************************************************* -* * - Binders -* * -********************************************************************* -} - -tcPatBndr :: PatEnv -> Name -> ExpSigmaType -> TcM (HsWrapper, TcId) --- (coi, xp) = tcPatBndr penv x pat_ty --- Then coi : pat_ty ~ typeof(xp) --- -tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl - , pc_sig_fn = sig_fn - , pc_new = no_gen } }) - bndr_name exp_pat_ty - -- For the LetPat cases, see - -- Note [Typechecking pattern bindings] in TcBinds - - | Just bndr_id <- sig_fn bndr_name -- There is a signature - = do { wrap <- tcSubTypePat penv exp_pat_ty (idType bndr_id) - -- See Note [Subsumption check at pattern variables] - ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty) - ; return (wrap, bndr_id) } - - | otherwise -- No signature - = do { (co, bndr_ty) <- case exp_pat_ty of - Check pat_ty -> promoteTcType bind_lvl pat_ty - Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res ) - -- If we were under a constructor that bumped - -- the level, we'd be in checking mode - do { bndr_ty <- inferResultToType infer_res - ; return (mkTcNomReflCo bndr_ty, bndr_ty) } - ; bndr_id <- newLetBndr no_gen bndr_name bndr_ty - ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl - , ppr exp_pat_ty, ppr bndr_ty, ppr co - , ppr bndr_id ]) - ; return (mkWpCastN co, bndr_id) } - -tcPatBndr _ bndr_name pat_ty - = do { pat_ty <- expTypeToType pat_ty - ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty) - ; return (idHsWrapper, mkLocalIdOrCoVar bndr_name pat_ty) } - -- We should not have "OrCoVar" here, this is a bug (#17545) - -- Whether or not there is a sig is irrelevant, - -- as this is local - -newLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId --- Make up a suitable Id for the pattern-binder. --- See Note [Typechecking pattern bindings], item (4) in TcBinds --- --- In the polymorphic case when we are going to generalise --- (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version" --- of the Id; the original name will be bound to the polymorphic version --- by the AbsBinds --- In the monomorphic case when we are not going to generalise --- (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds, --- and we use the original name directly -newLetBndr LetLclBndr name ty - = do { mono_name <- cloneLocalName name - ; return (mkLocalId mono_name ty) } -newLetBndr (LetGblBndr prags) name ty - = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name) - -tcSubTypePat :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper --- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt --- Used when typechecking patterns -tcSubTypePat penv t1 t2 = tcSubTypeET (pe_orig penv) GenSigCtxt t1 t2 - -{- Note [Subsumption check at pattern variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we come across a variable with a type signature, we need to do a -subsumption, not equality, check against the context type. e.g. - - data T = MkT (forall a. a->a) - f :: forall b. [b]->[b] - MkT f = blah - -Since 'blah' returns a value of type T, its payload is a polymorphic -function of type (forall a. a->a). And that's enough to bind the -less-polymorphic function 'f', but we need some impedance matching -to witness the instantiation. - - -************************************************************************ -* * - The main worker functions -* * -************************************************************************ - -Note [Nesting] -~~~~~~~~~~~~~~ -tcPat takes a "thing inside" over which the pattern scopes. This is partly -so that tcPat can extend the environment for the thing_inside, but also -so that constraints arising in the thing_inside can be discharged by the -pattern. - -This does not work so well for the ErrCtxt carried by the monad: we don't -want the error-context for the pattern to scope over the RHS. -Hence the getErrCtxt/setErrCtxt stuff in tcMultiple --} - --------------------- -type Checker inp out = forall r. - inp - -> PatEnv - -> TcM r - -> TcM (out, r) - -tcMultiple :: Checker inp out -> Checker [inp] [out] -tcMultiple tc_pat args penv thing_inside - = do { err_ctxt <- getErrCtxt - ; let loop _ [] - = do { res <- thing_inside - ; return ([], res) } - - loop penv (arg:args) - = do { (p', (ps', res)) - <- tc_pat arg penv $ - setErrCtxt err_ctxt $ - loop penv args - -- setErrCtxt: restore context before doing the next pattern - -- See note [Nesting] above - - ; return (p':ps', res) } - - ; loop penv args } - --------------------- -tc_lpat :: LPat GhcRn - -> ExpSigmaType - -> PatEnv - -> TcM a - -> TcM (LPat GhcTcId, a) -tc_lpat (L span pat) pat_ty penv thing_inside - = setSrcSpan span $ - do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) - thing_inside - ; return (L span pat', res) } - -tc_lpats :: PatEnv - -> [LPat GhcRn] -> [ExpSigmaType] - -> TcM a - -> TcM ([LPat GhcTcId], a) -tc_lpats penv pats tys thing_inside - = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys ) - tcMultiple (\(p,t) -> tc_lpat p t) - (zipEqual "tc_lpats" pats tys) - penv thing_inside - --------------------- -tc_pat :: PatEnv - -> Pat GhcRn - -> ExpSigmaType -- Fully refined result type - -> TcM a -- Thing inside - -> TcM (Pat GhcTcId, -- Translated pattern - a) -- Result of thing inside - -tc_pat penv (VarPat x (L l name)) pat_ty thing_inside - = do { (wrap, id) <- tcPatBndr penv name pat_ty - ; res <- tcExtendIdEnv1 name id thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } - -tc_pat penv (ParPat x pat) pat_ty thing_inside - = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (ParPat x pat', res) } - -tc_pat penv (BangPat x pat) pat_ty thing_inside - = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (BangPat x pat', res) } - -tc_pat penv (LazyPat x pat) pat_ty thing_inside - = do { (pat', (res, pat_ct)) - <- tc_lpat pat pat_ty (makeLazy penv) $ - captureConstraints thing_inside - -- Ignore refined penv', revert to penv - - ; emitConstraints pat_ct - -- captureConstraints/extendConstraints: - -- see Note [Hopping the LIE in lazy patterns] - - -- Check that the expected pattern type is itself lifted - ; pat_ty <- readExpType pat_ty - ; _ <- unifyType Nothing (tcTypeKind pat_ty) liftedTypeKind - - ; return (LazyPat x pat', res) } - -tc_pat _ (WildPat _) pat_ty thing_inside - = do { res <- thing_inside - ; pat_ty <- expTypeToType pat_ty - ; return (WildPat pat_ty, res) } - -tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside - = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) - ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ - tc_lpat pat (mkCheckExpType $ idType bndr_id) - penv thing_inside - -- NB: if we do inference on: - -- \ (y@(x::forall a. a->a)) = e - -- we'll fail. The as-pattern infers a monotype for 'y', which then - -- fails to unify with the polymorphic type for 'x'. This could - -- perhaps be fixed, but only with a bit more work. - -- - -- If you fix it, don't forget the bindInstsOfPatIds! - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, - res) } - -tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside - = do { - -- Expr must have type `forall a1...aN. OPT' -> B` - -- where overall_pat_ty is an instance of OPT'. - ; (expr',expr'_inferred) <- tcInferSigma expr - - -- expression must be a function - ; let expr_orig = lexprCtOrigin expr - herald = text "A view pattern expression expects" - ; (expr_wrap1, [inf_arg_ty], inf_res_ty) - <- matchActualFunTys herald expr_orig (Just (unLoc expr)) 1 expr'_inferred - -- expr_wrap1 :: expr'_inferred "->" (inf_arg_ty -> inf_res_ty) - - -- check that overall pattern is more polymorphic than arg type - ; expr_wrap2 <- tcSubTypePat penv overall_pat_ty inf_arg_ty - -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty - - -- pattern must have inf_res_ty - ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside - - ; overall_pat_ty <- readExpType overall_pat_ty - ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper - overall_pat_ty inf_res_ty doc - -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->" - -- (overall_pat_ty -> inf_res_ty) - expr_wrap = expr_wrap2' <.> expr_wrap1 - doc = text "When checking the view pattern function:" <+> (ppr expr) - ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)} - --- Type signatures in patterns --- See Note [Pattern coercions] below -tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside - = do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) - sig_ty pat_ty - -- Using tcExtendNameTyVarEnv is appropriate here - -- because we're not really bringing fresh tyvars into scope. - -- We're *naming* existing tyvars. Note that it is OK for a tyvar - -- from an outer scope to mention one of these tyvars in its kind. - ; (pat', res) <- tcExtendNameTyVarEnv wcs $ - tcExtendNameTyVarEnv tv_binds $ - tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) } - ------------------------- --- Lists, tuples, arrays -tc_pat penv (ListPat Nothing pats) pat_ty thing_inside - = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty - ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) - pats penv thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi - (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res) -} - -tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside - = do { tau_pat_ty <- expTypeToType pat_ty - ; ((pats', res, elt_ty), e') - <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] - SynList $ - \ [elt_ty] -> - do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) - pats penv thing_inside - ; return (pats', res, elt_ty) } - ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res) -} - -tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside - = do { let arity = length pats - tc = tupleTyCon boxity arity - -- NB: tupleTyCon does not flatten 1-tuples - -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make - ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) - penv pat_ty - -- Unboxed tuples have RuntimeRep vars, which we discard: - -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys - Boxed -> arg_tys - ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys) - thing_inside - - ; dflags <- getDynFlags - - -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) - -- so that we can experiment with lazy tuple-matching. - -- This is a pretty odd place to make the switch, but - -- it was easy to do. - ; let - unmangled_result = TuplePat con_arg_tys pats' boxity - -- pat_ty /= pat_ty iff coi /= IdCo - possibly_mangled_result - | gopt Opt_IrrefutableTuples dflags && - isBoxed boxity = LazyPat noExtField (noLoc unmangled_result) - | otherwise = unmangled_result - - ; pat_ty <- readExpType pat_ty - ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced - return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) - } - -tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside - = do { let tc = sumTyCon arity - ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) - penv pat_ty - ; -- Drop levity vars, we don't care about them here - let con_arg_tys = drop arity arg_tys - ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1))) - penv thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty - , res) - } - ------------------------- --- Data constructors -tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside - = tcConPat penv con pat_ty arg_pats thing_inside - ------------------------- --- Literal patterns -tc_pat penv (LitPat x simple_lit) pat_ty thing_inside - = do { let lit_ty = hsLitType simple_lit - ; wrap <- tcSubTypePat penv pat_ty lit_ty - ; res <- thing_inside - ; pat_ty <- readExpType pat_ty - ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty - , res) } - ------------------------- --- Overloaded patterns: n, and n+k - --- In the case of a negative literal (the more complicated case), --- we get --- --- case v of (-5) -> blah --- --- becoming --- --- if v == (negate (fromInteger 5)) then blah else ... --- --- There are two bits of rebindable syntax: --- (==) :: pat_ty -> neg_lit_ty -> Bool --- negate :: lit_ty -> neg_lit_ty --- where lit_ty is the type of the overloaded literal 5. --- --- When there is no negation, neg_lit_ty and lit_ty are the same -tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside - = do { let orig = LiteralOrigin over_lit - ; ((lit', mb_neg'), eq') - <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] - (mkCheckExpType boolTy) $ - \ [neg_lit_ty] -> - let new_over_lit lit_ty = newOverloadedLit over_lit - (mkCheckExpType lit_ty) - in case mb_neg of - Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty - Just neg -> -- Negative literal - -- The 'negate' is re-mappable syntax - second Just <$> - (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $ - \ [lit_ty] -> new_over_lit lit_ty) - - ; res <- thing_inside - ; pat_ty <- readExpType pat_ty - ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } - -{- -Note [NPlusK patterns] -~~~~~~~~~~~~~~~~~~~~~~ -From - - case v of x + 5 -> blah - -we get - - if v >= 5 then (\x -> blah) (v - 5) else ... - -There are two bits of rebindable syntax: - (>=) :: pat_ty -> lit1_ty -> Bool - (-) :: pat_ty -> lit2_ty -> var_ty - -lit1_ty and lit2_ty could conceivably be different. -var_ty is the type inferred for x, the variable in the pattern. - -If the pushed-down pattern type isn't a tau-type, the two pat_ty's above -could conceivably be different specializations. But this is very much -like the situation in Note [Case branches must be taus] in TcMatches. -So we tauify the pat_ty before proceeding. - -Note that we need to type-check the literal twice, because it is used -twice, and may be used at different types. The second HsOverLit stored in the -AST is used for the subtraction operation. --} - --- See Note [NPlusK patterns] -tc_pat penv (NPlusKPat _ (L nm_loc name) - (L loc lit) _ ge minus) pat_ty - thing_inside - = do { pat_ty <- expTypeToType pat_ty - ; let orig = LiteralOrigin lit - ; (lit1', ge') - <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho] - (mkCheckExpType boolTy) $ - \ [lit1_ty] -> - newOverloadedLit lit (mkCheckExpType lit1_ty) - ; ((lit2', minus_wrap, bndr_id), minus') - <- tcSyntaxOpGen orig minus [synKnownType pat_ty, SynRho] SynAny $ - \ [lit2_ty, var_ty] -> - do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) - ; (wrap, bndr_id) <- setSrcSpan nm_loc $ - tcPatBndr penv name (mkCheckExpType var_ty) - -- co :: var_ty ~ idType bndr_id - - -- minus_wrap is applicable to minus' - ; return (lit2', wrap, bndr_id) } - - -- The Report says that n+k patterns must be in Integral - -- but it's silly to insist on this in the RebindableSyntax case - ; unlessM (xoptM LangExt.RebindableSyntax) $ - do { icls <- tcLookupClass integralClassName - ; instStupidTheta orig [mkClassPred icls [pat_ty]] } - - ; res <- tcExtendIdEnv1 name bndr_id thing_inside - - ; let minus'' = case minus' of - NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus') - -- this should be statically avoidable - -- Case (3) from Note [NoSyntaxExpr] in Hs.Expr - SyntaxExprTc { syn_expr = minus'_expr - , syn_arg_wraps = minus'_arg_wraps - , syn_res_wrap = minus'_res_wrap } - -> SyntaxExprTc { syn_expr = minus'_expr - , syn_arg_wraps = minus'_arg_wraps - , syn_res_wrap = minus_wrap <.> minus'_res_wrap } - -- Oy. This should really be a record update, but - -- we get warnings if we try. #17783 - pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' - ge' minus'' - ; return (pat', res) } - --- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSplicePat'. --- Here we get rid of it and add the finalizers to the global environment. --- --- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. -tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat))) - pat_ty thing_inside - = do addModFinalizersWithLclEnv mod_finalizers - tc_pat penv pat pat_ty thing_inside - -tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut - - -{- -Note [Hopping the LIE in lazy patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a lazy pattern, we must *not* discharge constraints from the RHS -from dictionaries bound in the pattern. E.g. - f ~(C x) = 3 -We can't discharge the Num constraint from dictionaries bound by -the pattern C! - -So we have to make the constraints from thing_inside "hop around" -the pattern. Hence the captureConstraints and emitConstraints. - -The same thing ensures that equality constraints in a lazy match -are not made available in the RHS of the match. For example - data T a where { T1 :: Int -> T Int; ... } - f :: T a -> Int -> a - f ~(T1 i) y = y -It's obviously not sound to refine a to Int in the right -hand side, because the argument might not match T1 at all! - -Finally, a lazy pattern should not bind any existential type variables -because they won't be in scope when we do the desugaring - - -************************************************************************ -* * - Most of the work for constructors is here - (the rest is in the ConPatIn case of tc_pat) -* * -************************************************************************ - -[Pattern matching indexed data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following declarations: - - data family Map k :: * -> * - data instance Map (a, b) v = MapPair (Map a (Pair b v)) - -and a case expression - - case x :: Map (Int, c) w of MapPair m -> ... - -As explained by [Wrappers for data instance tycons] in GHC.Types.Id.Make, the -worker/wrapper types for MapPair are - - $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v - $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v - -So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is -:R123Map, which means the straight use of boxySplitTyConApp would give a type -error. Hence, the smart wrapper function boxySplitTyConAppWithFamily calls -boxySplitTyConApp with the family tycon Map instead, which gives us the family -type list {(Int, c), w}. To get the correct split for :R123Map, we need to -unify the family type list {(Int, c), w} with the instance types {(a, b), v} -(provided by tyConFamInst_maybe together with the family tycon). This -unification yields the substitution [a -> Int, b -> c, v -> w], which gives us -the split arguments for the representation tycon :R123Map as {Int, c, w} - -In other words, boxySplitTyConAppWithFamily implicitly takes the coercion - - Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} - -moving between representation and family type into account. To produce type -correct Core, this coercion needs to be used to case the type of the scrutinee -from the family to the representation type. This is achieved by -unwrapFamInstScrutinee using a CoPat around the result pattern. - -Now it might appear seem as if we could have used the previous GADT type -refinement infrastructure of refineAlt and friends instead of the explicit -unification and CoPat generation. However, that would be wrong. Why? The -whole point of GADT refinement is that the refinement is local to the case -alternative. In contrast, the substitution generated by the unification of -the family type list and instance types needs to be propagated to the outside. -Imagine that in the above example, the type of the scrutinee would have been -(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the -substitution [x -> (a, b), v -> w]. In contrast to GADT matching, the -instantiation of x with (a, b) must be global; ie, it must be valid in *all* -alternatives of the case expression, whereas in the GADT case it might vary -between alternatives. - -RIP GADT refinement: refinements have been replaced by the use of explicit -equality constraints that are used in conjunction with implication constraints -to express the local scope of GADT refinements. --} - --- Running example: --- MkT :: forall a b c. (a~[b]) => b -> c -> T a --- with scrutinee of type (T ty) - -tcConPat :: PatEnv -> Located Name - -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails GhcRn -> TcM a - -> TcM (Pat GhcTcId, a) -tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside - = do { con_like <- tcLookupConLike con_name - ; case con_like of - RealDataCon data_con -> tcDataConPat penv con_lname data_con - pat_ty arg_pats thing_inside - PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn - pat_ty arg_pats thing_inside - } - -tcDataConPat :: PatEnv -> Located Name -> DataCon - -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails GhcRn -> TcM a - -> TcM (Pat GhcTcId, a) -tcDataConPat penv (L con_span con_name) data_con pat_ty - arg_pats thing_inside - = do { let tycon = dataConTyCon data_con - -- For data families this is the representation tycon - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) - = dataConFullSig data_con - header = L con_span (RealDataCon data_con) - - -- Instantiate the constructor type variables [a->ty] - -- This may involve doing a family-instance coercion, - -- and building a wrapper - ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty - ; pat_ty <- readExpType pat_ty - - -- Add the stupid theta - ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys - - ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys - ; checkExistentials ex_tvs all_arg_tys penv - - ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys - -- NB: Do not use zipTvSubst! See #14154 - -- We want to create a well-kinded substitution, so - -- that the instantiated type is well-kinded - - ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs - -- Get location from monad, not from ex_tvs - - ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys - -- pat_ty' is type of the actual constructor application - -- pat_ty' /= pat_ty iff coi /= IdCo - - arg_tys' = substTys tenv arg_tys - - ; traceTc "tcConPat" (vcat [ ppr con_name - , pprTyVars univ_tvs - , pprTyVars ex_tvs - , ppr eq_spec - , ppr theta - , pprTyVars ex_tvs' - , ppr ctxt_res_tys - , ppr arg_tys' - , ppr arg_pats ]) - ; if null ex_tvs && null eq_spec && null theta - then do { -- The common case; no class bindings etc - -- (see Note [Arrows and patterns]) - (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys' - arg_pats penv thing_inside - ; let res_pat = ConPatOut { pat_con = header, - pat_tvs = [], pat_dicts = [], - pat_binds = emptyTcEvBinds, - pat_args = arg_pats', - pat_arg_tys = ctxt_res_tys, - pat_wrap = idHsWrapper } - - ; return (mkHsWrapPat wrap res_pat pat_ty, res) } - - else do -- The general case, with existential, - -- and local equality constraints - { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) - -- order is *important* as we generate the list of - -- dictionary binders from theta' - no_equalities = null eq_spec && not (any isEqPred theta) - skol_info = PatSkol (RealDataCon data_con) mc - mc = case pe_ctxt penv of - LamPat mc -> mc - LetPat {} -> PatBindRhs - - ; gadts_on <- xoptM LangExt.GADTs - ; families_on <- xoptM LangExt.TypeFamilies - ; checkTc (no_equalities || gadts_on || families_on) - (text "A pattern match on a GADT requires the" <+> - text "GADTs or TypeFamilies language extension") - -- #2905 decided that a *pattern-match* of a GADT - -- should require the GADT language flag. - -- Re TypeFamilies see also #7156 - - ; given <- newEvVars theta' - ; (ev_binds, (arg_pats', res)) - <- checkConstraints skol_info ex_tvs' given $ - tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside - - ; let res_pat = ConPatOut { pat_con = header, - pat_tvs = ex_tvs', - pat_dicts = given, - pat_binds = ev_binds, - pat_args = arg_pats', - pat_arg_tys = ctxt_res_tys, - pat_wrap = idHsWrapper } - ; return (mkHsWrapPat wrap res_pat pat_ty, res) - } } - -tcPatSynPat :: PatEnv -> Located Name -> PatSyn - -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails GhcRn -> TcM a - -> TcM (Pat GhcTcId, a) -tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside - = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn - - ; (subst, univ_tvs') <- newMetaTyVars univ_tvs - - ; let all_arg_tys = ty : prov_theta ++ arg_tys - ; checkExistentials ex_tvs all_arg_tys penv - ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs - ; let ty' = substTy tenv ty - arg_tys' = substTys tenv arg_tys - prov_theta' = substTheta tenv prov_theta - req_theta' = substTheta tenv req_theta - - ; wrap <- tcSubTypePat penv pat_ty ty' - ; traceTc "tcPatSynPat" (ppr pat_syn $$ - ppr pat_ty $$ - ppr ty' $$ - ppr ex_tvs' $$ - ppr prov_theta' $$ - ppr req_theta' $$ - ppr arg_tys') - - ; prov_dicts' <- newEvVars prov_theta' - - ; let skol_info = case pe_ctxt penv of - LamPat mc -> PatSkol (PatSynCon pat_syn) mc - LetPat {} -> UnkSkol -- Doesn't matter - - ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta' - ; traceTc "instCall" (ppr req_wrap) - - ; traceTc "checkConstraints {" Outputable.empty - ; (ev_binds, (arg_pats', res)) - <- checkConstraints skol_info ex_tvs' prov_dicts' $ - tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside - - ; traceTc "checkConstraints }" (ppr ev_binds) - ; let res_pat = ConPatOut { pat_con = L con_span $ PatSynCon pat_syn, - pat_tvs = ex_tvs', - pat_dicts = prov_dicts', - pat_binds = ev_binds, - pat_args = arg_pats', - pat_arg_tys = mkTyVarTys univ_tvs', - pat_wrap = req_wrap } - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap res_pat pat_ty, res) } - ----------------------------- --- | Convenient wrapper for calling a matchExpectedXXX function -matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a)) - -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a) --- See Note [Matching polytyped patterns] --- Returns a wrapper : pat_ty ~R inner_ty -matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty - = do { pat_ty <- expTypeToType pat_ty - ; (wrap, pat_rho) <- topInstantiate orig pat_ty - ; (co, res) <- inner_match pat_rho - ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap) - ; return (mkWpCastN (mkTcSymCo co) <.> wrap, res) } - ----------------------------- -matchExpectedConTy :: PatEnv - -> TyCon -- The TyCon that this data - -- constructor actually returns - -- In the case of a data family this is - -- the /representation/ TyCon - -> ExpSigmaType -- The type of the pattern; in the case - -- of a data family this would mention - -- the /family/ TyCon - -> TcM (HsWrapper, [TcSigmaType]) --- See Note [Matching constructor patterns] --- Returns a wrapper : pat_ty "->" T ty1 ... tyn -matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty - | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc - -- Comments refer to Note [Matching constructor patterns] - -- co_tc :: forall a. T [a] ~ T7 a - = do { pat_ty <- expTypeToType exp_pat_ty - ; (wrap, pat_rho) <- topInstantiate orig pat_ty - - ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc) - -- tys = [ty1,ty2] - - ; traceTc "matchExpectedConTy" (vcat [ppr data_tc, - ppr (tyConTyVars data_tc), - ppr fam_tc, ppr fam_args, - ppr exp_pat_ty, - ppr pat_ty, - ppr pat_rho, ppr wrap]) - ; co1 <- unifyType Nothing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho - -- co1 : T (ty1,ty2) ~N pat_rho - -- could use tcSubType here... but it's the wrong way round - -- for actual vs. expected in error messages. - - ; let tys' = mkTyVarTys tvs' - co2 = mkTcUnbranchedAxInstCo co_tc tys' [] - -- co2 : T (ty1,ty2) ~R T7 ty1 ty2 - - full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2 - -- full_co :: pat_rho ~R T7 ty1 ty2 - - ; return ( mkWpCastR full_co <.> wrap, tys') } - - | otherwise - = do { pat_ty <- expTypeToType exp_pat_ty - ; (wrap, pat_rho) <- topInstantiate orig pat_ty - ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho - ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) } - -{- -Note [Matching constructor patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose (coi, tys) = matchExpectedConType data_tc pat_ty - - * In the simple case, pat_ty = tc tys - - * If pat_ty is a polytype, we want to instantiate it - This is like part of a subsumption check. Eg - f :: (forall a. [a]) -> blah - f [] = blah - - * In a type family case, suppose we have - data family T a - data instance T (p,q) = A p | B q - Then we'll have internally generated - data T7 p q = A p | B q - axiom coT7 p q :: T (p,q) ~ T7 p q - - So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that - coi = coi2 . coi1 : T7 t ~ pat_ty - coi1 : T (ty1,ty2) ~ pat_ty - coi2 : T7 ty1 ty2 ~ T (ty1,ty2) - - For families we do all this matching here, not in the unifier, - because we never want a whisper of the data_tycon to appear in - error messages; it's a purely internal thing --} - -tcConArgs :: ConLike -> [TcSigmaType] - -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) - -tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside - = do { checkTc (con_arity == no_of_args) -- Check correct arity - (arityErr (text "constructor") con_like con_arity no_of_args) - ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys - ; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys - penv thing_inside - ; return (PrefixCon arg_pats', res) } - where - con_arity = conLikeArity con_like - no_of_args = length arg_pats - -tcConArgs con_like arg_tys (InfixCon p1 p2) penv thing_inside - = do { checkTc (con_arity == 2) -- Check correct arity - (arityErr (text "constructor") con_like con_arity 2) - ; let [arg_ty1,arg_ty2] = arg_tys -- This can't fail after the arity check - ; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)] - penv thing_inside - ; return (InfixCon p1' p2', res) } - where - con_arity = conLikeArity con_like - -tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside - = do { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside - ; return (RecCon (HsRecFields rpats' dd), res) } - where - tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) - (LHsRecField GhcTcId (LPat GhcTcId)) - tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) - penv thing_inside - = do { sel' <- tcLookupId sel - ; pat_ty <- setSrcSpan loc $ find_field_ty sel - (occNameFS $ rdrNameOcc rdr) - ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside - ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' - pun), res) } - tc_field (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) _ _ - = panic "tcConArgs" - - - find_field_ty :: Name -> FieldLabelString -> TcM TcType - find_field_ty sel lbl - = case [ty | (fl, ty) <- field_tys, flSelector fl == sel] of - - -- No matching field; chances are this field label comes from some - -- other record type (or maybe none). If this happens, just fail, - -- otherwise we get crashes later (#8570), and similar: - -- f (R { foo = (a,b) }) = a+b - -- If foo isn't one of R's fields, we don't want to crash when - -- typechecking the "a+b". - [] -> failWith (badFieldCon con_like lbl) - - -- The normal case, when the field comes from the right constructor - (pat_ty : extras) -> do - traceTc "find_field" (ppr pat_ty <+> ppr extras) - ASSERT( null extras ) (return pat_ty) - - field_tys :: [(FieldLabel, TcType)] - field_tys = zip (conLikeFieldLabels con_like) arg_tys - -- Don't use zipEqual! If the constructor isn't really a record, then - -- dataConFieldLabels will be empty (and each field in the pattern - -- will generate an error below). - -tcConArg :: Checker (LPat GhcRn, TcSigmaType) (LPat GhcTc) -tcConArg (arg_pat, arg_ty) penv thing_inside - = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside - -addDataConStupidTheta :: DataCon -> [TcType] -> TcM () --- Instantiate the "stupid theta" of the data con, and throw --- the constraints into the constraint set -addDataConStupidTheta data_con inst_tys - | null stupid_theta = return () - | otherwise = instStupidTheta origin inst_theta - where - origin = OccurrenceOf (dataConName data_con) - -- The origin should always report "occurrence of C" - -- even when C occurs in a pattern - stupid_theta = dataConStupidTheta data_con - univ_tvs = dataConUnivTyVars data_con - tenv = zipTvSubst univ_tvs (takeList univ_tvs inst_tys) - -- NB: inst_tys can be longer than the univ tyvars - -- because the constructor might have existentials - inst_theta = substTheta tenv stupid_theta - -{- -Note [Arrows and patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -(Oct 07) Arrow notation has the odd property that it involves -"holes in the scope". For example: - expr :: Arrow a => a () Int - expr = proc (y,z) -> do - x <- term -< y - expr' -< x - -Here the 'proc (y,z)' binding scopes over the arrow tails but not the -arrow body (e.g 'term'). As things stand (bogusly) all the -constraints from the proc body are gathered together, so constraints -from 'term' will be seen by the tcPat for (y,z). But we must *not* -bind constraints from 'term' here, because the desugarer will not make -these bindings scope over 'term'. - -The Right Thing is not to confuse these constraints together. But for -now the Easy Thing is to ensure that we do not have existential or -GADT constraints in a 'proc', and to short-cut the constraint -simplification for such vanilla patterns so that it binds no -constraints. Hence the 'fast path' in tcConPat; but it's also a good -plan for ordinary vanilla patterns to bypass the constraint -simplification step. - -************************************************************************ -* * - Note [Pattern coercions] -* * -************************************************************************ - -In principle, these program would be reasonable: - - f :: (forall a. a->a) -> Int - f (x :: Int->Int) = x 3 - - g :: (forall a. [a]) -> Bool - g [] = True - -In both cases, the function type signature restricts what arguments can be passed -in a call (to polymorphic ones). The pattern type signature then instantiates this -type. For example, in the first case, (forall a. a->a) <= Int -> Int, and we -generate the translated term - f = \x' :: (forall a. a->a). let x = x' Int in x 3 - -From a type-system point of view, this is perfectly fine, but it's *very* seldom useful. -And it requires a significant amount of code to implement, because we need to decorate -the translated pattern with coercion functions (generated from the subsumption check -by tcSub). - -So for now I'm just insisting on type *equality* in patterns. No subsumption. - -Old notes about desugaring, at a time when pattern coercions were handled: - -A SigPat is a type coercion and must be handled one at a time. We can't -combine them unless the type of the pattern inside is identical, and we don't -bother to check for that. For example: - - data T = T1 Int | T2 Bool - f :: (forall a. a -> a) -> T -> t - f (g::Int->Int) (T1 i) = T1 (g i) - f (g::Bool->Bool) (T2 b) = T2 (g b) - -We desugar this as follows: - - f = \ g::(forall a. a->a) t::T -> - let gi = g Int - in case t of { T1 i -> T1 (gi i) - other -> - let gb = g Bool - in case t of { T2 b -> T2 (gb b) - other -> fail }} - -Note that we do not treat the first column of patterns as a -column of variables, because the coerced variables (gi, gb) -would be of different types. So we get rather grotty code. -But I don't think this is a common case, and if it was we could -doubtless improve it. - -Meanwhile, the strategy is: - * treat each SigPat coercion (always non-identity coercions) - as a separate block - * deal with the stuff inside, and then wrap a binding round - the result to bind the new variable (gi, gb, etc) - - -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ - -Note [Existential check] -~~~~~~~~~~~~~~~~~~~~~~~~ -Lazy patterns can't bind existentials. They arise in two ways: - * Let bindings let { C a b = e } in b - * Twiddle patterns f ~(C a b) = e -The pe_lazy field of PatEnv says whether we are inside a lazy -pattern (perhaps deeply) - -See also Note [Typechecking pattern bindings] in TcBinds --} - -maybeWrapPatCtxt :: Pat GhcRn -> (TcM a -> TcM b) -> TcM a -> TcM b --- Not all patterns are worth pushing a context -maybeWrapPatCtxt pat tcm thing_inside - | not (worth_wrapping pat) = tcm thing_inside - | otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside - -- Remember to pop before doing thing_inside - where - worth_wrapping (VarPat {}) = False - worth_wrapping (ParPat {}) = False - worth_wrapping (AsPat {}) = False - worth_wrapping _ = True - msg = hang (text "In the pattern:") 2 (ppr pat) - ------------------------------------------------ -checkExistentials :: [TyVar] -- existentials - -> [Type] -- argument types - -> PatEnv -> TcM () - -- See Note [Existential check]] - -- See Note [Arrows and patterns] -checkExistentials ex_tvs tys _ - | all (not . (`elemVarSet` tyCoVarsOfTypes tys)) ex_tvs = return () -checkExistentials _ _ (PE { pe_ctxt = LetPat {}}) = return () -checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr }) = failWithTc existentialProcPat -checkExistentials _ _ (PE { pe_lazy = True }) = failWithTc existentialLazyPat -checkExistentials _ _ _ = return () - -existentialLazyPat :: SDoc -existentialLazyPat - = hang (text "An existential or GADT data constructor cannot be used") - 2 (text "inside a lazy (~) pattern") - -existentialProcPat :: SDoc -existentialProcPat - = text "Proc patterns cannot use existential or GADT data constructors" - -badFieldCon :: ConLike -> FieldLabelString -> SDoc -badFieldCon con field - = hsep [text "Constructor" <+> quotes (ppr con), - text "does not have field", quotes (ppr field)] - -polyPatSig :: TcType -> SDoc -polyPatSig sig_ty - = hang (text "Illegal polymorphic type signature in pattern:") - 2 (ppr sig_ty) diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs deleted file mode 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ /dev/null @@ -1,1150 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcPatSyn]{Typechecking pattern synonym declarations} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind - , tcPatSynBuilderOcc, nonBidirectionalErr - ) where - -import GhcPrelude - -import GHC.Hs -import TcPat -import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType ) -import TcRnMonad -import TcSigs( emptyPragEnv, completeSigFromId ) -import TcEnv -import TcMType -import TcHsSyn -import TysPrim -import GHC.Types.Name -import GHC.Types.SrcLoc -import GHC.Core.PatSyn -import GHC.Types.Name.Set -import Panic -import Outputable -import FastString -import GHC.Types.Var -import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSet ) -import GHC.Types.Id -import GHC.Types.Id.Info( RecSelParent(..), setLevityInfoWithType ) -import TcBinds -import GHC.Types.Basic -import TcSimplify -import TcUnify -import GHC.Core.Predicate -import TysWiredIn -import TcType -import TcEvidence -import TcOrigin -import BuildTyCl -import GHC.Types.Var.Set -import GHC.Types.Id.Make -import TcTyDecls -import GHC.Core.ConLike -import GHC.Types.FieldLabel -import Bag -import Util -import ErrUtils -import Data.Maybe( mapMaybe ) -import Control.Monad ( zipWithM ) -import Data.List( partition ) - -#include "HsVersions.h" - -{- -************************************************************************ -* * - Type checking a pattern synonym -* * -************************************************************************ --} - -tcPatSynDecl :: PatSynBind GhcRn GhcRn - -> Maybe TcSigInfo - -> TcM (LHsBinds GhcTc, TcGblEnv) -tcPatSynDecl psb mb_sig - = recoverM (recoverPSB psb) $ - case mb_sig of - Nothing -> tcInferPatSynDecl psb - Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi - _ -> panic "tcPatSynDecl" - -recoverPSB :: PatSynBind GhcRn GhcRn - -> TcM (LHsBinds GhcTc, TcGblEnv) --- See Note [Pattern synonym error recovery] -recoverPSB (PSB { psb_id = L _ name - , psb_args = details }) - = do { matcher_name <- newImplicitBinder name mkMatcherOcc - ; let placeholder = AConLike $ PatSynCon $ - mk_placeholder matcher_name - ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv - ; return (emptyBag, gbl_env) } - where - (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details - mk_placeholder matcher_name - = mkPatSyn name is_infix - ([mkTyVarBinder Specified alphaTyVar], []) ([], []) - [] -- Arg tys - alphaTy - (matcher_id, True) Nothing - [] -- Field labels - where - -- The matcher_id is used only by the desugarer, so actually - -- and error-thunk would probably do just as well here. - matcher_id = mkLocalId matcher_name $ - mkSpecForAllTys [alphaTyVar] alphaTy - -recoverPSB (XPatSynBind nec) = noExtCon nec - -{- Note [Pattern synonym error recovery] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If type inference for a pattern synonym fails, we can't continue with -the rest of tc_patsyn_finish, because we may get knock-on errors, or -even a crash. E.g. from - pattern What = True :: Maybe -we get a kind error; and we must stop right away (#15289). - -We stop if there are /any/ unsolved constraints, not just insoluble -ones; because pattern synonyms are top-level things, we will never -solve them later if we can't solve them now. And if we were to carry -on, tc_patsyn_finish does zonkTcTypeToType, which defaults any -unsolved unificatdion variables to Any, which confuses the error -reporting no end (#15685). - -So we use simplifyTop to completely solve the constraint, report -any errors, throw an exception. - -Even in the event of such an error we can recover and carry on, just -as we do for value bindings, provided we plug in placeholder for the -pattern synonym: see recoverPSB. The goal of the placeholder is not -to cause a raft of follow-on errors. I've used the simplest thing for -now, but we might need to elaborate it a bit later. (e.g. I've given -it zero args, which may cause knock-on errors if it is used in a -pattern.) But it'll do for now. - --} - -tcInferPatSynDecl :: PatSynBind GhcRn GhcRn - -> TcM (LHsBinds GhcTc, TcGblEnv) -tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details - , psb_def = lpat, psb_dir = dir }) - = addPatSynCtxt lname $ - do { traceTc "tcInferPatSynDecl {" $ ppr name - - ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details - ; (tclvl, wanted, ((lpat', args), pat_ty)) - <- pushLevelAndCaptureConstraints $ - tcInferNoInst $ \ exp_ty -> - tcPat PatSyn lpat exp_ty $ - mapM tcLookupId arg_names - - ; let (ex_tvs, prov_dicts) = tcCollectEx lpat' - - named_taus = (name, pat_ty) : map mk_named_tau args - mk_named_tau arg - = (getName arg, mkSpecForAllTys ex_tvs (varType arg)) - -- The mkSpecForAllTys is important (#14552), albeit - -- slightly artificial (there is no variable with this funny type). - -- We do not want to quantify over variable (alpha::k) - -- that mention the existentially-bound type variables - -- ex_tvs in its kind k. - -- See Note [Type variables whose kind is captured] - - ; (univ_tvs, req_dicts, ev_binds, residual, _) - <- simplifyInfer tclvl NoRestrictions [] named_taus wanted - ; top_ev_binds <- checkNoErrs (simplifyTop residual) - ; addTopEvBinds top_ev_binds $ - - do { prov_dicts <- mapM zonkId prov_dicts - ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts - -- Filtering: see Note [Remove redundant provided dicts] - (prov_theta, prov_evs) - = unzip (mapMaybe mkProvEvidence filtered_prov_dicts) - req_theta = map evVarPred req_dicts - - -- 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) ] - ; mapM_ dependentArgErr bad_args - - ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) - ; tc_patsyn_finish lname dir is_infix lpat' - (mkTyVarBinders Inferred univ_tvs - , req_theta, ev_binds, req_dicts) - (mkTyVarBinders Inferred ex_tvs - , mkTyVarTys ex_tvs, prov_theta, prov_evs) - (map nlHsVar args, map idType args) - pat_ty rec_fields } } -tcInferPatSynDecl (XPatSynBind nec) = noExtCon nec - -mkProvEvidence :: EvId -> Maybe (PredType, EvTerm) --- See Note [Equality evidence in pattern synonyms] -mkProvEvidence ev_id - | EqPred r ty1 ty2 <- classifyPredType pred - , let k1 = tcTypeKind ty1 - k2 = tcTypeKind ty2 - is_homo = k1 `tcEqType` k2 - homo_tys = [k1, ty1, ty2] - hetero_tys = [k1, k2, ty1, ty2] - = case r of - ReprEq | is_homo - -> Just ( mkClassPred coercibleClass homo_tys - , evDataConApp coercibleDataCon homo_tys eq_con_args ) - | otherwise -> Nothing - NomEq | is_homo - -> Just ( mkClassPred eqClass homo_tys - , evDataConApp eqDataCon homo_tys eq_con_args ) - | otherwise - -> Just ( mkClassPred heqClass hetero_tys - , evDataConApp heqDataCon hetero_tys eq_con_args ) - - | otherwise - = Just (pred, EvExpr (evId ev_id)) - where - pred = evVarPred ev_id - eq_con_args = [evId ev_id] - -dependentArgErr :: (Id, DTyCoVarSet) -> TcM () --- See Note [Coercions that escape] -dependentArgErr (arg, bad_cos) - = addErrTc $ - 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 - -{- Note [Type variables whose kind is captured] -~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data AST a = Sym [a] - class Prj s where { prj :: [a] -> Maybe (s a) } - pattern P x <= Sym (prj -> Just x) - -Here we get a matcher with this type - $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r - -No problem. But note that 's' is not fixed by the type of the -pattern (AST a), nor is it existentially bound. It's really only -fixed by the type of the continuation. - -#14552 showed that this can go wrong if the kind of 's' mentions -existentially bound variables. We obviously can't make a type like - $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r) - -> r -> r -But neither is 's' itself existentially bound, so the forall (s::k->*) -can't go in the inner forall either. (What would the matcher apply -the continuation to?) - -Solution: do not quantiify over any unification variable whose kind -mentions the existentials. We can conveniently do that by making the -"taus" passed to simplifyInfer look like - forall ex_tvs. arg_ty - -After that, Note [Naughty quantification candidates] in TcMType takes -over and errors. - -Note [Remove redundant provided dicts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Recall that - HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2) - => a1 :~~: a2 -(NB: technically the (k1~k2) existential dictionary is not necessary, -but it's there at the moment.) - -Now consider (#14394): - pattern Foo = HRefl -in a non-poly-kinded module. We don't want to get - pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b -with that redundant (* ~ *). We'd like to remove it; hence the call to -mkMinimalWithSCs. - -Similarly consider - data S a where { MkS :: Ord a => a -> S a } - pattern Bam x y <- (MkS (x::a), MkS (y::a))) - -The pattern (Bam x y) binds two (Ord a) dictionaries, but we only -need one. Again mkMimimalWithSCs removes the redundant one. - -Note [Equality evidence in pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data X a where - MkX :: Eq a => [a] -> X (Maybe a) - pattern P x = MkG x - -Then there is a danger that GHC will infer - P :: forall a. () => - forall b. (a ~# Maybe b, Eq b) => [b] -> X a - -The 'builder' for P, which is called in user-code, will then -have type - $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a - -and that is bad because (a ~# Maybe b) is not a predicate type -(see Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep -and is not implicitly instantiated. - -So in mkProvEvidence we lift (a ~# b) to (a ~ b). Tiresome, and -marginally less efficient, if the builder/martcher are not inlined. - -See also Note [Lift equality constraints when quantifying] in TcType - -Note [Coercions that escape] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#14507 showed an example where the inferred type of the matcher -for the pattern synonym was something like - $mSO :: forall (r :: TYPE rep) kk (a :: k). - TypeRep k a - -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r) - -> (Void# -> r) - -> r - -What is that co_a2sv :: Bool ~# *?? It was bound (via a superclass -selection) by the pattern being matched; and indeed it is implicit in -the context (Bool ~ k). You could imagine trying to extract it like -this: - $mSO :: forall (r :: TYPE rep) kk (a :: k). - TypeRep k a - -> ( co :: ((Bool :: *) ~ (k :: *)) => - let co_a2sv = sc_sel co - in TypeRep Bool (a |> co_a2sv) -> r) - -> (Void# -> r) - -> r - -But we simply don't allow that in types. Maybe one day but not now. - -How to detect this situation? We just look for free coercion variables -in the types of any of the arguments to the matcher. The error message -is not very helpful, but at least we don't get a Lint error. --} - -tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn - -> TcPatSynInfo - -> TcM (LHsBinds GhcTc, TcGblEnv) -tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details - , psb_def = lpat, psb_dir = dir } - TPSI{ patsig_implicit_bndrs = implicit_tvs - , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta - , patsig_ex_bndrs = explicit_ex_tvs, patsig_req = req_theta - , patsig_body_ty = sig_body_ty } - = addPatSynCtxt lname $ - do { let decl_arity = length arg_names - (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details - - ; traceTc "tcCheckPatSynDecl" $ - vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta - , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ] - - ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of - Right stuff -> return stuff - Left missing -> wrongNumberOfParmsErr name decl_arity missing - - -- Complain about: pattern P :: () => forall x. x -> P x - -- The existential 'x' should not appear in the result type - -- Can't check this until we know P's arity - ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs - ; checkTc (null bad_tvs) $ - 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) - - -- See Note [The pattern-synonym signature splitting rule] in TcSigs - ; let univ_fvs = closeOverKinds $ - (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs) - (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs - univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs - ex_bndrs = extra_ex ++ mkTyVarBinders Specified explicit_ex_tvs - univ_tvs = binderVars univ_bndrs - ex_tvs = binderVars ex_bndrs - - -- Right! Let's check the pattern against the signature - -- See Note [Checking against a pattern signature] - ; req_dicts <- newEvVars req_theta - ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <- - ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys ) - pushLevelAndCaptureConstraints $ - tcExtendTyVarEnv univ_tvs $ - tcPat PatSyn lpat (mkCheckExpType pat_ty) $ - do { let in_scope = mkInScopeSet (mkVarSet univ_tvs) - empty_subst = mkEmptyTCvSubst in_scope - ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs - -- newMetaTyVarX: see the "Existential type variables" - -- part of Note [Checking against a pattern signature] - ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs]) - ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs']) - ; let prov_theta' = substTheta subst prov_theta - -- Add univ_tvs to the in_scope set to - -- satisfy the substitution invariant. There's no need to - -- add 'ex_tvs' as they are already in the domain of the - -- substitution. - -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. - ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta' - ; args' <- zipWithM (tc_arg subst) arg_names arg_tys - ; return (ex_tvs', prov_dicts, args') } - - ; let skol_info = SigSkol (PatSynCtxt name) pat_ty [] - -- The type here is a bit bogus, but we do not print - -- the type for PatSynCtxt, so it doesn't matter - -- See Note [Skolem info for pattern synonyms] in Origin - ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted - - -- Solve the constraints now, because we are about to make a PatSyn, - -- which should not contain unification variables and the like (#10997) - ; simplifyTopImplic implics - - -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct - -- Otherwise we may get a type error when typechecking the builder, - -- when that should be impossible - - ; traceTc "tcCheckPatSynDecl }" $ ppr name - ; tc_patsyn_finish lname dir is_infix lpat' - (univ_bndrs, req_theta, ev_binds, req_dicts) - (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts) - (args', arg_tys) - pat_ty rec_fields } - where - tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId) - tc_arg subst arg_name arg_ty - = do { -- Look up the variable actually bound by lpat - -- and check that it has the expected type - arg_id <- tcLookupId arg_name - ; wrap <- tcSubType_NC GenSigCtxt - (idType arg_id) - (substTyUnchecked subst arg_ty) - -- Why do we need tcSubType here? - -- See Note [Pattern synonyms and higher rank types] - ; return (mkLHsWrap wrap $ nlHsVar arg_id) } -tcCheckPatSynDecl (XPatSynBind nec) _ = noExtCon nec - -{- [Pattern synonyms and higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = MkT (forall a. a->a) - - pattern P :: (Int -> Int) -> T - pattern P x <- MkT x - -This should work. But in the matcher we must match against MkT, and then -instantiate its argument 'x', to get a function of type (Int -> Int). -Equality is not enough! #13752 was an example. - - -Note [The pattern-synonym signature splitting rule] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a pattern signature, we must split - the kind-generalised variables, and - the implicitly-bound variables -into universal and existential. The rule is this -(see discussion on #11224): - - The universal tyvars are the ones mentioned in - - univ_tvs: the user-specified (forall'd) universals - - req_theta - - res_ty - The existential tyvars are all the rest - -For example - - pattern P :: () => b -> T a - pattern P x = ... - -Here 'a' is universal, and 'b' is existential. But there is a wrinkle: -how do we split the arg_tys from req_ty? Consider - - pattern Q :: () => b -> S c -> T a - pattern Q x = ... - -This is an odd example because Q has only one syntactic argument, and -so presumably is defined by a view pattern matching a function. But -it can happen (#11977, #12108). - -We don't know Q's arity from the pattern signature, so we have to wait -until we see the pattern declaration itself before deciding res_ty is, -and hence which variables are existential and which are universal. - -And that in turn is why TcPatSynInfo has a separate field, -patsig_implicit_bndrs, to capture the implicitly bound type variables, -because we don't yet know how to split them up. - -It's a slight compromise, because it means we don't really know the -pattern synonym's real signature until we see its declaration. So, -for example, in hs-boot file, we may need to think what to do... -(eg don't have any implicitly-bound variables). - - -Note [Checking against a pattern signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When checking the actual supplied pattern against the pattern synonym -signature, we need to be quite careful. - ------ Provided constraints -Example - - data T a where - MkT :: Ord a => a -> T a - - pattern P :: () => Eq a => a -> [T a] - pattern P x = [MkT x] - -We must check that the (Eq a) that P claims to bind (and to -make available to matches against P), is derivable from the -actual pattern. For example: - f (P (x::a)) = ...here (Eq a) should be available... -And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs. - ------ Existential type variables -Unusually, we instantiate the existential tyvars of the pattern with -*meta* type variables. For example - - data S where - MkS :: Eq a => [a] -> S - - pattern P :: () => Eq x => x -> S - pattern P x <- MkS x - -The pattern synonym conceals from its client the fact that MkS has a -list inside it. The client just thinks it's a type 'x'. So we must -unify x := [a] during type checking, and then use the instantiating type -[a] (called ex_tys) when building the matcher. In this case we'll get - - $mP :: S -> (forall x. Ex x => x -> r) -> r -> r - $mP x k = case x of - MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a] - dl = $dfunEqList d - in k [a] dl ys - -All this applies when type-checking the /matching/ side of -a pattern synonym. What about the /building/ side? - -* For Unidirectional, there is no builder - -* For ExplicitBidirectional, the builder is completely separate - code, typechecked in tcPatSynBuilderBind - -* For ImplicitBidirectional, the builder is still typechecked in - tcPatSynBuilderBind, by converting the pattern to an expression and - typechecking it. - - At one point, for ImplicitBidirectional I used TyVarTvs (instead of - TauTvs) in tcCheckPatSynDecl. But (a) strengthening the check here - is redundant since tcPatSynBuilderBind does the job, (b) it was - still incomplete (TyVarTvs can unify with each other), and (c) it - didn't even work (#13441 was accepted with - ExplicitBidirectional, but rejected if expressed in - ImplicitBidirectional form. Conclusion: trying to be too clever is - a bad idea. --} - -collectPatSynArgInfo :: HsPatSynDetails (Located Name) - -> ([Name], [Name], Bool) -collectPatSynArgInfo details = - case details of - PrefixCon names -> (map unLoc names, [], False) - InfixCon name1 name2 -> (map unLoc [name1, name2], [], True) - RecCon names -> (vars, sels, False) - where - (vars, sels) = unzip (map splitRecordPatSyn names) - where - splitRecordPatSyn :: RecordPatSynField (Located Name) - -> (Name, Name) - splitRecordPatSyn (RecordPatSynField - { recordPatSynPatVar = L _ patVar - , recordPatSynSelectorId = L _ selId }) - = (patVar, selId) - -addPatSynCtxt :: Located Name -> TcM a -> TcM a -addPatSynCtxt (L loc name) thing_inside - = setSrcSpan loc $ - addErrCtxt (text "In the declaration for pattern synonym" - <+> quotes (ppr name)) $ - thing_inside - -wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a -wrongNumberOfParmsErr name decl_arity missing - = failWithTc $ - hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has") - <+> speakNOf decl_arity (text "argument")) - 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") - -------------------------- --- Shared by both tcInferPatSyn and tcCheckPatSyn -tc_patsyn_finish :: Located Name -- ^ PatSyn Name - -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) - -> Bool -- ^ Whether infix - -> LPat GhcTc -- ^ Pattern of the PatSyn - -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar]) - -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm]) - -> ([LHsExpr GhcTcId], [TcType]) -- ^ Pattern arguments and - -- types - -> TcType -- ^ Pattern type - -> [Name] -- ^ Selector names - -- ^ Whether fields, empty if not record PatSyn - -> TcM (LHsBinds GhcTc, TcGblEnv) -tc_patsyn_finish lname dir is_infix lpat' - (univ_tvs, req_theta, req_ev_binds, req_dicts) - (ex_tvs, ex_tys, prov_theta, prov_dicts) - (args, arg_tys) - pat_ty field_labels - = do { -- Zonk everything. We are about to build a final PatSyn - -- so there had better be no unification variables in there - - (ze, univ_tvs') <- zonkTyVarBinders 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 - - ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs' - (env2, ex_tvs) = tidyTyCoVarBinders 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' - - ; traceTc "tc_patsyn_finish {" $ - ppr (unLoc lname) $$ ppr (unLoc lpat') $$ - ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$ - ppr (ex_tvs, prov_theta, prov_dicts) $$ - ppr args $$ - ppr arg_tys $$ - ppr pat_ty - - -- Make the 'matcher' - ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' - (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts) - (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts) - (args, arg_tys) - pat_ty - - -- Make the 'builder' - ; builder_id <- mkPatSynBuilderId dir lname - univ_tvs req_theta - ex_tvs prov_theta - arg_tys pat_ty - - -- TODO: Make this have the proper information - ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name) - , flIsOverloaded = False - , flSelector = name } - field_labels' = map mkFieldLabel field_labels - - - -- Make the PatSyn itself - ; let patSyn = mkPatSyn (unLoc lname) is_infix - (univ_tvs, req_theta) - (ex_tvs, prov_theta) - arg_tys - pat_ty - matcher_id builder_id - field_labels' - - -- Selectors - ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn) - tything = AConLike (PatSynCon patSyn) - ; tcg_env <- tcExtendGlobalEnv [tything] $ - tcRecSelBinds rn_rec_sel_binds - - ; traceTc "tc_patsyn_finish }" empty - ; return (matcher_bind, tcg_env) } - -{- -************************************************************************ -* * - Constructing the "matcher" Id and its binding -* * -************************************************************************ --} - -tcPatSynMatcher :: Located Name - -> LPat GhcTc - -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) - -> ([TcTyVar], [TcType], ThetaType, [EvTerm]) - -> ([LHsExpr GhcTcId], [TcType]) - -> TcType - -> TcM ((Id, Bool), LHsBinds GhcTc) --- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn -tcPatSynMatcher (L loc name) lpat - (univ_tvs, req_theta, req_ev_binds, req_dicts) - (ex_tvs, ex_tys, prov_theta, prov_dicts) - (args, arg_tys) pat_ty - = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc - ; tv_name <- newNameAt (mkTyVarOcc "r") loc - ; let rr_tv = mkTyVar rr_name runtimeRepTy - rr = mkTyVarTy rr_tv - res_tv = mkTyVar tv_name (tYPE rr) - res_ty = mkTyVarTy res_tv - is_unlifted = null args && null prov_dicts - (cont_args, cont_arg_tys) - | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy]) - | otherwise = (args, arg_tys) - cont_ty = mkInfSigmaTy ex_tvs prov_theta $ - mkVisFunTys cont_arg_tys res_ty - - fail_ty = mkVisFunTy voidPrimTy res_ty - - ; matcher_name <- newImplicitBinder name mkMatcherOcc - ; scrutinee <- newSysLocalId (fsLit "scrut") pat_ty - ; cont <- newSysLocalId (fsLit "cont") cont_ty - ; fail <- newSysLocalId (fsLit "fail") fail_ty - - ; let matcher_tau = mkVisFunTys [pat_ty, cont_ty, fail_ty] res_ty - matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau - matcher_id = mkExportedVanillaId matcher_name matcher_sigma - -- See Note [Exported LocalIds] in GHC.Types.Id - - inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys - cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args - - fail' = nlHsApps fail [nlHsVar voidPrimId] - - args = map nlVarPat [scrutinee, cont, fail] - lwpat = noLoc $ WildPat pat_ty - cases = if isIrrefutableHsPat lpat - then [mkHsCaseAlt lpat cont'] - else [mkHsCaseAlt lpat cont', - mkHsCaseAlt lwpat fail'] - body = mkLHsWrap (mkWpLet req_ev_binds) $ - L (getLoc lpat) $ - HsCase noExtField (nlHsVar scrutinee) $ - MG{ mg_alts = L (getLoc lpat) cases - , mg_ext = MatchGroupTc [pat_ty] res_ty - , mg_origin = Generated - } - body' = noLoc $ - HsLam noExtField $ - MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr - args body] - , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty - , mg_origin = Generated - } - match = mkMatch (mkPrefixFunRhs (L loc name)) [] - (mkHsLams (rr_tv:res_tv:univ_tvs) - req_dicts body') - (noLoc (EmptyLocalBinds noExtField)) - mg :: MatchGroup GhcTc (LHsExpr GhcTc) - mg = MG{ mg_alts = L (getLoc match) [match] - , mg_ext = MatchGroupTc [] res_ty - , mg_origin = Generated - } - - ; let bind = FunBind{ fun_id = L loc matcher_id - , fun_matches = mg - , fun_ext = idHsWrapper - , fun_tick = [] } - matcher_bind = unitBag (noLoc bind) - - ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) - ; traceTc "tcPatSynMatcher" (ppr matcher_bind) - - ; return ((matcher_id, is_unlifted), matcher_bind) } - -mkPatSynRecSelBinds :: PatSyn - -> [FieldLabel] -- ^ Visible field labels - -> [(Id, LHsBind GhcRn)] -mkPatSynRecSelBinds ps fields - = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl - | fld_lbl <- fields ] - -isUnidirectional :: HsPatSynDir a -> Bool -isUnidirectional Unidirectional = True -isUnidirectional ImplicitBidirectional = False -isUnidirectional ExplicitBidirectional{} = False - -{- -************************************************************************ -* * - Constructing the "builder" Id -* * -************************************************************************ --} - -mkPatSynBuilderId :: HsPatSynDir a -> Located Name - -> [TyVarBinder] -> ThetaType - -> [TyVarBinder] -> ThetaType - -> [Type] -> Type - -> TcM (Maybe (Id, Bool)) -mkPatSynBuilderId dir (L _ name) - univ_bndrs req_theta ex_bndrs prov_theta - arg_tys pat_ty - | isUnidirectional dir - = return Nothing - | otherwise - = do { builder_name <- newImplicitBinder name mkBuilderOcc - ; let theta = req_theta ++ prov_theta - need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta - builder_sigma = add_void need_dummy_arg $ - mkForAllTys univ_bndrs $ - mkForAllTys ex_bndrs $ - mkPhiTy theta $ - mkVisFunTys arg_tys $ - pat_ty - builder_id = mkExportedVanillaId builder_name builder_sigma - -- See Note [Exported LocalIds] in GHC.Types.Id - - builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id - - ; return (Just (builder_id', need_dummy_arg)) } - where - -tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn - -> TcM (LHsBinds GhcTc) --- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn -tcPatSynBuilderBind (PSB { psb_id = L loc name - , psb_def = lpat - , psb_dir = dir - , psb_args = details }) - | isUnidirectional dir - = return emptyBag - - | Left why <- mb_match_group -- Can't invert the pattern - = setSrcSpan (getLoc lpat) $ failWithTc $ - vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" - <+> quotes (ppr name) <> colon) - 2 why - , text "RHS pattern:" <+> ppr lpat ] - - | Right match_group <- mb_match_group -- Bidirectional - = do { patsyn <- tcLookupPatSyn name - ; case patSynBuilder patsyn of { - Nothing -> return emptyBag ; - -- This case happens if we found a type error in the - -- pattern synonym, recovered, and put a placeholder - -- with patSynBuilder=Nothing in the environment - - Just (builder_id, need_dummy_arg) -> -- Normal case - do { -- Bidirectional, so patSynBuilder returns Just - let match_group' | need_dummy_arg = add_dummy_arg match_group - | otherwise = match_group - - bind = FunBind { fun_id = L loc (idName builder_id) - , fun_matches = match_group' - , fun_ext = emptyNameSet - , fun_tick = [] } - - sig = completeSigFromId (PatSynCtxt name) builder_id - - ; traceTc "tcPatSynBuilderBind {" $ - ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id) - ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind) - ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds - ; return builder_binds } } } - -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = panic "tcPatSynBuilderBind" -- Both cases dealt with -#endif - where - mb_match_group - = case dir of - ExplicitBidirectional explicit_mg -> Right explicit_mg - ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat) - Unidirectional -> panic "tcPatSynBuilderBind" - - mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) - mk_mg body = mkMatchGroup Generated [builder_match] - where - builder_args = [L loc (VarPat noExtField (L loc n)) - | L loc n <- args] - builder_match = mkMatch (mkPrefixFunRhs (L loc name)) - builder_args body - (noLoc (EmptyLocalBinds noExtField)) - - args = case details of - PrefixCon args -> args - InfixCon arg1 arg2 -> [arg1, arg2] - RecCon args -> map recordPatSynPatVar args - - add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn) - -> MatchGroup GhcRn (LHsExpr GhcRn) - add_dummy_arg mg@(MG { mg_alts = - (L l [L loc match@(Match { m_pats = pats })]) }) - = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] } - add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ - pprMatches other_mg -tcPatSynBuilderBind (XPatSynBind nec) = noExtCon nec - -tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType) --- monadic only for failure -tcPatSynBuilderOcc ps - | Just (builder_id, add_void_arg) <- builder - , let builder_expr = HsConLikeOut noExtField (PatSynCon ps) - builder_ty = idType builder_id - = return $ - if add_void_arg - then ( builder_expr -- still just return builder_expr; the void# arg is added - -- by dsConLike in the desugarer - , tcFunResultTy builder_ty ) - else (builder_expr, builder_ty) - - | otherwise -- Unidirectional - = nonBidirectionalErr name - where - name = patSynName ps - builder = patSynBuilder ps - -add_void :: Bool -> Type -> Type -add_void need_dummy_arg ty - | need_dummy_arg = mkVisFunTy voidPrimTy ty - | otherwise = ty - -tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn - -> Either MsgDoc (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 --- input uses constructors from HsPat and the output uses constructors --- from HsExpr. --- --- 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 - where - lhsVars = mkNameSet (map unLoc args) - - -- Make a prefix con for prefix and infix patterns for simplicity - mkPrefixConExpr :: Located Name -> [LPat GhcRn] - -> Either MsgDoc (HsExpr GhcRn) - mkPrefixConExpr lcon@(L loc _) pats - = do { exprs <- mapM go pats - ; return (foldl' (\x y -> HsApp noExtField (L loc x) y) - (HsVar noExtField lcon) exprs) } - - mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) - -> Either MsgDoc (HsExpr GhcRn) - mkRecordConExpr con fields - = do { exprFields <- mapM go fields - ; return (RecordCon noExtField con exprFields) } - - go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) - go (L loc p) = L loc <$> go1 p - - go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn) - go1 (ConPatIn con info) - = case info of - PrefixCon ps -> mkPrefixConExpr con ps - InfixCon l r -> mkPrefixConExpr con [l,r] - RecCon fields -> mkRecordConExpr con fields - - go1 (SigPat _ pat _) = go1 (unLoc pat) - -- See Note [Type signatures and the builder expression] - - go1 (VarPat _ (L l var)) - | 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") - go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat - go1 p@(ListPat reb pats) - | Nothing <- reb = do { exprs <- mapM go pats - ; return $ ExplicitList noExtField Nothing exprs } - | otherwise = notInvertibleListPat p - go1 (TuplePat _ pats box) = do { exprs <- mapM go pats - ; return $ ExplicitTuple noExtField - (map (noLoc . (Present noExtField)) exprs) - box } - go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) - ; return $ ExplicitSum noExtField alt arity - (noLoc expr) - } - go1 (LitPat _ lit) = return $ HsLit noExtField lit - go1 (NPat _ (L _ n) mb_neg _) - | Just (SyntaxExprRn neg) <- mb_neg - = return $ unLoc $ foldl' nlHsApp (noLoc neg) - [noLoc (HsOverLit noExtField n)] - | otherwise = return $ HsOverLit noExtField n - go1 (ConPatOut{}) = panic "ConPatOut in output of renamer" - go1 (CoPat{}) = panic "CoPat in output of renamer" - go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) - = go1 pat - go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" - - -- The following patterns are not invertible. - go1 p@(BangPat {}) = notInvertible p -- #14112 - go1 p@(LazyPat {}) = notInvertible p - go1 p@(WildPat {}) = notInvertible p - go1 p@(AsPat {}) = notInvertible p - go1 p@(ViewPat {}) = notInvertible p - go1 p@(NPlusKPat {}) = notInvertible p - go1 (XPat nec) = noExtCon nec - go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p - go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p - go1 p@(SplicePat _ (HsQuasiQuote {})) = notInvertible p - go1 (SplicePat _ (XSplice nec)) = noExtCon nec - - 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) - - -- We should really be able to invert list patterns, even when - -- rebindable syntax is on, but doing so involves a bit of - -- refactoring; see #14380. Until then we reject with a - -- helpful error message. - notInvertibleListPat p - = Left (vcat [ not_invertible_msg p - , text "Reason: rebindable syntax is on." - , text "This is fixable: add use-case to #14380" ]) - -{- Note [Builder for a bidirectional pattern synonym] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a bidirectional pattern synonym we need to produce an /expression/ -that matches the supplied /pattern/, given values for the arguments -of the pattern synonym. For example - pattern F x y = (Just x, [y]) -The 'builder' for F looks like - $builderF x y = (Just x, [y]) - -We can't always do this: - * Some patterns aren't invertible; e.g. view patterns - pattern F x = (reverse -> x:_) - - * The RHS pattern might bind more variables than the pattern - synonym, so again we can't invert it - pattern F x = (x,y) - - * Ditto wildcards - pattern F x = (x,_) - - -Note [Redundant constraints for builder] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The builder can have redundant constraints, which are awkward to eliminate. -Consider - pattern P = Just 34 -To match against this pattern we need (Eq a, Num a). But to build -(Just 34) we need only (Num a). Fortunately instTcSigFromId sets -sig_warn_redundant to False. - -************************************************************************ -* * - Helper functions -* * -************************************************************************ - -Note [As-patterns in pattern synonym definitions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The rationale for rejecting as-patterns in pattern synonym definitions -is that an as-pattern would introduce nonindependent pattern synonym -arguments, e.g. given a pattern synonym like: - - pattern K x y = x@(Just y) - -one could write a nonsensical function like - - f (K Nothing x) = ... - -or - g (K (Just True) False) = ... - -Note [Type signatures and the builder expression] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - pattern L x = Left x :: Either [a] [b] - -In tc{Infer/Check}PatSynDecl we will check that the pattern has the -specified type. We check the pattern *as a pattern*, so the type -signature is a pattern signature, and so brings 'a' and 'b' into -scope. But we don't have a way to bind 'a, b' in the LHS, as we do -'x', say. Nevertheless, the signature may be useful to constrain -the type. - -When making the binding for the *builder*, though, we don't want - $buildL x = Left x :: Either [a] [b] -because that wil either mean (forall a b. Either [a] [b]), or we'll -get a complaint that 'a' and 'b' are out of scope. (Actually the -latter; #9867.) No, the job of the signature is done, so when -converting the pattern to an expression (for the builder RHS) we -simply discard the signature. - -Note [Record PatSyn Desugaring] -------------------------------- -It is important that prov_theta comes before req_theta as this ordering is used -when desugaring record pattern synonym updates. - -Any change to this ordering should make sure to change GHC.HsToCore.Expr if you -want to avoid difficult to decipher core lint errors! - -} - - -nonBidirectionalErr :: Outputable name => name -> TcM a -nonBidirectionalErr name = failWithTc $ - text "non-bidirectional pattern synonym" - <+> quotes (ppr name) <+> text "used in an expression" - --- Walk the whole pattern and for all ConPatOuts, collect the --- existentially-bound type variables and evidence binding variables. --- --- These are used in computing the type of a pattern synonym and also --- in generating matcher functions, since success continuations need --- to be passed these pattern-bound evidences. -tcCollectEx - :: LPat GhcTc - -> ( [TyVar] -- Existentially-bound type variables - -- in correctly-scoped order; e.g. [ k:*, x:k ] - , [EvVar] ) -- and evidence variables - -tcCollectEx pat = go pat - where - go :: LPat GhcTc -> ([TyVar], [EvVar]) - go = go1 . unLoc - - go1 :: Pat GhcTc -> ([TyVar], [EvVar]) - go1 (LazyPat _ p) = go p - go1 (AsPat _ _ p) = go p - go1 (ParPat _ p) = go p - go1 (BangPat _ p) = go p - go1 (ListPat _ ps) = mergeMany . map go $ ps - go1 (TuplePat _ ps _) = mergeMany . map go $ ps - go1 (SumPat _ p _ _) = go p - go1 (ViewPat _ _ p) = go p - go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $ - goConDetails $ pat_args con - go1 (SigPat _ p _) = go p - go1 (CoPat _ _ p _) = go1 p - go1 (NPlusKPat _ n k _ geq subtract) - = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract - go1 _ = empty - - goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar]) - goConDetails (PrefixCon ps) = mergeMany . map go $ ps - goConDetails (InfixCon p1 p2) = go p1 `merge` go p2 - goConDetails (RecCon HsRecFields{ rec_flds = flds }) - = mergeMany . map goRecFd $ flds - - goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar]) - goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p - - merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) - mergeMany = foldr merge empty - empty = ([], []) diff --git a/compiler/typecheck/TcPatSyn.hs-boot b/compiler/typecheck/TcPatSyn.hs-boot deleted file mode 100644 --- a/compiler/typecheck/TcPatSyn.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ -module TcPatSyn where - -import GHC.Hs ( PatSynBind, LHsBinds ) -import TcRnTypes ( TcM, TcSigInfo ) -import TcRnMonad ( TcGblEnv) -import Outputable ( Outputable ) -import GHC.Hs.Extension ( GhcRn, GhcTc ) -import Data.Maybe ( Maybe ) - -tcPatSynDecl :: PatSynBind GhcRn GhcRn - -> Maybe TcSigInfo - -> TcM (LHsBinds GhcTc, TcGblEnv) - -tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) - -nonBidirectionalErr :: Outputable name => name -> TcM a diff --git a/compiler/typecheck/TcPluginM.hs b/compiler/typecheck/TcPluginM.hs deleted file mode 100644 --- a/compiler/typecheck/TcPluginM.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE CPP #-} --- | This module provides an interface for typechecker plugins to --- access select functions of the 'TcM', principally those to do with --- reading parts of the state. -module TcPluginM ( - -- * Basic TcPluginM functionality - TcPluginM, - tcPluginIO, - tcPluginTrace, - unsafeTcPluginTcM, - - -- * Finding Modules and Names - FindResult(..), - findImportedModule, - lookupOrig, - - -- * Looking up Names in the typechecking environment - tcLookupGlobal, - tcLookupTyCon, - tcLookupDataCon, - tcLookupClass, - tcLookup, - tcLookupId, - - -- * Getting the TcM state - getTopEnv, - getEnvs, - getInstEnvs, - getFamInstEnvs, - matchFam, - - -- * Type variables - newUnique, - newFlexiTyVar, - isTouchableTcPluginM, - - -- * Zonking - zonkTcType, - zonkCt, - - -- * Creating constraints - newWanted, - newDerived, - newGiven, - newCoercionHole, - - -- * Manipulating evidence bindings - newEvVar, - setEvBind, - getEvBindsTcPluginM - ) where - -import GhcPrelude - -import qualified TcRnMonad as TcM -import qualified TcSMonad as TcS -import qualified TcEnv as TcM -import qualified TcMType as TcM -import qualified FamInst as TcM -import qualified GHC.Iface.Env as IfaceEnv -import qualified GHC.Driver.Finder as Finder - -import GHC.Core.FamInstEnv ( FamInstEnv ) -import TcRnMonad ( TcGblEnv, TcLclEnv, TcPluginM - , unsafeTcPluginTcM, getEvBindsTcPluginM - , liftIO, traceTc ) -import Constraint ( Ct, CtLoc, CtEvidence(..), ctLocOrigin ) -import TcMType ( TcTyVar, TcType ) -import TcEnv ( TcTyThing ) -import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..) - , EvExpr, EvBind, mkGivenEvBind ) -import GHC.Types.Var ( EvVar ) - -import GHC.Types.Module -import GHC.Types.Name -import GHC.Core.TyCon -import GHC.Core.DataCon -import GHC.Core.Class -import GHC.Driver.Types -import Outputable -import GHC.Core.Type -import GHC.Core.Coercion ( BlockSubstFlag(..) ) -import GHC.Types.Id -import GHC.Core.InstEnv -import FastString -import GHC.Types.Unique - - --- | Perform some IO, typically to interact with an external tool. -tcPluginIO :: IO a -> TcPluginM a -tcPluginIO a = unsafeTcPluginTcM (liftIO a) - --- | Output useful for debugging the compiler. -tcPluginTrace :: String -> SDoc -> TcPluginM () -tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) - - -findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult -findImportedModule mod_name mb_pkg = do - hsc_env <- getTopEnv - tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg - -lookupOrig :: Module -> OccName -> TcPluginM Name -lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod - - -tcLookupGlobal :: Name -> TcPluginM TyThing -tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal - -tcLookupTyCon :: Name -> TcPluginM TyCon -tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon - -tcLookupDataCon :: Name -> TcPluginM DataCon -tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon - -tcLookupClass :: Name -> TcPluginM Class -tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass - -tcLookup :: Name -> TcPluginM TcTyThing -tcLookup = unsafeTcPluginTcM . TcM.tcLookup - -tcLookupId :: Name -> TcPluginM Id -tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId - - -getTopEnv :: TcPluginM HscEnv -getTopEnv = unsafeTcPluginTcM TcM.getTopEnv - -getEnvs :: TcPluginM (TcGblEnv, TcLclEnv) -getEnvs = unsafeTcPluginTcM TcM.getEnvs - -getInstEnvs :: TcPluginM InstEnvs -getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs - -getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv) -getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs - -matchFam :: TyCon -> [Type] - -> TcPluginM (Maybe (TcCoercion, TcType)) -matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args - -newUnique :: TcPluginM Unique -newUnique = unsafeTcPluginTcM TcM.newUnique - -newFlexiTyVar :: Kind -> TcPluginM TcTyVar -newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar - -isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool -isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM - --- Confused by zonking? See Note [What is zonking?] in TcMType. -zonkTcType :: TcType -> TcPluginM TcType -zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType - -zonkCt :: Ct -> TcPluginM Ct -zonkCt = unsafeTcPluginTcM . TcM.zonkCt - - --- | Create a new wanted constraint. -newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence -newWanted loc pty - = unsafeTcPluginTcM (TcM.newWanted (ctLocOrigin loc) Nothing pty) - --- | Create a new derived constraint. -newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence -newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc } - --- | Create a new given constraint, with the supplied evidence. This --- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it --- will panic. -newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence -newGiven loc pty evtm = do - new_ev <- newEvVar pty - setEvBind $ mkGivenEvBind new_ev (EvExpr evtm) - return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc } - --- | Create a fresh evidence variable. -newEvVar :: PredType -> TcPluginM EvVar -newEvVar = unsafeTcPluginTcM . TcM.newEvVar - --- | Create a fresh coercion hole. -newCoercionHole :: PredType -> TcPluginM CoercionHole -newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole YesBlockSubst - --- | Bind an evidence variable. This must not be invoked from --- 'tcPluginInit' or 'tcPluginStop', or it will panic. -setEvBind :: EvBind -> TcPluginM () -setEvBind ev_bind = do - tc_evbinds <- getEvBindsTcPluginM - unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs deleted file mode 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ /dev/null @@ -1,3078 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcRnDriver]{Typechecking a whole module} - -https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcRnDriver ( - tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType, - tcRnImportDecls, - tcRnLookupRdrName, - getModuleInterface, - tcRnDeclsi, - isGHCiMonad, - runTcInteractive, -- Used by GHC API clients (#8878) - tcRnLookupName, - tcRnGetInfo, - tcRnModule, tcRnModuleTcRnM, - tcTopSrcDecls, - rnTopSrcDecls, - checkBootDecl, checkHiBootIface', - findExtraSigImports, - implicitRequirements, - checkUnitId, - mergeSignatures, - tcRnMergeSignatures, - instantiateSignature, - tcRnInstantiateSignature, - loadUnqualIfaces, - -- More private... - badReexportedBootThing, - checkBootDeclM, - missingBootThing, - getRenamedStuff, RenamedStuff - ) where - -import GhcPrelude - -import {-# SOURCE #-} TcSplice ( finishTH, runRemoteModFinalizers ) -import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) -import GHC.Iface.Env ( externaliseName ) -import TcHsType -import TcValidity( checkValidType ) -import TcMatches -import Inst( deeplyInstantiate ) -import TcUnify( checkConstraints ) -import GHC.Rename.Types -import GHC.Rename.Expr -import GHC.Rename.Utils ( HsDocContext(..) ) -import GHC.Rename.Fixity ( lookupFixityRn ) -import TysWiredIn ( unitTy, mkListTy ) -import GHC.Driver.Plugins -import GHC.Driver.Session -import GHC.Hs -import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) -import GHC.Iface.Type ( ShowForAllFlag(..) ) -import GHC.Core.PatSyn( pprPatSynType ) -import PrelNames -import PrelInfo -import GHC.Types.Name.Reader -import TcHsSyn -import TcExpr -import TcRnMonad -import TcRnExports -import TcEvidence -import Constraint -import TcOrigin -import qualified BooleanFormula as BF -import GHC.Core.Ppr.TyThing ( pprTyThingInContext ) -import GHC.Core.FVs ( orphNamesOfFamInst ) -import FamInst -import GHC.Core.InstEnv -import GHC.Core.FamInstEnv - ( FamInst, pprFamInst, famInstsRepTyCons - , famInstEnvElts, extendFamInstEnvList, normaliseType ) -import TcAnnotations -import TcBinds -import GHC.Iface.Make ( coAxiomToIfaceDecl ) -import HeaderInfo ( mkPrelImports ) -import TcDefaults -import TcEnv -import TcRules -import TcForeign -import TcInstDcls -import GHC.IfaceToCore -import TcMType -import TcType -import TcSimplify -import TcTyClsDecls -import TcTypeable ( mkTypeableBinds ) -import TcBackpack -import GHC.Iface.Load -import GHC.Rename.Names -import GHC.Rename.Env -import GHC.Rename.Source -import ErrUtils -import GHC.Types.Id as Id -import GHC.Types.Id.Info( IdDetails(..) ) -import GHC.Types.Var.Env -import GHC.Types.Module -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.Core.TyCon -import GHC.Types.SrcLoc -import GHC.Driver.Types -import ListSetOps -import Outputable -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.Type -import GHC.Core.Class -import GHC.Types.Basic hiding( SuccessFlag(..) ) -import GHC.Core.Coercion.Axiom -import GHC.Types.Annotations -import Data.List ( find, sortBy, sort ) -import Data.Ord -import FastString -import Maybes -import Util -import Bag -import Inst (tcGetInsts) -import qualified GHC.LanguageExtensions as LangExt -import Data.Data ( Data ) -import GHC.Hs.Dump -import qualified Data.Set as S - -import Control.DeepSeq -import Control.Monad - -import TcHoleFitTypes ( HoleFitPluginR (..) ) - - -#include "HsVersions.h" - -{- -************************************************************************ -* * - Typecheck and rename a module -* * -************************************************************************ --} - --- | Top level entry point for typechecker and renamer -tcRnModule :: HscEnv - -> ModSummary - -> Bool -- True <=> save renamed syntax - -> HsParsedModule - -> IO (Messages, Maybe TcGblEnv) - -tcRnModule hsc_env mod_sum save_rn_syntax - parsedModule@HsParsedModule {hpm_module= L loc this_module} - | RealSrcSpan real_loc _ <- loc - = withTiming dflags - (text "Renamer/typechecker"<+>brackets (ppr this_mod)) - (const ()) $ - initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ - withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $ - - tcRnModuleTcRnM hsc_env mod_sum parsedModule pair - - | otherwise - = return ((emptyBag, unitBag err_msg), Nothing) - - where - hsc_src = ms_hsc_src mod_sum - dflags = hsc_dflags hsc_env - err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $ - text "Module does not have a RealSrcSpan:" <+> ppr this_mod - - this_pkg = thisPackage (hsc_dflags hsc_env) - - pair :: (Module, SrcSpan) - pair@(this_mod,_) - | Just (L mod_loc mod) <- hsmodName this_module - = (mkModule this_pkg mod, mod_loc) - - | otherwise -- 'module M where' is omitted - = (mAIN, 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 maybe_mod export_ies - import_decls local_decls mod_deprec - maybe_doc_hdr)), - 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 } - - ; whenWOptM Opt_WarnImplicitPrelude $ - when (notNull prel_imports) $ - addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) - - ; -- TODO This is a little skeevy; maybe handle a bit more directly - let { simplifyImport (L _ idecl) = - ( fmap sl_fs (ideclPkgQual idecl) , 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 (Nothing, L _ mod_name) = noLoc - $ (simpleImportDecl mod_name) - { ideclHiding = Just (False, noLoc [])} - ; mkImport _ = panic "mkImport" } - ; let { all_imports = prel_imports ++ import_decls - ++ map mkImport (raw_sig_imports ++ raw_req_imports) } - ; -- OK now finally rename the imports - tcg_env <- {-# SCC "tcRnImports" #-} - tcRnImports hsc_env all_imports - - ; -- 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 - let { tcg_env1 = case mod_deprec of - Just (L _ txt) -> - tcg_env {tcg_warns = WarnAll txt} - Nothing -> tcg_env - } - ; setGblEnv tcg_env1 - $ do { -- Rename and type check the declarations - traceRn "rn1a" empty - ; tcg_env <- if isHsBootOrSig hsc_src - then tcRnHsBootDecls hsc_src local_decls - else {-# SCC "tcRnSrcDecls" #-} - tcRnSrcDecls explicit_mod_hdr local_decls export_ies - ; setGblEnv tcg_env - $ do { -- Process the export list - traceRn "rn4a: before exports" empty - ; tcg_env <- tcRnExports explicit_mod_hdr export_ies - tcg_env - ; traceRn "rn4b: after exports" empty - ; -- 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 - -- TcEnv.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. - - -- Don't need to rename the Haddock documentation, - -- it's not parsed by GHC anymore. - tcg_env <- return (tcg_env - { tcg_doc_hdr = maybe_doc_hdr }) - ; -- 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 - ; -- add extra source files to tcg_dependent_files - addDependentFiles src_files - ; tcg_env <- runTypecheckerPlugin mod_sum hsc_env 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] -> TcM TcGblEnv -tcRnImports hsc_env import_decls - = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; - - ; this_mod <- getModule - ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) - ; dep_mods = imp_dep_mods imports - - -- 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. - ; want_instances :: ModuleName -> Bool - ; want_instances mod = mod `elemUFM` dep_mods - && mod /= moduleName this_mod - ; (home_insts, home_fam_insts) = hptInstances hsc_env - want_instances - } ; - - -- Record boot-file info in the EPS, so that it's - -- visible to loadHiBootInterface in tcRnSrcDecls, - -- and any other incrementally-performed imports - ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; - - -- 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 = extendInstEnvList (tcg_inst_env gbl) home_insts, - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) - home_fam_insts, - tcg_hpc = hpc_info - }) $ do { - - ; traceRn "rn1" (ppr (imp_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 - -> [LHsDecl GhcPs] -- Declarations - -> Maybe (Located [LIE GhcPs]) - -> TcM TcGblEnv -tcRnSrcDecls explicit_mod_hdr decls export_ies - = do { -- Do all the declarations - ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls - - -- Check for the 'main' declaration - -- Must do this inside the captureTopConstraints - -- NB: always set envs *before* captureTopConstraints - ; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $ - captureTopConstraints $ - checkMain explicit_mod_hdr export_ies - - ; setEnvs (tcg_env, tcl_env) $ do { - - -- Simplify constraints - -- - -- We do this after checkMain, so that we use the type info - -- that checkMain adds - -- - -- We do it with both global and local env in scope: - -- * the global env exposes the instances to simplifyTop - -- * the local env exposes the local Ids to simplifyTop, - -- so that we get better error messages (monomorphism restriction) - ; new_ev_binds <- {-# SCC "simplifyTop" #-} - simplifyTop (lie `andWC` lie_main) - - -- Emit Typeable bindings - ; tcg_env <- mkTypeableBinds - - - ; traceTc "Tc9" empty - - ; failIfErrsM -- Don't zonk if there have been errors - -- It's a waste of time; and we may get debug warnings - -- about strangely-typed TyCons! - ; traceTc "Tc10" empty - - -- Zonk the final code. This must be done last. - -- Even simplifyTop may do some unification. - -- This pass also warns about missing type signatures - ; (bind_env, ev_binds', binds', fords', imp_specs', rules') - <- zonkTcGblEnv new_ev_binds tcg_env - - -- Finalizers must run after constraints are simplified, or some 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. - ; (tcg_env_mf, _) <- setGblEnv (clearTcGblEnv tcg_env) - run_th_modfinalizers - ; finishTH - ; traceTc "Tc11" empty - - ; -- zonk the new bindings arising from running the finalisers. - -- This won't give rise to any more finalisers as you can't nest - -- finalisers inside finalisers. - ; (bind_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf) - <- zonkTcGblEnv emptyBag tcg_env_mf - - - ; let { final_type_env = plusTypeEnv (tcg_type_env tcg_env) - (plusTypeEnv bind_env_mf bind_env) - ; tcg_env' = tcg_env_mf - { 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 new_ev_binds tcg_env = - let TcGblEnv { tcg_binds = binds, - tcg_ev_binds = cur_ev_binds, - tcg_imp_specs = imp_specs, - tcg_rules = rules, - tcg_fords = fords } = tcg_env - - all_ev_binds = cur_ev_binds `unionBags` new_ev_binds - - in {-# SCC "zonkTopDecls" #-} - zonkTopDecls all_ev_binds binds rules imp_specs fords - - --- | Remove accumulated bindings, rules and so on from TcGblEnv -clearTcGblEnv :: TcGblEnv -> TcGblEnv -clearTcGblEnv tcg_env - = tcg_env { tcg_binds = emptyBag, - tcg_ev_binds = emptyBag , - tcg_imp_specs = [], - tcg_rules = [], - tcg_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) = - setLclEnv 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 [] - - setEnvs (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 _) _, _) -> - setSrcSpan loc - $ addErr (text - ("Declaration splices are not " - ++ "permitted inside top-level " - ++ "declarations added with addTopDecls")) - ; Just (XSpliceDecl nec, _) -> noExtCon nec - } - -- 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 - ; setEnvs (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 - ; (tcg_env, tcl_env, lie2) <- - setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ - addTopEvBinds ev_binds1 $ - tc_rn_src_decls (spliced_decls ++ rest_ds) - - ; return (tcg_env, tcl_env, lie2) - } - ; Just (XSpliceDecl nec, _) -> noExtCon nec - } - } - -{- -************************************************************************ -* * - 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.Source - - ; (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 - Just (XSpliceDecl nec, _) -> noExtCon nec - 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) - <- 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 -> Located decl -> TcM () -badBootDecl hsc_src what (L loc _) - = addErrAt loc (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 ("TcRnDriver.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 () - | isWiredInName name = return () -- No checking for wired-in names. In particular, - -- 'error' is handled by a rather gross hack - -- (see comments in GHC.Err.hs-boot) - - -- Check that the actual module exports the same thing - | not (null missing_names) - = addErrAt (nameSrcSpan (head missing_names)) - (missingBootThing True (head missing_names) "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 (eqMaybeBy 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) - (_, rho_ty1) = splitForAllTys (idType id1) - op_ty1 = funResultTy rho_ty1 - (_, rho_ty2) = splitForAllTys (idType id2) - op_ty2 = funResultTy rho_ty2 - - 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 t2)) (Just (_, VanillaDM)) - = eqTypeX env t1 t2 - -- 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) = - eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && - eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) - in - checkRoles roles1 roles2 `andThenCheck` - -- Checks kind of class - check (eqListBy eqFD clas_fds1 clas_fds2) - (text "The functional dependencies do not match") `andThenCheck` - checkUnless (isAbstractTyCon tc1) $ - check (eqListBy (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 (eqListBy (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 (mkNthCo). 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 paramaters), - -- - -- 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 (eqListBy 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 (dataConUserType c1) (dataConUserType 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 - = eqListBy (eqTypeX env) lhs1 lhs2 && - eqTypeX env rhs1 rhs2 - - | otherwise = False - -emptyRnEnv2 :: RnEnv2 -emptyRnEnv2 = mkRnEnv2 emptyInScopeSet - ----------------- -missingBootThing :: Bool -> Name -> String -> SDoc -missingBootThing is_boot name what - = 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 -> SDoc -badReexportedBootThing is_boot name name' - = 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 -> SDoc -bootMisMatch is_boot extra_info real_thing boot_thing - = 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 -> SDoc -instMisMatch dfun - = 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, XValBindsLR (NValBinds deriv_binds deriv_sigs)) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; - - 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; - setEnvs 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) ; - setEnvs 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` gre_name gre) - emptyFVs fo_gres - - ; sig_names = mkNameSet (collectHsValBinders 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 - 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 . occEnvElts . tcg_rdr_env) getGblEnv - - ; let clashes :: GlobalRdrElt -> Bool - clashes x = isLocalDef && nameClashes && isNotInProperModule - where - isLocalDef = gre_lcl x == True - -- Names are identical ... - nameClashes = nameOccName (gre_name 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 = gre_name 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 = addWarnAt (Reason warnFlag) (nameSrcSpan (gre_name x)) (hsep - [ text "Local definition of" - , (quotes . ppr . nameOccName . gre_name) 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 - - -- 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 (Bool, [Name]) - importListOf = fmap toImportList . ideclHiding - where - toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc)) - - isExplicit :: ImportDecl GhcRn -> Bool - isExplicit x = case importListOf x of - Nothing -> False - Just (False, explicit) - -> nameOccName name `elem` map nameOccName explicit - Just (True, 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 (Just name:_) = - addWarnAt (Reason warnFlag) instLoc $ - 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 (null 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 - 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) - <- 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, val_binds) - }}} - -{- ********************************************************************* -* * - Checking for 'main' -* * -************************************************************************ --} - -checkMain :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (Located [LIE GhcPs]) -- Export specs of Main module - -> TcM TcGblEnv --- If we are in module Main, check that 'main' is defined and exported. -checkMain explicit_mod_hdr export_ies - = do { dflags <- getDynFlags - ; tcg_env <- getGblEnv - ; check_main dflags tcg_env explicit_mod_hdr export_ies } - -check_main :: DynFlags -> TcGblEnv -> Bool -> Maybe (Located [LIE GhcPs]) - -> TcM TcGblEnv -check_main dflags tcg_env explicit_mod_hdr export_ies - | mod /= main_mod - = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >> - return tcg_env - - | otherwise - -- Compare the list of main functions in scope with those - -- specified in the export list. - = do mains_all <- lookupInfoOccRn main_fn - -- get all 'main' functions in scope - -- They may also be imported from other modules! - case exportedMains of -- check the main(s) specified in the export list - [ ] -> do - -- The module has no main functions in the export spec, so we must give - -- some kind of error message. The tricky part is giving an error message - -- that accurately characterizes what the problem is. - -- See Note [Main module without a main function in the export spec] - traceTc "checkMain no main module exported" ppr_mod_mainfn - complain_no_main - -- In order to reduce the number of potential error messages, we check - -- to see if there are any main functions defined (but not exported)... - case getSomeMain mains_all of - Nothing -> return tcg_env - -- ...if there are no such main functions, there is nothing we can do... - Just some_main -> use_as_main some_main - -- ...if there is such a main function, then communicate this to the - -- typechecker. This can prevent a spurious "Ambiguous type variable" - -- error message in certain cases, as described in - -- Note [Main module without a main function in the export spec]. - _ -> do -- The module has one or more main functions in the export spec - let mains = filterInsMains exportedMains mains_all - case mains of - [] -> do -- - traceTc "checkMain fail" ppr_mod_mainfn - complain_no_main - return tcg_env - [main_name] -> use_as_main main_name - _ -> do -- multiple main functions are exported - addAmbiguousNameErr main_fn -- issue error msg - return tcg_env - where - mod = tcg_mod tcg_env - main_mod = mainModIs dflags - main_mod_nm = moduleName main_mod - main_fn = getMainFun dflags - occ_main_fn = occName main_fn - interactive = ghcLink dflags == LinkInMemory - exportedMains = selExportMains export_ies - ppr_mod_mainfn = ppr main_mod <+> ppr main_fn - - -- There is a single exported 'main' function. - use_as_main :: Name -> TcM TcGblEnv - use_as_main main_name = do - { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn) - ; let loc = srcLocSpan (getSrcLoc main_name) - ; ioTyCon <- tcLookupTyCon ioTyConName - ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; let io_ty = mkTyConApp ioTyCon [res_ty] - skol_info = SigSkol (FunSigCtxt main_name False) io_ty [] - ; (ev_binds, main_expr) - <- checkConstraints skol_info [] [] $ - addErrCtxt mainCtxt $ - tcMonoExpr (L loc (HsVar noExtField (L loc main_name))) - (mkCheckExpType 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 - (mkTyConApp ioTyCon [res_ty]) - ; co = mkWpTyApps [res_ty] - -- The ev_binds of the `main` function may contain deferred - -- type error 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 - })} - - complain_no_main = unless (interactive && not explicit_mod_hdr) - (addErrTc noMainMsg) -- #12906 - -- 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. - - mainCtxt = text "When checking the type of the" <+> pp_main_fn - noMainMsg = text "The" <+> pp_main_fn - <+> text "is not" <+> text defOrExp <+> text "module" - <+> quotes (ppr main_mod) - defOrExp = if null exportedMains then "exported by" else "defined in" - - pp_main_fn = ppMainFn main_fn - - -- Select the main functions from the export list. - -- Only the module name is needed, the function name is fixed. - selExportMains :: Maybe (Located [LIE GhcPs]) -> [ModuleName] -- #16453 - selExportMains Nothing = [main_mod_nm] - -- no main specified, but there is a header. - selExportMains (Just exps) = fmap fst $ - filter (\(_,n) -> n == occ_main_fn ) texp - where - ies = fmap unLoc $ unLoc exps - texp = mapMaybe transExportIE ies - - -- Filter all main functions in scope that match the export specs - filterInsMains :: [ModuleName] -> [Name] -> [Name] -- #16453 - filterInsMains export_mains inscope_mains = - [mod | mod <- inscope_mains, - (moduleName . nameModule) mod `elem` export_mains] - - -- Transform an export_ie to a (ModuleName, OccName) pair. - -- 'IEVar' constructors contain exported values (functions), eg '(Main.main)' - -- 'IEModuleContents' constructors contain fully exported modules, eg '(Main)' - -- All other 'IE...' constructors are not used and transformed to Nothing. - transExportIE :: IE GhcPs -> Maybe (ModuleName, OccName) -- #16453 - transExportIE (IEVar _ var) = isQual_maybe $ - upqual $ ieWrappedName $ unLoc var - where - -- A module name is always needed, so qualify 'UnQual' rdr names. - upqual (Unqual occ) = Qual main_mod_nm occ - upqual rdr = rdr - transExportIE (IEModuleContents _ mod) = Just (unLoc mod, occ_main_fn) - transExportIE _ = Nothing - - -- Get a main function that is in scope. - -- See Note [Main module without a main function in the export spec] - getSomeMain :: [Name] -> Maybe Name -- #16453 - getSomeMain all_mains = case all_mains of - [] -> Nothing -- No main function in scope - [m] -> Just m -- Just one main function in scope - _ -> case mbMainOfMain of - Nothing -> listToMaybe all_mains -- Take the first main function in scope or Nothing - _ -> mbMainOfMain -- Take the Main module's main function or Nothing - where - mbMainOfMain = find (\n -> (moduleName . nameModule) n == main_mod_nm ) - all_mains -- the main function of the Main module - --- | 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 -getMainFun :: DynFlags -> RdrName -getMainFun dflags = case mainFunIs dflags of - Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) - Nothing -> main_RDR_Unqual - -ppMainFn :: RdrName -> SDoc -ppMainFn main_fn - | rdrNameOcc main_fn == mainOcc - = text "IO action" <+> quotes (ppr main_fn) - | otherwise - = text "main IO action" <+> quotes (ppr main_fn) - -mainOcc :: OccName -mainOcc = mkVarOccFS (fsLit "main") - -{- -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! - - -Note [Main module without a main function in the export spec] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Giving accurate error messages for a Main module that does not export a main -function is surprisingly tricky. To see why, consider a module in a file -`Foo.hs` that has no `main` function in the explicit export specs of the module -header: - - module Main () where - foo = return () - -This does not export a main function and therefore should be rejected, per -chapter 5 of the Haskell Report 2010: - - A Haskell program is a collection of modules, one of which, by convention, - must be called Main and must export the value main. The value of the - program is the value of the identifier main in module Main, which must be - a computation of type IO τ for some type τ. - -In fact, when you compile the program above using `ghc Foo.hs`, you will -actually get *two* errors: - - - The IO action ‘main’ is not defined in module ‘Main’ - - - Ambiguous type variable ‘m0’ arising from a use of ‘return’ - prevents the constraint ‘(Monad m0)’ from being solved. - -The first error is self-explanatory, while the second error message occurs -due to the monomorphism restriction. - -Now consider what would happen if the program above were compiled with -`ghc -main-is foo Foo`. The has the effect of `foo` being designated as the -main function. The program will still be rejected since it does not export -`foo` (and therefore does not export its main function), but there is one -important difference: `foo` will be checked against the type `IO τ`. As a -result, we would *not* expect the monomorphism restriction error message -to occur, since the typechecker should have no trouble figuring out the type -of `foo`. In other words, we should only throw the former error message, -not the latter. - -The implementation uses the function `getSomeMain` to find a potential main -function that is defined but not exported. If one is found, it is passed to -`use_as_main` to inform the typechecker that the main function should be of -type `IO τ`. See also the `T414` and `T17171a` test cases for similar examples -of programs whose error messages are influenced by the situation described in -this Note. - - -********************************************************* -* * - GHCi stuff -* * -********************************************************* --} - -runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, 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 $ withHoleFitPlugins hsc_env $ - do { traceTc "setInteractiveContext" $ - vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) - , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts) - , text "ic_rn_gbl_env (LocalDef)" <+> - vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt) - , let local_gres = filter isLocalGRE gres - , not (null local_gres) ]) ] - - ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface - : dep_orphs (mi_deps iface)) - (loadSrcInterface (text "runTcInteractive") m - False mb_pkg) - - ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> - case i of -- force above: see #15111 - IIModule n -> getOrphans n Nothing - IIDecl i -> - let mb_pkg = sl_fs <$> ideclPkgQual i in - getOrphans (unLoc (ideclName i)) mb_pkg - - ; let imports = emptyImportAvails { - imp_orphs = orphs - } - - ; (gbl_env, lcl_env) <- getEnvs - ; let gbl_env' = gbl_env { - tcg_rdr_env = ic_rn_gbl_env icxt - , tcg_type_env = type_env - , tcg_inst_env = extendInstEnvList - (extendInstEnvList (tcg_inst_env gbl_env) ic_insts) - 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 - - ; setEnvs (gbl_env', lcl_env') thing_inside } - where - (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) - - 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 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, 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 levity 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 (isUnliftedType . 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.Types - -{- --------------------------------------------- - At one stage I removed any shadowed bindings from the type_env; - they are inaccessible but might, I suppose, cause a space leak if we leave them there. - However, with Template Haskell they aren't necessarily inaccessible. Consider this - GHCi session - Prelude> let f n = n * 2 :: Int - Prelude> fName <- runQ [| f |] - Prelude> $(return $ AppE fName (LitE (IntegerL 7))) - 14 - Prelude> let f n = n * 3 :: Int - Prelude> $(return $ AppE fName (LitE (IntegerL 7))) - In the last line we use 'fName', which resolves to the *first* 'f' - in scope. If we delete it from the type env, GHCi crashes because - it doesn't expect that. - - Hence this code is commented out - --------------------------------------------------- -} - - 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 (sep [text "GHCi can't bind a variable of unlifted type:", - nest 2 (ppr 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 :: [Plan] -> TcM PlanResult -runPlans [] = panic "runPlans" -runPlans [p] = p -runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p - --- | 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.Types 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) - -- Don't try to typecheck if the renamer fails! - ; ghciStep <- getGhciStepIO - ; uniq <- newUnique - ; interPrintName <- getInteractivePrintName - ; let fresh_it = itName uniq loc - matches = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr - (noLoc 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 noExtField $ noLoc $ HsValBinds noExtField - $ XValBindsLR - (NValBinds [(NonRecursive,unitBag the_bind)] []) - - -- [it <- e] - bind_stmt = L loc $ BindStmt noExtField - (L loc (VarPat noExtField (L loc fresh_it))) - (nlHsApp ghciStep rn_expr) - (mkRnSyntaxExpr bindIOName) - noSyntaxExpr - - -- [; 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 - - ; 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 GhciStmtCtxt rnLExpr [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 ty pat expr op1 op2)) <- rn_stmt - = L loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2 - | otherwise = rn_stmt - - ; opt_pr_flag <- goptM Opt_PrintBindResult - ; let print_result_plan - | opt_pr_flag -- The flag says "print result" - , [v] <- collectLStmtBinders gi_stmt -- One binder - = [mk_print_result_plan gi_stmt v] - | otherwise = [] - - -- The plans are: - -- [stmt; print v] if one binder and not v::() - -- [stmt] otherwise - ; plan <- runPlans (print_result_plan ++ [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 GhciStmtCtxt tcDoStmt stmts - (mkCheckExpType io_ret_ty) - names = collectLStmtsBinders stmts - - -- OK, we're ready to typecheck the stmts - ; traceTc "TcRnDriver.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 "TcRnDriver.tcGhciStmts: simplify ctxt" empty - ; const_binds <- checkNoErrs (simplifyInteractive lie) - -- checkNoErrs ensures that the plan fails if context redn fails - - - ; traceTc "TcRnDriver.tcGhciStmts: done" empty - - -- rec_expr is the expression - -- returnIO @ [()] [unsafeCoerce# () x, .., unsafeCorece# () 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]) $ - noLoc $ ExplicitList unitTy Nothing $ - 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 ++ [noLoc (mkLastStmt ret_expr)] - - ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc 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 ghciTy) (nlHsTyVar a_tv) - ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) - - step_ty = noLoc $ HsForAllTy - { hst_fvf = ForallInvis - , hst_bndrs = [noLoc $ UserTyVar noExtField (noLoc a_tv)] - , hst_xforall = noExtField - , hst_body = nlHsFunTy ghciM ioM } - - stepTy :: LHsSigWcType GhcRn - stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty) - - return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) - -isGHCiMonad :: HscEnv -> String -> IO (Messages, 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 = gre_name n - ghciClass <- tcLookupClass ghciIoClassName - userTyCon <- tcLookupTyCon name - let userTy = mkTyConApp userTyCon [] - _ <- tcLookupInstance ghciClass [userTy] - return name - - Just _ -> failWithTc $ text "Ambiguous type!" - Nothing -> failWithTc $ text ("Can't find type:" ++ ty) - --- | How should we infer a type? See Note [TcRnExprMode] -data TcRnExprMode = TM_Inst -- ^ Instantiate the type fully (:type) - | TM_NoInst -- ^ Do not instantiate the type (:type +v) - | TM_Default -- ^ Default the type eagerly (:type +d) - --- | tcRnExpr just finds the type of an expression -tcRnExpr :: HscEnv - -> TcRnExprMode - -> LHsExpr GhcPs - -> IO (Messages, Maybe Type) -tcRnExpr hsc_env mode rdr_expr - = runTcInteractive hsc_env $ - do { - - (rn_expr, _fvs) <- rnLExpr rdr_expr ; - failIfErrsM ; - - -- Now typecheck the expression, and generalise its type - -- it might have a rank-2 type (e.g. :t runST) - uniq <- newUnique ; - let { fresh_it = itName uniq (getLoc rdr_expr) - ; orig = lexprCtOrigin rn_expr } ; - ((tclvl, res_ty), lie) - <- captureTopConstraints $ - pushTcLevelM $ - do { (_tc_expr, expr_ty) <- tcInferSigma rn_expr - ; if inst - then snd <$> deeplyInstantiate orig expr_ty - else return expr_ty } ; - - -- Generalise - (qtvs, dicts, _, residual, _) - <- 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 = mkInvForAllTys qtvs $ - mkPhiTy (map idType dicts) res_ty } ; - ty <- zonkTcType all_expr_ty ; - - -- We normalise type families, so that the type of an expression is the - -- same as of a bound expression (TcBinds.mkInferredPolyId). See Trac - -- #10321 for further discussion. - fam_envs <- tcGetFamInstEnvs ; - -- normaliseType returns a coercion which we discard, so the Role is - -- irrelevant - return (snd (normaliseType fam_envs Nominal ty)) - } - where - -- See Note [TcRnExprMode] - (inst, infer_mode, perhaps_disable_default_warnings) = case mode of - TM_Inst -> (True, NoRestrictions, id) - TM_NoInst -> (False, NoRestrictions, id) - TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) - --------------------------- -tcRnImportDecls :: HscEnv - -> [LImportDecl GhcPs] - -> IO (Messages, 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 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, 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_type }, _fvs) - <- rnHsWcType GHCiCtx (mkHsWildCardBndrs 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 TcHsType 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_type]) - ; (ty, kind) <- pushTcLevelM_ $ - -- must push level to satisfy level precondition of - -- kindGeneralize, below - solveEqualities $ - tcNamedWildCardBinders wcs $ \ wcs' -> - do { emitNamedWildCardHoleConstraints wcs' - ; tcLHsTypeUnsaturated rn_type } - - -- Do kind generalisation; see Note [Kind-generalise in tcRnType] - ; kvs <- kindGeneralizeAll kind - ; e <- mkEmptyZonkEnv flexi - - ; ty <- zonkTcTypeToTypeX e ty - - -- Do validity checking on type - ; checkValidType (GhciCtxt True) ty - - ; ty' <- if normalise - then do { fam_envs <- tcGetFamInstEnvs - ; let (_, ty') - = normaliseType fam_envs Nominal ty - ; return ty' } - else return ty ; - - ; return (ty', mkInvForAllTys kvs (tcTypeKind 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 3 different possibilities, described below. Each -considers this example, with -fprint-explicit-foralls enabled: - - foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String - :type{,-spec,-def} foo @Int - -:type / TM_Inst - - In this mode, we report the type that would be inferred if a variable - were assigned to expression e, without applying the monomorphism restriction. - This means we deeply instantiate the type and then regeneralize, as discussed - in #11376. - - > :type foo @Int - forall {b} {f :: * -> *}. (Foldable f, Num b) => Int -> f b -> String - - 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. - -:type +v / TM_NoInst - - This mode is for the benefit of users using TypeApplications. It does no - instantiation whatsoever, sometimes meaning that class constraints are not - solved. - - > :type +v 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, any type variable that can be defaulted is defaulted. Because - GHCi uses -XExtendedDefaultRules, this means that Foldable and Traversable are - defaulted. - - > :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 [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, Maybe TcGblEnv) -tcRnDeclsi hsc_env local_decls - = runTcInteractive hsc_env $ - tcRnSrcDecls False local_decls Nothing - -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, Maybe ModIface) -getModuleInterface hsc_env mod - = runTcInteractive hsc_env $ - loadModuleInterface (text "getModuleInterface") mod - -tcRnLookupRdrName :: HscEnv -> Located RdrName - -> IO (Messages, Maybe [Name]) --- ^ Find all the Names that this RdrName could mean, in GHCi -tcRnLookupRdrName hsc_env (L loc rdr_name) - = runTcInteractive hsc_env $ - setSrcSpan 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 (text "Not in scope:" <+> quotes (ppr rdr_name))) - ; return names } - -tcRnLookupName :: HscEnv -> Name -> IO (Messages, 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 - , 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 $ do - mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) - where - this_pkg = thisPackage (hsc_dflags hsc_env) - - unqual_mods = [ nameModule name - | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt) - , let name = gre_name gre - , nameIsFromExternalPackage this_pkg 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 { dflags <- getDynFlags ; - - -- Dump short output if -ddump-types or -ddump-tc - when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types) - "" FormatText 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 (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:" <+> - pprUFM (imp_dep_mods imports) (ppr . sort) - , text "Dependent packages:" <+> - ppr (S.toList $ imp_dep_pkgs imports)] - where -- 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 - RecSelId {} -> True - ClassOpId {} -> True - FCallId {} -> True - _ -> False - -- Data cons (workers and wrappers), pattern synonyms, - -- etc are suppressed (unless -dppr-debug), - -- because they appear elsewhere - - ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id))) - -ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc -ppr_tycons debug fam_insts type_env - = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons - , ppr_things "COERCION AXIOMS" ppr_ax - (typeEnvCoAxioms type_env) ] - where - fi_tycons = famInstsRepTyCons fam_insts - - tycons = sortBy (comparing getOccName) $ - [tycon | tycon <- typeEnvTyCons type_env - , want_tycon tycon] - -- Sort by OccName to reduce unnecessary changes - want_tycon tycon | debug = True - | otherwise = isExternalName (tyConName tycon) && - not (tycon `elem` fi_tycons) - ppr_tc tc - = vcat [ hang (ppr (tyConFlavour tc) <+> ppr tc - <> braces (ppr (tyConArity tc)) <+> dcolon) - 2 (ppr (tidyTopType (tyConKind tc))) - , nest 2 $ - ppWhen show_roles $ - text "roles" <+> (sep (map ppr roles)) ] - where - show_roles = debug || not (all (== boring_role) roles) - roles = tyConRoles tc - boring_role | isClassTyCon tc = Nominal - | otherwise = Representational - -- Matches the choice in GHC.Iface.Syntax, calls to pprRoles - - ppr_ax ax = ppr (coAxiomToIfaceDecl ax) - -- We go via IfaceDecl rather than using pprCoAxiom - -- This way we get the full axiom (both LHS and RHS) with - -- wildcard binders tidied to _1, _2, etc. - -ppr_datacons :: Bool -> TypeEnv -> SDoc -ppr_datacons debug type_env - = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs - -- The filter gets rid of class data constructors - where - ppr_dc dc = ppr dc <+> dcolon <+> ppr (dataConUserType dc) - all_dcs = typeEnvDataCons type_env - wanted_dcs | debug = all_dcs - | otherwise = filterOut is_cls_dc all_dcs - is_cls_dc dc = isClassTyCon (dataConTyCon dc) - -ppr_patsyns :: TypeEnv -> SDoc -ppr_patsyns type_env - = ppr_things "PATTERN SYNONYMS" ppr_ps - (typeEnvPatSyns type_env) - where - ppr_ps ps = ppr ps <+> dcolon <+> pprPatSynType ps - -ppr_insts :: [ClsInst] -> SDoc -ppr_insts ispecs - = ppr_things "CLASS INSTANCES" pprInstance ispecs - -ppr_fam_insts :: [FamInst] -> SDoc -ppr_fam_insts fam_insts - = ppr_things "FAMILY INSTANCES" pprFamInst fam_insts - -ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc -ppr_things herald ppr_one things - | null things = empty - | otherwise = text herald $$ nest 2 (vcat (map ppr_one things)) - -hasTopUserName :: NamedThing x => x -> Bool --- A top-level thing whose name is not "derived" --- Thus excluding things like $tcX, from Typeable boilerplate --- and C:Coll from class-dictionary data constructors -hasTopUserName x - = isExternalName name && not (isDerivedOccName (nameOccName name)) - where - name = getName x - -{- -******************************************************************************** - -Type Checker Plugins - -******************************************************************************** --} - -withTcPlugins :: HscEnv -> TcM a -> TcM a -withTcPlugins hsc_env m = - do let plugins = getTcPlugins (hsc_dflags hsc_env) - case plugins of - [] -> m -- Common fast case - _ -> do ev_binds_var <- newTcEvBinds - (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins - -- This ensures that tcPluginStop is called even if a type - -- error occurs during compilation (Fix of #10078) - eitherRes <- tryM $ do - updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m - mapM_ (flip runTcPluginM ev_binds_var) stops - case eitherRes of - Left _ -> failM - Right res -> return res - where - startPlugin ev_binds_var (TcPlugin start solve stop) = - do s <- runTcPluginM start ev_binds_var - return (solve s, stop s) - -getTcPlugins :: DynFlags -> [TcRnMonad.TcPlugin] -getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args) - - -withHoleFitPlugins :: HscEnv -> TcM a -> TcM a -withHoleFitPlugins hsc_env m = - case (getHfPlugins (hsc_dflags hsc_env)) of - [] -> m -- Common fast case - plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins - -- This ensures that hfPluginStop is called even if a type - -- error occurs during compilation. - eitherRes <- tryM $ do - updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m - sequence_ stops - case eitherRes of - Left _ -> failM - Right res -> return res - where - startPlugin (HoleFitPluginR init plugin stop) = - do ref <- init - return (plugin ref, stop ref) - -getHfPlugins :: DynFlags -> [HoleFitPluginR] -getHfPlugins dflags = - catMaybes $ mapPlugins dflags (\p args -> holeFitPlugin p args) - - -runRenamerPlugin :: TcGblEnv - -> HsGroup GhcRn - -> TcM (TcGblEnv, HsGroup GhcRn) -runRenamerPlugin gbl_env hs_group = do - dflags <- getDynFlags - withPlugins dflags - (\p opts (e, g) -> ( mark_plugin_unsafe dflags >> renamedResultAction p opts e g)) - (gbl_env, hs_group) - - --- XXX: should this really be a Maybe X? Check under which circumstances this --- can become a Nothing and decide whether this should instead throw an --- exception/signal an error. -type RenamedStuff = - (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], - Maybe LHsDocString)) - --- | Extract the renamed information from TcGblEnv. -getRenamedStuff :: TcGblEnv -> RenamedStuff -getRenamedStuff tc_result - = fmap (\decls -> ( decls, tcg_rn_imports tc_result - , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) ) - (tcg_rn_decls tc_result) - -runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv -runTypecheckerPlugin sum hsc_env gbl_env = do - let dflags = hsc_dflags hsc_env - withPlugins dflags - (\p opts env -> mark_plugin_unsafe dflags - >> typeCheckResultAction p opts sum env) - gbl_env - -mark_plugin_unsafe :: DynFlags -> TcM () -mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $ - recordUnsafeInfer pluginUnsafe - where - unsafeText = "Use of plugins makes the module unsafe" - pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan - (Outputable.text unsafeText) ) diff --git a/compiler/typecheck/TcRnDriver.hs-boot b/compiler/typecheck/TcRnDriver.hs-boot deleted file mode 100644 --- a/compiler/typecheck/TcRnDriver.hs-boot +++ /dev/null @@ -1,12 +0,0 @@ -module TcRnDriver where - -import GhcPrelude -import GHC.Core.Type(TyThing) -import TcRnTypes (TcM) -import Outputable (SDoc) -import GHC.Types.Name (Name) - -checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) - -> TyThing -> TyThing -> TcM () -missingBootThing :: Bool -> Name -> String -> SDoc -badReexportedBootThing :: Bool -> Name -> Name -> SDoc diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs deleted file mode 100644 --- a/compiler/typecheck/TcRnExports.hs +++ /dev/null @@ -1,856 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module TcRnExports (tcRnExports, exports_from_avail) where - -import GhcPrelude - -import GHC.Hs -import PrelNames -import GHC.Types.Name.Reader -import TcRnMonad -import TcEnv -import TcType -import GHC.Rename.Names -import GHC.Rename.Env -import GHC.Rename.Unbound ( reportUnboundName ) -import ErrUtils -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Module -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Avail -import GHC.Core.TyCon -import GHC.Types.SrcLoc as SrcLoc -import GHC.Driver.Types -import Outputable -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.PatSyn -import Maybes -import GHC.Types.Unique.Set -import Util (capitalise) -import FastString (fsLit) - -import Control.Monad -import GHC.Driver.Session -import GHC.Rename.Doc ( rnHsDoc ) -import RdrHsSyn ( setRdrNameSpace ) -import Data.Either ( partitionEithers ) - -{- -************************************************************************ -* * -\subsection{Export list processing} -* * -************************************************************************ - -Processing the export list. - -You might think that we should record things that appear in the export -list as ``occurrences'' (using @addOccurrenceName@), but you'd be -wrong. We do check (here) that they are in scope, but there is no -need to slurp in their actual declaration (which is what -@addOccurrenceName@ forces). - -Indeed, doing so would big trouble when compiling @PrelBase@, because -it re-exports @GHC@, which includes @takeMVar#@, whose type includes -@ConcBase.StateAndSynchVar#@, and so on... - -Note [Exports of data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose you see (#5306) - module M where - import X( F ) - data instance F Int = FInt -What does M export? AvailTC F [FInt] - or AvailTC F [F,FInt]? -The former is strictly right because F isn't defined in this module. -But then you can never do an explicit import of M, thus - import M( F( FInt ) ) -because F isn't exported by M. Nor can you import FInt alone from here - import M( FInt ) -because we don't have syntax to support that. (It looks like an import of -the type FInt.) - -At one point I implemented a compromise: - * When constructing exports with no export list, or with module M( - module M ), we add the parent to the exports as well. - * But not when you see module M( f ), even if f is a - class method with a parent. - * Nor when you see module M( module N ), with N /= M. - -But the compromise seemed too much of a hack, so we backed it out. -You just have to use an explicit export list: - module M( F(..) ) where ... - -Note [Avails of associated data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose you have (#16077) - - {-# LANGUAGE TypeFamilies #-} - module A (module A) where - - class C a where { data T a } - instance C () where { data T () = D } - -Because @A@ is exported explicitly, GHC tries to produce an export list -from the @GlobalRdrEnv@. In this case, it pulls out the following: - - [ C defined at A.hs:4:1 - , T parent:C defined at A.hs:4:23 - , D parent:T defined at A.hs:5:35 ] - -If map these directly into avails, (via 'availFromGRE'), we get -@[C{C;}, C{T;}, T{D;}]@, which eventually gets merged into @[C{C, T;}, T{D;}]@. -That's not right, because @T{D;}@ violates the AvailTC invariant: @T@ is -exported, but it isn't the first entry in the avail! - -We work around this issue by expanding GREs where the parent and child -are both type constructors into two GRES. - - T parent:C defined at A.hs:4:23 - - => - - [ T parent:C defined at A.hs:4:23 - , T defined at A.hs:4:23 ] - -Then, we get @[C{C;}, C{T;}, T{T;}, T{D;}]@, which eventually gets merged -into @[C{C, T;}, T{T, D;}]@ (which satsifies the AvailTC invariant). --} - -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 - -emptyExportAccum :: ExportAccum -emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet - -accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, 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) - -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 - -- that have the same occurrence name - -tcRnExports :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list - -> TcGblEnv - -> RnM TcGblEnv - - -- Complains if two distinct exports have same OccName - -- Warns about identical exports. - -- Complains about exports items not in scope - -tcRnExports explicit_mod exports - tcg_env@TcGblEnv { tcg_mod = this_mod, - tcg_rdr_env = rdr_env, - tcg_imports = imports, - tcg_src = hsc_src } - = 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 { - ; dflags <- getDynFlags - ; let is_main_mod = mainModIs dflags == this_mod - ; let default_main = case mainFunIs dflags of - Just main_fun - | is_main_mod -> mkUnqual varName (fsLit main_fun) - _ -> main_RDR_Unqual - ; has_main <- (not . null) <$> lookupInfoOccRn default_main -- #17832 - -- If a module has no explicit header, and it has one or more main - -- functions in scope, then add a header like - -- "module Main(main) where ..." #13839 - -- See Note [Modules without a module header] - ; let real_exports - | explicit_mod = exports - | has_main - = Just (noLoc [noLoc (IEVar noExtField - (noLoc (IEName $ noLoc default_main)))]) - -- ToDo: the 'noLoc' here is unhelpful if 'main' - -- turns out to be out of scope - | otherwise = Nothing - - ; let do_it = exports_from_avail real_exports rdr_env imports this_mod - ; (rn_exports, final_avails) - <- if hsc_src == HsigFile - then do (mb_r, msgs) <- tryTc do_it - case mb_r of - Just r -> return r - Nothing -> addMessages msgs >> failM - else checkNoErrs do_it - ; let final_ns = availsToNameSetWithSelectors final_avails - - ; traceRn "rnExports: Exports:" (ppr final_avails) - - ; let new_tcg_env = - tcg_env { tcg_exports = final_avails, - tcg_rn_exports = case tcg_rn_exports tcg_env of - Nothing -> Nothing - Just _ -> rn_exports, - tcg_dus = tcg_dus tcg_env `plusDU` - usesOnly final_ns } - ; failIfErrsM - ; return new_tcg_env } - -exports_from_avail :: Maybe (Located [LIE GhcPs]) - -- ^ 'Nothing' means no explicit export list - -> GlobalRdrEnv - -> ImportAvails - -- ^ Imported modules; this is used to test if a - -- @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 - -- if explicit export list is present it contains - -- each renamed export item together with its exported - -- names. - -exports_from_avail Nothing rdr_env _imports _this_mod - -- The same as (module M) where M is the current module name, - -- so that's how we handle it, except we also export the data family - -- when a data instance is exported. - = do { - ; warnMissingExportList <- woptM Opt_WarnMissingExportList - ; warnIfFlag Opt_WarnMissingExportList - warnMissingExportList - (missingModuleExportWarn $ moduleName _this_mod) - ; let avails = - map fix_faminst . gresToAvailInfo - . filter isLocalGRE . globalRdrEnvElts $ rdr_env - ; return (Nothing, avails) } - where - -- #11164: when we define a data instance - -- but not data family, re-export the family - -- Even though we don't check whether this is actually a data family - -- only data families can locally define subordinate things (`ns` here) - -- without locally defining (and instead importing) the parent (`n`) - fix_faminst (AvailTC n ns flds) = - let new_ns = - case ns of - [] -> [n] - (p:_) -> if p == n then ns else n:ns - in AvailTC n new_ns flds - - fix_faminst avail = avail - - -exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod - = do ie_avails <- accumExports do_litem rdr_items - let final_exports = nubAvails (concatMap snd ie_avails) -- Combine families - return (Just ie_avails, final_exports) - where - do_litem :: ExportAccum -> LIE GhcPs - -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) - do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie) - - -- Maps a parent to its in-scope children - kids_env :: NameEnv [GlobalRdrElt] - kids_env = mkChildEnv (globalRdrEnvElts rdr_env) - - -- See Note [Avails of associated data families] - expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt] - expand_tyty_gre (gre@GRE { gre_name = me, gre_par = ParentIs p }) - | isTyConName p, isTyConName me = [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 { warnIfFlag Opt_WarnDuplicateExports True - (dupModuleExport mod) ; - return 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 - } - - ; checkErr exportValid (moduleNotImported mod) - ; warnIfFlag Opt_WarnDodgyExports - (exportValid && null gre_prs) - (nullModuleExport mod) - - ; traceRn "efa" (ppr mod $$ ppr all_gres) - ; addUsedGREs 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 ]) - - ; return (Just ( ExportAccum occs' mods - , ( L loc (IEModuleContents noExtField lmod) - , new_exports))) } - - exports_from_item acc@(ExportAccum occs mods) (L loc ie) - | isDoc ie - = do new_ie <- lookup_doc_ie ie - return (Just (acc, (L loc new_ie, []))) - - | otherwise - = do (new_ie, avail) <- lookup_ie ie - if isUnboundName (ieName new_ie) - then return Nothing -- Avoid error cascade - else do - - occs' <- check_occs ie occs [avail] - - return (Just ( ExportAccum occs' mods - , (L loc new_ie, [avail]))) - - ------------- - 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) - - lookup_ie (IEThingAbs _ (L l rdr)) - = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEThingAbs noExtField (L l (replaceWrappedName rdr name)) - , avail) - - lookup_ie ie@(IEThingAll _ n') - = do - (n, avail, flds) <- lookup_ie_all ie n' - let name = unLoc n - return (IEThingAll noExtField (replaceLWrappedName n' (unLoc n)) - , AvailTC name (name:avail) flds) - - - 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 - return (IEThingWith noExtField (replaceLWrappedName l name) wc subs - (flds ++ (map noLoc all_flds)), - AvailTC name (name : avails ++ all_avail) - (map unLoc flds ++ all_flds)) - - - lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier - - - lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName] - -> RnM (Located Name, [LIEWrappedName Name], [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 l name, [], [name], []) - else return (L l name, non_flds - , map (ieWrappedName . unLoc) non_flds - , flds) - - lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName - -> 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 - warnDodgyExports <- woptM Opt_WarnDodgyExports - when (null gres) $ - if isTyConName name - then when warnDodgyExports $ - addWarn (Reason Opt_WarnDodgyExports) - (dodgyExportWarn name) - else -- This occurs when you export T(..), but - -- only import T abstractly, or T is a synonym. - addErr (exportItemErr ie) - return (L l name, non_flds, flds) - - ------------- - lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn) - lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc - return (IEGroup noExtField lev rn_doc) - lookup_doc_ie (IEDoc _ doc) = do rn_doc <- rnHsDoc doc - return (IEDoc noExtField rn_doc) - lookup_doc_ie (IEDocNamed _ str) = return (IEDocNamed noExtField str) - lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier - - -- 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 = partitionEithers . map classifyGRE - -classifyGRE :: GlobalRdrElt -> Either Name FieldLabel -classifyGRE gre = case gre_par gre of - FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n) - FldParent _ (Just lbl) -> Right (FieldLabel lbl True n) - _ -> Left n - where - n = gre_name gre - -isDoc :: IE GhcPs -> Bool -isDoc (IEDoc {}) = True -isDoc (IEDocNamed {}) = True -isDoc (IEGroup {}) = True -isDoc _ = False - --- Renaming and typechecking of exports happens after everything else has --- been typechecked. - -{- -Note [Modules without a module header] --------------------------------------------------- - -The Haskell 2010 report says in section 5.1: - ->> An abbreviated form of module, consisting only of the module body, is ->> permitted. If this is used, the header is assumed to be ->> ‘module Main(main) where’. - -For modules without a module header, this is implemented the -following way: - -If the module has a main function in scope: - Then create a module header and export the main function, - as if a module header like ‘module Main(main) where...’ would exist. - This has the effect to mark the main function and all top level - functions called directly or indirectly via main as 'used', - and later on, unused top-level functions can be reported correctly. - There is no distinction between GHC and GHCi. -If the module has several main functions in scope: - Then generate a header as above. The ambiguity is reported later in - module `TcRnDriver.hs` function `check_main`. -If the module has NO main function: - Then export all top-level functions. This marks all top level - functions as 'used'. - In GHCi this has the effect, that we don't get any 'non-used' warnings. - In GHC, however, the 'has-main-module' check in the module - compiler/typecheck/TcRnDriver (functions checkMain / check-main) fires, - and we get the error: - The IO action ‘main’ is not defined in module ‘Main’ --} - - --- Renaming exports lists is a minefield. Five different things can appear in --- children export lists ( T(A, B, C) ). --- 1. Record selectors --- 2. Type constructors --- 3. Data constructors --- 4. Pattern Synonyms --- 5. Pattern Synonym Selectors --- --- However, things get put into weird name spaces. --- 1. Some type constructors are parsed as variables (-.->) for example. --- 2. All data constructors are parsed as type constructors --- 3. When there is ambiguity, we default type constructors to data --- constructors and require the explicit `type` keyword for type --- constructors. --- --- This function first establishes the possible namespaces that an --- identifier might be in (`choosePossibleNameSpaces`). --- --- Then for each namespace in turn, tries to find the correct identifier --- there returning the first positive result or the first terminating --- error. --- - - - -lookupChildrenExport :: Name -> [LIEWrappedName RdrName] - -> RnM ([LIEWrappedName Name], [Located FieldLabel]) -lookupChildrenExport spec_parent rdr_items = - do - xs <- mapAndReportM doOne rdr_items - return $ partitionEithers xs - 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 RdrName - -> RnM (Either (LIEWrappedName Name) (Located FieldLabel)) - doOne n = do - - let bareName = (ieWrappedName . unLoc) n - lkup v = lookupSubBndrOcc_helper False True - spec_parent (setRdrNameSpace bareName v) - - name <- combineChildLookupResult $ map lkup $ - choosePossibleNamespaces (rdrNameSpace bareName) - 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 - - case name of - NameNotFound -> do { ub <- reportUnboundName unboundName - ; let l = getLoc n - ; return (Left (L l (IEName (L l ub))))} - FoundFL fls -> return $ Right (L (getLoc n) fls) - FoundName par name -> do { checkPatSynParent spec_parent par name - ; return - $ Left (replaceLWrappedName n name) } - IncorrectParent p g td gs -> failWithDcErr p g td gs - - --- Note: [Typing Pattern Synonym Exports] --- It proved quite a challenge to precisely specify which pattern synonyms --- should be allowed to be bundled with which type constructors. --- In the end it was decided to be quite liberal in what we allow. Below is --- how Simon described the implementation. --- --- "Personally I think we should Keep It Simple. All this talk of --- satisfiability makes me shiver. I suggest this: allow T( P ) in all --- situations except where `P`'s type is ''visibly incompatible'' with --- `T`. --- --- What does "visibly incompatible" mean? `P` is visibly incompatible --- with --- `T` if --- * `P`'s type is of form `... -> S t1 t2` --- * `S` is a data/newtype constructor distinct from `T` --- --- Nothing harmful happens if we allow `P` to be exported with --- a type it can't possibly be useful for, but specifying a tighter --- relationship is very awkward as you have discovered." --- --- Note that this allows *any* pattern synonym to be bundled with any --- datatype type constructor. For example, the following pattern `P` can be --- bundled with any type. --- --- ``` --- pattern P :: (A ~ f) => f --- ``` --- --- So we provide basic type checking in order to help the user out, most --- pattern synonyms are defined with definite type constructors, but don't --- actually prevent a library author completely confusing their users if --- they want to. --- --- So, we check for exactly four things --- 1. The name arises from a pattern synonym definition. (Either a pattern --- synonym constructor or a pattern synonym selector) --- 2. The pattern synonym is only bundled with a datatype or newtype. --- 3. Check that the head of the result type constructor is an actual type --- constructor and not a type variable. (See above example) --- 4. Is so, check that this type constructor is the same as the parent --- type constructor. --- --- --- Note: [Types of TyCon] --- --- This check appears to be overlly complicated, Richard asked why it --- is not simply just `isAlgTyCon`. The answer for this is that --- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow. --- (It is either a newtype or data depending on the number of methods) --- - --- | Given a resolved name in the children export list and a parent. Decide --- whether we are allowed to export the child with the parent. --- Invariant: gre_par == NoParent --- See note [Typing Pattern Synonym Exports] -checkPatSynParent :: Name -- ^ Alleged parent type constructor - -- User wrote T( P, Q ) - -> Parent -- The parent of P we discovered - -> Name -- ^ Either a - -- a) Pattern Synonym Constructor - -- b) A pattern synonym selector - -> TcM () -- Fails if wrong parent -checkPatSynParent _ (ParentIs {}) _ - = return () - -checkPatSynParent _ (FldParent {}) _ - = return () - -checkPatSynParent parent NoParent mpat_syn - | isUnboundName parent -- Avoid an error cascade - = return () - - | otherwise - = do { parent_ty_con <- tcLookupTyCon parent - ; mpat_syn_thing <- tcLookupGlobal mpat_syn - - -- 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 i) parent_ty_con p - - AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p - - _ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] } - where - psErr = exportErrCtxt "pattern synonym" - selErr = exportErrCtxt "pattern synonym record selector" - - assocClassErr :: SDoc - assocClassErr = text "Pattern synonyms can be bundled only with datatypes." - - handle_pat_syn :: SDoc - -> TyCon -- ^ Parent TyCon - -> PatSyn -- ^ Corresponding bundled PatSyn - -- and pretty printed origin - -> TcM () - handle_pat_syn doc ty_con pat_syn - - -- 2. See note [Types of TyCon] - | not $ isTyConWithSrcDataCons ty_con - = addErrCtxt doc $ failWithTc assocClassErr - - -- 3. Is the head a type variable? - | Nothing <- mtycon - = return () - -- 4. Ok. Check they are actually the same type constructor. - - | Just p_ty_con <- mtycon, p_ty_con /= ty_con - = addErrCtxt doc $ failWithTc typeMismatchError - - -- 5. We passed! - | otherwise - = return () - - where - expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con)) - (_, _, _, _, _, res_ty) = patSynSig pat_syn - mtycon = fst <$> tcSplitTyConApp_maybe res_ty - typeMismatchError :: SDoc - typeMismatchError = - text "Pattern synonyms can only be bundled with matching type constructors" - $$ text "Couldn't match expected type of" - <+> quotes (ppr expected_res_ty) - <+> text "with actual type of" - <+> quotes (ppr res_ty) - - -{-===========================================================================-} -check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo] - -> RnM ExportOccMap -check_occs ie occs avails - -- 'names' and 'fls' are the entities specified by 'ie' - = foldlM check occs names_with_occs - where - -- Each Name specified by 'ie', paired with the OccName used to - -- refer to it in the GlobalRdrEnv - -- (see Note [Representing fields in AvailInfo] in GHC.Types.Avail). - -- - -- We check for export clashes using the selector Name, but need - -- the field label OccName for presenting error messages. - names_with_occs = availsNamesWithOccs avails - - check occs (name, occ) - = case lookupOccEnv occs name_occ of - Nothing -> return (extendOccEnv occs name_occ (name, ie)) - - Just (name', ie') - | name == name' -- Duplicate export - -- But we don't want to warn if the same thing is exported - -- by two different module exports. See ticket #4478. - -> do { warnIfFlag Opt_WarnDuplicateExports - (not (dupExport_ok name ie ie')) - (dupExportWarn occ ie ie') - ; return occs } - - | otherwise -- Same occ name but different names: an error - -> do { global_env <- getGlobalRdrEnv ; - addErr (exportClashErr global_env occ name' name ie' ie) ; - return occs } - where - name_occ = nameOccName name - - -dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool --- The Name 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 } --- --- 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 - -dupExport_ok n ie1 ie2 - = not ( single ie1 || single ie2 - || (explicit_in ie1 && explicit_in ie2) ) - where - explicit_in (IEModuleContents {}) = False -- module M - explicit_in (IEThingAll _ r) - = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..) - explicit_in _ = True - - single IEVar {} = True - single IEThingAbs {} = True - single _ = False - - -dupModuleExport :: ModuleName -> SDoc -dupModuleExport mod - = hsep [text "Duplicate", - quotes (text "Module" <+> ppr mod), - text "in export list"] - -moduleNotImported :: ModuleName -> SDoc -moduleNotImported mod - = hsep [text "The export item", - quotes (text "module" <+> ppr mod), - text "is not imported"] - -nullModuleExport :: ModuleName -> SDoc -nullModuleExport mod - = hsep [text "The export item", - quotes (text "module" <+> ppr mod), - text "exports nothing"] - -missingModuleExportWarn :: ModuleName -> SDoc -missingModuleExportWarn mod - = hsep [text "The export item", - quotes (text "module" <+> ppr mod), - text "is missing an export list"] - - -dodgyExportWarn :: Name -> SDoc -dodgyExportWarn item - = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn) - -exportErrCtxt :: Outputable o => String -> o -> SDoc -exportErrCtxt herald exp = - text "In the" <+> text (herald ++ ":") <+> ppr exp - - -addExportErrCtxt :: (OutputableBndrId p) - => IE (GhcPass p) -> TcM a -> TcM a -addExportErrCtxt ie = addErrCtxt exportCtxt - where - exportCtxt = text "In the export:" <+> ppr ie - -exportItemErr :: IE GhcPs -> SDoc -exportItemErr export_item - = sep [ text "The export item" <+> quotes (ppr export_item), - text "attempts to export constructors or class methods that are not visible here" ] - - -dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc -dupExportWarn occ_name ie1 ie2 - = hsep [quotes (ppr occ_name), - text "is exported by", quotes (ppr ie1), - text "and", quotes (ppr ie2)] - -dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc -dcErrMsg ty_con what_is thing parents = - text "The type constructor" <+> quotes (ppr ty_con) - <+> text "is not the parent of the" <+> text what_is - <+> quotes thing <> char '.' - $$ text (capitalise what_is) - <> text "s can only be exported with their parent type constructor." - $$ (case parents of - [] -> empty - [_] -> text "Parent:" - _ -> text "Parents:") <+> fsep (punctuate comma parents) - -failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a -failWithDcErr parent thing thing_doc parents = do - ty_thing <- tcLookupGlobal thing - failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing) - thing_doc (map ppr parents) - where - tyThingCategory' :: TyThing -> String - tyThingCategory' (AnId i) - | isRecordSelector i = "record selector" - tyThingCategory' i = tyThingCategory i - - -exportClashErr :: GlobalRdrEnv -> OccName - -> Name -> Name - -> IE GhcPs -> IE GhcPs - -> MsgDoc -exportClashErr global_env occ name1 name2 ie1 ie2 - = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon - , ppr_export ie1' name1' - , ppr_export ie2' name2' ] - where - ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> - quotes (ppr_name name)) - 2 (pprNameProvenance (get_gre name))) - - -- DuplicateRecordFields means that nameOccName might be a mangled - -- $sel-prefixed thing, in which case show the correct OccName alone - ppr_name name - | nameOccName name == occ = ppr name - | otherwise = ppr occ - - -- get_gre finds a GRE for the Name, so that we can show its provenance - get_gre name - = fromMaybe (pprPanic "exportClashErr" (ppr name)) - (lookupGRE_Name_OccName global_env name occ) - get_loc name = greSrcSpan (get_gre name) - (name1', ie1', name2', ie2') = - case SrcLoc.leftmost_smallest (get_loc name1) (get_loc name2) of - LT -> (name1, ie1, name2, ie2) - GT -> (name2, ie2, name1, ie1) - EQ -> panic "exportClashErr: clashing exports have idential location" diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs deleted file mode 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ /dev/null @@ -1,1998 +0,0 @@ -{- -(c) The University of Glasgow 2006 - - -Functions for working with the typechecker environment (setters, getters...). --} - -{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# LANGUAGE ViewPatterns #-} - - -module TcRnMonad( - -- * Initialisation - initTc, initTcWithGbl, initTcInteractive, initTcRnIf, - - -- * Simple accessors - discardResult, - getTopEnv, updTopEnv, getGblEnv, updGblEnv, - setGblEnv, getLclEnv, updLclEnv, setLclEnv, - getEnvs, setEnvs, - xoptM, doptM, goptM, woptM, - setXOptM, unsetXOptM, unsetGOptM, unsetWOptM, - whenDOptM, whenGOptM, whenWOptM, - whenXOptM, unlessXOptM, - getGhcMode, - withDoDynamicToo, - getEpsVar, - getEps, - updateEps, updateEps_, - getHpt, getEpsAndHpt, - - -- * Arrow scopes - newArrowScope, escapeArrowScope, - - -- * Unique supply - newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName, - newSysName, newSysLocalId, newSysLocalIds, - - -- * Accessing input/output - newTcRef, readTcRef, writeTcRef, updTcRef, - - -- * Debugging - traceTc, traceRn, traceOptTcRn, dumpOptTcRn, - dumpTcRn, - getPrintUnqualified, - printForUserTcRn, - traceIf, traceHiDiffs, traceOptIf, - debugTc, - - -- * Typechecker global environment - getIsGHCi, getGHCiMonad, getInteractivePrintName, - tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv, - getRdrEnvs, getImports, - getFixityEnv, extendFixityEnv, getRecFieldEnv, - getDeclaredDefaultTys, - addDependentFiles, - - -- * Error management - getSrcSpanM, setSrcSpan, addLocM, - wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_, - getErrsVar, setErrsVar, - addErr, - failWith, failAt, - addErrAt, addErrs, - checkErr, - addMessages, - discardWarnings, - - -- * Shared error message stuff: renamer and typechecker - mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError, - reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, - attemptM, tryTc, - askNoErrs, discardErrs, tryTcDiscardingErrs, - checkNoErrs, whenNoErrs, - ifErrsM, failIfErrsM, - - -- * Context management for the type checker - getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, - addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM, - - -- * Error message generation (type checker) - addErrTc, addErrsTc, - addErrTcM, mkErrTcM, mkErrTc, - failWithTc, failWithTcM, - checkTc, checkTcM, - failIfTc, failIfTcM, - warnIfFlag, warnIf, warnTc, warnTcM, - addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn, - mkErrInfo, - - -- * Type constraints - newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar, - addTcEvBind, addTopEvBinds, - getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, - chooseUniqueOccTc, - getConstraintVar, setConstraintVar, - emitConstraints, emitStaticConstraints, emitSimple, emitSimples, - emitImplication, emitImplications, emitInsoluble, - discardConstraints, captureConstraints, tryCaptureConstraints, - pushLevelAndCaptureConstraints, - pushTcLevelM_, pushTcLevelM, pushTcLevelsM, - getTcLevel, setTcLevel, isTouchableTcM, - getLclTypeEnv, setLclTypeEnv, - traceTcConstraints, - emitNamedWildCardHoleConstraints, emitAnonWildCardHoleConstraint, - - -- * Template Haskell context - recordThUse, recordThSpliceUse, - keepAlive, getStage, getStageAndBindLevel, setStage, - addModFinalizersWithLclEnv, - - -- * Safe Haskell context - recordUnsafeInfer, finalSafeMode, fixSafeInstances, - - -- * Stuff for the renamer's local env - getLocalRdrEnv, setLocalRdrEnv, - - -- * Stuff for interface decls - mkIfLclEnv, - initIfaceTcRn, - initIfaceCheck, - initIfaceLcl, - initIfaceLclWithSubst, - initIfaceLoad, - getIfModule, - failIfM, - forkM_maybe, - forkM, - setImplicitEnvM, - - withException, - - -- * Stuff for cost centres. - ContainsCostCentreState(..), getCCIndexM, - - -- * Types etc. - module TcRnTypes, - module IOEnv - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnTypes -- Re-export all -import IOEnv -- Re-export all -import Constraint -import TcEvidence -import TcOrigin - -import GHC.Hs hiding (LIE) -import GHC.Driver.Types -import GHC.Types.Module -import GHC.Types.Name.Reader -import GHC.Types.Name -import GHC.Core.Type - -import TcType -import GHC.Core.InstEnv -import GHC.Core.FamInstEnv -import PrelNames - -import GHC.Types.Id -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import ErrUtils -import GHC.Types.SrcLoc -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import Bag -import Outputable -import GHC.Types.Unique.Supply -import GHC.Driver.Session -import FastString -import Panic -import Util -import GHC.Types.Annotations -import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) ) -import Maybes -import GHC.Types.CostCentre.State - -import qualified GHC.LanguageExtensions as LangExt - -import Data.IORef -import Control.Monad - -import {-# SOURCE #-} TcEnv ( tcInitTidyEnv ) - -import qualified Data.Map as Map - -{- -************************************************************************ -* * - initTc -* * -************************************************************************ --} - --- | Setup the initial typechecking environment -initTc :: HscEnv - -> HscSource - -> Bool -- True <=> retain renamed syntax trees - -> Module - -> RealSrcSpan - -> TcM r - -> IO (Messages, Maybe r) - -- Nothing => error thrown by the thing inside - -- (error messages should have been printed already) - -initTc hsc_env hsc_src keep_rn_syntax mod loc do_this - = do { keep_var <- newIORef emptyNameSet ; - used_gre_var <- newIORef [] ; - th_var <- newIORef False ; - th_splice_var<- newIORef False ; - infer_var <- newIORef (True, emptyBag) ; - dfun_n_var <- newIORef emptyOccSet ; - type_env_var <- case hsc_type_env_var hsc_env of { - Just (_mod, te_var) -> return te_var ; - Nothing -> newIORef emptyNameEnv } ; - - dependent_files_var <- newIORef [] ; - static_wc_var <- newIORef emptyWC ; - cc_st_var <- newIORef newCostCentreState ; - th_topdecls_var <- newIORef [] ; - th_foreign_files_var <- newIORef [] ; - th_topnames_var <- newIORef emptyNameSet ; - th_modfinalizers_var <- newIORef [] ; - th_coreplugins_var <- newIORef [] ; - th_state_var <- newIORef Map.empty ; - th_remote_state_var <- newIORef Nothing ; - let { - dflags = hsc_dflags hsc_env ; - - maybe_rn_syntax :: forall a. a -> Maybe a ; - maybe_rn_syntax empty_val - | dopt Opt_D_dump_rn_ast dflags = Just empty_val - - | gopt Opt_WriteHie dflags = Just empty_val - - -- We want to serialize the documentation in the .hi-files, - -- and need to extract it from the renamed syntax first. - -- See 'GHC.HsToCore.Docs.extractDocs'. - | gopt Opt_Haddock dflags = Just empty_val - - | keep_rn_syntax = Just empty_val - | otherwise = Nothing ; - - gbl_env = TcGblEnv { - tcg_th_topdecls = th_topdecls_var, - tcg_th_foreign_files = th_foreign_files_var, - tcg_th_topnames = th_topnames_var, - tcg_th_modfinalizers = th_modfinalizers_var, - tcg_th_coreplugins = th_coreplugins_var, - tcg_th_state = th_state_var, - tcg_th_remote_state = th_remote_state_var, - - tcg_mod = mod, - tcg_semantic_mod = - canonicalizeModuleIfHome dflags mod, - tcg_src = hsc_src, - tcg_rdr_env = emptyGlobalRdrEnv, - tcg_fix_env = emptyNameEnv, - tcg_field_env = emptyNameEnv, - tcg_default = if moduleUnitId mod == primUnitId - then Just [] -- See Note [Default types] - else Nothing, - tcg_type_env = emptyNameEnv, - tcg_type_env_var = type_env_var, - tcg_inst_env = emptyInstEnv, - tcg_fam_inst_env = emptyFamInstEnv, - tcg_ann_env = emptyAnnEnv, - tcg_th_used = th_var, - tcg_th_splice_used = th_splice_var, - tcg_exports = [], - tcg_imports = emptyImportAvails, - tcg_used_gres = used_gre_var, - tcg_dus = emptyDUs, - - tcg_rn_imports = [], - tcg_rn_exports = - if hsc_src == HsigFile - -- Always retain renamed syntax, so that we can give - -- better errors. (TODO: how?) - then Just [] - else maybe_rn_syntax [], - tcg_rn_decls = maybe_rn_syntax emptyRnGroup, - tcg_tr_module = Nothing, - tcg_binds = emptyLHsBinds, - tcg_imp_specs = [], - tcg_sigs = emptyNameSet, - tcg_ev_binds = emptyBag, - tcg_warns = NoWarnings, - tcg_anns = [], - tcg_tcs = [], - tcg_insts = [], - tcg_fam_insts = [], - tcg_rules = [], - tcg_fords = [], - tcg_patsyns = [], - tcg_merged = [], - tcg_dfun_n = dfun_n_var, - tcg_keep = keep_var, - tcg_doc_hdr = Nothing, - tcg_hpc = False, - tcg_main = Nothing, - tcg_self_boot = NoSelfBoot, - tcg_safeInfer = infer_var, - tcg_dependent_files = dependent_files_var, - tcg_tc_plugins = [], - tcg_hf_plugins = [], - tcg_top_loc = loc, - tcg_static_wc = static_wc_var, - tcg_complete_matches = [], - tcg_cc_st = cc_st_var - } ; - } ; - - -- OK, here's the business end! - initTcWithGbl hsc_env gbl_env loc do_this - } - --- | Run a 'TcM' action in the context of an existing 'GblEnv'. -initTcWithGbl :: HscEnv - -> TcGblEnv - -> RealSrcSpan - -> TcM r - -> IO (Messages, Maybe r) -initTcWithGbl hsc_env gbl_env loc do_this - = do { lie_var <- newIORef emptyWC - ; errs_var <- newIORef (emptyBag, emptyBag) - ; let lcl_env = TcLclEnv { - tcl_errs = errs_var, - tcl_loc = loc, -- Should be over-ridden very soon! - tcl_ctxt = [], - tcl_rdr = emptyLocalRdrEnv, - tcl_th_ctxt = topStage, - tcl_th_bndrs = emptyNameEnv, - tcl_arrow_ctxt = NoArrowCtxt, - tcl_env = emptyNameEnv, - tcl_bndrs = [], - tcl_lie = lie_var, - tcl_tclvl = topTcLevel - } - - ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ - do { r <- tryM do_this - ; case r of - Right res -> return (Just res) - Left _ -> return Nothing } - - -- Check for unsolved constraints - -- If we succeed (maybe_res = Just r), there should be - -- no unsolved constraints. But if we exit via an - -- exception (maybe_res = Nothing), we may have skipped - -- solving, so don't panic then (#13466) - ; lie <- readIORef (tcl_lie lcl_env) - ; when (isJust maybe_res && not (isEmptyWC lie)) $ - pprPanic "initTc: unsolved constraints" (ppr lie) - - -- Collect any error messages - ; msgs <- readIORef (tcl_errs lcl_env) - - ; let { final_res | errorsFound dflags msgs = Nothing - | otherwise = maybe_res } - - ; return (msgs, final_res) - } - where dflags = hsc_dflags hsc_env - -initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a) --- Initialise the type checker monad for use in GHCi -initTcInteractive hsc_env thing_inside - = initTc hsc_env HsSrcFile False - (icInteractiveModule (hsc_IC hsc_env)) - (realSrcLocSpan interactive_src_loc) - thing_inside - where - interactive_src_loc = mkRealSrcLoc (fsLit "") 1 1 - -{- Note [Default types] -~~~~~~~~~~~~~~~~~~~~~~~ -The Integer type is simply not available in package ghc-prim (it is -declared in integer-gmp). So we set the defaulting types to (Just -[]), meaning there are no default types, rather then Nothing, which -means "use the default default types of Integer, Double". - -If you don't do this, attempted defaulting in package ghc-prim causes -an actual crash (attempting to look up the Integer type). - - -************************************************************************ -* * - Initialisation -* * -************************************************************************ --} - -initTcRnIf :: Char -- ^ Mask for unique supply - -> HscEnv - -> gbl -> lcl - -> TcRnIf gbl lcl a - -> IO a -initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside - = do { let { env = Env { env_top = hsc_env, - env_um = uniq_mask, - env_gbl = gbl_env, - env_lcl = lcl_env} } - - ; runIOEnv env thing_inside - } - -{- -************************************************************************ -* * - Simple accessors -* * -************************************************************************ --} - -discardResult :: TcM a -> TcM () -discardResult a = a >> return () - -getTopEnv :: TcRnIf gbl lcl HscEnv -getTopEnv = do { env <- getEnv; return (env_top env) } - -updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -updTopEnv upd = updEnv (\ env@(Env { env_top = top }) -> - env { env_top = upd top }) - -getGblEnv :: TcRnIf gbl lcl gbl -getGblEnv = do { Env{..} <- getEnv; return env_gbl } - -updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> - env { env_gbl = upd gbl }) - -setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env }) - -getLclEnv :: TcRnIf gbl lcl lcl -getLclEnv = do { Env{..} <- getEnv; return env_lcl } - -updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> - env { env_lcl = upd lcl }) - -setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a -setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) - -getEnvs :: TcRnIf gbl lcl (gbl, lcl) -getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } - -setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a -setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env }) - --- Command-line flags - -xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool -xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) } - -doptM :: DumpFlag -> TcRnIf gbl lcl Bool -doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) } - -goptM :: GeneralFlag -> TcRnIf gbl lcl Bool -goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) } - -woptM :: WarningFlag -> TcRnIf gbl lcl Bool -woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) } - -setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -setXOptM flag = - updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag}) - -unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetXOptM flag = - updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag}) - -unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetGOptM flag = - updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag}) - -unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetWOptM flag = - updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag}) - --- | Do it flag is true -whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenDOptM flag thing_inside = do b <- doptM flag - when b thing_inside - -whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenGOptM flag thing_inside = do b <- goptM flag - when b thing_inside - -whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenWOptM flag thing_inside = do b <- woptM flag - when b thing_inside - -whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenXOptM flag thing_inside = do b <- xoptM flag - when b thing_inside - -unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -unlessXOptM flag thing_inside = do b <- xoptM flag - unless b thing_inside - -getGhcMode :: TcRnIf gbl lcl GhcMode -getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } - -withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a -withDoDynamicToo = - updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) -> - top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags }) - -getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) -getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } - -getEps :: TcRnIf gbl lcl ExternalPackageState -getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) } - --- | Update the external package state. Returns the second result of the --- modifier function. --- --- This is an atomic operation and forces evaluation of the modified EPS in --- order to avoid space leaks. -updateEps :: (ExternalPackageState -> (ExternalPackageState, a)) - -> TcRnIf gbl lcl a -updateEps upd_fn = do - traceIf (text "updating EPS") - eps_var <- getEpsVar - atomicUpdMutVar' eps_var upd_fn - --- | Update the external package state. --- --- This is an atomic operation and forces evaluation of the modified EPS in --- order to avoid space leaks. -updateEps_ :: (ExternalPackageState -> ExternalPackageState) - -> TcRnIf gbl lcl () -updateEps_ upd_fn = do - traceIf (text "updating EPS_") - eps_var <- getEpsVar - atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ())) - -getHpt :: TcRnIf gbl lcl HomePackageTable -getHpt = do { env <- getTopEnv; return (hsc_HPT env) } - -getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) -getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) - ; return (eps, hsc_HPT env) } - --- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing --- an exception if it is an error. -withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a -withException do_this = do - r <- do_this - dflags <- getDynFlags - case r of - Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) - Succeeded result -> return result - -{- -************************************************************************ -* * - Arrow scopes -* * -************************************************************************ --} - -newArrowScope :: TcM a -> TcM a -newArrowScope - = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) } - --- Return to the stored environment (from the enclosing proc) -escapeArrowScope :: TcM a -> TcM a -escapeArrowScope - = updLclEnv $ \ env -> - case tcl_arrow_ctxt env of - NoArrowCtxt -> env - ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt - , tcl_lie = lie - , tcl_rdr = rdr_env } - -{- -************************************************************************ -* * - Unique supply -* * -************************************************************************ --} - -newUnique :: TcRnIf gbl lcl Unique -newUnique - = do { env <- getEnv - ; let mask = env_um env - ; liftIO $! uniqFromMask mask } - -newUniqueSupply :: TcRnIf gbl lcl UniqSupply -newUniqueSupply - = do { env <- getEnv - ; let mask = env_um env - ; liftIO $! mkSplitUniqSupply mask } - -cloneLocalName :: Name -> TcM Name --- Make a fresh Internal name with the same OccName and SrcSpan -cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name) - -newName :: OccName -> TcM Name -newName occ = do { loc <- getSrcSpanM - ; newNameAt occ loc } - -newNameAt :: OccName -> SrcSpan -> TcM Name -newNameAt occ span - = do { uniq <- newUnique - ; return (mkInternalName uniq occ span) } - -newSysName :: OccName -> TcRnIf gbl lcl Name -newSysName occ - = do { uniq <- newUnique - ; return (mkSystemName uniq occ) } - -newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId -newSysLocalId fs ty - = do { u <- newUnique - ; return (mkSysLocal fs u ty) } - -newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] -newSysLocalIds fs tys - = do { us <- newUniqueSupply - ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } - -instance MonadUnique (IOEnv (Env gbl lcl)) where - getUniqueM = newUnique - getUniqueSupplyM = newUniqueSupply - -{- -************************************************************************ -* * - 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 $ do { old <- readIORef ref - ; writeIORef ref (fn old) } - -{- -************************************************************************ -* * - Debugging -* * -************************************************************************ --} - - --- Typechecker trace -traceTc :: String -> SDoc -> TcRn () -traceTc = - labelledTraceOptTcRn Opt_D_dump_tc_trace - --- Renamer Trace -traceRn :: String -> SDoc -> TcRn () -traceRn = - labelledTraceOptTcRn Opt_D_dump_rn_trace - --- | Trace when a certain flag is enabled. This is like `traceOptTcRn` --- but accepts a string as a label and formats the trace message uniformly. -labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn () -labelledTraceOptTcRn flag herald doc = do - traceOptTcRn flag (formatTraceMsg herald doc) - -formatTraceMsg :: String -> SDoc -> SDoc -formatTraceMsg herald doc = hang (text herald) 2 doc - --- | Trace if the given 'DumpFlag' is set. -traceOptTcRn :: DumpFlag -> SDoc -> TcRn () -traceOptTcRn flag doc = do - dflags <- getDynFlags - when (dopt flag dflags) $ - dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc - --- | Dump if the given 'DumpFlag' is set. -dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () -dumpOptTcRn flag title fmt doc = do - dflags <- getDynFlags - when (dopt flag dflags) $ - dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc - --- | Unconditionally dump some trace output --- --- Certain tests (T3017, Roles3, T12763 etc.) expect part of the --- output generated by `-ddump-types` to be in 'PprUser' style. However, --- generally we want all other debugging output to use 'PprDump' --- style. We 'PprUser' style if 'useUserStyle' is True. --- -dumpTcRn :: Bool -> DumpOptions -> String -> DumpFormat -> SDoc -> TcRn () -dumpTcRn useUserStyle dumpOpt title fmt doc = do - dflags <- getDynFlags - printer <- getPrintUnqualified dflags - real_doc <- wrapDocLoc doc - let sty = if useUserStyle - then mkUserStyle dflags printer AllTheWay - else mkDumpStyle dflags printer - liftIO $ dumpAction dflags sty dumpOpt title fmt real_doc - --- | Add current location if -dppr-debug --- (otherwise the full location is usually way too much) -wrapDocLoc :: SDoc -> TcRn SDoc -wrapDocLoc doc = do - dflags <- getDynFlags - if hasPprDebug dflags - then do - loc <- getSrcSpanM - return (mkLocMessage SevOutput loc doc) - else - return doc - -getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified -getPrintUnqualified dflags - = do { rdr_env <- getGlobalRdrEnv - ; return $ mkPrintUnqualified dflags rdr_env } - --- | Like logInfoTcRn, but for user consumption -printForUserTcRn :: SDoc -> TcRn () -printForUserTcRn doc - = do { dflags <- getDynFlags - ; printer <- getPrintUnqualified dflags - ; liftIO (printOutputForUser dflags printer doc) } - -{- -traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is -available. Alas, they behave inconsistently with the other stuff; -e.g. are unaffected by -dump-to-file. --} - -traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () -traceIf = traceOptIf Opt_D_dump_if_trace -traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs - - -traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () -traceOptIf flag doc - = whenDOptM flag $ -- No RdrEnv available, so qualify everything - do { dflags <- getDynFlags - ; liftIO (putMsg dflags doc) } - -{- -************************************************************************ -* * - Typechecker global environment -* * -************************************************************************ --} - -getIsGHCi :: TcRn Bool -getIsGHCi = do { mod <- getModule - ; return (isInteractiveModule mod) } - -getGHCiMonad :: TcRn Name -getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } - -getInteractivePrintName :: TcRn Name -getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) } - -tcIsHsBootOrSig :: TcRn Bool -tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) } - -tcIsHsig :: TcRn Bool -tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) } - -tcSelfBootInfo :: TcRn SelfBootInfo -tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) } - -getGlobalRdrEnv :: TcRn GlobalRdrEnv -getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } - -getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) -getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) } - -getImports :: TcRn ImportAvails -getImports = do { env <- getGblEnv; return (tcg_imports env) } - -getFixityEnv :: TcRn FixityEnv -getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) } - -extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a -extendFixityEnv new_bit - = 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) } - -addDependentFiles :: [FilePath] -> TcRn () -addDependentFiles fs = do - ref <- fmap tcg_dependent_files getGblEnv - dep_files <- readTcRef ref - writeTcRef ref (fs ++ dep_files) - -{- -************************************************************************ -* * - Error management -* * -************************************************************************ --} - -getSrcSpanM :: TcRn SrcSpan - -- Avoid clash with Name.getSrcLoc -getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) } - -setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -setSrcSpan (RealSrcSpan real_loc _) thing_inside - = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside --- Don't overwrite useful info with useless: -setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside - -addLocM :: (a -> TcM b) -> Located a -> TcM b -addLocM fn (L loc a) = setSrcSpan loc $ fn a - -wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) --- wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a - ; return (L loc b) } - -wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) -wrapLocFstM fn (L loc a) = - setSrcSpan loc $ do - (b,c) <- fn a - return (L loc b, c) - -wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c) -wrapLocSndM fn (L loc a) = - setSrcSpan loc $ do - (b,c) <- fn a - return (b, L loc c) - -wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM () -wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a) - --- Reporting errors - -getErrsVar :: TcRn (TcRef Messages) -getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } - -setErrsVar :: TcRef Messages -> TcRn a -> TcRn a -setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) - -addErr :: MsgDoc -> TcRn () -addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } - -failWith :: MsgDoc -> TcRn a -failWith msg = addErr msg >> failM - -failAt :: SrcSpan -> MsgDoc -> TcRn a -failAt loc msg = addErrAt loc msg >> failM - -addErrAt :: SrcSpan -> MsgDoc -> TcRn () --- addErrAt is mainly (exclusively?) used by the renamer, where --- 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 - ; err_info <- mkErrInfo tidy_env ctxt - ; addLongErrAt loc msg err_info } - -addErrs :: [(SrcSpan,MsgDoc)] -> TcRn () -addErrs msgs = mapM_ add msgs - where - add (loc,msg) = addErrAt loc msg - -checkErr :: Bool -> MsgDoc -> TcRn () --- Add the error if the bool is False -checkErr ok msg = unless ok (addErr msg) - -addMessages :: Messages -> TcRn () -addMessages msgs1 - = do { errs_var <- getErrsVar ; - msgs0 <- readTcRef errs_var ; - writeTcRef errs_var (unionMessages msgs0 msgs1) } - -discardWarnings :: TcRn a -> TcRn a --- Ignore warnings inside the thing inside; --- used to ignore-unused-variable warnings inside derived code -discardWarnings thing_inside - = do { errs_var <- getErrsVar - ; (old_warns, _) <- readTcRef errs_var - - ; result <- thing_inside - - -- Revert warnings to old_warns - ; (_new_warns, new_errs) <- readTcRef errs_var - ; writeTcRef errs_var (old_warns, new_errs) - - ; return result } - -{- -************************************************************************ -* * - Shared error message stuff: renamer and typechecker -* * -************************************************************************ --} - -mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg -mkLongErrAt loc msg extra - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; - return $ mkLongErrMsg dflags loc printer msg extra } - -mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg -mkErrDocAt loc errDoc - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; - return $ mkErrDoc dflags loc printer errDoc } - -addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () -addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError - -reportErrors :: [ErrMsg] -> TcM () -reportErrors = mapM_ reportError - -reportError :: ErrMsg -> TcRn () -reportError err - = do { traceTc "Adding error:" (pprLocErrMsg err) ; - errs_var <- getErrsVar ; - (warns, errs) <- readTcRef errs_var ; - writeTcRef errs_var (warns, errs `snocBag` err) } - -reportWarning :: WarnReason -> ErrMsg -> TcRn () -reportWarning reason err - = do { let warn = makeIntoWarning reason err - -- 'err' was built by mkLongErrMsg or something like that, - -- so it's of error severity. For a warning we downgrade - -- its severity to SevWarning - - ; traceTc "Adding warning:" (pprLocErrMsg warn) - ; errs_var <- getErrsVar - ; (warns, errs) <- readTcRef errs_var - ; writeTcRef errs_var (warns `snocBag` warn, errs) } - - ------------------------ -checkNoErrs :: TcM r -> TcM r --- (checkNoErrs m) succeeds iff m succeeds and generates no errors --- If m fails then (checkNoErrsTc m) fails. --- If m succeeds, it checks whether m generated any errors messages --- (it might have recovered internally) --- If so, it fails too. --- Regardless, any errors generated by m are propagated to the enclosing context. -checkNoErrs main - = do { (res, no_errs) <- askNoErrs main - ; unless no_errs failM - ; return res } - ------------------------ -whenNoErrs :: TcM () -> TcM () -whenNoErrs thing = ifErrsM (return ()) thing - -ifErrsM :: TcRn r -> TcRn r -> TcRn r --- ifErrsM bale_out normal --- does 'bale_out' if there are errors in errors collection --- otherwise does 'normal' -ifErrsM bale_out normal - = do { errs_var <- getErrsVar ; - msgs <- readTcRef errs_var ; - dflags <- getDynFlags ; - if errorsFound dflags msgs then - bale_out - else - normal } - -failIfErrsM :: TcRn () --- Useful to avoid error cascades -failIfErrsM = ifErrsM failM (return ()) - -{- ********************************************************************* -* * - Context management for the type checker -* * -************************************************************************ --} - -getErrCtxt :: TcM [ErrCtxt] -getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } - -setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a -setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) - --- | Add a fixed message to the error context. This message should not --- do any tidying. -addErrCtxt :: MsgDoc -> TcM a -> TcM a -addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) - --- | Add a message to the error context. This message may do tidying. -addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a -addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts) - --- | Add a fixed landmark message to the error context. A landmark --- message is always sure to be reported, even if there is a lot of --- context. It also doesn't count toward the maximum number of contexts --- reported. -addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a -addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) - --- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations --- and tidying. -addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a -addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts) - --- Helper function for the above -updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a -updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> - env { tcl_ctxt = upd ctxt }) - -popErrCtxt :: TcM a -> TcM a -popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) - -getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc -getCtLocM origin t_or_k - = do { env <- getLclEnv - ; return (CtLoc { ctl_origin = origin - , ctl_env = env - , ctl_t_or_k = t_or_k - , ctl_depth = initialSubGoalDepth }) } - -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 - - -{- ********************************************************************* -* * - Error recovery and exceptions -* * -********************************************************************* -} - -tcTryM :: TcRn r -> TcRn (Maybe r) --- The most basic function: catch the exception --- Nothing => an exception happened --- Just r => no exception, result R --- Errors and constraints are propagated in both cases --- Never throws an exception -tcTryM thing_inside - = do { either_res <- tryM thing_inside - ; return (case either_res of - Left _ -> Nothing - Right r -> Just r) } - -- In the Left case the exception is always the IOEnv - -- built-in in exception; see IOEnv.failM - ------------------------ -capture_constraints :: TcM r -> TcM (r, WantedConstraints) --- capture_constraints simply captures and returns the --- constraints 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 lie_var, and we'd lose the constraints altogether -capture_constraints thing_inside - = do { lie_var <- newTcRef emptyWC - ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $ - thing_inside - ; lie <- readTcRef lie_var - ; return (res, lie) } - -capture_messages :: TcM r -> TcM (r, Messages) --- capture_messages simply captures and returns the --- errors arnd 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 -capture_messages thing_inside - = do { msg_var <- newTcRef emptyMessages - ; res <- setErrsVar msg_var thing_inside - ; msgs <- readTcRef msg_var - ; return (res, msgs) } - ------------------------ --- (askNoErrs m) runs m --- If m fails, --- then (askNoErrs m) fails, propagating only --- insoluble constraints --- --- If m succeeds with result r, --- then (askNoErrs m) succeeds with result (r, b), --- where b is True iff m generated no errors --- --- Regardless of success or failure, --- propagate any errors/warnings generated by m -askNoErrs :: TcRn a -> TcRn (a, Bool) -askNoErrs thing_inside - = do { ((mb_res, lie), msgs) <- capture_messages $ - capture_constraints $ - tcTryM thing_inside - ; addMessages msgs - - ; case mb_res of - Nothing -> do { emitConstraints (insolublesOnly lie) - ; failM } - - Just res -> do { emitConstraints lie - ; dflags <- getDynFlags - ; let errs_found = errorsFound dflags msgs - || insolubleWC lie - ; return (res, not errs_found) } } - ------------------------ -tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints) --- (tryCaptureConstraints_maybe m) runs m, --- and returns the type constraints it generates --- It never throws an exception; instead if thing_inside fails, --- it returns Nothing and the /insoluble/ constraints --- Error messages are propagated -tryCaptureConstraints thing_inside - = do { (mb_res, lie) <- capture_constraints $ - tcTryM thing_inside - - -- See Note [Constraints and errors] - ; let lie_to_keep = case mb_res of - Nothing -> insolublesOnly lie - Just {} -> lie - - ; return (mb_res, lie_to_keep) } - -captureConstraints :: TcM a -> TcM (a, WantedConstraints) --- (captureConstraints m) runs m, and returns the type constraints it generates --- If thing_inside fails (throwing an exception), --- then (captureConstraints thing_inside) fails too --- propagating the insoluble constraints only --- Error messages are propagated in either case -captureConstraints thing_inside - = do { (mb_res, lie) <- tryCaptureConstraints thing_inside - - -- See Note [Constraints and errors] - -- If the thing_inside threw an exception, emit the insoluble - -- constraints only (returned by tryCaptureConstraints) - -- so that they are not lost - ; case mb_res of - Nothing -> do { emitConstraints lie; failM } - Just res -> return (res, lie) } - ------------------------ -attemptM :: TcRn r -> TcRn (Maybe r) --- (attemptM thing_inside) runs thing_inside --- If thing_inside succeeds, returning r, --- we return (Just r), and propagate all constraints and errors --- If thing_inside fail, throwing an exception, --- we return Nothing, propagating insoluble constraints, --- and all errors --- attemptM never throws an exception -attemptM thing_inside - = do { (mb_r, lie) <- tryCaptureConstraints thing_inside - ; emitConstraints lie - - -- Debug trace - ; when (isNothing mb_r) $ - traceTc "attemptM recovering with insoluble constraints" $ - (ppr lie) - - ; return mb_r } - ------------------------ -recoverM :: TcRn r -- Recovery action; do this if the main one fails - -> TcRn r -- Main action: do this first; - -- if it generates errors, propagate them all - -> TcRn r --- (recoverM recover thing_inside) runs thing_inside --- If thing_inside fails, propagate its errors and insoluble constraints --- and run 'recover' --- If thing_inside succeeds, propagate all its errors and constraints --- --- Can fail, if 'recover' fails -recoverM recover thing - = do { mb_res <- attemptM thing ; - case mb_res of - Nothing -> recover - Just res -> return res } - ------------------------ - --- | Drop elements of the input that fail, so the result --- list can be shorter than the argument list -mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] -mapAndRecoverM f xs - = do { mb_rs <- mapM (attemptM . f) xs - ; return [r | Just r <- mb_rs] } - --- | Apply the function to all elements on the input list --- If all succeed, return the list of results --- Otherwise fail, propagating all errors -mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b] -mapAndReportM f xs - = do { mb_rs <- mapM (attemptM . f) xs - ; when (any isNothing mb_rs) failM - ; return [r | Just r <- mb_rs] } - --- | The accumulator is not updated if the action fails -foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b -foldAndRecoverM _ acc [] = return acc -foldAndRecoverM f acc (x:xs) = - do { mb_r <- attemptM (f acc x) - ; case mb_r of - Nothing -> foldAndRecoverM f acc xs - Just acc' -> foldAndRecoverM f acc' xs } - ------------------------ -tryTc :: TcRn a -> TcRn (Maybe a, Messages) --- (tryTc m) executes m, and returns --- Just r, if m succeeds (returning r) --- Nothing, if m fails --- It also returns all the errors and warnings accumulated by m --- It always succeeds (never raises an exception) -tryTc thing_inside - = capture_messages (attemptM thing_inside) - ------------------------ -discardErrs :: TcRn a -> TcRn a --- (discardErrs m) runs m, --- discarding all error messages and warnings generated by m --- If m fails, discardErrs fails, and vice versa -discardErrs m - = do { errs_var <- newTcRef emptyMessages - ; setErrsVar errs_var m } - ------------------------ -tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r --- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside'; --- if 'main' succeeds with no error messages, it's the answer --- otherwise discard everything from 'main', including errors, --- and try 'recover' instead. -tryTcDiscardingErrs recover thing_inside - = do { ((mb_res, lie), msgs) <- capture_messages $ - capture_constraints $ - tcTryM thing_inside - ; dflags <- getDynFlags - ; case mb_res of - Just res | not (errorsFound dflags msgs) - , not (insolubleWC lie) - -> -- 'main' succeeded with no errors - do { addMessages msgs -- msgs might still have warnings - ; emitConstraints lie - ; return res } - - _ -> -- 'main' failed, or produced an error message - recover -- Discard all errors and warnings - -- and unsolved constraints entirely - } - -{- -************************************************************************ -* * - Error message generation (type checker) -* * -************************************************************************ - - The addErrTc functions add an error message, but do not cause failure. - The 'M' variants pass a TidyEnv that has already been used to - tidy up the message; we then use it to tidy the context messages --} - -addErrTc :: MsgDoc -> TcM () -addErrTc err_msg = do { env0 <- tcInitTidyEnv - ; addErrTcM (env0, err_msg) } - -addErrsTc :: [MsgDoc] -> TcM () -addErrsTc err_msgs = mapM_ addErrTc err_msgs - -addErrTcM :: (TidyEnv, MsgDoc) -> TcM () -addErrTcM (tidy_env, err_msg) - = do { ctxt <- getErrCtxt ; - loc <- getSrcSpanM ; - add_err_tcm tidy_env err_msg loc ctxt } - --- Return the error message, instead of reporting it straight away -mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg -mkErrTcM (tidy_env, err_msg) - = do { ctxt <- getErrCtxt ; - loc <- getSrcSpanM ; - err_info <- mkErrInfo tidy_env ctxt ; - mkLongErrAt loc err_msg err_info } - -mkErrTc :: MsgDoc -> TcM ErrMsg -mkErrTc msg = do { env0 <- tcInitTidyEnv - ; mkErrTcM (env0, msg) } - --- The failWith functions add an error message and cause failure - -failWithTc :: MsgDoc -> TcM a -- Add an error message and fail -failWithTc err_msg - = addErrTc err_msg >> failM - -failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail -failWithTcM local_and_msg - = addErrTcM local_and_msg >> failM - -checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true -checkTc True _ = return () -checkTc False err = failWithTc err - -checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () -checkTcM True _ = return () -checkTcM False err = failWithTcM err - -failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false -failIfTc False _ = return () -failIfTc True err = failWithTc err - -failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () - -- Check that the boolean is false -failIfTcM False _ = return () -failIfTcM True err = failWithTcM err - - --- Warnings have no 'M' variant, nor failure - --- | Display a warning if a condition is met, --- and the warning is enabled -warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn () -warnIfFlag warn_flag is_bad msg - = do { warn_on <- woptM warn_flag - ; when (warn_on && is_bad) $ - addWarn (Reason warn_flag) msg } - --- | Display a warning if a condition is met. -warnIf :: Bool -> MsgDoc -> TcRn () -warnIf is_bad msg - = when is_bad (addWarn NoReason msg) - --- | Display a warning if a condition is met. -warnTc :: WarnReason -> Bool -> MsgDoc -> TcM () -warnTc reason warn_if_true warn_msg - | warn_if_true = addWarnTc reason warn_msg - | otherwise = return () - --- | Display a warning if a condition is met. -warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM () -warnTcM reason warn_if_true warn_msg - | warn_if_true = addWarnTcM reason warn_msg - | otherwise = return () - --- | Display a warning in the current context. -addWarnTc :: WarnReason -> MsgDoc -> TcM () -addWarnTc reason msg - = do { env0 <- tcInitTidyEnv ; - addWarnTcM reason (env0, msg) } - --- | Display a warning in a given context. -addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM () -addWarnTcM reason (env0, msg) - = do { ctxt <- getErrCtxt ; - err_info <- mkErrInfo env0 ctxt ; - add_warn reason msg err_info } - --- | Display a warning for the current source location. -addWarn :: WarnReason -> MsgDoc -> TcRn () -addWarn reason msg = add_warn reason msg Outputable.empty - --- | Display a warning for a given source location. -addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn () -addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty - --- | Display a warning, with an optional flag, for the current source --- location. -add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn () -add_warn reason msg extra_info - = do { loc <- getSrcSpanM - ; add_warn_at reason loc msg extra_info } - --- | Display a warning, with an optional flag, for a given location. -add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn () -add_warn_at reason loc msg extra_info - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; - let { warn = mkLongWarnMsg dflags loc printer - msg extra_info } ; - reportWarning reason warn } - - -{- ------------------------------------ - Other helper functions --} - -add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan - -> [ErrCtxt] - -> TcM () -add_err_tcm tidy_env err_msg loc ctxt - = do { err_info <- mkErrInfo tidy_env ctxt ; - addLongErrAt loc err_msg err_info } - -mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc --- Tidy the error info, trimming excessive contexts -mkErrInfo env ctxts --- = do --- dbg <- hasPprDebug <$> getDynFlags --- if dbg -- In -dppr-debug style the output --- then return empty -- just becomes too voluminous --- else go dbg 0 env ctxts - = go False 0 env ctxts - where - go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc - go _ _ _ [] = return empty - go dbg n env ((is_landmark, ctxt) : ctxts) - | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg - = do { (env', msg) <- ctxt env - ; let n' = if is_landmark then n else n+1 - ; rest <- go dbg n' env' ctxts - ; return (msg $$ rest) } - | otherwise - = go dbg n env ctxts - -mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts -mAX_CONTEXTS = 3 - --- debugTc is useful for monadic debugging code - -debugTc :: TcM () -> TcM () -debugTc thing - | debugIsOn = thing - | otherwise = return () - -{- -************************************************************************ -* * - Type constraints -* * -************************************************************************ --} - -addTopEvBinds :: Bag EvBind -> TcM a -> TcM a -addTopEvBinds new_ev_binds thing_inside - =updGblEnv upd_env thing_inside - where - upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env - `unionBags` new_ev_binds } - -newTcEvBinds :: TcM EvBindsVar -newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap - ; tcvs_ref <- newTcRef emptyVarSet - ; uniq <- newUnique - ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq) - ; return (EvBindsVar { ebv_binds = binds_ref - , ebv_tcvs = tcvs_ref - , ebv_uniq = uniq }) } - --- | Creates an EvBindsVar incapable of holding any bindings. It still --- tracks covar usages (see comments on ebv_tcvs in TcEvidence), thus --- must be made monadically -newNoTcEvBinds :: TcM EvBindsVar -newNoTcEvBinds - = do { tcvs_ref <- newTcRef emptyVarSet - ; uniq <- newUnique - ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq) - ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref - , ebv_uniq = uniq }) } - -cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar --- Clone the refs, so that any binding created when --- solving don't pollute the original -cloneEvBindsVar ebv@(EvBindsVar {}) - = do { binds_ref <- newTcRef emptyEvBindMap - ; tcvs_ref <- newTcRef emptyVarSet - ; return (ebv { ebv_binds = binds_ref - , ebv_tcvs = tcvs_ref }) } -cloneEvBindsVar ebv@(CoEvBindsVar {}) - = do { tcvs_ref <- newTcRef emptyVarSet - ; return (ebv { ebv_tcvs = tcvs_ref }) } - -getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet -getTcEvTyCoVars ev_binds_var - = readTcRef (ebv_tcvs ev_binds_var) - -getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap -getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) - = readTcRef ev_ref -getTcEvBindsMap (CoEvBindsVar {}) - = return emptyEvBindMap - -setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM () -setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds - = writeTcRef ev_ref binds -setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds - | isEmptyEvBindMap ev_binds - = return () - | otherwise - = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds) - -addTcEvBind :: EvBindsVar -> EvBind -> TcM () --- Add a binding to the TcEvBinds by side effect -addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind - = do { traceTc "addTcEvBind" $ ppr u $$ - ppr ev_bind - ; bnds <- readTcRef ev_ref - ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) } -addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind - = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u) - -chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName -chooseUniqueOccTc fn = - do { env <- getGblEnv - ; let dfun_n_var = tcg_dfun_n env - ; set <- readTcRef dfun_n_var - ; let occ = fn set - ; writeTcRef dfun_n_var (extendOccSet set occ) - ; return occ } - -getConstraintVar :: TcM (TcRef WantedConstraints) -getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) } - -setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a -setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var }) - -emitStaticConstraints :: WantedConstraints -> TcM () -emitStaticConstraints static_lie - = do { gbl_env <- getGblEnv - ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) } - -emitConstraints :: WantedConstraints -> TcM () -emitConstraints ct - | isEmptyWC ct - = return () - | otherwise - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`andWC` ct) } - -emitSimple :: Ct -> TcM () -emitSimple ct - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addSimples` unitBag ct) } - -emitSimples :: Cts -> TcM () -emitSimples cts - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addSimples` cts) } - -emitImplication :: Implication -> TcM () -emitImplication ct - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addImplics` unitBag ct) } - -emitImplications :: Bag Implication -> TcM () -emitImplications ct - = unless (isEmptyBag ct) $ - 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) } - -emitInsolubles :: Cts -> TcM () -emitInsolubles cts - | isEmptyBag cts = return () - | otherwise = do { traceTc "emitInsolubles" (ppr cts) - ; lie_var <- getConstraintVar - ; updTcRef lie_var (`addInsols` cts) } - --- | Throw out any constraints emitted by the thing_inside -discardConstraints :: TcM a -> TcM a -discardConstraints thing_inside = fst <$> captureConstraints thing_inside - --- | The name says it all. The returned TcLevel is the *inner* TcLevel. -pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) -pushLevelAndCaptureConstraints thing_inside - = do { env <- getLclEnv - ; let tclvl' = pushTcLevel (tcl_tclvl env) - ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl') - ; (res, lie) <- setLclEnv (env { tcl_tclvl = 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 :: TcM a -> TcM (TcLevel, a) --- See Note [TcLevel assignment] in TcType -pushTcLevelM thing_inside - = do { env <- getLclEnv - ; let tclvl' = pushTcLevel (tcl_tclvl env) - ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) - thing_inside - ; return (tclvl', res) } - --- Returns pushed TcLevel -pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel) -pushTcLevelsM num_levels thing_inside - = do { env <- getLclEnv - ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env) - ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $ - thing_inside - ; return (res, tclvl') } - -getTcLevel :: TcM TcLevel -getTcLevel = do { env <- getLclEnv - ; return (tcl_tclvl env) } - -setTcLevel :: TcLevel -> TcM a -> TcM a -setTcLevel tclvl thing_inside - = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside - -isTouchableTcM :: TcTyVar -> TcM Bool -isTouchableTcM tv - = do { lvl <- getTcLevel - ; return (isTouchableMetaTyVar lvl tv) } - -getLclTypeEnv :: TcM TcTypeEnv -getLclTypeEnv = do { env <- getLclEnv; return (tcl_env 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 } - -traceTcConstraints :: String -> TcM () -traceTcConstraints msg - = do { lie_var <- getConstraintVar - ; lie <- readTcRef lie_var - ; traceOptTcRn Opt_D_dump_tc_trace $ - hang (text (msg ++ ": LIE:")) 2 (ppr lie) - } - -emitAnonWildCardHoleConstraint :: TcTyVar -> TcM () -emitAnonWildCardHoleConstraint tv - = do { ct_loc <- getCtLocM HoleOrigin Nothing - ; emitInsolubles $ unitBag $ - CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv - , ctev_loc = ct_loc } - , cc_occ = mkTyVarOcc "_" - , cc_hole = TypeHole } } - -emitNamedWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM () -emitNamedWildCardHoleConstraints wcs - = do { ct_loc <- getCtLocM HoleOrigin Nothing - ; emitInsolubles $ listToBag $ - map (do_one ct_loc) wcs } - where - do_one :: CtLoc -> (Name, TcTyVar) -> Ct - do_one ct_loc (name, tv) - = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv - , ctev_loc = ct_loc' } - , cc_occ = occName name - , cc_hole = TypeHole } - where - real_span = case nameSrcSpan name of - RealSrcSpan span _ -> span - UnhelpfulSpan str -> pprPanic "emitNamedWildCardHoleConstraints" - (ppr name <+> quotes (ftext str)) - -- Wildcards are defined locally, and so have RealSrcSpans - ct_loc' = setCtLocSpan ct_loc real_span - -{- Note [Constraints and errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#12124): - - foo :: Maybe Int - foo = return (case Left 3 of - Left -> 1 -- Hard error here! - _ -> 0) - -The call to 'return' will generate a (Monad m) wanted constraint; but -then there'll be "hard error" (i.e. an exception in the TcM monad), from -the unsaturated Left constructor pattern. - -We'll recover in tcPolyBinds, using recoverM. But then the final -tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly -un-filled-in, and will emit a misleading error message. - -The underlying problem is that an exception interrupts the constraint -gathering process. Bottom line: if we have an exception, it's best -simply to discard any gathered constraints. Hence in 'attemptM' we -capture the constraints in a fresh variable, and only emit them into -the surrounding context if we exit normally. If an exception is -raised, simply discard the collected constraints... we have a hard -error to report. So this capture-the-emit dance isn't as stupid as it -looks :-). - -However suppose we throw an exception inside an invocation of -captureConstraints, and discard all the constraints. Some of those -constraints might be "variable out of scope" Hole constraints, and that -might have been the actual original cause of the exception! For -example (#12529): - f = p @ Int -Here 'p' is out of scope, so we get an insoluble Hole constraint. But -the visible type application fails in the monad (throws an exception). -We must not discard the out-of-scope error. - -So we /retain the insoluble constraints/ if there is an exception. -Hence: - - insolublesOnly in tryCaptureConstraints - - emitConstraints in the Left case of captureConstraints - -However note that freshly-generated constraints like (Int ~ Bool), or -((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as -insoluble. The constraint solver does that. So they'll be discarded. -That's probably ok; but see th/5358 as a not-so-good example: - t1 :: Int - t1 x = x -- Manifestly wrong - - foo = $(...raises exception...) -We report the exception, but not the bug in t1. Oh well. Possible -solution: make TcUnify.uType spot manifestly-insoluble constraints. - - -************************************************************************ -* * - Template Haskell context -* * -************************************************************************ --} - -recordThUse :: TcM () -recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } - -recordThSpliceUse :: TcM () -recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True } - -keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set -keepAlive name - = do { env <- getGblEnv - ; traceRn "keep alive" (ppr name) - ; updTcRef (tcg_keep env) (`extendNameSet` name) } - -getStage :: TcM ThStage -getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) } - -getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage)) -getStageAndBindLevel name - = do { env <- getLclEnv; - ; case lookupNameEnv (tcl_th_bndrs env) name of - Nothing -> return Nothing - Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) } - -setStage :: ThStage -> TcM a -> TcRn a -setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) - --- | Adds the given modFinalizers to the global environment and set them to use --- the current local environment. -addModFinalizersWithLclEnv :: ThModFinalizers -> TcM () -addModFinalizersWithLclEnv mod_finalizers - = do lcl_env <- getLclEnv - th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv - updTcRef th_modfinalizers_var $ \fins -> - (lcl_env, mod_finalizers) : fins - -{- -************************************************************************ -* * - Safe Haskell context -* * -************************************************************************ --} - --- | Mark that safe inference has failed --- See Note [Safe Haskell Overlapping Instances Implementation] --- although this is used for more than just that failure case. -recordUnsafeInfer :: WarningMessages -> TcM () -recordUnsafeInfer warns = - getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns) - --- | Figure out the final correct safe haskell mode -finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode -finalSafeMode dflags tcg_env = do - safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env) - return $ case safeHaskell dflags of - Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred - | otherwise -> Sf_None - s -> s - --- | Switch instances to safe instances if we're in Safe mode. -fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst] -fixSafeInstances sfMode | sfMode /= Sf_Safe && sfMode /= Sf_SafeInferred = id -fixSafeInstances _ = map fixSafe - where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True } - in inst { is_flag = new_flag } - -{- -************************************************************************ -* * - Stuff for the renamer's local env -* * -************************************************************************ --} - -getLocalRdrEnv :: RnM LocalRdrEnv -getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) } - -setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a -setLocalRdrEnv rdr_env thing_inside - = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside - -{- -************************************************************************ -* * - Stuff for interface decls -* * -************************************************************************ --} - -mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv -mkIfLclEnv mod loc boot - = IfLclEnv { if_mod = mod, - if_loc = loc, - if_boot = boot, - if_nsubst = Nothing, - if_implicits_env = Nothing, - if_tv_env = emptyFsEnv, - if_id_env = emptyFsEnv } - --- | Run an 'IfG' (top-level interface monad) computation inside an existing --- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv' --- based on 'TcGblEnv'. -initIfaceTcRn :: IfG a -> TcRn a -initIfaceTcRn thing_inside - = do { tcg_env <- getGblEnv - ; dflags <- getDynFlags - ; let !mod = tcg_semantic_mod tcg_env - -- When we are instantiating a signature, we DEFINITELY - -- do not want to knot tie. - is_instantiate = unitIdIsDefinite (thisPackage dflags) && - not (null (thisUnitIdInsts dflags)) - ; let { if_env = IfGblEnv { - if_doc = text "initIfaceTcRn", - if_rec_types = - if is_instantiate - then Nothing - else Just (mod, get_type_env) - } - ; get_type_env = readTcRef (tcg_type_env_var tcg_env) } - ; setEnvs (if_env, ()) thing_inside } - --- Used when sucking in a ModIface into a ModDetails to put in --- the HPT. Notably, unlike initIfaceCheck, this does NOT use --- hsc_type_env_var (since we're not actually going to typecheck, --- so this variable will never get updated!) -initIfaceLoad :: HscEnv -> IfG a -> IO a -initIfaceLoad hsc_env do_this - = do let gbl_env = IfGblEnv { - if_doc = text "initIfaceLoad", - if_rec_types = Nothing - } - initTcRnIf 'i' hsc_env gbl_env () do_this - -initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a --- Used when checking the up-to-date-ness of the old Iface --- Initialise the environment with no useful info at all -initIfaceCheck doc hsc_env do_this - = do let rec_types = case hsc_type_env_var hsc_env of - Just (mod,var) -> Just (mod, readTcRef var) - Nothing -> Nothing - gbl_env = IfGblEnv { - if_doc = text "initIfaceCheck" <+> doc, - if_rec_types = rec_types - } - initTcRnIf 'i' hsc_env gbl_env () do_this - -initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a -initIfaceLcl mod loc_doc hi_boot_file thing_inside - = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside - --- | Initialize interface typechecking, but with a 'NameShape' --- to apply when typechecking top-level 'OccName's (see --- 'lookupIfaceTop') -initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a -initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside - = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside - -getIfModule :: IfL Module -getIfModule = do { env <- getLclEnv; return (if_mod env) } - --------------------- -failIfM :: MsgDoc -> IfL a --- The Iface monad doesn't have a place to accumulate errors, so we --- just fall over fast if one happens; it "shouldn't happen". --- We use IfL here so that we can get context info out of the local env -failIfM msg - = do { env <- getLclEnv - ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; dflags <- getDynFlags - ; liftIO (putLogMsg dflags NoReason SevFatal - noSrcSpan (defaultErrStyle dflags) full_msg) - ; failM } - --------------------- -forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) --- Run thing_inside in an interleaved thread. --- It shares everything with the parent thread, so this is DANGEROUS. --- --- It returns Nothing if the computation fails --- --- It's used for lazily type-checking interface --- signatures, which is pretty benign - -forkM_maybe doc thing_inside - = do { -- see Note [Masking exceptions in forkM_maybe] - ; unsafeInterleaveM $ uninterruptibleMaskM_ $ - do { traceIf (text "Starting fork {" <+> doc) - ; mb_res <- tryM $ - updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ - thing_inside - ; case mb_res of - Right r -> do { traceIf (text "} ending fork" <+> doc) - ; return (Just r) } - Left exn -> do { - - -- Bleat about errors in the forked thread, if -ddump-if-trace is on - -- Otherwise we silently discard errors. Errors can legitimately - -- happen when compiling interface signatures (see tcInterfaceSigs) - whenDOptM Opt_D_dump_if_trace $ do - dflags <- getDynFlags - let msg = hang (text "forkM failed:" <+> doc) - 2 (text (show exn)) - liftIO $ putLogMsg dflags - NoReason - SevFatal - noSrcSpan - (defaultErrStyle dflags) - msg - - ; traceIf (text "} ending fork (badly)" <+> doc) - ; return Nothing } - }} - -forkM :: SDoc -> IfL a -> IfL a -forkM doc thing_inside - = do { mb_res <- forkM_maybe doc thing_inside - ; return (case mb_res of - Nothing -> pgmError "Cannot continue after interface file error" - -- pprPanic "forkM" doc - Just r -> r) } - -setImplicitEnvM :: TypeEnv -> IfL a -> IfL a -setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl - { if_implicits_env = Just tenv }) m - -{- -Note [Masking exceptions in forkM_maybe] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When using GHC-as-API it must be possible to interrupt snippets of code -executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible -by throwing an asynchronous interrupt to the GHC thread. However, there is a -subtle problem: runStmt first typechecks the code before running it, and the -exception might interrupt the type checker rather than the code. Moreover, the -typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and -more importantly might be inside an exception handler inside that -unsafeInterleaveIO. If that is the case, the exception handler will rethrow the -asynchronous exception as a synchronous exception, and the exception will end -up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed -discussion). We don't currently know a general solution to this problem, but -we can use uninterruptibleMask_ to avoid the situation. --} - --- | Environments which track 'CostCentreState' -class ContainsCostCentreState e where - extractCostCentreState :: e -> TcRef CostCentreState - -instance ContainsCostCentreState TcGblEnv where - extractCostCentreState = tcg_cc_st - -instance ContainsCostCentreState DsGblEnv where - extractCostCentreState = ds_cc_st - --- | Get the next cost centre index associated with a given name. -getCCIndexM :: (ContainsCostCentreState gbl) - => FastString -> TcRnIf gbl lcl CostCentreIndex -getCCIndexM nm = do - env <- getGblEnv - let cc_st_ref = extractCostCentreState env - cc_st <- readTcRef cc_st_ref - let (idx, cc_st') = getCCIndex nm cc_st - writeTcRef cc_st_ref cc_st' - return idx diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs deleted file mode 100644 --- a/compiler/typecheck/TcRules.hs +++ /dev/null @@ -1,499 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - - -TcRules: Typechecking transformation rules --} - -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} - -module TcRules ( tcRules ) where - -import GhcPrelude - -import GHC.Hs -import TcRnTypes -import TcRnMonad -import TcSimplify -import Constraint -import GHC.Core.Predicate -import TcOrigin -import TcMType -import TcType -import TcHsType -import TcExpr -import TcEnv -import TcUnify( buildImplicationFor ) -import TcEvidence( mkTcCoVarCo ) -import GHC.Core.Type -import GHC.Core.TyCon( isTypeFamilyTyCon ) -import GHC.Types.Id -import GHC.Types.Var( EvVar ) -import GHC.Types.Var.Set -import GHC.Types.Basic ( RuleName ) -import GHC.Types.SrcLoc -import Outputable -import FastString -import Bag - -{- -Note [Typechecking rules] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We *infer* the typ of the LHS, and use that type to *check* the type of -the RHS. That means that higher-rank rules work reasonably well. Here's -an example (test simplCore/should_compile/rule2.hs) produced by Roman: - - foo :: (forall m. m a -> m b) -> m a -> m b - foo f = ... - - bar :: (forall m. m a -> m a) -> m a -> m a - bar f = ... - - {-# RULES "foo/bar" foo = bar #-} - -He wanted the rule to typecheck. - -Note [TcLevel in type checking rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Bringing type variables into scope naturally bumps the TcLevel. Thus, we type -check the term-level binders in a bumped level, and we must accordingly bump -the level whenever these binders are in scope. - -Note [Re-quantify type variables in rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this example from #17710: - - foo :: forall k (a :: k) (b :: k). Proxy a -> Proxy b - foo x = Proxy - {-# RULES "foo" forall (x :: Proxy (a :: k)). foo x = Proxy #-} - -Written out in more detail, the "foo" rewrite rule looks like this: - - forall k (a :: k). forall (x :: Proxy (a :: k)). foo @k @a @b0 x = Proxy @k @b0 - -Where b0 is a unification variable. Where should b0 be quantified? We have to -quantify it after k, since (b0 :: k). But generalization usually puts inferred -type variables (such as b0) at the /front/ of the telescope! This creates a -conflict. - -One option is to simply throw an error, per the principles of -Note [Naughty quantification candidates] in TcMType. This is what would happen -if we were generalising over a normal type signature. On the other hand, the -types in a rewrite rule aren't quite "normal", since the notions of specified -and inferred type variables aren't applicable. - -A more permissive design (and the design that GHC uses) is to simply requantify -all of the type variables. That is, we would end up with this: - - forall k (a :: k) (b :: k). forall (x :: Proxy (a :: k)). foo @k @a @b x = Proxy @k @b - -It's a bit strange putting the generalized variable `b` after the user-written -variables `k` and `a`. But again, the notion of specificity is not relevant to -rewrite rules, since one cannot "visibly apply" a rewrite rule. This design not -only makes "foo" typecheck, but it also makes the implementation simpler. - -See also Note [Generalising in tcTyFamInstEqnGuts] in TcTyClsDecls, which -explains a very similar design when generalising over a type family instance -equation. --} - -tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTcId] -tcRules decls = mapM (wrapLocM tcRuleDecls) decls - -tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTcId) -tcRuleDecls (HsRules { rds_src = src - , rds_rules = decls }) - = do { tc_decls <- mapM (wrapLocM tcRule) decls - ; return $ HsRules { rds_ext = noExtField - , rds_src = src - , rds_rules = tc_decls } } -tcRuleDecls (XRuleDecls nec) = noExtCon nec - -tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId) -tcRule (HsRule { rd_ext = ext - , rd_name = rname@(L _ (_,name)) - , rd_act = act - , rd_tyvs = ty_bndrs - , rd_tmvs = tm_bndrs - , rd_lhs = lhs - , rd_rhs = rhs }) - = addErrCtxt (ruleCtxt name) $ - do { traceTc "---- Rule ------" (pprFullRuleName rname) - - -- Note [Typechecking rules] - ; (tc_lvl, stuff) <- pushTcLevelM $ - generateRuleConstraints ty_bndrs tm_bndrs lhs rhs - - ; let (id_bndrs, lhs', lhs_wanted - , rhs', rhs_wanted, rule_ty) = stuff - - ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname - , ppr lhs_wanted - , ppr rhs_wanted ]) - - ; (lhs_evs, residual_lhs_wanted) - <- simplifyRule name tc_lvl lhs_wanted rhs_wanted - - -- SimplfyRule Plan, step 4 - -- Now figure out what to quantify over - -- c.f. TcSimplify.simplifyInfer - -- We quantify over any tyvars free in *either* the rule - -- *or* the bound variables. The latter is important. Consider - -- ss (x,(y,z)) = (x,z) - -- RULE: forall v. fst (ss v) = fst v - -- The type of the rhs of the rule is just a, but v::(a,(b,c)) - -- - -- 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 TcHsSyn.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) - ; qtkvs <- quantifyTyVars forall_tkvs - ; traceTc "tcRule" (vcat [ pprFullRuleName rname - , ppr forall_tkvs - , ppr qtkvs - , ppr rule_ty - , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] - ]) - - -- SimplfyRule Plan, step 5 - -- Simplify the LHS and RHS constraints: - -- For the LHS constraints we must solve the remaining constraints - -- (a) so that we report insoluble ones - -- (b) so that we bind any soluble ones - ; let skol_info = RuleSkol name - ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs - lhs_evs residual_lhs_wanted - ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs - lhs_evs rhs_wanted - - ; emitImplications (lhs_implic `unionBags` rhs_implic) - ; return $ HsRule { rd_ext = ext - , rd_name = rname - , rd_act = act - , rd_tyvs = ty_bndrs -- preserved for ppr-ing - , rd_tmvs = map (noLoc . RuleBndr noExtField . noLoc) - (qtkvs ++ tpl_ids) - , rd_lhs = mkHsDictLet lhs_binds lhs' - , rd_rhs = mkHsDictLet rhs_binds rhs' } } -tcRule (XRuleDecl nec) = noExtCon nec - -generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] - -> LHsExpr GhcRn -> LHsExpr GhcRn - -> TcM ( [TcId] - , LHsExpr GhcTc, WantedConstraints - , LHsExpr GhcTc, WantedConstraints - , TcType ) -generateRuleConstraints ty_bndrs tm_bndrs lhs rhs - = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $ - tcRuleBndrs ty_bndrs tm_bndrs - -- bndr_wanted constraints can include wildcard hole - -- constraints, which we should not forget about. - -- It may mention the skolem type variables bound by - -- the RULE. c.f. #10072 - - ; tcExtendTyVarEnv tv_bndrs $ - tcExtendIdEnv id_bndrs $ - do { -- See Note [Solve order for RULES] - ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) - ; (rhs', rhs_wanted) <- captureConstraints $ - tcMonoExpr rhs (mkCheckExpType rule_ty) - ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted - ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } } - --- See Note [TcLevel in type checking rules] -tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] - -> TcM ([TcTyVar], [Id]) -tcRuleBndrs (Just bndrs) xs - = do { (tys1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $ - tcRuleTmBndrs xs - ; return (tys1 ++ tys2, tms) } - -tcRuleBndrs Nothing xs - = tcRuleTmBndrs xs - --- See Note [TcLevel in type checking rules] -tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id]) -tcRuleTmBndrs [] = return ([],[]) -tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs) - = do { ty <- newOpenFlexiTyVarTy - ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs - ; return (tyvars, mkLocalId name ty : tmvars) } -tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) --- e.g x :: a->a --- The tyvar 'a' is brought into scope first, just as if you'd written --- a::*, x :: a->a --- If there's an explicit forall, the renamer would have already reported an --- error for each out-of-scope type variable used - = do { let ctxt = RuleSigCtxt name - ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty - ; let id = mkLocalId name id_ty - -- See Note [Pattern signature binders] in TcHsType - - -- The type variables scope over subsequent bindings; yuk - ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $ - tcRuleTmBndrs rule_bndrs - ; return (map snd tvs ++ tyvars, id : tmvars) } -tcRuleTmBndrs (L _ (XRuleBndr nec) : _) = noExtCon nec - -ruleCtxt :: FastString -> SDoc -ruleCtxt name = text "When checking the transformation rule" <+> - doubleQuotes (ftext name) - - -{- -********************************************************************************* -* * - Constraint simplification for rules -* * -*********************************************************************************** - -Note [The SimplifyRule Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Example. Consider the following left-hand side of a rule - f (x == y) (y > z) = ... -If we typecheck this expression we get constraints - d1 :: Ord a, d2 :: Eq a -We do NOT want to "simplify" to the LHS - forall x::a, y::a, z::a, d1::Ord a. - f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ... -Instead we want - forall x::a, y::a, z::a, d1::Ord a, d2::Eq a. - f ((==) d2 x y) ((>) d1 y z) = ... - -Here is another example: - fromIntegral :: (Integral a, Num b) => a -> b - {-# RULES "foo" fromIntegral = id :: Int -> Int #-} -In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But -we *dont* want to get - forall dIntegralInt. - fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int -because the scsel will mess up RULE matching. Instead we want - forall dIntegralInt, dNumInt. - fromIntegral Int Int dIntegralInt dNumInt = id Int - -Even if we have - g (x == y) (y == z) = .. -where the two dictionaries are *identical*, we do NOT WANT - forall x::a, y::a, z::a, d1::Eq a - f ((==) d1 x y) ((>) d1 y z) = ... -because that will only match if the dict args are (visibly) equal. -Instead we want to quantify over the dictionaries separately. - -In short, simplifyRuleLhs must *only* squash equalities, leaving -all dicts unchanged, with absolutely no sharing. - -Also note that we can't solve the LHS constraints in isolation: -Example foo :: Ord a => a -> a - foo_spec :: Int -> Int - {-# RULE "foo" foo = foo_spec #-} -Here, it's the RHS that fixes the type variable - -HOWEVER, under a nested implication things are different -Consider - f :: (forall a. Eq a => a->a) -> Bool -> ... - {-# RULES "foo" forall (v::forall b. Eq b => b->b). - f b True = ... - #-} -Here we *must* solve the wanted (Eq a) from the given (Eq a) -resulting from skolemising the argument type of g. So we -revert to SimplCheck when going under an implication. - - ---------- So the SimplifyRule Plan is this ----------------------- - -* Step 0: typecheck the LHS and RHS to get constraints from each - -* Step 1: Simplify the LHS and RHS constraints all together in one bag - We do this to discover all unification equalities - -* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take - advantage of those unifications - -* Setp 3: Partition the LHS constraints into the ones we will - quantify over, and the others. - See Note [RULE quantification over equalities] - -* Step 4: Decide on the type variables to quantify over - -* Step 5: Simplify the LHS and RHS constraints separately, using the - quantified constraints as givens - -Note [Solve order for RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In step 1 above, we need to be a bit careful about solve order. -Consider - f :: Int -> T Int - type instance T Int = Bool - - RULE f 3 = True - -From the RULE we get - lhs-constraints: T Int ~ alpha - rhs-constraints: Bool ~ alpha -where 'alpha' is the type that connects the two. If we glom them -all together, and solve the RHS constraint first, we might solve -with alpha := Bool. But then we'd end up with a RULE like - - RULE: f 3 |> (co :: T Int ~ Bool) = True - -which is terrible. We want - - RULE: f 3 = True |> (sym co :: Bool ~ T Int) - -So we are careful to solve the LHS constraints first, and *then* the -RHS constraints. Actually much of this is done by the on-the-fly -constraint solving, so the same order must be observed in -tcRule. - - -Note [RULE quantification over equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deciding which equalities to quantify over is tricky: - * We do not want to quantify over insoluble equalities (Int ~ Bool) - (a) because we prefer to report a LHS type error - (b) because if such things end up in 'givens' we get a bogus - "inaccessible code" error - - * But we do want to quantify over things like (a ~ F b), where - F is a type function. - -The difficulty is that it's hard to tell what is insoluble! -So we see whether the simplification step yielded any type errors, -and if so refrain from quantifying over *any* equalities. - -Note [Quantifying over coercion holes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Equality constraints from the LHS will emit coercion hole Wanteds. -These don't have a name, so we can't quantify over them directly. -Instead, because we really do want to quantify here, invent a new -EvVar for the coercion, fill the hole with the invented EvVar, and -then quantify over the EvVar. Not too tricky -- just some -impedance matching, really. - -Note [Simplify cloned constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At this stage, we're simplifying constraints only for insolubility -and for unification. Note that all the evidence is quickly discarded. -We use a clone of the real constraint. If we don't do this, -then RHS coercion-hole constraints get filled in, only to get filled -in *again* when solving the implications emitted from tcRule. That's -terrible, so we avoid the problem by cloning the constraints. - --} - -simplifyRule :: RuleName - -> TcLevel -- Level at which to solve the constraints - -> WantedConstraints -- Constraints from LHS - -> WantedConstraints -- Constraints from RHS - -> TcM ( [EvVar] -- Quantify over these LHS vars - , WantedConstraints) -- Residual un-quantified LHS constraints --- See Note [The SimplifyRule Plan] --- NB: This consumes all simple constraints on the LHS, but not --- any LHS implication constraints. -simplifyRule name tc_lvl lhs_wanted rhs_wanted - = do { - -- Note [The SimplifyRule Plan] step 1 - -- First solve the LHS and *then* solve the RHS - -- Crucially, this performs unifications - -- Why clone? See Note [Simplify cloned constraints] - ; lhs_clone <- cloneWC lhs_wanted - ; rhs_clone <- cloneWC rhs_wanted - ; setTcLevel tc_lvl $ - runTcSDeriveds $ - do { _ <- solveWanteds lhs_clone - ; _ <- solveWanteds rhs_clone - -- Why do them separately? - -- See Note [Solve order for RULES] - ; return () } - - -- Note [The SimplifyRule Plan] step 2 - ; lhs_wanted <- zonkWC lhs_wanted - ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted - - -- Note [The SimplifyRule Plan] step 3 - ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts) - - ; traceTc "simplifyRule" $ - vcat [ text "LHS of rule" <+> doubleQuotes (ftext name) - , text "lhs_wanted" <+> ppr lhs_wanted - , text "rhs_wanted" <+> ppr rhs_wanted - , text "quant_cts" <+> ppr quant_cts - , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted - ] - - ; return (quant_evs, residual_lhs_wanted) } - - where - mk_quant_ev :: Ct -> TcM EvVar - mk_quant_ev ct - | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct - = case dest of - EvVarDest ev_id -> return ev_id - HoleDest hole -> -- See Note [Quantifying over coercion holes] - do { ev_id <- newEvVar pred - ; fillCoercionHole hole (mkTcCoVarCo ev_id) - ; return ev_id } - mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct) - - -getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints) --- Extract all the constraints we can quantify over, --- also returning the depleted WantedConstraints --- --- NB: we must look inside implications, because with --- -fdefer-type-errors we generate implications rather eagerly; --- see TcUnify.implicationNeeded. Not doing so caused #14732. --- --- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged, --- 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 TcInteract Note [Shortcut solving]) ignores the quantified --- and instead solves from the top level. --- --- So we must partition the WantedConstraints ourselves --- Not hard, but tiresome. - -getRuleQuantCts wc - = float_wc emptyVarSet wc - where - float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints) - float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics }) - = ( simple_yes `andCts` implic_yes - , WC { wc_simple = simple_no, wc_impl = implics_no }) - where - (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples - (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs) - emptyBag implics - - float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication) - float_implic skol_tvs yes1 imp - = (yes1 `andCts` yes2, imp { ic_wanted = no }) - where - (yes2, no) = float_wc new_skol_tvs (ic_wanted imp) - new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp - - rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool - rule_quant_ct skol_tvs ct - | EqPred _ t1 t2 <- classifyPredType (ctPred ct) - , not (ok_eq t1 t2) - = False -- Note [RULE quantification over equalities] - | isHoleCt ct - = False -- Don't quantify over type holes, obviously - | otherwise - = tyCoVarsOfCt ct `disjointVarSet` skol_tvs - - ok_eq t1 t2 - | t1 `tcEqType` t2 = False - | otherwise = is_fun_app t1 || is_fun_app t2 - - is_fun_app ty -- ty is of form (F tys) where F is a type function - = case tyConAppTyCon_maybe ty of - Just tc -> isTypeFamilyTyCon tc - Nothing -> False diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs deleted file mode 100644 --- a/compiler/typecheck/TcSMonad.hs +++ /dev/null @@ -1,3643 +0,0 @@ -{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - --- Type definitions for the constraint solver -module TcSMonad ( - - -- The work list - WorkList(..), isEmptyWorkList, emptyWorkList, - extendWorkListNonEq, extendWorkListCt, - extendWorkListCts, extendWorkListEq, extendWorkListFunEq, - appendWorkList, - selectNextWorkItem, - workListSize, workListWantedCount, - getWorkList, updWorkListTcS, pushLevelNoWorkList, - - -- The TcS monad - TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, - failTcS, warnTcS, addErrTcS, - runTcSEqualities, - nestTcS, nestImplicTcS, setEvBindsTcS, - emitImplicationTcS, emitTvImplicationTcS, - - runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive, - matchGlobalInst, TcM.ClsInstResult(..), - - QCInst(..), - - -- Tracing etc - panicTcS, traceTcS, - traceFireTcS, bumpStepCountTcS, csTraceTcS, - wrapErrTcS, wrapWarnTcS, - - -- Evidence creation and transformation - MaybeNew(..), freshGoals, isFresh, getEvExpr, - - newTcEvBinds, newNoTcEvBinds, - newWantedEq, newWantedEq_SI, emitNewWantedEq, - newWanted, newWanted_SI, newWantedEvVar, - newWantedNC, newWantedEvVarNC, - newDerivedNC, - newBoundEvVarId, - unifyTyVar, unflattenFmv, reportUnifications, - setEvBind, setWantedEq, - setWantedEvTerm, setEvBindIfWanted, - newEvVar, newGivenEvVar, newGivenEvVars, - emitNewDeriveds, emitNewDerivedEq, - checkReductionDepth, - getSolvedDicts, setSolvedDicts, - - getInstEnvs, getFamInstEnvs, -- Getting the environments - getTopEnv, getGblEnv, getLclEnv, - getTcEvBindsVar, getTcLevel, - getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, - tcLookupClass, tcLookupId, - - -- Inerts - InertSet(..), InertCans(..), - updInertTcS, updInertCans, updInertDicts, updInertIrreds, - getNoGivenEqs, setInertCans, - getInertEqs, getInertCans, getInertGivens, - getInertInsols, - getTcSInerts, setTcSInerts, - matchableGivens, prohibitedSuperClassSolve, mightMatchLater, - getUnsolvedInerts, - removeInertCts, getPendingGivenScs, - addInertCan, insertFunEq, addInertForAll, - emitWorkNC, emitWork, - isImprovable, - - -- The Model - kickOutAfterUnification, - - -- Inert Safe Haskell safe-overlap failures - addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask, - getSafeOverlapFailures, - - -- Inert CDictCans - DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict, - addDictsByClass, delDict, foldDicts, filterDicts, findDict, - - -- Inert CTyEqCans - EqualCtList, findTyEqs, foldTyEqs, isInInertEqs, - lookupInertTyVar, - - -- Inert solved dictionaries - addSolvedDict, lookupSolvedDict, - - -- Irreds - foldIrreds, - - -- The flattening cache - lookupFlatCache, extendFlatCache, newFlattenSkolem, -- Flatten skolems - dischargeFunEq, pprKicked, - - -- Inert CFunEqCans - updInertFunEqs, findFunEq, - findFunEqsByTyCon, - - instDFunType, -- Instantiation - - -- MetaTyVars - newFlexiTcSTy, instFlexi, instFlexiX, - cloneMetaTyVar, demoteUnfilledFmv, - 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 TcSimplify. I am wondering - -- if the whole instance matcher simply belongs - -- here -) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Driver.Types - -import qualified Inst as TcM -import GHC.Core.InstEnv -import FamInst -import GHC.Core.FamInstEnv - -import qualified TcRnMonad as TcM -import qualified TcMType as TcM -import qualified ClsInst as TcM( matchGlobalInst, ClsInstResult(..) ) -import qualified TcEnv as TcM - ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl ) -import ClsInst( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) -import TcType -import GHC.Driver.Session -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Core.Unify - -import ErrUtils -import TcEvidence -import GHC.Core.Class -import GHC.Core.TyCon -import TcErrors ( solverDepthErrorTcS ) - -import GHC.Types.Name -import GHC.Types.Module ( HasModule, getModule ) -import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt ) -import qualified GHC.Rename.Env as TcM -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import Outputable -import Bag -import GHC.Types.Unique.Supply -import Util -import TcRnTypes -import TcOrigin -import Constraint -import GHC.Core.Predicate - -import GHC.Types.Unique -import GHC.Types.Unique.FM -import GHC.Types.Unique.DFM -import Maybes - -import GHC.Core.Map -import Control.Monad -import MonadUtils -import Data.IORef -import Data.List ( partition, mapAccumL ) - -#if defined(DEBUG) -import Digraph -import GHC.Types.Unique.Set -#endif - -{- -************************************************************************ -* * -* Worklists * -* Canonical and non-canonical constraints that the simplifier has to * -* work on. Including their simplification depths. * -* * -* * -************************************************************************ - -Note [WorkList priorities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A WorkList contains canonical and non-canonical items (of all flavors). -Notice that each Ct now has a simplification depth. We may -consider using this depth for prioritization as well in the future. - -As a simple form of priority queue, our worklist separates out - -* equalities (wl_eqs); see Note [Prioritise equalities] -* type-function equalities (wl_funeqs) -* all the rest (wl_rest) - -Note [Prioritise equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very important to process equalities /first/: - -* (Efficiency) The general reason to do so is that if we process a - class constraint first, we may end up putting it into the inert set - and then kicking it out later. That's extra work compared to just - doing the equality first. - -* (Avoiding fundep iteration) As #14723 showed, it's possible to - get non-termination if we - - Emit the Derived fundep equalities for a class constraint, - generating some fresh unification variables. - - That leads to some unification - - Which kicks out the class constraint - - Which isn't solved (because there are still some more Derived - equalities in the work-list), but generates yet more fundeps - Solution: prioritise derived equalities over class constraints - -* (Class equalities) We need to prioritise equalities even if they - are hidden inside a class constraint; - see Note [Prioritise class equalities] - -* (Kick-out) We want to apply this priority scheme to kicked-out - constraints too (see the call to extendWorkListCt in kick_out_rewritable - E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become - homo-kinded when kicked out, and hence we want to prioritise it. - -* (Derived equalities) Originally we tried to postpone processing - Derived equalities, in the hope that we might never need to deal - with them at all; but in fact we must process Derived equalities - eagerly, partly for the (Efficiency) reason, and more importantly - for (Avoiding fundep iteration). - -Note [Prioritise class equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We prioritise equalities in the solver (see selectWorkItem). But class -constraints like (a ~ b) and (a ~~ b) are actually equalities too; -see Note [The equality types story] in TysPrim. - -Failing to prioritise these is inefficient (more kick-outs etc). -But, worse, it can prevent us spotting a "recursive knot" among -Wanted constraints. See comment:10 of #12734 for a worked-out -example. - -So we arrange to put these particular class constraints in the wl_eqs. - - NB: since we do not currently apply the substitution to the - inert_solved_dicts, the knot-tying still seems a bit fragile. - But this makes it better. - --} - --- See Note [WorkList priorities] -data WorkList - = WL { wl_eqs :: [Ct] -- CTyEqCan, CDictCan, CIrredCan - -- Given, Wanted, and Derived - -- Contains both equality constraints and their - -- class-level variants (a~b) and (a~~b); - -- See Note [Prioritise equalities] - -- See Note [Prioritise class equalities] - - , wl_funeqs :: [Ct] - - , wl_rest :: [Ct] - - , wl_implics :: Bag Implication -- See Note [Residual implications] - } - -appendWorkList :: WorkList -> WorkList -> WorkList -appendWorkList - (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1 - , wl_implics = implics1 }) - (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2 - , wl_implics = implics2 }) - = WL { wl_eqs = eqs1 ++ eqs2 - , wl_funeqs = funeqs1 ++ funeqs2 - , wl_rest = rest1 ++ rest2 - , wl_implics = implics1 `unionBags` implics2 } - -workListSize :: WorkList -> Int -workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest }) - = length eqs + length funeqs + length rest - -workListWantedCount :: WorkList -> Int --- Count the things we need to solve --- excluding the insolubles (c.f. inert_count) -workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest }) - = count isWantedCt eqs + count is_wanted rest - where - is_wanted ct - | CIrredCan { cc_status = InsolubleCIS } <- ct - = False - | otherwise - = isWantedCt ct - -extendWorkListEq :: Ct -> WorkList -> WorkList -extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl } - -extendWorkListFunEq :: Ct -> WorkList -> WorkList -extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl } - -extendWorkListNonEq :: Ct -> WorkList -> WorkList --- Extension by non equality -extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } - -extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList -extendWorkListDeriveds evs wl - = extendWorkListCts (map mkNonCanonical evs) wl - -extendWorkListImplic :: Implication -> WorkList -> WorkList -extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl } - -extendWorkListCt :: Ct -> WorkList -> WorkList --- Agnostic -extendWorkListCt ct wl - = case classifyPredType (ctPred ct) of - EqPred NomEq ty1 _ - | Just tc <- tcTyConAppTyCon_maybe ty1 - , isTypeFamilyTyCon tc - -> extendWorkListFunEq ct wl - - EqPred {} - -> extendWorkListEq ct wl - - ClassPred cls _ -- See Note [Prioritise class equalities] - | isEqPredClass cls - -> extendWorkListEq ct wl - - _ -> extendWorkListNonEq ct wl - -extendWorkListCts :: [Ct] -> WorkList -> WorkList --- Agnostic -extendWorkListCts cts wl = foldr extendWorkListCt wl cts - -isEmptyWorkList :: WorkList -> Bool -isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs - , wl_rest = rest, wl_implics = implics }) - = null eqs && null rest && null funeqs && isEmptyBag implics - -emptyWorkList :: WorkList -emptyWorkList = WL { wl_eqs = [], wl_rest = [] - , wl_funeqs = [], wl_implics = emptyBag } - -selectWorkItem :: WorkList -> Maybe (Ct, WorkList) --- See Note [Prioritise equalities] -selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs - , wl_rest = rest }) - | ct:cts <- eqs = Just (ct, wl { wl_eqs = cts }) - | ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes }) - | ct:cts <- rest = Just (ct, wl { wl_rest = cts }) - | otherwise = Nothing - -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 TcInteract.chooseInstance - ; writeTcRef wl_var new_wl - ; return (Just ct) } } } - --- Pretty printing -instance Outputable WorkList where - ppr (WL { wl_eqs = eqs, wl_funeqs = feqs - , wl_rest = rest, wl_implics = implics }) - = text "WL" <+> (braces $ - vcat [ ppUnless (null eqs) $ - text "Eqs =" <+> vcat (map ppr eqs) - , ppUnless (null feqs) $ - text "Funeqs =" <+> vcat (map ppr feqs) - , ppUnless (null rest) $ - text "Non-eqs =" <+> vcat (map ppr rest) - , ppUnless (isEmptyBag implics) $ - ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics))) - (text "(Implics omitted)") - ]) - - -{- ********************************************************************* -* * - InertSet: the inert set -* * -* * -********************************************************************* -} - -data InertSet - = IS { inert_cans :: InertCans - -- Canonical Given, Wanted, Derived - -- Sometimes called "the inert set" - - , inert_fsks :: [(TcTyVar, TcType)] - -- A list of (fsk, ty) pairs; we add one element when we flatten - -- a function application in a Given constraint, creating - -- a new fsk in newFlattenSkolem. When leaving a nested scope, - -- unflattenGivens unifies fsk := ty - -- - -- We could also get this info from inert_funeqs, filtered by - -- level, but it seems simpler and more direct to capture the - -- fsk as we generate them. - - , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour) - -- See Note [Type family equations] - -- If F tys :-> (co, rhs, flav), - -- then co :: F tys ~ rhs - -- flav is [G] or [WD] - -- - -- Just a hash-cons cache for use when flattening only - -- These include entirely un-processed goals, so don't use - -- them to solve a top-level goal, else you may end up solving - -- (w:F ty ~ a) by setting w:=w! We just use the flat-cache - -- when allocating a new flatten-skolem. - -- Not necessarily inert wrt top-level equations (or inert_cans) - - -- NB: An ExactFunEqMap -- this doesn't match via loose types! - - , inert_solved_dicts :: DictMap CtEvidence - -- All Wanteds, of form ev :: C t1 .. tn - -- See Note [Solved dictionaries] - -- and Note [Do not add superclasses of solved dictionaries] - } - -instance Outputable InertSet where - ppr (IS { inert_cans = ics - , inert_fsks = ifsks - , inert_solved_dicts = solved_dicts }) - = vcat [ ppr ics - , text "Inert fsks =" <+> ppr ifsks - , ppUnless (null dicts) $ - text "Solved dicts =" <+> vcat (map ppr dicts) ] - where - dicts = bagToList (dictsToBag solved_dicts) - -emptyInertCans :: InertCans -emptyInertCans - = IC { inert_count = 0 - , inert_eqs = emptyDVarEnv - , inert_dicts = emptyDicts - , inert_safehask = emptyDicts - , inert_funeqs = emptyFunEqs - , inert_insts = [] - , inert_irreds = emptyCts } - -emptyInert :: InertSet -emptyInert - = IS { inert_cans = emptyInertCans - , inert_fsks = [] - , inert_flat_cache = emptyExactFunEqs - , inert_solved_dicts = emptyDictMap } - - -{- Note [Solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we apply a top-level instance declaration, we add the "solved" -dictionary to the inert_solved_dicts. In general, we use it to avoid -creating a new EvVar when we have a new goal that we have solved in -the past. - -But in particular, we can use it to create *recursive* dictionaries. -The simplest, degenerate case is - instance C [a] => C [a] where ... -If we have - [W] d1 :: C [x] -then we can apply the instance to get - d1 = $dfCList d - [W] d2 :: C [x] -Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1. - d1 = $dfCList d - d2 = d1 - -See Note [Example of recursive dictionaries] - -VERY IMPORTANT INVARIANT: - - (Solved Dictionary Invariant) - Every member of the inert_solved_dicts is the result - of applying an instance declaration that "takes a step" - - An instance "takes a step" if it has the form - dfunDList d1 d2 = MkD (...) (...) (...) - That is, the dfun is lazy in its arguments, and guarantees to - immediately return a dictionary constructor. NB: all dictionary - data constructors are lazy in their arguments. - - This property is crucial to ensure that all dictionaries are - non-bottom, which in turn ensures that the whole "recursive - dictionary" idea works at all, even if we get something like - rec { d = dfunDList d dx } - See Note [Recursive superclasses] in TcInstDcls. - - Reason: - - All instances, except two exceptions listed below, "take a step" - in the above sense - - - Exception 1: local quantified constraints have no such guarantee; - indeed, adding a "solved dictionary" when appling a quantified - constraint led to the ability to define unsafeCoerce - in #17267. - - - Exception 2: the magic built-in instance for (~) has no - such guarantee. It behaves as if we had - class (a ~# b) => (a ~ b) where {} - instance (a ~# b) => (a ~ b) where {} - The "dfun" for the instance is strict in the coercion. - Anyway there's no point in recording a "solved dict" for - (t1 ~ t2); it's not going to allow a recursive dictionary - to be constructed. Ditto (~~) and Coercible. - -THEREFORE we only add a "solved dictionary" - - when applying an instance declaration - - subject to Exceptions 1 and 2 above - -In implementation terms - - TcSMonad.addSolvedDict adds a new solved dictionary, - conditional on the kind of instance - - - It is only called when applying an instance decl, - in TcInteract.doTopReactDict - - - ClsInst.InstanceWhat says what kind of instance was - used to solve the constraint. In particular - * LocalInstance identifies quantified constraints - * BuiltinEqInstance identifies the strange built-in - instances for equality. - - - ClsInst.instanceReturnsDictCon says which kind of - instance guarantees to return a dictionary constructor - -Other notes about solved dictionaries - -* See also Note [Do not add superclasses of solved dictionaries] - -* The inert_solved_dicts field is not rewritten by equalities, - so it may get out of date. - -* The inert_solved_dicts are all Wanteds, never givens - -* We only cache dictionaries from top-level instances, not from - local quantified constraints. Reason: if we cached the latter - we'd need to purge the cache when bringing new quantified - constraints into scope, because quantified constraints "shadow" - top-level instances. - -Note [Do not add superclasses of solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Every member of inert_solved_dicts is the result of applying a -dictionary function, NOT of applying superclass selection to anything. -Consider - - class Ord a => C a where - instance Ord [a] => C [a] where ... - -Suppose we are trying to solve - [G] d1 : Ord a - [W] d2 : C [a] - -Then we'll use the instance decl to give - - [G] d1 : Ord a Solved: d2 : C [a] = $dfCList d3 - [W] d3 : Ord [a] - -We must not add d4 : Ord [a] to the 'solved' set (by taking the -superclass of d2), otherwise we'll use it to solve d3, without ever -using d1, which would be a catastrophe. - -Solution: when extending the solved dictionaries, do not add superclasses. -That's why each element of the inert_solved_dicts is the result of applying -a dictionary function. - -Note [Example of recursive dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ---- Example 1 - - data D r = ZeroD | SuccD (r (D r)); - - instance (Eq (r (D r))) => Eq (D r) where - ZeroD == ZeroD = True - (SuccD a) == (SuccD b) = a == b - _ == _ = False; - - equalDC :: D [] -> D [] -> Bool; - equalDC = (==); - -We need to prove (Eq (D [])). Here's how we go: - - [W] d1 : Eq (D []) -By instance decl of Eq (D r): - [W] d2 : Eq [D []] where d1 = dfEqD d2 -By instance decl of Eq [a]: - [W] d3 : Eq (D []) where d2 = dfEqList d3 - d1 = dfEqD d2 -Now this wanted can interact with our "solved" d1 to get: - d3 = d1 - --- Example 2: -This code arises in the context of "Scrap Your Boilerplate with Class" - - class Sat a - class Data ctx a - instance Sat (ctx Char) => Data ctx Char -- dfunData1 - instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] -- dfunData2 - - class Data Maybe a => Foo a - - instance Foo t => Sat (Maybe t) -- dfunSat - - instance Data Maybe a => Foo a -- dfunFoo1 - instance Foo a => Foo [a] -- dfunFoo2 - instance Foo [Char] -- dfunFoo3 - -Consider generating the superclasses of the instance declaration - instance Foo a => Foo [a] - -So our problem is this - [G] d0 : Foo t - [W] d1 : Data Maybe [t] -- Desired superclass - -We may add the given in the inert set, along with its superclasses - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - WorkList - [W] d1 : Data Maybe [t] - -Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3 - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - WorkList: - [W] d2 : Sat (Maybe [t]) - [W] d3 : Data Maybe t - -Now, we may simplify d2 using dfunSat; d2 := dfunSat d4 - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - WorkList: - [W] d3 : Data Maybe t - [W] d4 : Foo [t] - -Now, we can just solve d3 from d01; d3 := d01 - Inert - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - WorkList - [W] d4 : Foo [t] - -Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5 - Inert - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - d4 : Foo [t] - WorkList: - [W] d5 : Foo t - -Now, d5 can be solved! d5 := d0 - -Result - d1 := dfunData2 d2 d3 - d2 := dfunSat d4 - d3 := d01 - d4 := dfunFoo2 d5 - d5 := d0 --} - -{- ********************************************************************* -* * - InertCans: the canonical inerts -* * -* * -********************************************************************* -} - -data InertCans -- See Note [Detailed InertCans Invariants] for more - = IC { inert_eqs :: InertEqs - -- See Note [inert_eqs: the inert equalities] - -- All CTyEqCans; index is the LHS tyvar - -- Domain = skolems and untouchables; a touchable would be unified - - , inert_funeqs :: FunEqMap Ct - -- All CFunEqCans; index is the whole family head type. - -- All Nominal (that's an invariant of all CFunEqCans) - -- LHS is fully rewritten (modulo eqCanRewrite constraints) - -- wrt inert_eqs - -- Can include all flavours, [G], [W], [WD], [D] - -- See Note [Type family equations] - - , inert_dicts :: DictMap Ct - -- Dictionaries only - -- All fully rewritten (modulo flavour constraints) - -- wrt inert_eqs - - , inert_insts :: [QCInst] - - , inert_safehask :: DictMap Ct - -- Failed dictionary resolution due to Safe Haskell overlapping - -- instances restriction. We keep this separate from inert_dicts - -- as it doesn't cause compilation failure, just safe inference - -- failure. - -- - -- ^ See Note [Safe Haskell Overlapping Instances Implementation] - -- in TcSimplify - - , inert_irreds :: Cts - -- Irreducible predicates that cannot be made canonical, - -- and which don't interact with others (e.g. (c a)) - -- and insoluble predicates (e.g. Int ~ Bool, or a ~ [a]) - - , inert_count :: Int - -- Number of Wanted goals in - -- inert_eqs, inert_dicts, inert_safehask, inert_irreds - -- Does not include insolubles - -- When non-zero, keep trying to solve - } - -type InertEqs = DTyVarEnv EqualCtList -type EqualCtList = [Ct] -- See Note [EqualCtList invariants] - -{- Note [Detailed InertCans Invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The InertCans represents a collection of constraints with the following properties: - - * All canonical - - * No two dictionaries with the same head - * No two CIrreds with the same type - - * Family equations inert wrt top-level family axioms - - * Dictionaries have no matching top-level instance - - * Given family or dictionary constraints don't mention touchable - unification variables - - * Non-CTyEqCan constraints are fully rewritten with respect - to the CTyEqCan equalities (modulo canRewrite of course; - eg a wanted cannot rewrite a given) - - * CTyEqCan equalities: see Note [inert_eqs: the inert equalities] - Also see documentation in Constraint.Ct for a list of invariants - -Note [EqualCtList invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * All are equalities - * All these equalities have the same LHS - * The list is never empty - * No element of the list can rewrite any other - * Derived before Wanted - -From the fourth invariant it follows that the list is - - A single [G], or - - Zero or one [D] or [WD], followed by any number of [W] - -The Wanteds can't rewrite anything which is why we put them last - -Note [Type family equations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Type-family equations, CFunEqCans, of form (ev : F tys ~ ty), -live in three places - - * The work-list, of course - - * The inert_funeqs are un-solved but fully processed, and in - the InertCans. They can be [G], [W], [WD], or [D]. - - * The inert_flat_cache. This is used when flattening, to get maximal - sharing. Everything in the inert_flat_cache is [G] or [WD] - - It contains lots of things that are still in the work-list. - E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the - work list. Then we flatten w1, dumping (w3: G a ~ f1) in the work - list. Now if we flatten w2 before we get to w3, we still want to - share that (G a). - Because it contains work-list things, DO NOT use the flat cache to solve - a top-level goal. Eg in the above example we don't want to solve w3 - using w3 itself! - -The CFunEqCan Ownership Invariant: - - * Each [G/W/WD] CFunEqCan has a distinct fsk or fmv - It "owns" that fsk/fmv, in the sense that: - - reducing a [W/WD] CFunEqCan fills in the fmv - - unflattening a [W/WD] CFunEqCan fills in the fmv - (in both cases unless an occurs-check would result) - - * In contrast a [D] CFunEqCan does not "own" its fmv: - - reducing a [D] CFunEqCan does not fill in the fmv; - it just generates an equality - - unflattening ignores [D] CFunEqCans altogether - - -Note [inert_eqs: the inert equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Definition [Can-rewrite relation] -A "can-rewrite" relation between flavours, written f1 >= f2, is a -binary relation with the following properties - - (R1) >= is transitive - (R2) If f1 >= f, and f2 >= f, - then either f1 >= f2 or f2 >= f1 - -Lemma. If f1 >= f then f1 >= f1 -Proof. By property (R2), with f1=f2 - -Definition [Generalised substitution] -A "generalised substitution" S is a set of triples (a -f-> t), where - a is a type variable - t is a type - f is a flavour -such that - (WF1) if (a -f1-> t1) in S - (a -f2-> t2) in S - then neither (f1 >= f2) nor (f2 >= f1) hold - (WF2) if (a -f-> t) is in S, then t /= a - -Definition [Applying a generalised substitution] -If S is a generalised substitution - S(f,a) = t, if (a -fs-> t) in S, and fs >= f - = a, otherwise -Application extends naturally to types S(f,t), modulo roles. -See Note [Flavours with roles]. - -Theorem: S(f,a) is well defined as a function. -Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S, - and f1 >= f and f2 >= f - Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1) - -Notation: repeated application. - S^0(f,t) = t - S^(n+1)(f,t) = S(f, S^n(t)) - -Definition: inert generalised substitution -A generalised substitution S is "inert" iff - - (IG1) there is an n such that - for every f,t, S^n(f,t) = S^(n+1)(f,t) - -By (IG1) we define S*(f,t) to be the result of exahaustively -applying S(f,_) to t. - ----------------------------------------------------------------- -Our main invariant: - the inert CTyEqCans should be an inert generalised substitution ----------------------------------------------------------------- - -Note that inertness is not the same as idempotence. To apply S to a -type, you may have to apply it recursive. But inertness does -guarantee that this recursive use will terminate. - -Note [Extending the inert equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Main Theorem [Stability under extension] - Suppose we have a "work item" - a -fw-> t - and an inert generalised substitution S, - THEN the extended substitution T = S+(a -fw-> t) - is an inert generalised substitution - PROVIDED - (T1) S(fw,a) = a -- LHS of work-item is a fixpoint of S(fw,_) - (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_) - (T3) a not in t -- No occurs check in the work item - - AND, for every (b -fs-> s) in S: - (K0) not (fw >= fs) - Reason: suppose we kick out (a -fs-> s), - and add (a -fw-> t) to the inert set. - The latter can't rewrite the former, - so the kick-out achieved nothing - - OR { (K1) not (a = b) - Reason: if fw >= fs, WF1 says we can't have both - a -fw-> t and a -fs-> s - - AND (K2): guarantees inertness of the new substitution - { (K2a) not (fs >= fs) - OR (K2b) fs >= fw - OR (K2d) a not in s } - - AND (K3) See Note [K3: completeness of solving] - { (K3a) If the role of fs is nominal: s /= a - (K3b) If the role of fs is representational: - s is not of form (a t1 .. tn) } } - - -Conditions (T1-T3) are established by the canonicaliser -Conditions (K1-K3) are established by TcSMonad.kickOutRewritable - -The idea is that -* (T1-2) are guaranteed by exhaustively rewriting the work-item - with S(fw,_). - -* T3 is guaranteed by a simple occurs-check on the work item. - This is done during canonicalisation, in canEqTyVar; invariant - (TyEq:OC) of CTyEqCan. - -* (K1-3) are the "kick-out" criteria. (As stated, they are really the - "keep" criteria.) If the current inert S contains a triple that does - not satisfy (K1-3), then we remove it from S by "kicking it out", - and re-processing it. - -* Note that kicking out is a Bad Thing, because it means we have to - re-process a constraint. The less we kick out, the better. - TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed - this but haven't done the empirical study to check. - -* Assume we have G>=G, G>=W and that's all. Then, when performing - a unification we add a new given a -G-> ty. But doing so does NOT require - us to kick out an inert wanted that mentions a, because of (K2a). This - is a common case, hence good not to kick out. - -* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing - Proof: using Definition [Can-rewrite relation], fw can't rewrite anything - and so K0 holds. Intuitively, since fw can't rewrite anything, - adding it cannot cause any loops - This is a common case, because Wanteds cannot rewrite Wanteds. - It's used to avoid even looking for constraint to kick out. - -* Lemma (L1): The conditions of the Main Theorem imply that there is no - (a -fs-> t) in S, s.t. (fs >= fw). - Proof. Suppose the contrary (fs >= fw). Then because of (T1), - S(fw,a)=a. But since fs>=fw, S(fw,a) = s, hence s=a. But now we - have (a -fs-> a) in S, which contradicts (WF2). - -* The extended substitution satisfies (WF1) and (WF2) - - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1). - - (T3) guarantees (WF2). - -* (K2) is about inertness. Intuitively, any infinite chain T^0(f,t), - T^1(f,t), T^2(f,T).... must pass through the new work item infinitely - often, since the substitution without the work item is inert; and must - pass through at least one of the triples in S infinitely often. - - - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f), - and hence this triple never plays a role in application S(f,a). - It is always safe to extend S with such a triple. - - (NB: we could strengten K1) in this way too, but see K3. - - - (K2b): If this holds then, by (T2), b is not in t. So applying the - work item does not generate any new opportunities for applying S - - - (K2c): If this holds, we can't pass through this triple infinitely - often, because if we did then fs>=f, fw>=f, hence by (R2) - * either fw>=fs, contradicting K2c - * or fs>=fw; so by the argument in K2b we can't have a loop - - - (K2d): if a not in s, we hae no further opportunity to apply the - work item, similar to (K2b) - - NB: Dimitrios has a PDF that does this in more detail - -Key lemma to make it watertight. - Under the conditions of the Main Theorem, - forall f st fw >= f, a is not in S^k(f,t), for any k - -Also, consider roles more carefully. See Note [Flavours with roles] - -Note [K3: completeness of solving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(K3) is not necessary for the extended substitution -to be inert. In fact K1 could be made stronger by saying - ... then (not (fw >= fs) or not (fs >= fs)) -But it's not enough for S to be inert; we also want completeness. -That is, we want to be able to solve all soluble wanted equalities. -Suppose we have - - work-item b -G-> a - inert-item a -W-> b - -Assuming (G >= W) but not (W >= W), this fulfills all the conditions, -so we could extend the inerts, thus: - - inert-items b -G-> a - a -W-> b - -But if we kicked-out the inert item, we'd get - - work-item a -W-> b - inert-item b -G-> a - -Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl. -So we add one more clause to the kick-out criteria - -Another way to understand (K3) is that we treat an inert item - a -f-> b -in the same way as - b -f-> a -So if we kick out one, we should kick out the other. The orientation -is somewhat accidental. - -When considering roles, we also need the second clause (K3b). Consider - - work-item c -G/N-> a - inert-item a -W/R-> b c - -The work-item doesn't get rewritten by the inert, because (>=) doesn't hold. -But we don't kick out the inert item because not (W/R >= W/R). So we just -add the work item. But then, consider if we hit the following: - - work-item b -G/N-> Id - inert-items a -W/R-> b c - c -G/N-> a -where - newtype Id x = Id x - -For similar reasons, if we only had (K3a), we wouldn't kick the -representational inert out. And then, we'd miss solving the inert, which -now reduced to reflexivity. - -The solution here is to kick out representational inerts whenever the -tyvar of a work item is "exposed", where exposed means being at the -head of the top-level application chain (a t1 .. tn). See -TcType.isTyVarHead. This is encoded in (K3b). - -Beware: if we make this test succeed too often, we kick out too much, -and the solver might loop. Consider (#14363) - work item: [G] a ~R f b - inert item: [G] b ~R f a -In GHC 8.2 the completeness tests more aggressive, and kicked out -the inert item; but no rewriting happened and there was an infinite -loop. All we need is to have the tyvar at the head. - -Note [Flavours with roles] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The system described in Note [inert_eqs: the inert equalities] -discusses an abstract -set of flavours. In GHC, flavours have two components: the flavour proper, -taken from {Wanted, Derived, Given} and the equality relation (often called -role), taken from {NomEq, ReprEq}. -When substituting w.r.t. the inert set, -as described in Note [inert_eqs: the inert equalities], -we must be careful to respect all components of a flavour. -For example, if we have - - inert set: a -G/R-> Int - b -G/R-> Bool - - type role T nominal representational - -and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT -T Int Bool. The reason is that T's first parameter has a nominal role, and -thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of -substitution means that the proof in Note [The inert equalities] may need -to be revisited, but we don't think that the end conclusion is wrong. --} - -instance Outputable InertCans where - ppr (IC { inert_eqs = eqs - , inert_funeqs = funeqs, inert_dicts = dicts - , inert_safehask = safehask, inert_irreds = irreds - , inert_insts = insts - , inert_count = count }) - = braces $ vcat - [ ppUnless (isEmptyDVarEnv eqs) $ - text "Equalities:" - <+> pprCts (foldDVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs) - , ppUnless (isEmptyTcAppMap funeqs) $ - text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs) - , ppUnless (isEmptyTcAppMap dicts) $ - text "Dictionaries =" <+> pprCts (dictsToBag dicts) - , ppUnless (isEmptyTcAppMap safehask) $ - text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask) - , ppUnless (isEmptyCts irreds) $ - text "Irreds =" <+> pprCts irreds - , ppUnless (null insts) $ - text "Given instances =" <+> vcat (map ppr insts) - , text "Unsolved goals =" <+> int count - ] - -{- ********************************************************************* -* * - Shadow constraints and improvement -* * -************************************************************************ - -Note [The improvement story and derived shadows] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not -rewrite Wanteds] in Constraint), we may miss some opportunities for -solving. Here's a classic example (indexed-types/should_fail/T4093a) - - Ambiguity check for f: (Foo e ~ Maybe e) => Foo e - - We get [G] Foo e ~ Maybe e - [W] Foo e ~ Foo ee -- ee is a unification variable - [W] Foo ee ~ Maybe ee - - Flatten: [G] Foo e ~ fsk - [G] fsk ~ Maybe e -- (A) - - [W] Foo ee ~ fmv - [W] fmv ~ fsk -- (B) From Foo e ~ Foo ee - [W] fmv ~ Maybe ee - - --> rewrite (B) with (A) - [W] Foo ee ~ fmv - [W] fmv ~ Maybe e - [W] fmv ~ Maybe ee - - But now we appear to be stuck, since we don't rewrite Wanteds with - Wanteds. This is silly because we can see that ee := e is the - only solution. - -The basic plan is - * generate Derived constraints that shadow Wanted constraints - * allow Derived to rewrite Derived - * in order to cause some unifications to take place - * that in turn solve the original Wanteds - -The ONLY reason for all these Derived equalities is to tell us how to -unify a variable: that is, what Mark Jones calls "improvement". - -The same idea is sometimes also called "saturation"; find all the -equalities that must hold in any solution. - -Or, equivalently, you can think of the derived shadows as implementing -the "model": a non-idempotent but no-occurs-check substitution, -reflecting *all* *Nominal* equalities (a ~N ty) that are not -immediately soluble by unification. - -More specifically, here's how it works (Oct 16): - -* Wanted constraints are born as [WD]; this behaves like a - [W] and a [D] paired together. - -* When we are about to add a [WD] to the inert set, if it can - be rewritten by a [D] a ~ ty, then we split it into [W] and [D], - putting the latter into the work list (see maybeEmitShadow). - -In the example above, we get to the point where we are stuck: - [WD] Foo ee ~ fmv - [WD] fmv ~ Maybe e - [WD] fmv ~ Maybe ee - -But now when [WD] fmv ~ Maybe ee is about to be added, we'll -split it into [W] and [D], since the inert [WD] fmv ~ Maybe e -can rewrite it. Then: - work item: [D] fmv ~ Maybe ee - inert: [W] fmv ~ Maybe ee - [WD] fmv ~ Maybe e -- (C) - [WD] Foo ee ~ fmv - -See Note [Splitting WD constraints]. Now the work item is rewritten -by (C) and we soon get ee := e. - -Additional notes: - - * The derived shadow equalities live in inert_eqs, along with - the Givens and Wanteds; see Note [EqualCtList invariants]. - - * We make Derived shadows only for Wanteds, not Givens. So we - have only [G], not [GD] and [G] plus splitting. See - Note [Add derived shadows only for Wanteds] - - * We also get Derived equalities from functional dependencies - and type-function injectivity; see calls to unifyDerived. - - * This splitting business applies to CFunEqCans too; and then - we do apply type-function reductions to the [D] CFunEqCan. - See Note [Reduction for Derived CFunEqCans] - - * It's worth having [WD] rather than just [W] and [D] because - * efficiency: silly to process the same thing twice - * inert_funeqs, inert_dicts is a finite map keyed by - the type; it's inconvenient for it to map to TWO constraints - -Note [Splitting WD constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We are about to add a [WD] constraint to the inert set; and we -know that the inert set has fully rewritten it. Should we split -it into [W] and [D], and put the [D] in the work list for further -work? - -* CDictCan (C tys) or CFunEqCan (F tys ~ fsk): - Yes if the inert set could rewrite tys to make the class constraint, - or type family, fire. That is, yes if the inert_eqs intersects - with the free vars of tys. For this test we use - (anyRewritableTyVar True) which ignores casts and coercions in tys, - because rewriting the casts or coercions won't make the thing fire - more often. - -* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'. - We need to check both 'a' and 'ty' against the inert set: - - Inert set contains [D] a ~ ty2 - Then we want to put [D] a ~ ty in the worklist, so we'll - get [D] ty ~ ty2 with consequent good things - - - Inert set contains [D] b ~ a, where b is in ty. - We can't just add [WD] a ~ ty[b] to the inert set, because - that breaks the inert-set invariants. If we tried to - canonicalise another [D] constraint mentioning 'a', we'd - get an infinite loop - - Moreover we must use (anyRewritableTyVar False) for the RHS, - because even tyvars in the casts and coercions could give - an infinite loop if we don't expose it - -* CIrredCan: Yes if the inert set can rewrite the constraint. - We used to think splitting irreds was unnecessary, but - see Note [Splitting Irred WD constraints] - -* Others: nothing is gained by splitting. - -Note [Splitting Irred WD constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Splitting Irred constraints can make a difference. Here is the -scenario: - - a[sk] :: F v -- F is a type family - beta :: alpha - - work item: [WD] a ~ beta - -This is heterogeneous, so we try flattening the kinds. - - co :: F v ~ fmv - [WD] (a |> co) ~ beta - -This is still hetero, so we emit a kind equality and make the work item an -inert Irred. - - work item: [D] fmv ~ alpha - inert: [WD] (a |> co) ~ beta (CIrredCan) - -Can't make progress on the work item. Add to inert set. This kicks out the -old inert, because a [D] can rewrite a [WD]. - - work item: [WD] (a |> co) ~ beta - inert: [D] fmv ~ alpha (CTyEqCan) - -Can't make progress on this work item either (although GHC tries by -decomposing the cast and reflattening... but that doesn't make a difference), -which is still hetero. Emit a new kind equality and add to inert set. But, -critically, we split the Irred. - - work list: - [D] fmv ~ alpha (CTyEqCan) - [D] (a |> co) ~ beta (CIrred) -- this one was split off - inert: - [W] (a |> co) ~ beta - [D] fmv ~ alpha - -We quickly solve the first work item, as it's the same as an inert. - - work item: [D] (a |> co) ~ beta - inert: - [W] (a |> co) ~ beta - [D] fmv ~ alpha - -We decompose the cast, yielding - - [D] a ~ beta - -We then flatten the kinds. The lhs kind is F v, which flattens to fmv which -then rewrites to alpha. - - co' :: F v ~ alpha - [D] (a |> co') ~ beta - -Now this equality is homo-kinded. So we swizzle it around to - - [D] beta ~ (a |> co') - -and set beta := a |> co', and go home happy. - -If we don't split the Irreds, we loop. This is all dangerously subtle. - -This is triggered by test case typecheck/should_compile/SplitWD. - -Note [Examples of how Derived shadows helps completeness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#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] UnF (F a) ~ a - [WD] UnF (F beta) ~ beta - [WD] F a ~ F beta - Flatten: - [G] g1: F a ~ fsk1 fsk1 := F a - [G] g2: UnF fsk1 ~ fsk2 fsk2 := UnF fsk1 - [G] g3: fsk2 ~ a - - [WD] w1: F beta ~ fmv1 - [WD] w2: UnF fmv1 ~ fmv2 - [WD] w3: fmv2 ~ beta - [WD] w4: fmv1 ~ fsk1 -- From F a ~ F beta using flat-cache - -- and re-orient to put meta-var on left - -Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2 -React that with g2: [D] d2: fmv2 ~ fsk2 -React that with w3: [D] beta ~ fsk2 - and g3: [D] beta ~ a -- Hooray beta := a -And that is enough to solve everything - -Note [Add derived shadows only for Wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only add shadows for Wanted constraints. That is, we have -[WD] but not [GD]; and maybeEmitShaodw looks only at [WD] -constraints. - -It does just possibly make sense ot add a derived shadow for a -Given. If we created a Derived shadow of a Given, it could be -rewritten by other Deriveds, and that could, conceivably, lead to a -useful unification. - -But (a) I have been unable to come up with an example of this - happening - (b) see #12660 for how adding the derived shadows - of a Given led to an infinite loop. - (c) It's unlikely that rewriting derived Givens will lead - to a unification because Givens don't mention touchable - unification variables - -For (b) there may be other ways to solve the loop, but simply -reraining from adding derived shadows of Givens is particularly -simple. And it's more efficient too! - -Still, here's one possible reason for adding derived shadows -for Givens. Consider - work-item [G] a ~ [b], inerts has [D] b ~ a. -If we added the derived shadow (into the work list) - [D] a ~ [b] -When we process it, we'll rewrite to a ~ [a] and get an -occurs check. Without it we'll miss the occurs check (reporting -inaccessible code); but that's probably OK. - -Note [Keep CDictCan shadows as CDictCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - class C a => D a b -and [G] D a b, [G] C a in the inert set. Now we insert -[D] b ~ c. We want to kick out a derived shadow for [D] D a b, -so we can rewrite it with the new constraint, and perhaps get -instance reduction or other consequences. - -BUT we do not want to kick out a *non-canonical* (D a b). If we -did, we would do this: - - rewrite it to [D] D a c, with pend_sc = True - - use expandSuperClasses to add C a - - go round again, which solves C a from the givens -This loop goes on for ever and triggers the simpl_loop limit. - -Solution: kick out the CDictCan which will have pend_sc = False, -because we've already added its superclasses. So we won't re-add -them. If we forget the pend_sc flag, our cunning scheme for avoiding -generating superclasses repeatedly will fail. - -See #11379 for a case of this. - -Note [Do not do improvement for WOnly] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do improvement between two constraints (e.g. for injectivity -or functional dependencies) only if both are "improvable". And -we improve a constraint wrt the top-level instances only if -it is improvable. - -Improvable: [G] [WD] [D} -Not improvable: [W] - -Reasons: - -* It's less work: fewer pairs to compare - -* Every [W] has a shadow [D] so nothing is lost - -* Consider [WD] C Int b, where 'b' is a skolem, and - class C a b | a -> b - instance C Int Bool - We'll do a fundep on it and emit [D] b ~ Bool - That will kick out constraint [WD] C Int b - Then we'll split it to [W] C Int b (keep in inert) - and [D] C Int b (in work list) - When processing the latter we'll rewrite it to - [D] C Int Bool - At that point it would be /stupid/ to interact it - with the inert [W] C Int b in the inert set; after all, - it's the very constraint from which the [D] C Int Bool - was split! We can avoid this by not doing improvement - on [W] constraints. This came up in #12860. --} - -maybeEmitShadow :: InertCans -> Ct -> TcS Ct --- See Note [The improvement story and derived shadows] -maybeEmitShadow ics ct - | let ev = ctEvidence ct - , CtWanted { ctev_pred = pred, ctev_loc = loc - , ctev_nosh = WDeriv } <- ev - , shouldSplitWD (inert_eqs ics) ct - = do { traceTcS "Emit derived shadow" (ppr ct) - ; let derived_ev = CtDerived { ctev_pred = pred - , ctev_loc = loc } - shadow_ct = ct { cc_ev = derived_ev } - -- Te shadow constraint keeps the canonical shape. - -- This just saves work, but is sometimes important; - -- see Note [Keep CDictCan shadows as CDictCan] - ; emitWork [shadow_ct] - - ; let ev' = ev { ctev_nosh = WOnly } - ct' = ct { cc_ev = ev' } - -- Record that it now has a shadow - -- This is /the/ place we set the flag to WOnly - ; return ct' } - - | otherwise - = return ct - -shouldSplitWD :: InertEqs -> Ct -> Bool --- Precondition: 'ct' is [WD], and is inert --- True <=> we should split ct ito [W] and [D] because --- the inert_eqs can make progress on the [D] --- See Note [Splitting WD constraints] - -shouldSplitWD inert_eqs (CFunEqCan { cc_tyargs = tys }) - = should_split_match_args inert_eqs tys - -- We don't need to split if the tv is the RHS fsk - -shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys }) - = should_split_match_args inert_eqs tys - -- NB True: ignore coercions - -- See Note [Splitting WD constraints] - -shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty - , cc_eq_rel = eq_rel }) - = tv `elemDVarEnv` inert_eqs - || anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty - -- NB False: do not ignore casts and coercions - -- See Note [Splitting WD constraints] - -shouldSplitWD inert_eqs (CIrredCan { cc_ev = ev }) - = anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev) - -shouldSplitWD _ _ = False -- No point in splitting otherwise - -should_split_match_args :: InertEqs -> [TcType] -> Bool --- True if the inert_eqs can rewrite anything in the argument --- types, ignoring casts and coercions -should_split_match_args inert_eqs tys - = any (anyRewritableTyVar True NomEq (canRewriteTv inert_eqs)) tys - -- NB True: ignore casts coercions - -- See Note [Splitting WD constraints] - -canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool -canRewriteTv inert_eqs eq_rel tv - | Just (ct : _) <- lookupDVarEnv inert_eqs tv - , CTyEqCan { cc_eq_rel = eq_rel1 } <- ct - = eq_rel1 `eqCanRewrite` eq_rel - | otherwise - = False - -isImprovable :: CtEvidence -> Bool --- See Note [Do not do improvement for WOnly] -isImprovable (CtWanted { ctev_nosh = WOnly }) = False -isImprovable _ = True - - -{- ********************************************************************* -* * - Inert equalities -* * -********************************************************************* -} - -addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs -addTyEq old_eqs tv ct - = extendDVarEnv_C add_eq old_eqs tv [ct] - where - add_eq old_eqs _ - | isWantedCt ct - , (eq1 : eqs) <- old_eqs - = eq1 : ct : eqs - | otherwise - = ct : old_eqs - -foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b -foldTyEqs k eqs z - = foldDVarEnv (\cts z -> foldr k z cts) z eqs - -findTyEqs :: InertCans -> TyVar -> EqualCtList -findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` [] - -delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs -delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv - where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1 - isThisOne _ = False - -lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType -lookupInertTyVar ieqs tv - = case lookupDVarEnv ieqs tv of - Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs - _ -> Nothing - -{- ********************************************************************* -* * - Inert instances: inert_insts -* * -********************************************************************* -} - -addInertForAll :: QCInst -> TcS () --- Add a local Given instance, typically arising from a type signature -addInertForAll new_qci - = do { ics <- getInertCans - ; insts' <- add_qci (inert_insts ics) - ; setInertCans (ics { inert_insts = insts' }) } - where - add_qci :: [QCInst] -> TcS [QCInst] - -- See Note [Do not add duplicate quantified instances] - add_qci qcis - | any same_qci qcis - = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci) - ; return qcis } - - | otherwise - = do { traceTcS "adding new inert quantified instance" (ppr new_qci) - ; return (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] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#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 ... - -Then in f's RHS there are two identical quantified constraints -available, one via the superclasses of C and one via the superclasses -of D. The two are identical, and it seems wrong to reject the program -because of that. But without doing duplicate-elimination we will have -two matching QCInsts when we try to solve constraints arising from f's -RHS. - -The simplest thing is simply to eliminate duplicates, which we do here. --} - -{- ********************************************************************* -* * - Adding an inert -* * -************************************************************************ - -Note [Adding an equality to the InertCans] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When adding an equality to the inerts: - -* Split [WD] into [W] and [D] if the inerts can rewrite the latter; - done by maybeEmitShadow. - -* 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 [Kicking out CFunEqCan for fundeps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - New: [D] fmv1 ~ fmv2 - Inert: [W] F alpha ~ fmv1 - [W] F beta ~ fmv2 - -where F is injective. The new (derived) equality certainly can't -rewrite the inerts. But we *must* kick out the first one, to get: - - New: [W] F alpha ~ fmv1 - Inert: [W] F beta ~ fmv2 - [D] fmv1 ~ fmv2 - -and now improvement will discover [D] alpha ~ beta. This is important; -eg in #9587. - -So in kickOutRewritable we look at all the tyvars of the -CFunEqCan, including the fsk. --} - -addInertCan :: Ct -> TcS () -- Constraints *other than* equalities --- Precondition: item /is/ canonical --- See Note [Adding an equality to the InertCans] -addInertCan ct - = do { traceTcS "insertInertCan {" $ - text "Trying to insert new inert item:" <+> ppr ct - - ; ics <- getInertCans - ; ct <- maybeEmitShadow ics ct - ; ics <- maybeKickOut ics ct - ; setInertCans (add_item ics ct) - - ; traceTcS "addInertCan }" $ empty } - -maybeKickOut :: InertCans -> Ct -> TcS InertCans --- For a CTyEqCan, kick out any inert that can be rewritten by the CTyEqCan -maybeKickOut ics ct - | CTyEqCan { cc_tyvar = tv, cc_ev = ev, cc_eq_rel = eq_rel } <- ct - = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics - ; return ics' } - | otherwise - = return ics - -add_item :: InertCans -> Ct -> InertCans -add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys }) - = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item } - -add_item ics item@(CTyEqCan { cc_tyvar = tv, cc_ev = ev }) - = ics { inert_eqs = addTyEq (inert_eqs ics) tv item - , inert_count = bumpUnsolvedCount ev (inert_count ics) } - -add_item ics@(IC { inert_irreds = irreds, inert_count = count }) - item@(CIrredCan { cc_ev = ev, cc_status = status }) - = ics { inert_irreds = irreds `Bag.snocBag` item - , inert_count = case status of - InsolubleCIS -> count - _ -> bumpUnsolvedCount ev count } - -- inert_count does not include insolubles - - -add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys }) - = ics { inert_dicts = addDict (inert_dicts ics) cls tys item - , inert_count = bumpUnsolvedCount ev (inert_count ics) } - -add_item _ item - = pprPanic "upd_inert set: can't happen! Inserting " $ - ppr item -- Can't be CNonCanonical, CHoleCan, - -- because they only land in inert_irreds - -bumpUnsolvedCount :: CtEvidence -> Int -> Int -bumpUnsolvedCount ev n | isWanted ev = n+1 - | otherwise = n - - ------------------------------------------ -kickOutRewritable :: CtFlavourRole -- Flavour/role of the equality that - -- is being added to the inert set - -> TcTyVar -- The new equality is tv ~ ty - -> InertCans - -> TcS (Int, InertCans) -kickOutRewritable new_fr new_tv ics - = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics - n_kicked = workListSize kicked_out - - ; unless (n_kicked == 0) $ - do { updWorkListTcS (appendWorkList kicked_out) - ; csTraceTcS $ - hang (text "Kick out, tv =" <+> ppr new_tv) - 2 (vcat [ text "n-kicked =" <+> int n_kicked - , text "kicked_out =" <+> ppr kicked_out - , text "Residual inerts =" <+> ppr ics' ]) } - - ; return (n_kicked, ics') } - -kick_out_rewritable :: CtFlavourRole -- Flavour/role of the equality that - -- is being added to the inert set - -> TcTyVar -- The new equality is tv ~ ty - -> InertCans - -> (WorkList, InertCans) --- See Note [kickOutRewritable] -kick_out_rewritable new_fr new_tv - ics@(IC { inert_eqs = tv_eqs - , inert_dicts = dictmap - , inert_safehask = safehask - , inert_funeqs = funeqmap - , inert_irreds = irreds - , inert_insts = old_insts - , inert_count = n }) - | not (new_fr `eqMayRewriteFR` new_fr) - = (emptyWorkList, ics) - -- If new_fr can't rewrite itself, it can't rewrite - -- anything else, so no need to kick out anything. - -- (This is a common case: wanteds can't rewrite wanteds) - -- Lemma (L2) in Note [Extending the inert equalities] - - | otherwise - = (kicked_out, inert_cans_in) - where - inert_cans_in = IC { inert_eqs = tv_eqs_in - , inert_dicts = dicts_in - , inert_safehask = safehask -- ?? - , inert_funeqs = feqs_in - , inert_irreds = irs_in - , inert_insts = insts_in - , inert_count = n - workListWantedCount kicked_out } - - kicked_out :: WorkList - -- NB: use extendWorkList to ensure that kicked-out equalities get priority - -- See Note [Prioritise equalities] (Kick-out). - -- The irreds may include non-canonical (hetero-kinded) equality - -- constraints, which perhaps may have become soluble after new_tv - -- is substituted; ditto the dictionaries, which may include (a~b) - -- or (a~~b) constraints. - kicked_out = foldr extendWorkListCt - (emptyWorkList { wl_eqs = tv_eqs_out - , wl_funeqs = feqs_out }) - ((dicts_out `andCts` irs_out) - `extendCtsList` insts_out) - - (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs - (feqs_out, feqs_in) = partitionFunEqs kick_out_ct funeqmap - -- See Note [Kicking out CFunEqCan for fundeps] - (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap - (irs_out, irs_in) = partitionBag kick_out_ct irreds - -- Kick out even insolubles: See Note [Rewrite insolubles] - -- Of course we must kick out irreducibles like (c a), in case - -- we can rewrite 'c' to something more useful - - -- Kick-out for inert instances - -- See Note [Quantified constraints] in TcCanonical - insts_out :: [Ct] - insts_in :: [QCInst] - (insts_out, insts_in) - | fr_may_rewrite (Given, NomEq) -- All the insts are Givens - = partitionWith kick_out_qci old_insts - | otherwise - = ([], old_insts) - kick_out_qci qci - | let ev = qci_ev qci - , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci)) - = Left (mkNonCanonical ev) - | otherwise - = Right qci - - (_, new_role) = new_fr - - fr_can_rewrite_ty :: EqRel -> Type -> Bool - fr_can_rewrite_ty role ty = anyRewritableTyVar False role - fr_can_rewrite_tv ty - fr_can_rewrite_tv :: EqRel -> TyVar -> Bool - fr_can_rewrite_tv role tv = new_role `eqCanRewrite` role - && tv == new_tv - - fr_may_rewrite :: CtFlavourRole -> Bool - fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs - -- Can the new item rewrite the inert item? - - kick_out_ct :: Ct -> Bool - -- Kick it out if the new CTyEqCan can rewrite the inert one - -- See Note [kickOutRewritable] - kick_out_ct ct | let fs@(_,role) = ctFlavourRole ct - = fr_may_rewrite fs - && fr_can_rewrite_ty role (ctPred ct) - -- False: ignore casts and coercions - -- NB: this includes the fsk of a CFunEqCan. It can't - -- actually be rewritten, but we need to kick it out - -- so we get to take advantage of injectivity - -- See Note [Kicking out CFunEqCan for fundeps] - - kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList) - -> ([Ct], DTyVarEnv EqualCtList) - kick_out_eqs eqs (acc_out, acc_in) - = (eqs_out ++ acc_out, case eqs_in of - [] -> acc_in - (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in) - where - (eqs_out, eqs_in) = partition kick_out_eq eqs - - -- Implements criteria K1-K3 in Note [Extending the inert equalities] - kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty - , cc_ev = ev, cc_eq_rel = eq_rel }) - | not (fr_may_rewrite fs) - = False -- Keep it in the inert set if the new thing can't rewrite it - - -- Below here (fr_may_rewrite fs) is True - | tv == new_tv = True -- (K1) - | kick_out_for_inertness = True - | kick_out_for_completeness = True - | otherwise = False - - where - fs = (ctEvFlavour ev, eq_rel) - kick_out_for_inertness - = (fs `eqMayRewriteFR` fs) -- (K2a) - && not (fs `eqMayRewriteFR` new_fr) -- (K2b) - && fr_can_rewrite_ty eq_rel rhs_ty -- (K2d) - -- (K2c) is guaranteed by the first guard of keep_eq - - kick_out_for_completeness - = case eq_rel of - NomEq -> rhs_ty `eqType` mkTyVarTy new_tv - ReprEq -> isTyVarHead new_tv rhs_ty - - kick_out_eq ct = pprPanic "keep_eq" (ppr ct) - -kickOutAfterUnification :: TcTyVar -> TcS Int -kickOutAfterUnification new_tv - = do { ics <- getInertCans - ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq) - 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 (2b) in Note [Equalities with incompatible kinds] in TcCanonical -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_irreds = irreds }) - = let (to_kick, to_keep) = partitionBag kick_ct irreds - - kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList - ics' = ics { inert_irreds = to_keep } - in - (kicked_out, ics') - - kick_ct :: Ct -> Bool - -- This is not particularly efficient. Ways to do better: - -- 1) Have a custom function that looks for a coercion hole and returns a Bool - -- 2) Keep co-hole-blocked constraints in a separate part of the inert set, - -- keyed by their co-hole. (Is it possible for more than one co-hole to be - -- in a constraint? I doubt it.) - kick_ct (CIrredCan { cc_ev = ev, cc_status = BlockedCIS }) - = coHoleCoVar hole `elemVarSet` tyCoVarsOfType (ctEvPred ev) - kick_ct _other = False - -{- Note [kickOutRewritable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [inert_eqs: the inert equalities]. - -When we add a new inert equality (a ~N ty) to the inert set, -we must kick out any inert items that could be rewritten by the -new equality, to maintain the inert-set invariants. - - - We want to kick out an existing inert constraint if - a) the new constraint can rewrite the inert one - b) 'a' is free in the inert constraint (so that it *will*) - rewrite it if we kick it out. - - For (b) we use tyCoVarsOfCt, which returns the type variables /and - the kind variables/ that are directly visible in the type. Hence - we will have exposed all the rewriting we care about to make the - most precise kinds visible for matching classes etc. No need to - kick out constraints that mention type variables whose kinds - contain this variable! - - - A Derived equality can kick out [D] constraints in inert_eqs, - inert_dicts, inert_irreds etc. - - - We don't kick out constraints from inert_solved_dicts, and - inert_solved_funeqs optimistically. But when we lookup we have to - take the substitution into account - - -Note [Rewrite insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an insoluble alpha ~ [alpha], which is insoluble -because an occurs check. And then we unify alpha := [Int]. Then we -really want to rewrite the insoluble to [Int] ~ [[Int]]. Now it can -be decomposed. Otherwise we end up with a "Can't match [Int] ~ -[[Int]]" which is true, but a bit confusing because the outer type -constructors match. - -Similarly, if we have a CHoleCan, we'd like to rewrite it with any -Givens, to give as informative an error messasge as possible -(#12468, #11325). - -Hence: - * In the main simplifier loops in TcSimplify (solveWanteds, - simpl_loop), we feed the insolubles in solveSimpleWanteds, - so that they get rewritten (albeit not solved). - - * We kick insolubles out of the inert set, if they can be - rewritten (see TcSMonad.kick_out_rewritable) - - * We rewrite those insolubles in TcCanonical. - See Note [Make sure that insolubles are fully rewritten] --} - - - --------------- -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 TcSimplify -insertSafeOverlapFailureTcS what item - | safeOverlap what = return () - | otherwise = updInertCans (\ics -> addInertSafehask ics item) - -getSafeOverlapFailures :: TcS Cts --- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify -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] -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) } - -updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertFunEqs upd_fn - = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs 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 (DTyVarEnv EqualCtList) -getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } - -getInertInsols :: TcS Cts --- Returns insoluble equality constraints --- specifically including Givens -getInertInsols = do { inert <- getInertCans - ; return (filterBag insolubleEqCt (inert_irreds inert)) } - -getInertGivens :: TcS [Ct] --- Returns the Given constraints in the inert set, --- with type functions *not* unflattened -getInertGivens - = do { inerts <- getInertCans - ; let all_cts = foldDicts (:) (inert_dicts inerts) - $ foldFunEqs (:) (inert_funeqs inerts) - $ concat (dVarEnvElts (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 }) - = ASSERT2( 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' <- isPendingScDict 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' <- isPendingScInst 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 TcCanonical - -getUnsolvedInerts :: TcS ( Bag Implication - , Cts -- Tyvar eqs: a ~ ty - , Cts -- Fun eqs: F a ~ ty - , Cts ) -- All others --- Return all the unsolved [Wanted] or [Derived] 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_wanted fun_eqs emptyCts - unsolved_irreds = Bag.filterBag is_unsolved irreds - unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts - unsolved_others = unsolved_irreds `unionBags` 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, unsolved_fun_eqs, unsolved_others) } - where - add_if_unsolved :: Ct -> Cts -> Cts - add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts - | otherwise = cts - - is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived - - -- For CFunEqCans we ignore the Derived ones, and keep - -- only the Wanteds for flattening. The Derived ones - -- share a unification variable with the corresponding - -- Wanted, so we definitely don't want to participate - -- in unflattening - -- See Note [Type family equations] - add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts - | otherwise = cts - -isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool --- True if (a ~N ty) is in the inert set, in either Given or Wanted -isInInertEqs eqs tv rhs - = case lookupDVarEnv eqs tv of - Nothing -> False - Just cts -> any (same_pred rhs) cts - where - same_pred rhs ct - | CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct - , NomEq <- eq_rel - , rhs `eqType` rhs2 = True - | otherwise = False - -getNoGivenEqs :: TcLevel -- TcLevel of this implication - -> [TcTyVar] -- Skolems of this implication - -> TcS ( Bool -- True <=> definitely no residual given equalities - , Cts ) -- Insoluble equalities arising from givens --- See Note [When does an implication have given equalities?] -getNoGivenEqs tclvl skol_tvs - = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds }) - <- getInertCans - ; let has_given_eqs = foldr ((||) . ct_given_here) False irreds - || anyDVarEnv eqs_given_here ieqs - insols = filterBag insolubleEqCt irreds - -- Specifically includes ones that originated in some - -- outer context but were refined to an insoluble by - -- a local equality; so do /not/ add ct_given_here. - - ; traceTcS "getNoGivenEqs" $ - vcat [ if has_given_eqs then text "May have given equalities" - else text "No given equalities" - , text "Skols:" <+> ppr skol_tvs - , text "Inerts:" <+> ppr inerts - , text "Insols:" <+> ppr insols] - ; return (not has_given_eqs, insols) } - where - eqs_given_here :: EqualCtList -> Bool - eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })] - -- Givens are always a singleton - = not (skolem_bound_here tv) && ct_given_here ct - eqs_given_here _ = False - - ct_given_here :: Ct -> Bool - -- True for a Given bound by the current implication, - -- i.e. the current level - ct_given_here ct = isGiven ev - && tclvl == ctLocLevel (ctEvLoc ev) - where - ev = ctEvidence ct - - skol_tv_set = mkVarSet skol_tvs - skolem_bound_here tv -- See Note [Let-bound skolems] - = case tcTyVarDetails tv of - SkolemTv {} -> tv `elemVarSet` skol_tv_set - _ -> False - --- | Returns Given constraints that might, --- potentially, match the given pred. This is used when checking to see if a --- Given might overlap with an instance. See Note [Instance and Given overlap] --- in TcInteract. -matchableGivens :: CtLoc -> PredType -> InertSet -> Cts -matchableGivens loc_w pred_w (IS { inert_cans = inert_cans }) - = filterBag matchable_given all_relevant_givens - where - -- just look in class constraints and irreds. matchableGivens does get called - -- for ~R constraints, but we don't need to look through equalities, because - -- canonical equalities are used for rewriting. We'll only get caught by - -- non-canonical -- that is, irreducible -- equalities. - all_relevant_givens :: Cts - all_relevant_givens - | Just (clas, _) <- getClassPredTys_maybe pred_w - = findDictsByClass (inert_dicts inert_cans) clas - `unionBags` inert_irreds inert_cans - | otherwise - = inert_irreds inert_cans - - matchable_given :: Ct -> Bool - matchable_given ct - | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct - = mightMatchLater pred_g loc_g pred_w loc_w - - | otherwise - = False - -mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool -mightMatchLater given_pred given_loc wanted_pred wanted_loc - = not (prohibitedSuperClassSolve given_loc wanted_loc) - && isJust (tcUnifyTys bind_meta_tv [given_pred] [wanted_pred]) - where - bind_meta_tv :: TcTyVar -> BindFlag - -- Any meta tyvar may be unified later, so we treat it as - -- bindable when unifying with givens. That ensures that we - -- conservatively assume that a meta tyvar might get unified with - -- something that matches the 'given', until demonstrated - -- otherwise. More info in Note [Instance and Given overlap] - -- in TcInteract - bind_meta_tv tv | isMetaTyVar tv - , not (isFskTyVar tv) = BindMe - | otherwise = Skolem - -prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool --- See Note [Solving superclass constraints] in TcInstDcls -prohibitedSuperClassSolve from_loc solve_loc - | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc - , ScOrigin wanted_size <- ctLocOrigin solve_loc - = given_size >= wanted_size - | otherwise - = False - -{- Note [Unsolved Derived equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In getUnsolvedInerts, we return a derived equality from the inert_eqs -because it is a candidate for floating out of this implication. We -only float equalities with a meta-tyvar on the left, so we only pull -those out here. - -Note [When does an implication have given equalities?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider an implication - beta => alpha ~ Int -where beta is a unification variable that has already been unified -to () in an outer scope. Then we can float the (alpha ~ Int) out -just fine. So when deciding whether the givens contain an equality, -we should canonicalise first, rather than just looking at the original -givens (#8644). - -So we simply look at the inert, canonical Givens and see if there are -any equalities among them, the calculation of has_given_eqs. There -are some wrinkles: - - * We must know which ones are bound in *this* implication and which - are bound further out. We can find that out from the TcLevel - of the Given, which is itself recorded in the tcl_tclvl field - of the TcLclEnv stored in the Given (ev_given_here). - - What about interactions between inner and outer givens? - - Outer given is rewritten by an inner given, then there must - have been an inner given equality, hence the “given-eq” flag - will be true anyway. - - - Inner given rewritten by outer, retains its level (ie. The inner one) - - * We must take account of *potential* equalities, like the one above: - beta => ...blah... - If we still don't know what beta is, we conservatively treat it as potentially - becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs. - - * When flattening givens, we generate Given equalities like - : F [a] ~ f, - with Refl evidence, and we *don't* want those to count as an equality - in the givens! After all, the entire flattening business is just an - internal matter, and the evidence does not mention any of the 'givens' - of this implication. So we do not treat inert_funeqs as a 'given equality'. - - * See Note [Let-bound skolems] for another wrinkle - - * We do *not* need to worry about representational equalities, because - these do not affect the ability to float constraints. - -Note [Let-bound skolems] -~~~~~~~~~~~~~~~~~~~~~~~~ -If * the inert set contains a canonical Given CTyEqCan (a ~ ty) -and * 'a' is a skolem bound in this very implication, - -then: -a) The Given is pretty much a let-binding, like - f :: (a ~ b->c) => a -> a - Here the equality constraint is like saying - let a = b->c in ... - It is not adding any new, local equality information, - and hence can be ignored by has_given_eqs - -b) 'a' will have been completely substituted out in the inert set, - so we can safely discard it. Notably, it doesn't need to be - returned as part of 'fsks' - -For an example, see #9211. - -See also TcUnify Note [Deeper level on the left] for how we ensure -that the right variable is on the left of the equality when both are -tyvars. - -You might wonder whether the skokem really needs to be bound "in the -very same implication" as the equuality constraint. -(c.f. #15009) Consider this: - - data S a where - MkS :: (a ~ Int) => S a - - g :: forall a. S a -> a -> blah - g x y = let h = \z. ( z :: Int - , case x of - MkS -> [y,z]) - in ... - -From the type signature for `g`, we get `y::a` . Then when when we -encounter the `\z`, we'll assign `z :: alpha[1]`, say. Next, from the -body of the lambda we'll get - - [W] alpha[1] ~ Int -- From z::Int - [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a -- From [y,z] - -Now, suppose we decide to float `alpha ~ a` out of the implication -and then unify `alpha := a`. Now we are stuck! But if treat -`alpha ~ Int` first, and unify `alpha := Int`, all is fine. -But we absolutely cannot float that equality or we will get stuck. --} - -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 } - - CFunEqCan { cc_fun = tf, cc_tyargs = tys } -> - is { inert_funeqs = delFunEq (inert_funeqs is) tf tys } - - CTyEqCan { cc_tyvar = x, cc_rhs = ty } -> - is { inert_eqs = delTyEq (inert_eqs is) x ty } - - CQuantCan {} -> panic "removeInertCt: CQuantCan" - CIrredCan {} -> panic "removeInertCt: CIrredEvCan" - CNonCanonical {} -> panic "removeInertCt: CNonCanonical" - CHoleCan {} -> panic "removeInertCt: CHoleCan" - - -lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour)) -lookupFlatCache fam_tc tys - = do { IS { inert_flat_cache = flat_cache - , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts - ; return (firstJusts [lookup_inerts inert_funeqs, - lookup_flats flat_cache]) } - where - lookup_inerts inert_funeqs - | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis }) - <- findFunEq inert_funeqs fam_tc tys - , tys `eqTypes` xis -- The lookup might find a near-match; see - -- Note [Use loose types in inert set] - = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev) - | otherwise = Nothing - - lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys - - -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 - ; return (lookupSolvedDict inerts loc cls tys `mplus` - lookupInertDict (inert_cans inerts) loc cls tys) } - | otherwise -- NB: No caching for equalities, IPs, holes, or errors - = return Nothing - --- | Look up a dictionary inert. NB: the returned 'CtEvidence' might not --- match the input exactly. Note [Use loose types in inert set]. -lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe CtEvidence -lookupInertDict (IC { inert_dicts = dicts }) loc cls tys - = case findDict dicts loc cls tys of - Just ct -> Just (ctEvidence ct) - _ -> Nothing - --- | Look up a solved inert. NB: the returned 'CtEvidence' might not --- match the input exactly. See Note [Use loose types in inert set]. -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 - -{- ********************************************************************* -* * - Irreds -* * -********************************************************************* -} - -foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b -foldIrreds k irreds z = foldr k z irreds - - -{- ********************************************************************* -* * - TcAppMap -* * -************************************************************************ - -Note [Use loose types in inert set] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Say we know (Eq (a |> c1)) and we need (Eq (a |> c2)). One is clearly -solvable from the other. So, we do lookup in the inert set using -loose types, which omit the kind-check. - -We must be careful when using the result of a lookup because it may -not match the requested info exactly! - --} - -type TcAppMap a = UniqDFM (ListMap LooseTypeMap a) - -- Indexed by tycon then the arg types, using "loose" matching, where - -- we don't require kind equality. This allows, for example, (a |> co) - -- to match (a). - -- See Note [Use loose types in inert set] - -- Used for types and classes; hence UniqDFM - -- See Note [foldTM determinism] for why we use UniqDFM here - -isEmptyTcAppMap :: TcAppMap a -> Bool -isEmptyTcAppMap m = isNullUDFM m - -emptyTcAppMap :: TcAppMap a -emptyTcAppMap = emptyUDFM - -findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a -findTcApp m u tys = do { tys_map <- lookupUDFM m u - ; lookupTM tys tys_map } - -delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a -delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls - -insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a -insertTcApp m cls tys ct = alterUDFM alter_tm m cls - where - alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM)) - --- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b --- mapTcApp f = mapUDFM (mapTM f) - -filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct -filterTcAppMap f m - = mapUDFM do_tm m - where - do_tm tm = foldTM insert_mb tm emptyTM - insert_mb ct tm - | f ct = insertTM tys ct tm - | otherwise = tm - where - tys = case ct of - CFunEqCan { cc_tyargs = tys } -> tys - CDictCan { cc_tyargs = tys } -> tys - _ -> pprPanic "filterTcAppMap" (ppr ct) - -tcAppMapToBag :: TcAppMap a -> Bag a -tcAppMapToBag m = foldTcAppMap consBag m emptyBag - -foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b -foldTcAppMap k m z = foldUDFM (foldTM k) z m - - -{- ********************************************************************* -* * - DictMap -* * -********************************************************************* -} - - -{- Note [Tuples hiding implicit parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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 we always fail when looking up a -tuple constraint that hides an implicit parameter. Not that this applies - * both to the inert_dicts (lookupInertDict) - * and to the solved_dicts (looukpSolvedDict) -An alternative would be not to extend these sets with such tuple -constraints, but it seemed more direct to deal with the lookup. - -Note [Solving CallStack constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose f :: HasCallStack => blah. Then - -* Each call to 'f' gives rise to - [W] s1 :: IP "callStack" CallStack -- CtOrigin = OccurrenceOf f - with a CtOrigin that says "OccurrenceOf f". - Remember that HasCallStack is just shorthand for - IP "callStack CallStack - See Note [Overview of implicit CallStacks] in TcEvidence - -* We cannonicalise such constraints, in TcCanonical.canClassNC, by - pushing the call-site info on the stack, and changing the CtOrigin - to record that has been done. - Bind: s1 = pushCallStack s2 - [W] s2 :: IP "callStack" CallStack -- CtOrigin = IPOccOrigin - -* Then, and only then, we can solve the constraint from an enclosing - Given. - -So we must be careful /not/ to solve 's1' from the Givens. Again, -we ensure this by arranging that findDict always misses when looking -up souch constraints. --} - -type DictMap a = TcAppMap a - -emptyDictMap :: DictMap a -emptyDictMap = emptyTcAppMap - -findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a -findDict m loc cls tys - | isCTupleClass cls - , any hasIPPred tys -- See Note [Tuples hiding implicit parameters] - = Nothing - - | Just {} <- isCallStackPred cls tys - , OccurrenceOf {} <- ctLocOrigin loc - = Nothing -- See Note [Solving CallStack constraints] - - | otherwise - = findTcApp m (getUnique cls) tys - -findDictsByClass :: DictMap a -> Class -> Bag a -findDictsByClass m cls - | Just tm <- lookupUDFM m cls = foldTM consBag tm emptyBag - | otherwise = emptyBag - -delDict :: DictMap a -> Class -> [Type] -> DictMap a -delDict m cls tys = delTcApp m (getUnique cls) tys - -addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a -addDict m cls tys item = insertTcApp m (getUnique cls) tys item - -addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct -addDictsByClass m cls items - = addToUDFM m cls (foldr add emptyTM items) - where - add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm - add ct _ = pprPanic "addDictsByClass" (ppr ct) - -filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct -filterDicts f m = filterTcAppMap f m - -partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct) -partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts) - where - k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes) - | otherwise = (yeses, add ct noes) - add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m - = addDict m cls tys ct - add ct _ = pprPanic "partitionDicts" (ppr ct) - -dictsToBag :: DictMap a -> Bag a -dictsToBag = tcAppMapToBag - -foldDicts :: (a -> b -> b) -> DictMap a -> b -> b -foldDicts = foldTcAppMap - -emptyDicts :: DictMap a -emptyDicts = emptyTcAppMap - - -{- ********************************************************************* -* * - FunEqMap -* * -********************************************************************* -} - -type FunEqMap a = TcAppMap a -- A map whose key is a (TyCon, [Type]) pair - -emptyFunEqs :: TcAppMap a -emptyFunEqs = emptyTcAppMap - -findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a -findFunEq m tc tys = findTcApp m (getUnique tc) tys - -funEqsToBag :: FunEqMap a -> Bag a -funEqsToBag m = foldTcAppMap consBag m emptyBag - -findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a] --- Get inert function equation constraints that have the given tycon --- in their head. Not that the constraints remain in the inert set. --- We use this to check for derived interactions with built-in type-function --- constructors. -findFunEqsByTyCon m tc - | Just tm <- lookupUDFM m tc = foldTM (:) tm [] - | otherwise = [] - -foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b -foldFunEqs = foldTcAppMap - --- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b --- mapFunEqs = mapTcApp - --- filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct --- filterFunEqs = filterTcAppMap - -insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a -insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val - -partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct) --- Optimise for the case where the predicate is false --- partitionFunEqs is called only from kick-out, and kick-out usually --- kicks out very few equalities, so we want to optimise for that case -partitionFunEqs f m = (yeses, foldr del m yeses) - where - yeses = foldTcAppMap k m [] - k ct yeses | f ct = ct : yeses - | otherwise = yeses - del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m - = delFunEq m tc tys - del ct _ = pprPanic "partitionFunEqs" (ppr ct) - -delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a -delFunEq m tc tys = delTcApp m (getUnique tc) tys - ------------------------------- -type ExactFunEqMap a = UniqFM (ListMap TypeMap a) - -emptyExactFunEqs :: ExactFunEqMap a -emptyExactFunEqs = emptyUFM - -findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a -findExactFunEq m tc tys = do { tys_map <- lookupUFM m (getUnique tc) - ; lookupTM tys tys_map } - -insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a -insertExactFunEq m tc tys val = alterUFM alter_tm m (getUnique tc) - where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM)) - -{- -************************************************************************ -* * -* 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_count :: IORef Int, -- Global step count - - tcs_inerts :: IORef InertSet, -- Current inert set - - -- The main work-list and the flattening worklist - -- See Note [Work list priorities] and - tcs_worklist :: IORef WorkList -- Current worklist - } - ---------------- -newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor) - -instance Applicative TcS where - pure x = TcS (\_ -> return x) - (<*>) = ap - -instance Monad TcS where - m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs) - -instance MonadFail TcS where - fail err = TcS (\_ -> 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 = TcS . const -- a TcM action will not use the TcEvBinds - -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 - -failTcS, panicTcS :: SDoc -> TcS a -warnTcS :: WarningFlag -> SDoc -> TcS () -addErrTcS :: SDoc -> TcS () -failTcS = wrapTcS . TcM.failWith -warnTcS flag = wrapTcS . TcM.addWarn (Reason flag) -addErrTcS = wrapTcS . TcM.addErr -panicTcS doc = pprPanic "TcCanonical" doc - -traceTcS :: String -> SDoc -> TcS () -traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) - -runTcPluginTcS :: TcPluginM a -> TcS a -runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar - -instance HasDynFlags TcS where - getDynFlags = wrapTcS getDynFlags - -getGlobalRdrEnvTcS :: TcS GlobalRdrEnv -getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv - -bumpStepCountTcS :: TcS () -bumpStepCountTcS = TcS $ \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) - -traceFireTcS :: CtEvidence -> SDoc -> TcS () --- Dump a rule-firing trace -traceFireTcS ev doc - = TcS $ \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)) } - -csTraceTcM :: TcM SDoc -> TcM () --- Constraint-solver tracing, -ddump-cs-trace -csTraceTcM mk_doc - = do { dflags <- getDynFlags - ; when ( dopt Opt_D_dump_cs_trace dflags - || dopt Opt_D_dump_tc_trace dflags ) - ( do { msg <- mk_doc - ; TcM.dumpTcRn False - (dumpOptionsFromFlag Opt_D_dump_cs_trace) - "" FormatText - msg }) } - -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 keep solving, even when only Deriveds --- are left around. It also doesn't return any evidence, as callers won't --- need it. -runTcSDeriveds :: TcS a -> TcM a -runTcSDeriveds tcs - = do { ev_binds_var <- TcM.newTcEvBinds - ; runTcSWithEvBinds 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 } - -runTcSWithEvBinds :: EvBindsVar - -> TcS a - -> TcM a -runTcSWithEvBinds 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 - ; let env = TcSEnv { tcs_ev_binds = ev_binds_var - , tcs_unified = unified_var - , tcs_count = step_count - , tcs_inerts = inert_var - , 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) - - ; unflattenGivens inert_var - -#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 Digraph. -#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 - } -> - do { inerts <- TcM.readTcRef old_inert_var - ; let nest_inert = emptyInert - { inert_cans = inert_cans inerts - , inert_solved_dicts = inert_solved_dicts inerts } - -- See Note [Do not inherit the flat cache] - ; new_inert_var <- TcM.newTcRef nest_inert - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = TcSEnv { tcs_ev_binds = ref - , tcs_unified = unified_var - , tcs_count = count - , tcs_inerts = new_inert_var - , tcs_worklist = new_wl_var } - ; res <- TcM.setTcLevel inner_tclvl $ - thing_inside nest_env - - ; unflattenGivens new_inert_var - -#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 } - -{- Note [Do not inherit the flat cache] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not want to inherit the flat cache when processing nested -implications. Consider - a ~ F b, forall c. b~Int => blah -If we have F b ~ fsk in the flat-cache, and we push that into the -nested implication, we might miss that F b can be rewritten to F Int, -and hence perhaps solve it. Moreover, the fsk from outside is -flattened out after solving the outer level, but and we don't -do that flattening recursively. --} - -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_flat_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 -> SkolemInfo - -> [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 -> SkolemInfo - -> [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 TcEnv 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 "TcSMonad.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 - = ASSERT2( 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) } - -getDefaultInfo :: TcS ([Type], (Bool, Bool)) -getDefaultInfo = wrapTcS TcM.tcGetDefaultTys - --- 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 - -tcLookupClass :: Name -> TcS Class -tcLookupClass c = wrapTcS $ TcM.tcLookupClass c - -tcLookupId :: Name -> TcS Id -tcLookupId n = wrapTcS $ TcM.tcLookupId n - --- Setting names as used (used in the deriving of Coercible evidence) --- Too hackish to expose it to TcS? In that case somehow extract the used --- constructors from the result of solveInteract -addUsedGREs :: [GlobalRdrElt] -> TcS () -addUsedGREs gres = wrapTcS $ TcM.addUsedGREs gres - -addUsedGRE :: Bool -> GlobalRdrElt -> TcS () -addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre - -keepAlive :: Name -> TcS () -keepAlive = wrapTcS . TcM.keepAlive - --- 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 - | TopLevInstance { iw_dfun_id = dfun_id } <- what - , let bind_lvl = TcM.topIdLvl dfun_id - , bind_lvl > impLevel - = wrapTcS $ TcM.setCtLocM loc $ - do { use_stage <- TcM.getStage - ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) } - - | otherwise - = return () -- Fast path for common case - where - pp_thing = text "instance for" <+> quotes (ppr pred) - -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) - -{- ********************************************************************* -* * -* Flatten skolems * -* * -********************************************************************* -} - -newFlattenSkolem :: CtFlavour -> CtLoc - -> TyCon -> [TcType] -- F xis - -> TcS (CtEvidence, Coercion, TcTyVar) -- [G/WD] x:: F xis ~ fsk -newFlattenSkolem flav loc tc xis - = do { stuff@(ev, co, fsk) <- new_skolem - ; let fsk_ty = mkTyVarTy fsk - ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev) - ; return stuff } - where - fam_ty = mkTyConApp tc xis - - new_skolem - | Given <- flav - = do { fsk <- wrapTcS (TcM.newFskTyVar fam_ty) - - -- Extend the inert_fsks list, for use by unflattenGivens - ; updInertTcS $ \is -> is { inert_fsks = (fsk, fam_ty) : inert_fsks is } - - -- Construct the Refl evidence - ; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk) - co = mkNomReflCo fam_ty - ; ev <- newGivenEvVar loc (pred, evCoercion co) - ; return (ev, co, fsk) } - - | otherwise -- Generate a [WD] for both Wanted and Derived - -- See Note [No Derived CFunEqCans] - = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty) - -- See (2a) in TcCanonical - -- Note [Equalities with incompatible kinds] - ; (ev, hole_co) <- newWantedEq_SI NoBlockSubst WDeriv loc Nominal - fam_ty (mkTyVarTy fmv) - ; return (ev, hole_co, fmv) } - ----------------------------- -unflattenGivens :: IORef InertSet -> TcM () --- Unflatten all the fsks created by flattening types in Given --- constraints. We must be sure to do this, else we end up with --- flatten-skolems buried in any residual Wanteds --- --- NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv) --- is filled in. Nothing else does so. --- --- It's here (rather than in TcFlatten) because the Right Places --- to call it are in runTcSWithEvBinds/nestImplicTcS, where it --- is nicely paired with the creation an empty inert_fsks list. -unflattenGivens inert_var - = do { inerts <- TcM.readTcRef inert_var - ; TcM.traceTc "unflattenGivens" (ppr (inert_fsks inerts)) - ; mapM_ flatten_one (inert_fsks inerts) } - where - flatten_one (fsk, ty) = TcM.writeMetaTyVar fsk ty - ----------------------------- -extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS () -extendFlatCache tc xi_args stuff@(_, ty, fl) - | isGivenOrWDeriv fl -- Maintain the invariant that inert_flat_cache - -- only has [G] and [WD] CFunEqCans - = do { dflags <- getDynFlags - ; when (gopt Opt_FlatCache dflags) $ - do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args - , ppr fl, ppr ty ]) - -- 'co' can be bottom, in the case of derived items - ; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) -> - is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } } - - | otherwise - = return () - ----------------------------- -unflattenFmv :: TcTyVar -> TcType -> TcS () --- Fill a flatten-meta-var, simply by unifying it. --- This does NOT count as a unification in tcs_unified. -unflattenFmv tv ty - = ASSERT2( isMetaTyVar tv, ppr tv ) - TcS $ \ _ -> - do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty) - ; TcM.writeMetaTyVar tv ty } - ----------------------------- -demoteUnfilledFmv :: TcTyVar -> TcS () --- If a flatten-meta-var is still un-filled, --- turn it into an ordinary meta-var -demoteUnfilledFmv fmv - = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv - ; unless is_filled $ - do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv) - ; TcM.writeMetaTyVar fmv tv_ty } } - ------------------------------ -dischargeFunEq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS () --- (dischargeFunEq tv co ty) --- Preconditions --- - ev :: F tys ~ tv is a CFunEqCan --- - tv is a FlatMetaTv of FlatSkolTv --- - co :: F tys ~ xi --- - fmv/fsk `notElem` xi --- - fmv not filled (for Wanteds) --- - xi is flattened (and obeys Note [Almost function-free] in TcRnTypes) --- --- Then for [W] or [WD], we actually fill in the fmv: --- set fmv := xi, --- set ev := co --- kick out any inert things that are now rewritable --- --- For [D], we instead emit an equality that must ultimately hold --- [D] xi ~ fmv --- Does not evaluate 'co' if 'ev' is Derived --- --- For [G], emit this equality --- [G] (sym ev; co) :: fsk ~ xi - --- See TcFlatten Note [The flattening story], --- especially "Ownership of fsk/fmv" -dischargeFunEq (CtGiven { ctev_evar = old_evar, ctev_loc = loc }) fsk co xi - = do { new_ev <- newGivenEvVar loc ( new_pred, evCoercion new_co ) - ; emitWorkNC [new_ev] } - where - new_pred = mkPrimEqPred (mkTyVarTy fsk) xi - new_co = mkTcSymCo (mkTcCoVarCo old_evar) `mkTcTransCo` co - -dischargeFunEq ev@(CtWanted { ctev_dest = dest }) fmv co xi - = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi ) - do { setWantedEvTerm dest (evCoercion co) - ; unflattenFmv fmv xi - ; n_kicked <- kickOutAfterUnification fmv - ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ pprKicked n_kicked) } - -dischargeFunEq (CtDerived { ctev_loc = loc }) fmv _co xi - = emitNewDerivedEq loc Nominal xi (mkTyVarTy fmv) - -- FunEqs are always at Nominal role - -pprKicked :: Int -> SDoc -pprKicked 0 = empty -pprKicked n = parens (int n <+> text "kicked out") - -{- ********************************************************************* -* * -* 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) - -instFlexi :: [TKVar] -> TcS TCvSubst -instFlexi = instFlexiX emptyTCvSubst - -instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst -instFlexiX subst tvs - = wrapTcS (foldlM instFlexiHelper subst tvs) - -instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst -instFlexiHelper subst tv - = do { uniq <- TcM.newUnique - ; details <- TcM.newMetaDetails TauTv - ; let name = setNameUnique (tyVarName tv) uniq - kind = substTyUnchecked subst (tyVarKind tv) - ty' = mkTyVarTy (mkTcTyVar name kind details) - ; TcM.traceTc "instFlexi" (ppr ty') - ; return (extendTvSubst subst tv ty') } - -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 :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar]) -tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX 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 :: TcEvDest -> Coercion -> TcS () -setWantedEq (HoleDest hole) co - = do { useVars (coVarsOfCo co) - ; fillCoercionHole hole co } -setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (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 (mkTcCoVarCo 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 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 -> Role -> TcType -> TcType -> TcS Coercion --- | Emit a new Wanted equality into the work-list -emitNewWantedEq loc role ty1 ty2 - = do { (ev, co) <- newWantedEq loc role ty1 ty2 - ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) - ; return co } - --- | Make a new equality CtEvidence -newWantedEq :: CtLoc -> Role -> TcType -> TcType - -> TcS (CtEvidence, Coercion) -newWantedEq = newWantedEq_SI YesBlockSubst WDeriv - -newWantedEq_SI :: BlockSubstFlag -> ShadowInfo -> CtLoc -> Role - -> TcType -> TcType - -> TcS (CtEvidence, Coercion) -newWantedEq_SI blocker si loc role ty1 ty2 - = do { hole <- wrapTcS $ TcM.newCoercionHole blocker pty - ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty) - ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole - , ctev_nosh = si - , ctev_loc = loc} - , mkHoleCo hole ) } - where - pty = mkPrimEqPredRole role ty1 ty2 - --- no equalities here. Use newWantedEq instead -newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence -newWantedEvVarNC = newWantedEvVarNC_SI WDeriv - -newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence --- Don't look up in the solved/inerts; we know it's not there -newWantedEvVarNC_SI si loc 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_nosh = si - , ctev_loc = loc })} - -newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew -newWantedEvVar = newWantedEvVar_SI WDeriv - -newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew --- For anything except ClassPred, this is the same as newWantedEvVarNC -newWantedEvVar_SI si loc pty - = do { mb_ct <- lookupInInerts loc pty - ; case mb_ct of - Just ctev - | not (isDerived ctev) - -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev - ; return $ Cached (ctEvExpr ctev) } - _ -> do { ctev <- newWantedEvVarNC_SI si loc pty - ; return (Fresh ctev) } } - -newWanted :: CtLoc -> PredType -> TcS MaybeNew --- Deals with both equalities and non equalities. Tries to look --- up non-equalities in the cache -newWanted = newWanted_SI WDeriv - -newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew -newWanted_SI si loc pty - | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = Fresh . fst <$> newWantedEq_SI YesBlockSubst si loc role ty1 ty2 - | otherwise - = newWantedEvVar_SI si loc pty - --- deals with both equalities and non equalities. Doesn't do any cache lookups. -newWantedNC :: CtLoc -> PredType -> TcS CtEvidence -newWantedNC loc pty - | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = fst <$> newWantedEq loc role ty1 ty2 - | otherwise - = newWantedEvVarNC loc pty - -emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS () -emitNewDeriveds loc preds - | null preds - = return () - | otherwise - = do { evs <- mapM (newDerivedNC loc) preds - ; traceTcS "Emitting new deriveds" (ppr evs) - ; updWorkListTcS (extendWorkListDeriveds evs) } - -emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS () --- Create new equality Derived and put it in the work list --- There's no caching, no lookupInInerts -emitNewDerivedEq loc role ty1 ty2 - = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2) - ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc) - ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) } - -- Very important: put in the wl_eqs - -- See Note [Prioritise equalities] (Avoiding fundep iteration) - -newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence -newDerivedNC loc pred - = do { -- checkReductionDepth loc pred - ; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) } - --- --------- Check done in TcInteract.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 $ - solverDepthErrorTcS loc ty } - -matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType)) --- Given (F tys) return (ty, co), where co :: F tys ~N ty -matchFam tycon args = wrapTcS $ matchFamTcM tycon args - -matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType)) --- 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 (co,ty)) = hang (text "Match succeeded:") - 2 (vcat [ text "Rewrites to:" <+> ppr ty - , text "Coercion:" <+> ppr co ]) - -{- -Note [Residual implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wl_implics in the WorkList are the residual implication -constraints that are generated while solving or canonicalising the -current worklist. Specifically, when canonicalising - (forall a. t1 ~ forall a. t2) -from which we get the implication - (forall a. t1 ~ t2) -See TcSMonad.deferTcSForAllEq --} diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs deleted file mode 100644 --- a/compiler/typecheck/TcSigs.hs +++ /dev/null @@ -1,836 +0,0 @@ -{- -(c) The University of Glasgow 2006-2012 -(c) The GRASP Project, Glasgow University, 1992-2002 - --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -module TcSigs( - TcSigInfo(..), - TcIdSigInfo(..), TcIdSigInst, - TcPatSynInfo(..), - TcSigFun, - - isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName, - completeSigPolyId_maybe, - - tcTySigs, tcUserTypeSig, completeSigFromId, - tcInstSig, - - TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv, - mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import TcHsType -import TcRnTypes -import TcRnMonad -import TcOrigin -import TcType -import TcMType -import TcValidity ( checkValidType ) -import TcUnify( tcSkolemise, unifyType ) -import Inst( topInstantiate ) -import TcEnv( tcLookupId ) -import TcEvidence( HsWrapper, (<.>) ) -import GHC.Core.Type ( mkTyVarBinders ) - -import GHC.Driver.Session -import GHC.Types.Var ( TyVar, tyVarKind ) -import GHC.Types.Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) -import PrelNames( mkUnboundName ) -import GHC.Types.Basic -import GHC.Types.Module( getModule ) -import GHC.Types.Name -import GHC.Types.Name.Env -import Outputable -import GHC.Types.SrcLoc -import Util( singleton ) -import Maybes( orElse ) -import Data.Maybe( mapMaybe ) -import Control.Monad( unless ) - - -{- ------------------------------------------------------------- - Note [Overview of type signatures] ----------------------------------------------------------------- -Type signatures, including partial signatures, are jolly tricky, -especially on value bindings. Here's an overview. - - f :: forall a. [a] -> [a] - g :: forall b. _ -> b - - f = ...g... - g = ...f... - -* HsSyn: a signature in a binding starts off as a TypeSig, in - type HsBinds.Sig - -* When starting a mutually recursive group, like f/g above, we - call tcTySig on each signature in the group. - -* tcTySig: Sig -> TcIdSigInfo - - For a /complete/ signature, like 'f' above, tcTySig kind-checks - the HsType, producing a Type, and wraps it in a CompleteSig, and - extend the type environment with this polymorphic 'f'. - - - For a /partial/signature, like 'g' above, tcTySig does nothing - Instead it just wraps the pieces in a PartialSig, to be handled - later. - -* tcInstSig: TcIdSigInfo -> TcIdSigInst - In tcMonoBinds, when looking at an individual binding, we use - tcInstSig to instantiate the signature forall's in the signature, - and attribute that instantiated (monomorphic) type to the - binder. You can see this in TcBinds.tcLhsId. - - The instantiation does the obvious thing for complete signatures, - but for /partial/ signatures it starts from the HsSyn, so it - has to kind-check it etc: tcHsPartialSigType. It's convenient - to do this at the same time as instantiation, because we can - make the wildcards into unification variables right away, raather - than somehow quantifying over them. And the "TcLevel" of those - unification variables is correct because we are in tcMonoBinds. - - -Note [Scoped tyvars] -~~~~~~~~~~~~~~~~~~~~ -The -XScopedTypeVariables flag brings lexically-scoped type variables -into scope for any explicitly forall-quantified type variables: - f :: forall a. a -> a - f x = e -Then 'a' is in scope inside 'e'. - -However, we do *not* support this - - For pattern bindings e.g - f :: forall a. a->a - (f,g) = e - -Note [Binding scoped type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type variables *brought into lexical scope* by a type signature -may be a subset of the *quantified type variables* of the signatures, -for two reasons: - -* With kind polymorphism a signature like - f :: forall f a. f a -> f a - may actually give rise to - f :: forall k. forall (f::k -> *) (a:k). f a -> f a - So the sig_tvs will be [k,f,a], but only f,a are scoped. - NB: the scoped ones are not necessarily the *initial* ones! - -* Even aside from kind polymorphism, there may be more instantiated - type variables than lexically-scoped ones. For example: - type T a = forall b. b -> (a,b) - f :: forall c. T c - Here, the signature for f will have one scoped type variable, c, - but two instantiated type variables, c' and b'. - -However, all of this only applies to the renamer. The typechecker -just puts all of them into the type environment; any lexical-scope -errors were dealt with by the renamer. - --} - - -{- ********************************************************************* -* * - Utility functions for TcSigInfo -* * -********************************************************************* -} - -tcIdSigName :: TcIdSigInfo -> Name -tcIdSigName (CompleteSig { sig_bndr = id }) = idName id -tcIdSigName (PartialSig { psig_name = n }) = n - -tcSigInfoName :: TcSigInfo -> Name -tcSigInfoName (TcIdSig idsi) = tcIdSigName idsi -tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi - -completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId -completeSigPolyId_maybe sig - | TcIdSig sig_info <- sig - , CompleteSig { sig_bndr = id } <- sig_info = Just id - | otherwise = Nothing - - -{- ********************************************************************* -* * - Typechecking user signatures -* * -********************************************************************* -} - -tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun) -tcTySigs hs_sigs - = checkNoErrs $ - do { -- Fail if any of the signatures is duff - -- Hence mapAndReportM - -- See Note [Fail eagerly on bad signatures] - ty_sigs_s <- mapAndReportM tcTySig hs_sigs - - ; let ty_sigs = concat ty_sigs_s - poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs - -- The returned [TcId] are the ones for which we have - -- a complete type signature. - -- See Note [Complete and partial type signatures] - env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs] - - ; return (poly_ids, lookupNameEnv env) } - -tcTySig :: LSig GhcRn -> TcM [TcSigInfo] -tcTySig (L _ (IdSig _ id)) - = do { let ctxt = FunSigCtxt (idName id) False - -- False: do not report redundant constraints - -- The user has no control over the signature! - sig = completeSigFromId ctxt id - ; return [TcIdSig sig] } - -tcTySig (L loc (TypeSig _ names sig_ty)) - = setSrcSpan loc $ - do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name) - | L _ name <- names ] - ; return (map TcIdSig sigs) } - -tcTySig (L loc (PatSynSig _ names sig_ty)) - = setSrcSpan loc $ - do { tpsigs <- sequence [ tcPatSynSig name sig_ty - | L _ name <- names ] - ; return (map TcPatSynSig tpsigs) } - -tcTySig _ = return [] - - -tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name - -> TcM TcIdSigInfo --- A function or expression type signature --- Returns a fully quantified type signature; even the wildcards --- are quantified with ordinary skolems that should be instantiated --- --- The SrcSpan is what to declare as the binding site of the --- any skolems in the signature. For function signatures we --- use the whole `f :: ty' signature; for expression signatures --- just the type part. --- --- Just n => Function type signature name :: type --- Nothing => Expression type signature :: type -tcUserTypeSig loc hs_sig_ty mb_name - | isCompleteHsSig hs_sig_ty - = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty - ; traceTc "tcuser" (ppr sigma_ty) - ; return $ - CompleteSig { sig_bndr = mkLocalId name sigma_ty - , sig_ctxt = ctxt_T - , sig_loc = loc } } - -- Location of the in f :: - - -- Partial sig with wildcards - | otherwise - = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty - , sig_ctxt = ctxt_F, sig_loc = loc }) - where - name = case mb_name of - Just n -> n - Nothing -> mkUnboundName (mkVarOcc "") - ctxt_F = case mb_name of - Just n -> FunSigCtxt n False - Nothing -> ExprSigCtxt - ctxt_T = case mb_name of - Just n -> FunSigCtxt n True - Nothing -> ExprSigCtxt - - - -completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo --- Used for instance methods and record selectors -completeSigFromId ctxt id - = CompleteSig { sig_bndr = id - , sig_ctxt = ctxt - , sig_loc = getSrcSpan id } - -isCompleteHsSig :: LHsSigWcType GhcRn -> Bool --- ^ If there are no wildcards, return a LHsSigType -isCompleteHsSig (HsWC { hswc_ext = wcs - , hswc_body = HsIB { hsib_body = hs_ty } }) - = null wcs && no_anon_wc hs_ty -isCompleteHsSig (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec -isCompleteHsSig (XHsWildCardBndrs nec) = noExtCon nec - -no_anon_wc :: LHsType GhcRn -> Bool -no_anon_wc lty = go lty - where - go (L _ ty) = case ty of - HsWildCardTy _ -> False - HsAppTy _ ty1 ty2 -> go ty1 && go ty2 - HsAppKindTy _ ty ki -> go ty && go ki - HsFunTy _ ty1 ty2 -> go ty1 && go ty2 - HsListTy _ ty -> go ty - HsTupleTy _ _ tys -> gos tys - HsSumTy _ tys -> gos tys - HsOpTy _ ty1 _ ty2 -> go ty1 && go ty2 - HsParTy _ ty -> go ty - HsIParamTy _ _ ty -> go ty - HsKindSig _ ty kind -> go ty && go kind - HsDocTy _ ty _ -> go ty - HsBangTy _ _ ty -> go ty - HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds - HsExplicitListTy _ _ tys -> gos tys - HsExplicitTupleTy _ tys -> gos tys - HsForAllTy { hst_bndrs = bndrs - , hst_body = ty } -> no_anon_wc_bndrs bndrs - && go ty - HsQualTy { hst_ctxt = L _ ctxt - , hst_body = ty } -> gos ctxt && go ty - HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty - HsSpliceTy{} -> True - HsTyLit{} -> True - HsTyVar{} -> True - HsStarTy{} -> True - XHsType (NHsCoreTy{}) -> True -- Core type, which does not have any wildcard - - gos = all go - -no_anon_wc_bndrs :: [LHsTyVarBndr GhcRn] -> Bool -no_anon_wc_bndrs ltvs = all (go . unLoc) ltvs - where - go (UserTyVar _ _) = True - go (KindedTyVar _ _ ki) = no_anon_wc ki - go (XTyVarBndr nec) = noExtCon nec - -{- Note [Fail eagerly on bad signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a type signature is wrong, fail immediately: - - * the type sigs may bind type variables, so proceeding without them - can lead to a cascade of errors - - * the type signature might be ambiguous, in which case checking - the code against the signature will give a very similar error - to the ambiguity error. - -ToDo: this means we fall over if any top-level type signature in the -module is wrong, because we typecheck all the signatures together -(see TcBinds.tcValBinds). Moreover, because of top-level -captureTopConstraints, only insoluble constraints will be reported. -We typecheck all signatures at the same time because a signature -like f,g :: blah might have f and g from different SCCs. - -So it's a bit awkward to get better error recovery, and no one -has complained! --} - -{- ********************************************************************* -* * - Type checking a pattern synonym signature -* * -************************************************************************ - -Note [Pattern synonym signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Pattern synonym signatures are surprisingly tricky (see #11224 for example). -In general they look like this: - - pattern P :: forall univ_tvs. req_theta - => forall ex_tvs. prov_theta - => arg1 -> .. -> argn -> res_ty - -For parsing and renaming we treat the signature as an ordinary LHsSigType. - -Once we get to type checking, we decompose it into its parts, in tcPatSynSig. - -* Note that 'forall univ_tvs' and 'req_theta =>' - and 'forall ex_tvs' and 'prov_theta =>' - are all optional. We gather the pieces at the top of tcPatSynSig - -* Initially the implicitly-bound tyvars (added by the renamer) include both - universal and existential vars. - -* After we kind-check the pieces and convert to Types, we do kind generalisation. - -Note [solveEqualities in tcPatSynSig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important that we solve /all/ the equalities in a pattern -synonym signature, because we are going to zonk the signature to -a Type (not a TcType), in TcPatSyn.tc_patsyn_finish, and that -fails if there are un-filled-in coercion variables mentioned -in the type (#15694). - -The best thing is simply to use solveEqualities to solve all the -equalites, rather than leaving them in the ambient constraints -to be solved later. Pattern synonyms are top-level, so there's -no problem with completely solving them. - -(NB: this solveEqualities wraps newImplicitTKBndrs, which itself -does a solveLocalEqualities; so solveEqualities isn't going to -make any further progress; it'll just report any unsolved ones, -and fail, as it should.) --} - -tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo --- See Note [Pattern synonym signatures] --- See Note [Recipe for checking a signature] in TcHsType -tcPatSynSig name sig_ty - | HsIB { hsib_ext = implicit_hs_tvs - , hsib_body = hs_ty } <- sig_ty - , (univ_hs_tvs, hs_req, hs_ty1) <- splitLHsSigmaTyInvis hs_ty - , (ex_hs_tvs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 - = do { traceTc "tcPatSynSig 1" (ppr sig_ty) - ; (implicit_tvs, (univ_tvs, (ex_tvs, (req, prov, body_ty)))) - <- pushTcLevelM_ $ - solveEqualities $ -- See Note [solveEqualities in tcPatSynSig] - bindImplicitTKBndrs_Skol implicit_hs_tvs $ - bindExplicitTKBndrs_Skol univ_hs_tvs $ - bindExplicitTKBndrs_Skol ex_hs_tvs $ - do { req <- tcHsContext hs_req - ; prov <- tcHsContext hs_prov - ; body_ty <- tcHsOpenType hs_body_ty - -- A (literal) pattern can be unlifted; - -- e.g. pattern Zero <- 0# (#12094) - ; return (req, prov, body_ty) } - - ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvs - req ex_tvs prov body_ty - - -- Kind generalisation - ; kvs <- kindGeneralizeAll ungen_patsyn_ty - ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty) - - -- These are /signatures/ so we zonk to squeeze out any kind - -- unification variables. Do this after kindGeneralize which may - -- default kind variables to *. - ; implicit_tvs <- zonkAndScopedSort implicit_tvs - ; univ_tvs <- mapM zonkTyCoVarKind univ_tvs - ; ex_tvs <- mapM zonkTyCoVarKind ex_tvs - ; req <- zonkTcTypes req - ; prov <- zonkTcTypes prov - ; body_ty <- zonkTcType body_ty - - -- Skolems have TcLevels too, though they're used only for debugging. - -- If you don't do this, the debugging checks fail in TcPatSyn. - -- Test case: patsyn/should_compile/T13441 -{- - ; tclvl <- getTcLevel - ; let env0 = mkEmptyTCvSubst $ mkInScopeSet $ mkVarSet kvs - (env1, implicit_tvs') = promoteSkolemsX tclvl env0 implicit_tvs - (env2, univ_tvs') = promoteSkolemsX tclvl env1 univ_tvs - (env3, ex_tvs') = promoteSkolemsX tclvl env2 ex_tvs - req' = substTys env3 req - prov' = substTys env3 prov - body_ty' = substTy env3 body_ty --} - ; let implicit_tvs' = implicit_tvs - univ_tvs' = univ_tvs - ex_tvs' = ex_tvs - req' = req - prov' = prov - body_ty' = body_ty - - -- Now do validity checking - ; checkValidType ctxt $ - build_patsyn_type kvs implicit_tvs' univ_tvs' req' ex_tvs' prov' body_ty' - - -- arguments become the types of binders. We thus cannot allow - -- levity polymorphism here - ; let (arg_tys, _) = tcSplitFunTys body_ty' - ; mapM_ (checkForLevPoly empty) arg_tys - - ; traceTc "tcTySig }" $ - vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs' - , text "kvs" <+> ppr_tvs kvs - , text "univ_tvs" <+> ppr_tvs univ_tvs' - , text "req" <+> ppr req' - , text "ex_tvs" <+> ppr_tvs ex_tvs' - , text "prov" <+> ppr prov' - , text "body_ty" <+> ppr body_ty' ] - ; return (TPSI { patsig_name = name - , patsig_implicit_bndrs = mkTyVarBinders Inferred kvs ++ - mkTyVarBinders Specified implicit_tvs' - , patsig_univ_bndrs = univ_tvs' - , patsig_req = req' - , patsig_ex_bndrs = ex_tvs' - , patsig_prov = prov' - , patsig_body_ty = body_ty' }) } - where - ctxt = PatSynCtxt name - - build_patsyn_type kvs imp univ req ex prov body - = mkInvForAllTys kvs $ - mkSpecForAllTys (imp ++ univ) $ - mkPhiTy req $ - mkSpecForAllTys ex $ - mkPhiTy prov $ - body -tcPatSynSig _ (XHsImplicitBndrs nec) = noExtCon nec - -ppr_tvs :: [TyVar] -> SDoc -ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv) - | tv <- tvs]) - - -{- ********************************************************************* -* * - Instantiating user signatures -* * -********************************************************************* -} - - -tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst --- Instantiate a type signature; only used with plan InferGen -tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }) - = setSrcSpan loc $ -- Set the binding site of the tyvars - do { (tv_prs, theta, tau) <- tcInstType newMetaTyVarTyVars poly_id - -- See Note [Pattern bindings and complete signatures] - - ; return (TISI { sig_inst_sig = sig - , sig_inst_skols = tv_prs - , sig_inst_wcs = [] - , sig_inst_wcx = Nothing - , sig_inst_theta = theta - , sig_inst_tau = tau }) } - -tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty - , sig_ctxt = ctxt - , sig_loc = loc }) - = setSrcSpan loc $ -- Set the binding site of the tyvars - do { traceTc "Staring partial sig {" (ppr hs_sig) - ; (wcs, wcx, tv_prs, theta, tau) <- tcHsPartialSigType ctxt hs_ty - -- See Note [Checking partial type signatures] in TcHsType - ; let inst_sig = TISI { sig_inst_sig = hs_sig - , sig_inst_skols = tv_prs - , sig_inst_wcs = wcs - , sig_inst_wcx = wcx - , sig_inst_theta = theta - , sig_inst_tau = tau } - ; traceTc "End partial sig }" (ppr inst_sig) - ; return inst_sig } - - -{- Note [Pattern bindings and complete signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a = MkT a a - f :: forall a. a->a - g :: forall b. b->b - MkT f g = MkT (\x->x) (\y->y) -Here we'll infer a type from the pattern of 'T a', but if we feed in -the signature types for f and g, we'll end up unifying 'a' and 'b' - -So we instantiate f and g's signature with TyVarTv skolems -(newMetaTyVarTyVars) that can unify with each other. If too much -unification takes place, we'll find out when we do the final -impedance-matching check in TcBinds.mkExport - -See Note [Signature skolems] in TcType - -None of this applies to a function binding with a complete -signature, which doesn't use tcInstSig. See TcBinds.tcPolyCheck. --} - -{- ********************************************************************* -* * - Pragmas and PragEnv -* * -********************************************************************* -} - -type TcPragEnv = NameEnv [LSig GhcRn] - -emptyPragEnv :: TcPragEnv -emptyPragEnv = emptyNameEnv - -lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn] -lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` [] - -extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv -extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig - ---------------- -mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv -mkPragEnv sigs binds - = foldl' extendPragEnv emptyNameEnv prs - where - prs = mapMaybe get_sig sigs - - get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn) - get_sig (L l (SpecSig x lnm@(L _ nm) ty inl)) - = Just (nm, L l $ SpecSig x lnm ty (add_arity nm inl)) - get_sig (L l (InlineSig x lnm@(L _ nm) inl)) - = Just (nm, L l $ InlineSig x lnm (add_arity nm inl)) - get_sig (L l (SCCFunSig x st lnm@(L _ nm) str)) - = Just (nm, L l $ SCCFunSig x st lnm str) - get_sig _ = Nothing - - add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function - | Inline <- inl_inline inl_prag - -- add arity only for real INLINE pragmas, not INLINABLE - = case lookupNameEnv ar_env n of - Just ar -> inl_prag { inl_sat = Just ar } - Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n ) - -- There really should be a binding for every INLINE pragma - inl_prag - | otherwise - = inl_prag - - -- ar_env maps a local to the arity of its definition - ar_env :: NameEnv Arity - ar_env = foldr lhsBindArity emptyNameEnv binds - -lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity -lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env - = extendNameEnv env (unLoc id) (matchGroupArity ms) -lhsBindArity _ env = env -- PatBind/VarBind - - ------------------ -addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId -addInlinePrags poly_id prags_for_me - | inl@(L _ prag) : inls <- inl_prags - = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) - ; unless (null inls) (warn_multiple_inlines inl inls) - ; return (poly_id `setInlinePragma` prag) } - | otherwise - = return poly_id - where - inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me] - - warn_multiple_inlines _ [] = return () - - warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls) - | inlinePragmaActivation prag1 == inlinePragmaActivation prag2 - , noUserInlineSpec (inlinePragmaSpec prag1) - = -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop - -- and inl2 is a user NOINLINE pragma; we don't want to complain - warn_multiple_inlines inl2 inls - | otherwise - = setSrcSpan loc $ - addWarnTc NoReason - (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) - 2 (vcat (text "Ignoring all but the first" - : map pp_inl (inl1:inl2:inls)))) - - pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) - - -{- ********************************************************************* -* * - SPECIALISE pragmas -* * -************************************************************************ - -Note [Handling SPECIALISE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea is this: - - foo :: Num a => a -> b -> a - {-# SPECIALISE foo :: Int -> b -> Int #-} - -We check that - (forall a b. Num a => a -> b -> a) - is more polymorphic than - forall b. Int -> b -> Int -(for which we could use tcSubType, but see below), generating a HsWrapper -to connect the two, something like - wrap = /\b. Int b dNumInt -This wrapper is put in the TcSpecPrag, in the ABExport record of -the AbsBinds. - - - f :: (Eq a, Ix b) => a -> b -> Bool - {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-} - f = - -From this the typechecker generates - - AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds - - SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX - -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ]) - -From these we generate: - - Rule: forall p, q, (dp:Ix p), (dq:Ix q). - f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq - - Spec bind: f_spec = wrap_fn - -Note that - - * The LHS of the rule may mention dictionary *expressions* (eg - $dfIxPair dp dq), and that is essential because the dp, dq are - needed on the RHS. - - * The RHS of f_spec, has a *copy* of 'binds', so that it - can fully specialise it. - - - -From the TcSpecPrag, in GHC.HsToCore.Binds we generate a binding for f_spec and a RULE: - - f_spec :: Int -> b -> Int - f_spec = wrap - - RULE: forall b (d:Num b). f b d = f_spec b - -The RULE is generated by taking apart the HsWrapper, which is a little -delicate, but works. - -Some wrinkles - -1. We don't use full-on tcSubType, because that does co and contra - variance and that in turn will generate too complex a LHS for the - RULE. So we use a single invocation of skolemise / - topInstantiate in tcSpecWrapper. (Actually I think that even - the "deeply" stuff may be too much, because it introduces lambdas, - though I think it can be made to work without too much trouble.) - -2. We need to take care with type families (#5821). Consider - type instance F Int = Bool - f :: Num a => a -> F a - {-# SPECIALISE foo :: Int -> Bool #-} - - We *could* try to generate an f_spec with precisely the declared type: - f_spec :: Int -> Bool - f_spec = Int dNumInt |> co - - RULE: forall d. f Int d = f_spec |> sym co - - but the 'co' and 'sym co' are (a) playing no useful role, and (b) are - hard to generate. At all costs we must avoid this: - RULE: forall d. f Int d |> co = f_spec - because the LHS will never match (indeed it's rejected in - decomposeRuleLhs). - - So we simply do this: - - Generate a constraint to check that the specialised type (after - skolemiseation) is equal to the instantiated function type. - - But *discard* the evidence (coercion) for that constraint, - so that we ultimately generate the simpler code - f_spec :: Int -> F Int - f_spec = Int dNumInt - - RULE: forall d. f Int d = f_spec - You can see this discarding happening in - -3. Note that the HsWrapper can transform *any* function with the right - type prefix - forall ab. (Eq a, Ix b) => XXX - regardless of XXX. It's sort of polymorphic in XXX. This is - useful: we use the same wrapper to transform each of the class ops, as - well as the dict. That's what goes on in TcInstDcls.mk_meth_spec_prags --} - -tcSpecPrags :: Id -> [LSig GhcRn] - -> TcM [LTcSpecPrag] --- Add INLINE and SPECIALSE pragmas --- INLINE prags are added to the (polymorphic) Id directly --- SPECIALISE prags are passed to the desugarer via TcSpecPrags --- Pre-condition: the poly_id is zonked --- Reason: required by tcSubExp -tcSpecPrags poly_id prag_sigs - = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs) - ; unless (null bad_sigs) warn_discarded_sigs - ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs - ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } - where - spec_sigs = filter isSpecLSig prag_sigs - bad_sigs = filter is_bad_sig prag_sigs - is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) - - warn_discarded_sigs - = addWarnTc NoReason - (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) - 2 (vcat (map (ppr . getLoc) bad_sigs))) - --------------- -tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag] -tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl) --- See Note [Handling SPECIALISE pragmas] --- --- The Name fun_name in the SpecSig may not be the same as that of the poly_id --- Example: SPECIALISE for a class method: the Name in the SpecSig is --- for the selector Id, but the poly_id is something like $cop --- However we want to use fun_name in the error message, since that is --- what the user wrote (#8537) - = addErrCtxt (spec_ctxt prag) $ - do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) - (text "SPECIALISE pragma for non-overloaded function" - <+> quotes (ppr fun_name)) - -- Note [SPECIALISE pragmas] - ; spec_prags <- mapM tc_one hs_tys - ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags))) - ; return spec_prags } - where - name = idName poly_id - poly_ty = idType poly_id - spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) - - tc_one hs_ty - = do { spec_ty <- tcHsSigType (FunSigCtxt name False) hs_ty - ; wrap <- tcSpecWrapper (FunSigCtxt name True) poly_ty spec_ty - ; return (SpecPrag poly_id wrap inl) } - -tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag) - --------------- -tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper --- A simpler variant of tcSubType, used for SPECIALISE pragmas --- See Note [Handling SPECIALISE pragmas], wrinkle 1 -tcSpecWrapper ctxt poly_ty spec_ty - = do { (sk_wrap, inst_wrap) - <- tcSkolemise ctxt spec_ty $ \ _ spec_tau -> - do { (inst_wrap, tau) <- topInstantiate orig poly_ty - ; _ <- unifyType Nothing spec_tau tau - -- Deliberately ignore the evidence - -- See Note [Handling SPECIALISE pragmas], - -- wrinkle (2) - ; return inst_wrap } - ; return (sk_wrap <.> inst_wrap) } - where - orig = SpecPragOrigin ctxt - --------------- -tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag] --- SPECIALISE pragmas for imported things -tcImpPrags prags - = do { this_mod <- getModule - ; dflags <- getDynFlags - ; if (not_specialising dflags) then - return [] - else do - { pss <- mapAndRecoverM (wrapLocM tcImpSpec) - [L loc (name,prag) - | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags - , not (nameIsLocalOrFrom this_mod name) ] - ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } } - where - -- Ignore SPECIALISE pragmas for imported things - -- when we aren't specialising, or when we aren't generating - -- code. The latter happens when Haddocking the base library; - -- we don't want complaints about lack of INLINABLE pragmas - not_specialising dflags - | not (gopt Opt_Specialise dflags) = True - | otherwise = case hscTarget dflags of - HscNothing -> True - HscInterpreted -> True - _other -> False - -tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] -tcImpSpec (name, prag) - = do { id <- tcLookupId name - ; unless (isAnyInlinePragma (idInlinePragma id)) - (addWarnTc NoReason (impSpecErr name)) - ; tcSpecPrag id prag } - -impSpecErr :: Name -> SDoc -impSpecErr name - = hang (text "You cannot SPECIALISE" <+> quotes (ppr name)) - 2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma" - , parens $ sep - [ text "or its defining module" <+> quotes (ppr mod) - , text "was compiled without -O"]]) - where - mod = nameModule name diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs deleted file mode 100644 --- a/compiler/typecheck/TcSimplify.hs +++ /dev/null @@ -1,2727 +0,0 @@ -{-# LANGUAGE CPP #-} - -module TcSimplify( - simplifyInfer, InferMode(..), - growThetaTyVars, - simplifyAmbiguityCheck, - simplifyDefault, - simplifyTop, simplifyTopImplic, - simplifyInteractive, - solveEqualities, solveLocalEqualities, solveLocalEqualitiesX, - simplifyWantedsTcM, - tcCheckSatisfiability, - tcNormalise, - - captureTopConstraints, - - simpl_top, - - promoteTyVar, - promoteTyVarSet, - - -- For Rules we need these - solveWanteds, solveWantedsAndDrop, - approximateWC, runTcSDeriveds - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Bag -import GHC.Core.Class ( Class, classKey, classTyCon ) -import GHC.Driver.Session -import GHC.Types.Id ( idType, mkLocalId ) -import Inst -import ListSetOps -import GHC.Types.Name -import Outputable -import PrelInfo -import PrelNames -import TcErrors -import TcEvidence -import TcInteract -import TcCanonical ( makeSuperClasses, solveCallStack ) -import TcMType as TcM -import TcRnMonad as TcM -import TcSMonad as TcS -import Constraint -import GHC.Core.Predicate -import TcOrigin -import TcType -import GHC.Core.Type -import TysWiredIn ( liftedRepTy ) -import GHC.Core.Unify ( tcMatchTyKi ) -import Util -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Unique.Set -import GHC.Types.Basic ( IntWithInf, intGtLimit ) -import ErrUtils ( emptyMessages ) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Foldable ( toList ) -import Data.List ( partition ) -import Data.List.NonEmpty ( NonEmpty(..) ) -import Maybes ( 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 TcRnDriver 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 solveLocalEqualities (maybe --- other things too) throws an exception without adding any error --- messages; it just puts the unsolved constraints back into the --- monad. See TcRnMonad 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 TcRnMonad 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 TcRnMonad - -- 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 - ; MASSERT2( 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 <- simpl_top 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 $ WC { wc_simple = unsafe_ol - , wc_impl = emptyBag } - - ; whyUnsafe <- fst <$> TcM.readTcRef errs_var - ; TcM.writeTcRef errs_var saved_msg - ; recordUnsafeInfer whyUnsafe - } - ; traceTc "reportUnsolved (unsafe overlapping) }" empty - - ; return (evBindMapBinds binds1 `unionBags` binds2) } - - --- | Type-check a thing that emits only equality constraints, solving any --- constraints we can and re-emitting constraints that we can't. The thing_inside --- should generally bump the TcLevel to make sure that this run of the solver --- doesn't affect anything lying around. -solveLocalEqualities :: String -> TcM a -> TcM a -solveLocalEqualities callsite thing_inside - = do { (wanted, res) <- solveLocalEqualitiesX callsite thing_inside - ; emitConstraints wanted - - -- See Note [Fail fast if there are insoluble kind equalities] - ; when (insolubleWC wanted) $ - failM - - ; return res } - -{- Note [Fail fast if there are insoluble kind equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Rather like in simplifyInfer, fail fast if there is an insoluble -constraint. Otherwise we'll just succeed in kind-checking a nonsense -type, with a cascade of follow-up errors. - -For example polykinds/T12593, T15577, and many others. - -Take care to ensure that you emit the insoluble constraints before -failing, because they are what will ultimately lead to the error -messsage! --} - -solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a) -solveLocalEqualitiesX callsite thing_inside - = do { traceTc "solveLocalEqualitiesX {" (vcat [ text "Called from" <+> text callsite ]) - - ; (result, wanted) <- captureConstraints thing_inside - - ; traceTc "solveLocalEqualities: running solver" (ppr wanted) - ; residual_wanted <- runTcSEqualities (solveWanteds wanted) - - ; traceTc "solveLocalEqualitiesX end }" $ - text "residual_wanted =" <+> ppr residual_wanted - - ; return (residual_wanted, result) } - --- | Type-check a thing that emits only equality constraints, then --- solve those constraints. Fails outright if there is trouble. --- Use this if you're not going to get another crack at solving --- (because, e.g., you're checking a datatype declaration) -solveEqualities :: TcM a -> TcM a -solveEqualities thing_inside - = checkNoErrs $ -- See Note [Fail fast on kind errors] - do { lvl <- TcM.getTcLevel - ; traceTc "solveEqualities {" (text "level =" <+> ppr lvl) - - ; (result, wanted) <- captureConstraints thing_inside - - ; traceTc "solveEqualities: running solver" $ text "wanted = " <+> ppr wanted - ; final_wc <- runTcSEqualities $ simpl_top wanted - -- NB: Use simpl_top here so that we potentially default RuntimeRep - -- vars to LiftedRep. This is needed to avoid #14991. - - ; traceTc "End solveEqualities }" empty - ; reportAllUnsolved final_wc - ; return result } - --- | Simplify top-level constraints, but without reporting any unsolved --- constraints nor unsafe overlapping. -simpl_top :: WantedConstraints -> TcS WantedConstraints - -- See Note [Top-level Defaulting Plan] -simpl_top wanteds - = do { wc_first_go <- nestTcS (solveWantedsAndDrop 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 { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc) - ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs - -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked - -- filter isMetaTyVar: we might have runtime-skolems in GHCi, - -- and we definitely don't want to try to assign to those! - -- The isTyVar is needed to weed out coercion variables - - ; defaulted <- mapM defaultTyVarTcS meta_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] - = return 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 (solveWantedsAndDrop wc) - ; try_class_defaulting wc_residual } - -- See Note [Overview of implicit CallStacks] in TcEvidence - 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 TcEvidence -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 [Fail fast on kind errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -solveEqualities is used to solve kind equalities when kind-checking -user-written types. If solving fails we should fail outright, rather -than just accumulate an error message, 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, so we - don't build evidence bindings (by usine reportAllUnsolved). That - means that we'll be left with with a type that has coercion holes - in it, something like - |> co-hole - where co-hole is not filled in. Eeek! That un-filled-in - hole actually causes GHC to crash with "fvProv falls into a hole" - See #11563, #11520, #11516, #11399 - -So it's important to use 'checkNoErrs' here! - -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 [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 inferrence 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) `TcInteract.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) `TcInteract.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) `TcSimplify.simplifyTop`: - * Call simpl_top, 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 `TcErrors.reportUnsolved`, - while for resolved but unsafe overlapping dictionary constraints, call - `TcErrors.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 `TcRnMonad.recordUnsafeInfer` to - mark the module we are compiling as unsafe, passing the - warning message along as the reason. - - 5) `TcErrors.*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) `TcRnMonad.recordUnsafeInfer` -- Save the unsafe result and reason in an - IORef called `tcg_safeInfer`. - - 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling - `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inferrence - failed. - -Note [No defaulting in the ambiguity check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When simplifying constraints for the ambiguity check, we use -solveWantedsAndDrop, not simpl_top, 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. - -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. --} - ------------------- -simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () -simplifyAmbiguityCheck ty wanteds - = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds) - ; (final_wc, _) <- runTcS $ solveWantedsAndDrop 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 () -- Succeeds if the constraint is soluble -simplifyDefault theta - = do { traceTc "simplifyDefault" empty - ; wanteds <- newWanteds DefaultOrigin theta - ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds)) - ; reportAllUnsolved unsolved - ; return () } - ------------------- -tcCheckSatisfiability :: Bag EvVar -> TcM Bool --- Return True if satisfiable, False if definitely contradictory -tcCheckSatisfiability given_ids - = do { lcl_env <- TcM.getLclEnv - ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env - ; (res, _ev_binds) <- runTcS $ - do { traceTcS "checkSatisfiability {" (ppr given_ids) - ; let given_cts = mkGivens given_loc (bagToList given_ids) - -- See Note [Superclasses and satisfiability] - ; solveSimpleGivens given_cts - ; insols <- getInertInsols - ; insols <- try_harder insols - ; traceTcS "checkSatisfiability }" (ppr insols) - ; return (isEmptyBag insols) } - ; return res } - 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 } - --- | Normalise a type as much as possible using the given constraints. --- See @Note [tcNormalise]@. -tcNormalise :: Bag EvVar -> Type -> TcM Type -tcNormalise given_ids ty - = do { lcl_env <- TcM.getLclEnv - ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env - ; wanted_ct <- mk_wanted_ct - ; (res, _ev_binds) <- runTcS $ - do { traceTcS "tcNormalise {" (ppr given_ids) - ; let given_cts = mkGivens given_loc (bagToList given_ids) - ; solveSimpleGivens given_cts - ; wcs <- solveSimpleWanteds (unitBag wanted_ct) - -- It's an invariant that this wc_simple will always be - -- a singleton Ct, since that's what we fed in as input. - ; let ty' = case bagToList (wc_simple wcs) of - (ct:_) -> ctEvPred (ctEvidence ct) - cts -> pprPanic "tcNormalise" (ppr cts) - ; traceTcS "tcNormalise }" (ppr ty') - ; pure ty' } - ; return res } - where - mk_wanted_ct :: TcM Ct - mk_wanted_ct = do - let occ = mkVarOcc "$tcNorm" - name <- newSysName occ - let ev = mkLocalId name ty - newHoleCt ExprHole ev ty - -{- Note [Superclasses and satisfiability] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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 TysPrim. - -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 stratightforard 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 local constraints, 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 Check. - -To accomplish its stated goal, tcNormalise first feeds the local constraints -into solveSimpleGivens, then stuffs the argument type in a CHoleCan, and feeds -that singleton Ct into solveSimpleWanteds, which reduces the type in the -CHoleCan as much as possible with respect to the local given constraints. When -solveSimpleWanteds is finished, we dig out the type from the CHoleCan and -return that. - -*********************************************************************************** -* * -* 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 TcBinds.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. - --} - --- | 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 TcRnDriver, - -- the :type +d case; this mode refuses - -- to quantify over any defaultable constraint - | NoRestrictions -- ^ Quantify over any constraint that - -- satisfies TcType.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 - WantedConstraints, -- Redidual as-yet-unsolved constraints - 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 - , (_,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) - ; qtkvs <- quantifyTyVars dep_vars - ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) - ; return (qtkvs, [], emptyTcEvBinds, emptyWC, 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. - - ; tc_env <- TcM.getEnv - ; ev_binds_var <- TcM.newTcEvBinds - ; psig_theta_vars <- mapM TcM.newEvVar psig_theta - ; wanted_transformed_incl_derivs - <- setTcLevel rhs_tclvl $ - runTcSWithEvBinds ev_binds_var $ - do { let loc = mkGivenLoc rhs_tclvl UnkSkol $ - env_lcl tc_env - psig_givens = mkGivens loc psig_theta_vars - ; _ <- solveSimpleGivens psig_givens - -- See Note [Add signature contexts as givens] - ; solveWanteds wanteds } - - -- 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_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs - ; let definite_error = insolubleWC wanted_transformed_incl_derivs - -- See Note [Quantification with errors] - -- NB: must include derived errors in this test, - -- hence "incl_derivs" - wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs - 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 - ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl - name_taus partial_sigs - quant_pred_candidates - ; bound_theta_vars <- mapM TcM.newEvVar bound_theta - - -- We must produce bindings for the psig_theta_vars, because we may have - -- used them in evidence bindings constructed by solveWanteds earlier - -- Easiest way to do this is to emit them as new Wanteds (#14643) - ; ct_loc <- getCtLocM AnnOrigin Nothing - ; let psig_wanted = [ CtWanted { ctev_pred = idType psig_theta_var - , ctev_dest = EvVarDest psig_theta_var - , ctev_nosh = WDeriv - , ctev_loc = ct_loc } - | psig_theta_var <- psig_theta_vars ] - - -- Now construct the residual constraint - ; residual_wanted <- mkResidualConstraints rhs_tclvl ev_binds_var - name_taus co_vars qtvs bound_theta_vars - (wanted_transformed `andWC` mkSimpleWC psig_wanted) - - -- 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 =" <+> ppr bound_theta - , text "qtvs =" <+> ppr qtvs - , text "definite_error =" <+> ppr definite_error ] - - ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var - , residual_wanted, definite_error ) } - -- NB: bound_theta_vars must be fully zonked - where - partial_sigs = filter isPartialSig sigs - --------------------- -mkResidualConstraints :: TcLevel -> EvBindsVar - -> [(Name, TcTauType)] - -> VarSet -> [TcTyVar] -> [EvVar] - -> WantedConstraints -> TcM WantedConstraints --- Emit the remaining constraints from the RHS. --- See Note [Emitting the residual implication in simplifyInfer] -mkResidualConstraints rhs_tclvl ev_binds_var - name_taus co_vars qtvs full_theta_vars wanteds - | isEmptyWC wanteds - = return wanteds - - | otherwise - = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds) - ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple - is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars - - ; _ <- 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_telescope = Nothing - , ic_given = full_theta_vars - , ic_wanted = inner_wanted - , ic_binds = ev_binds_var - , ic_no_eqs = False - , ic_info = skol_info } - - ; return (WC { 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 ] - -- 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 ] - -{- 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 givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#11016): - f2 :: (?x :: Int) => _ - f2 = ?x -or this - f3 :: a ~ Bool => (a, _) - f3 = (True, False) -or theis - f4 :: (Ord a, _) => a -> Bool - f4 x = x==x - -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 we want the (a ~ Bool) available to solve the wanted (a ~ Bool) - in the RHS - * For f4 we want to use the (Ord a) in the signature to solve the Eq a - constraint. - -Solution: in simplifyInfer, just before simplifying the constraints -gathered from the RHS, add Given constraints for the context of any -type signatures. - -************************************************************************ -* * - Quantification -* * -************************************************************************ - -Note [Deciding quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the monomorphism restriction does not apply, then we quantify as follows: - -* Step 1. Take the global tyvars, and "grow" them using the equality - constraints - 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 - - 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. 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. - -* Step 3: decide which variables to quantify over, as follows: - - - Take the free vars of the tau-type (zonked_tau_tvs) and "grow" - them using all the constraints. These are tau_tvs_plus - - - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being - careful to close over kinds, and to skolemise the quantified tyvars. - (This actually unifies each quantifies meta-tyvar with a fresh skolem.) - - 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. - --} - -decideQuantification - :: 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) - , VarSet) --- See Note [Deciding quantification] -decideQuantification 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 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 quantifiable_candidates - = pickQuantifiablePreds (mkVarSet qtvs) candidates - -- NB: do /not/ run pickQuantifiablePreds over psig_theta, - -- because we always want to quantify over psig_theta, and not - -- drop any of them; e.g. CallStack constraints. c.f #14658 - - theta = mkMinimalBySCs id $ -- See Note [Minimize by Superclasses] - (psig_theta ++ quantifiable_candidates) - - ; 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) } - ------------------- -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 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 <- mapM zonkTcTyVarToTyVar $ - 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) - 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 - -- candidates 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 - - eq_constraints = filter isEqPrimPred candidates - mono_tvs2 = growThetaTyVars eq_constraints mono_tvs1 - - constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $ - (growThetaTyVars eq_constraints - (tyCoVarsOfTypes no_quant) - `minusVarSet` mono_tvs2) - `delVarSetList` psig_qtvs - -- 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) - -- - -- (`delVarSetList` psig_qtvs): if the user has explicitly - -- asked for quantification, then that request "wins" - -- over the MR. Note: do /not/ delete psig_qtvs from - -- mono_tvs1, because mono_tvs1 cannot under any circumstances - -- be quantified (#14479); see - -- Note [Quantification and partial signatures], Wrinkle 3, 4 - - mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs - - -- Warn about the monomorphism restriction - ; warn_mono <- woptM Opt_WarnMonomorphism - ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $ - warnTc (Reason Opt_WarnMonomorphism) - (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) - mr_msg - - ; traceTc "decideMonoTyVars" $ vcat - [ text "mono_tvs0 =" <+> ppr mono_tvs0 - , text "no_quant =" <+> ppr no_quant - , text "maybe_quant =" <+> ppr maybe_quant - , text "eq_constraints =" <+> ppr eq_constraints - , 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 - - pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus - mr_msg = - hang (sep [ text "The Monomorphism Restriction applies to the binding" - <> plural name_taus - , text "for" <+> pp_bndrs ]) - 2 (hsep [ text "Consider giving" - , text (if isSingleton name_taus then "it" else "them") - , text "a type signature"]) - -------------------- -defaultTyVarsAndSimplify :: TcLevel - -> TyCoVarSet - -> [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 mono_tvs candidates - = do { -- Promote any tyvars that we cannot generalise - -- See Note [Promote momomorphic tyvars] - ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs) - ; (prom, _) <- 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 - ; default_kvs <- mapM (default_one poly_kinds True) - (dVarSetElems cand_kvs) - ; default_tvs <- mapM (default_one poly_kinds False) - (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) - ; let some_default = or default_kvs || or default_tvs - - ; case () of - _ | some_default -> simplify_cand candidates - | prom -> mapM TcM.zonkTcType candidates - | otherwise -> return candidates - } - where - default_one poly_kinds is_kind_var tv - | not (isMetaTyVar tv) - = return False - | tv `elemVarSet` mono_tvs - = return False - | otherwise - = defaultTyVar (not poly_kinds && is_kind_var) tv - - 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 - :: [(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 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 - , (_,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' - 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 "candidates =" <+> ppr candidates - , 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 dvs_plus } - ------------------- -growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet --- See Note [Growing the tau-tvs using constraints] -growThetaTyVars theta tcvs - | null theta = tcvs - | otherwise = transCloVarSet mk_next seed_tcvs - where - seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips - (ips, non_ips) = partition isIPPred theta - -- See Note [Inheriting implicit parameters] in TcType - - 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 momomorphic 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: promoteTyVar 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, be 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 (HoleCan (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 TcSimplify.decideMonoTyVars. We - report the error later, in TcBinds.chooseInferredQuantifiers. - -Note [Growing the tau-tvs using constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(growThetaTyVars insts tvs) is the result of extending the set - of tyvars, tvs, using all conceivable links from pred - -E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e} -Then growThetaTyVars preds tvs = {a,b,c} - -Notice that - growThetaTyVars is conservative if v might be fixed by vs - => v `elem` grow(vs,C) - -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 -TcBinds.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. - -NB that we must include *derived* errors in the check for insolubles. -Example: - (a::*) ~ Int# -We get an insoluble derived error *~#, and we don't want to discard -it before doing the isInsolubleWC test! (#8262) - -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 --- Discards all Derived stuff in result --- Postcondition: fully zonked and unflattened constraints -simplifyWantedsTcM wanted - = do { traceTc "simplifyWantedsTcM {" (ppr wanted) - ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted)) - ; result <- TcM.zonkWC result - ; traceTc "simplifyWantedsTcM }" (ppr result) - ; return result } - -solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints --- Since solveWanteds returns the residual WantedConstraints, --- it should always be called within a runTcS or something similar, --- Result is not zonked -solveWantedsAndDrop wanted - = do { wc <- solveWanteds wanted - ; return (dropDerivedWC wc) } - -solveWanteds :: WantedConstraints -> TcS WantedConstraints --- so that the inert set doesn't mindlessly propagate. --- NB: wc_simples may be wanted /or/ derived now -solveWanteds wc@(WC { wc_simple = simples, wc_impl = implics }) - = do { cur_lvl <- TcS.getTcLevel - ; traceTcS "solveWanteds {" $ - vcat [ text "Level =" <+> ppr cur_lvl - , ppr wc ] - - ; wc1 <- solveSimpleWanteds simples - -- Any insoluble constraints are in 'simples' and so get rewritten - -- See Note [Rewrite insolubles] in TcSMonad - - ; (floated_eqs, implics2) <- solveNestedImplications $ - implics `unionBags` wc_impl wc1 - - ; dflags <- getDynFlags - ; final_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs - (wc1 { wc_impl = implics2 }) - - ; 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 } - -simpl_loop :: Int -> IntWithInf -> Cts - -> WantedConstraints -> TcS WantedConstraints -simpl_loop n limit floated_eqs 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 (hang (text "solveWanteds: too many iterations" - <+> parens (text "limit =" <+> ppr limit)) - 2 (vcat [ text "Unsolved:" <+> ppr wc - , ppUnless (isEmptyBag floated_eqs) $ - text "Floated equalities:" <+> ppr floated_eqs - , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" - ])) - ; return wc } - - | not (isEmptyBag floated_eqs) - = simplify_again n limit True (wc { wc_simple = floated_eqs `unionBags` simples }) - -- Put floated_eqs first so they get solved first - -- NB: the floated_eqs may include /derived/ equalities - -- arising from fundeps inside an implication - - | 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_again n limit (null pending_given) - wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } } - - | otherwise - = return wc - -simplify_again :: Int -> IntWithInf -> Bool - -> WantedConstraints -> TcS WantedConstraints --- We have definitely decided to have another go at solving --- the wanted constraints (we have tried at least once already -simplify_again n limit no_new_given_scs - wc@(WC { wc_simple = simples, wc_impl = implics }) - = do { csTraceTcS $ - text "simpl_loop iteration=" <> int n - <+> (parens $ hsep [ text "no new given superclasses =" <+> ppr no_new_given_scs <> comma - , int (lengthBag simples) <+> text "simples to solve" ]) - ; traceTcS "simpl_loop: wc =" (ppr wc) - - ; (unifs1, wc1) <- reportUnifications $ - solveSimpleWanteds $ - simples - - -- See Note [Cutting off simpl_loop] - -- We have already tried to solve the nested implications once - -- Try again only if we have unified some meta-variables - -- (which is a bit like adding more givens), or we have some - -- new Given superclasses - ; let new_implics = wc_impl wc1 - ; if unifs1 == 0 && - no_new_given_scs && - isEmptyBag new_implics - - then -- Do not even try to solve the implications - simpl_loop (n+1) limit emptyBag (wc1 { wc_impl = implics }) - - else -- Try to solve the implications - do { (floated_eqs2, implics2) <- solveNestedImplications $ - implics `unionBags` new_implics - ; simpl_loop (n+1) limit floated_eqs2 (wc1 { wc_impl = implics2 }) - } } - -solveNestedImplications :: Bag Implication - -> TcS (Cts, 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, emptyBag) - | otherwise - = do { traceTcS "solveNestedImplications starting {" empty - ; (floated_eqs_s, unsolved_implics) <- mapAndUnzipBagM solveImplication implics - ; let floated_eqs = concatBag floated_eqs_s - - -- ... 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 "all floated_eqs =" <+> ppr floated_eqs - , text "unsolved_implics =" <+> ppr unsolved_implics ] - - ; return (floated_eqs, catBagMaybes unsolved_implics) } - -solveImplication :: Implication -- Wanted - -> TcS (Cts, -- All wanted or derived floated equalities: var = type - 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_skols = skols - , ic_given = given_ids - , ic_wanted = wanteds - , ic_info = info - , ic_status = status }) - | isSolvedStatus status - = return (emptyCts, 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 - ; (no_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 - -- solveWanteds, *not* solveWantedsAndDrop, because - -- we want to retain derived equalities so we can float - -- them out in floatEqualities - - ; (no_eqs, given_insols) <- getNoGivenEqs tclvl skols - -- Call getNoGivenEqs /after/ solveWanteds, because - -- solveWanteds can augment the givens, via expandSuperClasses, - -- to reveal given superclass equalities - - ; return (no_eqs, given_insols, residual_wanted) } - - ; (floated_eqs, residual_wanted) - <- floatEqualities skols given_ids ev_binds_var - no_given_eqs 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_no_eqs = no_given_eqs - , ic_wanted = final_wanted }) - - ; evbinds <- TcS.getTcEvBindsMap ev_binds_var - ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var - ; traceTcS "solveImplication end }" $ vcat - [ text "no_given_eqs =" <+> ppr no_given_eqs - , text "floated_eqs =" <+> ppr floated_eqs - , text "res_implic =" <+> ppr res_implic - , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) - , text "implication tvcs =" <+> ppr tcvs ] - - ; return (floated_eqs, res_implic) } - - where - -- TcLevels must be strictly increasing (see (ImplicInv) in - -- Note [TcLevel and untouchable type variables] in 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 - ; MASSERT2( 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: --- * Set the ic_status field --- * Trim the ic_wanted field to remove Derived constraints --- 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 }) - | ASSERT2( 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 dead_givens | warnRedundantGivens info - = filterOut (`elemVarSet` need_inner) givens - | otherwise = [] -- None to report - - discard_entire_implication -- Can we discard the entire implication? - = null dead_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 = dead_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 - - pruned_simples = dropDerivedSimples simples - pruned_implics = filterBag keep_me implics - pruned_wc = WC { wc_simple = pruned_simples - , wc_impl = pruned_implics } - - 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 - -checkBadTelescope :: Implication -> TcS Bool --- True <=> the skolems form a bad telescope --- See Note [Checking telescopes] in Constraint -checkBadTelescope (Implic { ic_telescope = m_telescope - , ic_skols = skols }) - | isJust m_telescope - = 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 :: SkolemInfo -> Bool -warnRedundantGivens (SigSkol ctxt _ _) - = case ctxt of - FunSigCtxt _ warn_redundant -> warn_redundant - ExprSigCtxt -> True - _ -> 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 = foldEvBindMap add_wanted seeds1 ev_binds - seeds3 = seeds2 `unionVarSet` tcvs - need_inner = findNeededEvVars ev_binds seeds3 - live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds - need_outer = foldEvBindMap del_ev_bndr need_inner live_ev_binds - `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 - - del_ev_bndr :: EvBind -> VarSet -> VarSet - del_ev_bndr (EvBind { eb_lhs = v }) needs = delVarSet needs v - - add_wanted :: EvBind -> VarSet -> VarSet - add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs - | is_given = needs -- Add the rhs vars of the Wanted bindings only - | otherwise = evVarsOfTerm rhs `unionVarSet` needs - - -{- 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_looop), 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 [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: - ------ 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 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 - b) 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 - -* To find (a), when we have two Given constraints, - we must be careful to drop the one that is a naked variable (if poss). - So if we have - f :: (Eq a, Ord a) => blah - then we may find [G] sc_sel (d1::Ord a) :: Eq a - [G] d2 :: Eq a - We want to discard d2 in favour of the superclass selection from - the Ord dictionary. This is done by TcInteract.solveOneFromTheOther - See Note [Replacement vs keeping]. - -* To find (b) we need to know which evidence bindings are 'wanted'; - hence the eb_is_given field on an EvBind. - ------ How tracking works - -* 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. - -* 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, - c) it is in the ics_need of a nested implication. - -* 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. - ------ Reporting redundant constraints - -* TcErrors does the actual warning, in warnRedundantConstraints. - -* We don't report redundant givens for *every* implication; only - for those which reply True to TcSimplify.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 - - TcBinds.tcSpecPrag - - TcBinds.tcTySig - - This decision is taken in setImplicationStatus, rather than TcErrors - so that we can discard implication constraints that we don't need. - So ics_dead consists only of the *reportable* redundant givens. - ------ Shortcomings - -Consider (see #9939) - f2 :: (Eq a, Ord a) => a -> a -> Bool - -- Ord a redundant, but Eq a is reported - f2 x y = (x == y) - -We report (Eq a) as redundant, whereas actually (Ord a) is. But it's -really not easy to detect that! - - -Note [Cutting off simpl_loop] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is very important not to iterate in simpl_loop unless there is a chance -of progress. #8474 is a classic 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 [D] alpha ~ Int, - but alpha is untouchable until we get out to the outermost one - - * We float [D] alpha~Int out (it is in floated_eqs), but since alpha - is untouchable, the solveInteract in simpl_loop makes no progress - - * So there is no point in attempting to re-solve - ?yn:betan => [W] ?x:Int - via solveNestedImplications, because we'll just get the - same [D] again - - * If we *do* re-solve, we'll get an infinite loop. It is cut off by - the fixed bound of 10, but solving the next takes 10*10*...*10 (ie - exponentially many) iterations! - -Conclusion: we should call solveNestedImplications only if we did -some unification in solveSimpleWanteds; because that's the only way -we'll get more Givens (a unification is like adding a Given) to -allow the implication to make progress. --} - -promoteTyVar :: TcTyVar -> TcM (Bool, TcTyVar) --- When we float a constraint out of an implication we must restore --- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in TcType --- Return True <=> we did some promotion --- Also returns either the original tyvar (no promotion) or the new one --- See Note [Promoting unification variables] -promoteTyVar tv - = do { tclvl <- TcM.getTcLevel - ; if (isFloatedTouchableMetaTyVar tclvl tv) - then do { cloned_tv <- TcM.cloneMetaTyVar tv - ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl - ; TcM.writeMetaTyVar tv (mkTyVarTy rhs_tv) - ; return (True, rhs_tv) } - else return (False, tv) } - --- Returns whether or not *any* tyvar is defaulted -promoteTyVarSet :: TcTyVarSet -> TcM (Bool, TcTyVarSet) -promoteTyVarSet tvs - = do { (bools, tyvars) <- mapAndUnzipM promoteTyVar (nonDetEltsUniqSet tvs) - -- non-determinism is OK because order of promotion doesn't matter - - ; return (or bools, mkVarSet tyvars) } - -promoteTyVarTcS :: TcTyVar -> TcS () --- When we float a constraint out of an implication we must restore --- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in TcType --- See Note [Promoting unification variables] --- We don't just call promoteTyVar because we want to use unifyTyVar, --- not writeMetaTyVar -promoteTyVarTcS tv - = do { tclvl <- TcS.getTcLevel - ; when (isFloatedTouchableMetaTyVar tclvl tv) $ - do { cloned_tv <- TcS.cloneMetaTyVar tv - ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl - ; unifyTyVar tv (mkTyVarTy rhs_tv) } } - --- | Like 'defaultTyVar', but in the TcS monad. -defaultTyVarTcS :: TcTyVar -> TcS Bool -defaultTyVarTcS the_tv - | isRuntimeRepVar the_tv - , not (isTyVarTyVar the_tv) - -- TyVarTvs should only be unified with a tyvar - -- never with a type; c.f. TcMType.defaultTyVar - -- and Note [Inferring kinds for type declarations] in TcTyClsDecls - = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) - ; unifyTyVar the_tv liftedRepTy - ; return True } - | otherwise - = return False -- the common case - -approximateWC :: Bool -> WantedConstraints -> Cts --- Postcondition: Wanted or Derived Cts --- See Note [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` - do_bag (float_implic trapping_tvs) implics - where - - float_implic :: TcTyCoVarSet -> Implication -> Cts - float_implic trapping_tvs imp - | float_past_equalities || ic_no_eqs imp - = 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 - - do_bag :: (a -> Bag c) -> Bag a -> Bag c - do_bag f = foldr (unionBags.f) emptyBag - - is_floatable skol_tvs ct - | isGivenCt ct = False - | isHoleCt 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 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 tcTypeKind (*) 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 derived 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 and untouchable type variables] in 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 and untouchable type variables] in -TcType. for the leftover implication. - -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) - - - -********************************************************************************* -* * -* Floating equalities * -* * -********************************************************************************* - -Note [Float Equalities out of Implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For ordinary pattern matches (including existentials) we float -equalities out of implications, for instance: - data T where - MkT :: Eq a => a -> T - f x y = case x of MkT _ -> (y::Int) -We get the implication constraint (x::T) (y::alpha): - forall a. [untouchable=alpha] Eq a => alpha ~ Int -We want to float out the equality into a scope where alpha is no -longer untouchable, to solve the implication! - -But we cannot float equalities out of implications whose givens may -yield or contain equalities: - - data T a where - T1 :: T Int - T2 :: T Bool - T3 :: T a - - h :: T a -> a -> Int - - f x y = case x of - T1 -> y::Int - T2 -> y::Bool - T3 -> h x y - -We generate constraint, for (x::T alpha) and (y :: beta): - [untouchables = beta] (alpha ~ Int => beta ~ Int) -- From 1st branch - [untouchables = beta] (alpha ~ Bool => beta ~ Bool) -- From 2nd branch - (alpha ~ beta) -- From 3rd branch - -If we float the equality (beta ~ Int) outside of the first implication and -the equality (beta ~ Bool) out of the second we get an insoluble constraint. -But if we just leave them inside the implications, we unify alpha := beta and -solve everything. - -Principle: - We do not want to float equalities out which may - need the given *evidence* to become soluble. - -Consequence: classes with functional dependencies don't matter (since there is -no evidence for a fundep equality), but equality superclasses do matter (since -they carry evidence). --} - -floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> Bool - -> WantedConstraints - -> TcS (Cts, WantedConstraints) --- Main idea: see Note [Float Equalities out of Implications] --- --- Precondition: the wc_simple of the incoming WantedConstraints are --- fully zonked, so that we can see their free variables --- --- Postcondition: The returned floated constraints (Cts) are only --- Wanted or Derived --- --- Also performs some unifications (via promoteTyVar), adding to --- monadically-carried ty_binds. These will be used when processing --- floated_eqs later --- --- Subtleties: Note [Float equalities from under a skolem binding] --- Note [Skolem escape] --- Note [What prevents a constraint from floating] -floatEqualities skols given_ids ev_binds_var no_given_eqs - wanteds@(WC { wc_simple = simples }) - | not no_given_eqs -- There are some given equalities, so don't float - = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] - - | otherwise - = do { -- First zonk: the inert set (from whence they came) is fully - -- zonked, but unflattening may have filled in unification - -- variables, and we /must/ see them. Otherwise we may float - -- constraints that mention the skolems! - simples <- TcS.zonkSimples simples - ; binds <- TcS.getTcEvBindsMap ev_binds_var - - -- Now we can pick the ones to float - -- The constraints are un-flattened and de-canonicalised - ; let (candidate_eqs, no_float_cts) = partitionBag is_float_eq_candidate simples - - seed_skols = mkVarSet skols `unionVarSet` - mkVarSet given_ids `unionVarSet` - foldr add_non_flt_ct emptyVarSet no_float_cts `unionVarSet` - foldEvBindMap add_one_bind emptyVarSet binds - -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3) - -- Include the EvIds of any non-floating constraints - - extended_skols = transCloVarSet (add_captured_ev_ids candidate_eqs) seed_skols - -- extended_skols contains the EvIds of all the trapped constraints - -- See Note [What prevents a constraint from floating] (3) - - (flt_eqs, no_flt_eqs) = partitionBag (is_floatable extended_skols) - candidate_eqs - - remaining_simples = no_float_cts `andCts` no_flt_eqs - - -- Promote any unification variables mentioned in the floated equalities - -- See Note [Promoting unification variables] - ; mapM_ promoteTyVarTcS (tyCoVarsOfCtsList flt_eqs) - - ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols - , text "Extended skols =" <+> ppr extended_skols - , text "Simples =" <+> ppr simples - , text "Candidate eqs =" <+> ppr candidate_eqs - , text "Floated eqs =" <+> ppr flt_eqs]) - ; return ( flt_eqs, wanteds { wc_simple = remaining_simples } ) } - - where - add_one_bind :: EvBind -> VarSet -> VarSet - add_one_bind bind acc = extendVarSet acc (evBindVar bind) - - add_non_flt_ct :: Ct -> VarSet -> VarSet - add_non_flt_ct ct acc | isDerivedCt ct = acc - | otherwise = extendVarSet acc (ctEvId ct) - - is_floatable :: VarSet -> Ct -> Bool - is_floatable skols ct - | isDerivedCt ct = not (tyCoVarsOfCt ct `intersectsVarSet` skols) - | otherwise = not (ctEvId ct `elemVarSet` skols) - - add_captured_ev_ids :: Cts -> VarSet -> VarSet - add_captured_ev_ids cts skols = foldr extra_skol emptyVarSet cts - where - extra_skol ct acc - | isDerivedCt ct = acc - | tyCoVarsOfCt ct `intersectsVarSet` skols = extendVarSet acc (ctEvId ct) - | otherwise = acc - - -- Identify which equalities are candidates for floating - -- Float out alpha ~ ty, or ty ~ alpha which might be unified outside - -- See Note [Which equalities to float] - is_float_eq_candidate ct - | pred <- ctPred ct - , EqPred NomEq ty1 ty2 <- classifyPredType pred - = case (tcGetTyVar_maybe ty1, tcGetTyVar_maybe ty2) of - (Just tv1, _) -> float_tv_eq_candidate tv1 ty2 - (_, Just tv2) -> float_tv_eq_candidate tv2 ty1 - _ -> False - | otherwise = False - - float_tv_eq_candidate tv1 ty2 -- See Note [Which equalities to float] - = isMetaTyVar tv1 - && (not (isTyVarTyVar tv1) || isTyVarTy ty2) - - -{- Note [Float equalities from under a skolem binding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Which of the simple equalities can we float out? Obviously, only -ones that don't mention the skolem-bound variables. But that is -over-eager. Consider - [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int -The second constraint doesn't mention 'a'. But if we float it, -we'll promote gamma[2] to gamma'[1]. Now suppose that we learn that -beta := Bool, and F a Bool = a, and G Bool _ = Int. Then we'll -we left with the constraint - [2] forall a. a ~ gamma'[1] -which is insoluble because gamma became untouchable. - -Solution: float only constraints that stand a jolly good chance of -being soluble simply by being floated, namely ones of form - a ~ ty -where 'a' is a currently-untouchable unification variable, but may -become touchable by being floated (perhaps by more than one level). - -We had a very complicated rule previously, but this is nice and -simple. (To see the notes, look at this Note in a version of -TcSimplify prior to Oct 2014). - -Note [Which equalities to float] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Which equalities should we float? We want to float ones where there -is a decent chance that floating outwards will allow unification to -happen. In particular, float out equalities that are: - -* Of form (alpha ~# ty) or (ty ~# alpha), where - * alpha is a meta-tyvar. - * And 'alpha' is not a TyVarTv with 'ty' being a non-tyvar. In that - case, floating out won't help either, and it may affect grouping - of error messages. - -* Nominal. No point in floating (alpha ~R# ty), because we do not - unify representational equalities even if alpha is touchable. - See Note [Do not unify representational equalities] in TcInteract. - -Note [Skolem escape] -~~~~~~~~~~~~~~~~~~~~ -You might worry about skolem escape with all this floating. -For example, consider - [2] forall a. (a ~ F beta[2] delta, - Maybe beta[2] ~ gamma[1]) - -The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and -solve with gamma := beta. But what if later delta:=Int, and - F b Int = b. -Then we'd get a ~ beta[2], and solve to get beta:=a, and now the -skolem has escaped! - -But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2] -to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be. - -Note [What prevents a constraint from floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What /prevents/ a constraint from floating? If it mentions one of the -"bound variables of the implication". What are they? - -The "bound variables of the implication" are - - 1. The skolem type variables `ic_skols` - - 2. The "given" evidence variables `ic_given`. Example: - forall a. (co :: t1 ~# t2) => [W] co2 : (a ~# b |> co) - Here 'co' is bound - - 3. The binders of all evidence bindings in `ic_binds`. Example - forall a. (d :: t1 ~ t2) - EvBinds { (co :: t1 ~# t2) = superclass-sel d } - => [W] co2 : (a ~# b |> co) - Here `co` is gotten by superclass selection from `d`, and the - wanted constraint co2 must not float. - - 4. And the evidence variable of any equality constraint (incl - Wanted ones) whose type mentions a bound variable. Example: - forall k. [W] co1 :: t1 ~# t2 |> co2 - [W] co2 :: k ~# * - Here, since `k` is bound, so is `co2` and hence so is `co1`. - -Here (1,2,3) are handled by the "seed_skols" calculation, and -(4) is done by the transCloVarSet call. - -The possible dependence on givens, and evidence bindings, is more -subtle than we'd realised at first. See #14584. - -How can (4) arise? Suppose we have (k :: *), (a :: k), and ([G} k ~ *). -Then form an equality like (a ~ Int) we might end up with - [W] co1 :: k ~ * - [W] co2 :: (a |> co1) ~ Int - - -********************************************************************************* -* * -* Defaulting and disambiguation * -* * -********************************************************************************* --} - -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 - - ; 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) } - -findDefaultableGroups - :: ( [Type] - , (Bool,Bool) ) -- (Overloaded strings, extended default rules) - -> WantedConstraints -- Unsolved (wanted or derived) - -> [(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 <- tcGetTyVar_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 -foverloaded-strings is enabled - is_std_class cls = isStandardClass cls || - (ovl_strings && (cls `hasKey` isStringClassKey)) - ------------------------------- -disambigGroup :: [Type] -- The default types - -> (TcTyVar, [Ct]) -- All classes of the form (C a) - -- 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 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 UnkSkol lcl_env - ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred) - wanteds - ; fmap isEmptyWC $ - solveSimpleWanteds $ listToBag $ - map mkNonCanonical wanted_evs } - - | otherwise - = return False - - the_ty = mkTyVarTy the_tv - mb_subst = tcMatchTyKi the_ty default_ty - -- Make sure the kinds match too; hence this call to tcMatchTyKi - -- E.g. suppose the only constraint was (Typeable k (a::k)) - -- With the addition of polykinded defaulting we also want to reject - -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here. - --- In interactive mode, or with -XExtendedDefaultRules, --- we default Show a to Show () to avoid graututious errors on "show []" -isInteractiveClass :: Bool -- -XOverloadedStrings? - -> Class -> Bool -isInteractiveClass ovl_strings cls - = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys) - - -- isNumClass adds IsString to the standard numeric classes, - -- when -foverloaded-strings is enabled -isNumClass :: Bool -- -XOverloadedStrings? - -> Class -> Bool -isNumClass ovl_strings cls - = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) - - -{- -Note [Avoiding spurious errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When doing the unification for defaulting, we check for skolem -type variables, and simply don't default them. For example: - f = (*) -- Monomorphic - g :: Num a => a -> a - g x = f x x -Here, we get a complaint when checking the type signature for g, -that g isn't polymorphic enough; but then we get another one when -dealing with the (Num a) context arising from f's definition; -we try to unify a with Int (to default it), but find that it's -already been unified with the rigid variable from g's type sig. - -Note [Multi-parameter defaults] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With -XExtendedDefaultRules, we default only based on single-variable -constraints, but do not exclude from defaulting any type variables which also -appear in multi-variable constraints. This means that the following will -default properly: - - default (Integer, Double) - - class A b (c :: Symbol) where - a :: b -> Proxy c - - instance A Integer c where a _ = Proxy - - main = print (a 5 :: Proxy "5") - -Note that if we change the above instance ("instance A Integer") to -"instance A Double", we get an error: - - No instance for (A Integer "5") - -This is because the first defaulted type (Integer) has successfully satisfied -its single-parameter constraints (in this case Num). --} diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs deleted file mode 100644 --- a/compiler/typecheck/TcSplice.hs +++ /dev/null @@ -1,2385 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcSplice: Template Haskell splices --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcSplice( - tcSpliceExpr, tcTypedBracket, tcUntypedBracket, --- runQuasiQuoteExpr, runQuasiQuotePat, --- runQuasiQuoteDecl, runQuasiQuoteType, - runAnnotation, - - runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, - tcTopSpliceExpr, lookupThName_maybe, - defaultRunMeta, runMeta', runRemoteModFinalizers, - finishTH, runTopSplice - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import GHC.Types.Annotations -import GHC.Driver.Finder -import GHC.Types.Name -import TcRnMonad -import TcType - -import Outputable -import TcExpr -import GHC.Types.SrcLoc -import THNames -import TcUnify -import TcEnv -import TcOrigin -import GHC.Core.Coercion( etaExpandCoAxBranch ) -import FileCleanup ( newTempName, TempFileLifetime(..) ) - -import Control.Monad - -import GHCi.Message -import GHCi.RemoteTypes -import GHC.Runtime.Interpreter -import GHC.Runtime.Interpreter.Types -import GHC.Driver.Main - -- These imports are the reason that TcSplice - -- is very high up the module hierarchy -import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) -import GHC.Types.Name.Reader -import GHC.Driver.Types -import GHC.ThToHs -import GHC.Rename.Expr -import GHC.Rename.Env -import GHC.Rename.Utils ( HsDocContext(..) ) -import GHC.Rename.Fixity ( lookupFixityRn_help ) -import GHC.Rename.Types -import TcHsSyn -import TcSimplify -import GHC.Core.Type as Type -import GHC.Types.Name.Set -import TcMType -import TcHsType -import GHC.IfaceToCore -import GHC.Core.TyCo.Rep as TyCoRep -import FamInst -import GHC.Core.FamInstEnv -import GHC.Core.InstEnv as InstEnv -import Inst -import GHC.Types.Name.Env -import PrelNames -import TysWiredIn -import GHC.Types.Name.Occurrence as OccName -import GHC.Driver.Hooks -import GHC.Types.Var -import GHC.Types.Module -import GHC.Iface.Load -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Core.Coercion.Axiom -import GHC.Core.PatSyn -import GHC.Core.ConLike -import GHC.Core.DataCon as DataCon -import TcEvidence -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.HsToCore.Expr -import GHC.HsToCore.Monad -import GHC.Serialized -import ErrUtils -import Util -import GHC.Types.Unique -import GHC.Types.Var.Set -import Data.List ( find ) -import Data.Maybe -import FastString -import GHC.Types.Basic as BasicTypes hiding( SuccessFlag(..) ) -import Maybes( MaybeErr(..) ) -import GHC.Driver.Session -import Panic -import GHC.Utils.Lexeme -import qualified EnumSet -import GHC.Driver.Plugins -import Bag - -import qualified Language.Haskell.TH as TH --- THSyntax gives access to internal functions and data types -import qualified Language.Haskell.TH.Syntax as TH - -#if defined(HAVE_INTERNAL_INTERPRETER) --- Because GHC.Desugar might not be in the base library of the bootstrapping compiler -import GHC.Desugar ( AnnotationWrapper(..) ) -import Unsafe.Coerce ( unsafeCoerce ) -#endif - -import Control.Exception -import Data.Binary -import Data.Binary.Get -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LB -import Data.Dynamic ( fromDynamic, toDyn ) -import qualified Data.Map as Map -import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) -import Data.Data (Data) -import Data.Proxy ( Proxy (..) ) - -{- -************************************************************************ -* * -\subsection{Main interface + stubs for the non-GHCI case -* * -************************************************************************ --} - -tcTypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType - -> TcM (HsExpr GhcTcId) -tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) - -- None of these functions add constraints to the LIE - --- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName) --- runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName) --- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName) --- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] - -runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation -{- -************************************************************************ -* * -\subsection{Quoting an expression} -* * -************************************************************************ --} - --- See Note [How brackets and nested splices are handled] --- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) -tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty - = addErrCtxt (quotationCtxtDoc brack) $ - do { cur_stage <- getStage - ; ps_ref <- newMutVar [] - ; lie_var <- getConstraintVar -- Any constraints arising from nested splices - -- should get thrown into the constraint set - -- from outside the bracket - - -- Make a new type variable for the type of the overall quote - ; m_var <- mkTyVarTy <$> mkMetaTyVar - -- Make sure the type variable satisfies Quote - ; ev_var <- emitQuoteWanted m_var - -- Bundle them together so they can be used in GHC.HsToCore.Quote for desugaring - -- brackets. - ; let wrapper = QuoteWrapper ev_var m_var - -- Typecheck expr to make sure it is valid, - -- Throw away the typechecked expression but return its type. - -- We'll typecheck it again when we splice it in somewhere - ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $ - tcInferRhoNC expr - -- NC for no context; tcBracket does that - ; let rep = getRuntimeRep expr_ty - ; meta_ty <- tcTExpTy m_var expr_ty - ; ps' <- readMutVar ps_ref - ; texpco <- tcLookupId unsafeTExpCoerceName - ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") - rn_expr - (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper) - (nlHsTyApp texpco [rep, expr_ty])) - (noLoc (HsTcBracketOut noExtField (Just wrapper) brack ps')))) - meta_ty res_ty } -tcTypedBracket _ other_brack _ - = pprPanic "tcTypedBracket" (ppr other_brack) - --- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId) --- See Note [Typechecking Overloaded Quotes] -tcUntypedBracket rn_expr brack ps res_ty - = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) - - - -- Create the type m Exp for expression bracket, m Type for a type - -- bracket and so on. The brack_info is a Maybe because the - -- VarBracket ('a) isn't overloaded, but also shouldn't contain any - -- splices. - ; (brack_info, expected_type) <- brackTy brack - - -- Match the expected type with the type of all the internal - -- splices. They might have further constrained types and if they do - -- we want to reflect that in the overall type of the bracket. - ; ps' <- case quoteWrapperTyVarTy <$> brack_info of - Just m_var -> mapM (tcPendingSplice m_var) ps - Nothing -> ASSERT(null ps) return [] - - ; traceTc "tc_bracket done untyped" (ppr expected_type) - - -- Unify the overall type of the bracket with the expected result - -- type - ; tcWrapResultO BracketOrigin rn_expr - (HsTcBracketOut noExtField brack_info brack ps') - expected_type res_ty - - } - --- | A type variable with kind * -> * named "m" -mkMetaTyVar :: TcM TyVar -mkMetaTyVar = - newNamedFlexiTyVar (fsLit "m") (mkVisFunTy liftedTypeKind liftedTypeKind) - - --- | For a type 'm', emit the constraint 'Quote m'. -emitQuoteWanted :: Type -> TcM EvVar -emitQuoteWanted m_var = do - quote_con <- tcLookupTyCon quoteClassName - emitWantedEvVar BracketOrigin $ - mkTyConApp quote_con [m_var] - ---------------- --- | Compute the expected type of a quotation, and also the QuoteWrapper in --- the case where it is an overloaded quotation. All quotation forms are --- overloaded aprt from Variable quotations ('foo) -brackTy :: HsBracket GhcRn -> TcM (Maybe QuoteWrapper, Type) -brackTy b = - let mkTy n = do - -- New polymorphic type variable for the bracket - m_var <- mkTyVarTy <$> mkMetaTyVar - -- Emit a Quote constraint for the bracket - ev_var <- emitQuoteWanted m_var - -- Construct the final expected type of the quote, for example - -- m Exp or m Type - final_ty <- mkAppTy m_var <$> tcMetaTy n - -- Return the evidence variable and metavariable to be used during - -- desugaring. - let wrapper = QuoteWrapper ev_var m_var - return (Just wrapper, final_ty) - in - case b of - (VarBr {}) -> (Nothing,) <$> tcMetaTy nameTyConName - -- Result type is Var (not Quote-monadic) - (ExpBr {}) -> mkTy expTyConName -- Result type is m Exp - (TypBr {}) -> mkTy typeTyConName -- Result type is m Type - (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec] - (PatBr {}) -> mkTy patTyConName -- Result type is m Pat - (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL" - (TExpBr {}) -> panic "tcUntypedBracket: Unexpected TExpBr" - (XBracket nec) -> noExtCon nec - ---------------- --- | Typechecking a pending splice from a untyped bracket -tcPendingSplice :: TcType -- Metavariable for the expected overall type of the - -- quotation. - -> PendingRnSplice - -> TcM PendingTcSplice -tcPendingSplice m_var (PendingRnSplice flavour splice_name expr) - -- See Note [Typechecking Overloaded Quotes] - = do { meta_ty <- tcMetaTy meta_ty_name - -- Expected type of splice, e.g. m Exp - ; let expected_type = mkAppTy m_var meta_ty - ; expr' <- tcPolyExpr expr expected_type - ; return (PendingTcSplice splice_name expr') } - where - meta_ty_name = case flavour of - UntypedExpSplice -> expTyConName - UntypedPatSplice -> patTyConName - UntypedTypeSplice -> typeTyConName - UntypedDeclSplice -> decsTyConName - ---------------- --- 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 (err_msg exp_ty) - ; texp <- tcLookupTyCon tExpTyConName - ; let rep = getRuntimeRep exp_ty - ; return (mkAppTy m_ty (mkTyConApp texp [rep, exp_ty])) } - where - err_msg ty - = vcat [ text "Illegal polytype:" <+> ppr ty - , text "The type of a Typed Template Haskell expression must" <+> - text "not have any quantification." ] - -quotationCtxtDoc :: HsBracket GhcRn -> SDoc -quotationCtxtDoc br_body - = hang (text "In the Template Haskell quotation") - 2 (ppr br_body) - - - -- The whole of the rest of the file is the else-branch (ie stage2 only) - -{- -Note [How top-level splices are handled] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Top-level splices (those not inside a [| .. |] quotation bracket) are handled -very straightforwardly: - - 1. tcTopSpliceExpr: typecheck the body e of the splice $(e) - - 2. runMetaT: desugar, compile, run it, and convert result back to - GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName, - HsExpr RdrName etc) - - 3. treat the result as if that's what you saw in the first place - e.g for HsType, rename and kind-check - for HsExpr, rename and type-check - - (The last step is different for decls, because they can *only* be - top-level: we return the result of step 2.) - -Note [How brackets and nested splices are handled] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Nested splices (those inside a [| .. |] quotation bracket), -are treated quite differently. - -Remember, there are two forms of bracket - typed [|| e ||] - and untyped [| e |] - -The life cycle of a typed bracket: - * Starts as HsBracket - - * When renaming: - * Set the ThStage to (Brack s RnPendingTyped) - * Rename the body - * Result is still a HsBracket - - * When typechecking: - * Set the ThStage to (Brack s (TcPending ps_var lie_var)) - * Typecheck the body, and throw away the elaborated result - * Nested splices (which must be typed) are typechecked, and - the results accumulated in ps_var; their constraints - accumulate in lie_var - * Result is a HsTcBracketOut rn_brack pending_splices - where rn_brack is the incoming renamed bracket - -The life cycle of a un-typed bracket: - * Starts as HsBracket - - * When renaming: - * Set the ThStage to (Brack s (RnPendingUntyped ps_var)) - * Rename the body - * Nested splices (which must be untyped) are renamed, and the - results accumulated in ps_var - * Result is still (HsRnBracketOut rn_body pending_splices) - - * When typechecking a HsRnBracketOut - * Typecheck the pending_splices individually - * Ignore the body of the bracket; just check that the context - expects a bracket of that type (e.g. a [p| pat |] bracket should - be in a context needing a (Q Pat) - * Result is a HsTcBracketOut rn_brack pending_splices - where rn_brack is the incoming renamed bracket - - -In both cases, desugaring happens like this: - * HsTcBracketOut is desugared by GHC.HsToCore.Quote.dsBracket. It - - a) Extends the ds_meta environment with the PendingSplices - attached to the bracket - - b) Converts the quoted (HsExpr Name) to a CoreExpr that, when - run, will produce a suitable TH expression/type/decl. This - is why we leave the *renamed* expression attached to the bracket: - the quoted expression should not be decorated with all the goop - added by the type checker - - * Each splice carries a unique Name, called a "splice point", thus - ${n}(e). The name is initialised to an (Unqual "splice") when the - splice is created; the renamer gives it a unique. - - * When GHC.HsToCore.Quote (used to desugar the body of the bracket) comes across - a splice, it looks up the splice's Name, n, in the ds_meta envt, - to find an (HsExpr Id) that should be substituted for the splice; - it just desugars it to get a CoreExpr (GHC.HsToCore.Quote.repSplice). - -Example: - Source: f = [| Just $(g 3) |] - The [| |] part is a HsBracket - - Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3} - The [| |] part is a HsBracketOut, containing *renamed* - (not typechecked) expression - The "s7" is the "splice point"; the (g Int 3) part - is a typechecked expression - - Desugared: f = do { s7 <- g Int 3 - ; return (ConE "Data.Maybe.Just" s7) } - - -Note [Template Haskell state diagram] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here are the ThStages, s, their corresponding level numbers -(the result of (thLevel s)), and their state transitions. -The top level of the program is stage Comp: - - Start here - | - V - ----------- $ ------------ $ - | Comp | ---------> | Splice | -----| - | 1 | | 0 | <----| - ----------- ------------ - ^ | ^ | - $ | | [||] $ | | [||] - | v | v - -------------- ---------------- - | Brack Comp | | Brack Splice | - | 2 | | 1 | - -------------- ---------------- - -* Normal top-level declarations start in state Comp - (which has level 1). - Annotations start in state Splice, since they are - treated very like a splice (only without a '$') - -* Code compiled in state Splice (and only such code) - will be *run at compile time*, with the result replacing - the splice - -* The original paper used level -1 instead of 0, etc. - -* The original paper did not allow a splice within a - splice, but there is no reason not to. This is the - $ transition in the top right. - -Note [Template Haskell levels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Imported things are impLevel (= 0) - -* However things at level 0 are not *necessarily* imported. - eg $( \b -> ... ) here b is bound at level 0 - -* In GHCi, variables bound by a previous command are treated - as impLevel, because we have bytecode for them. - -* Variables are bound at the "current level" - -* The current level starts off at outerLevel (= 1) - -* The level is decremented by splicing $(..) - incremented by brackets [| |] - incremented by name-quoting 'f - -* When a variable is used, checkWellStaged compares - bind: binding level, and - use: current level at usage site - - Generally - bind > use Always error (bound later than used) - [| \x -> $(f x) |] - - bind = use Always OK (bound same stage as used) - [| \x -> $(f [| x |]) |] - - bind < use Inside brackets, it depends - Inside splice, OK - Inside neither, OK - - For (bind < use) inside brackets, there are three cases: - - Imported things OK f = [| map |] - - Top-level things OK g = [| f |] - - Non-top-level Only if there is a liftable instance - h = \(x:Int) -> [| x |] - - To track top-level-ness we use the ThBindEnv in TcLclEnv - - For example: - f = ... - g1 = $(map ...) is OK - g2 = $(f ...) is not OK; because we haven't compiled f yet - -Note [Typechecking Overloaded Quotes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The main function for typechecking untyped quotations is `tcUntypedBracket`. - -Consider an expression quote, `[| e |]`, its type is `forall m . Quote m => m Exp`. -When we typecheck it we therefore create a template of a metavariable `m` applied to `Exp` and -emit a constraint `Quote m`. All this is done in the `brackTy` function. -`brackTy` also selects the correct contents type for the quotation (Exp, Type, Decs etc). - -The meta variable and the constraint evidence variable are -returned together in a `QuoteWrapper` and then passed along to two further places -during compilation: - -1. Typechecking nested splices (immediately in tcPendingSplice) -2. Desugaring quotations (see GHC.HsToCore.Quote) - -`tcPendingSplice` takes the `m` type variable as an argument and checks -each nested splice against this variable `m`. During this -process the variable `m` can either be fixed to a specific value or further constrained by the -nested splices. - -Once we have checked all the nested splices, the quote type is checked against -the expected return type. - -The process is very simple and like typechecking a list where the quotation is -like the container and the splices are the elements of the list which must have -a specific type. - -After the typechecking process is completed, the evidence variable for `Quote m` -and the type `m` is stored in a `QuoteWrapper` which is passed through the pipeline -and used when desugaring quotations. - -Typechecking typed quotations is a similar idea but the `QuoteWrapper` is stored -in the `PendingStuff` as the nested splices are gathered up in a different way -to untyped splices. Untyped splices are found in the renamer but typed splices are -not typechecked and extracted until during typechecking. - --} - --- | We only want to produce warnings for TH-splices if the user requests so. --- See Note [Warnings for TH splices]. -getThSpliceOrigin :: TcM Origin -getThSpliceOrigin = do - warn <- goptM Opt_EnableThSpliceWarnings - if warn then return FromSource else return Generated - -{- Note [Warnings for TH splices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only produce warnings for TH splices when the user requests so -(-fenable-th-splice-warnings). There are multiple reasons: - - * It's not clear that the user that compiles a splice is the author of the code - that produces the warning. Think of the situation where she just splices in - code from a third-party library that produces incomplete pattern matches. - In this scenario, the user isn't even able to fix that warning. - * Gathering information for producing the warnings (pattern-match check - warnings in particular) is costly. There's no point in doing so if the user - is not interested in those warnings. - -That's why we store Origin flags in the Haskell AST. The functions from ThToHs -take such a flag and depending on whether TH splice warnings were enabled or -not, we pass FromSource (if the user requests warnings) or Generated -(otherwise). This is implemented in getThSpliceOrigin. - -For correct pattern-match warnings it's crucial that we annotate the Origin -consistently (#17270). In the future we could offer the Origin as part of the -TH AST. That would enable us to give quotes from the current module get -FromSource origin, and/or third library authors to tag certain parts of -generated code as FromSource to enable warnings. That effort is tracked in -#14838. --} - -{- -************************************************************************ -* * -\subsection{Splicing an expression} -* * -************************************************************************ --} - -tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty - = addErrCtxt (spliceCtxtDoc splice) $ - setSrcSpan (getLoc expr) $ do - { stage <- getStage - ; case stage of - Splice {} -> tcTopSplice expr res_ty - Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty - RunSplice _ -> - -- See Note [RunSplice ThLevel] in "TcRnTypes". - pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++ - "running another splice") (ppr splice) - Comp -> tcTopSplice expr res_ty - } -tcSpliceExpr splice _ - = pprPanic "tcSpliceExpr" (ppr splice) - -{- Note [Collecting modFinalizers in typed splices] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local -environment (see Note [Delaying modFinalizers in untyped splices] in -GHC.Rename.Splice). Thus after executing the splice, we move the finalizers to the -finalizer list in the global environment and set them to use the current local -environment (with 'addModFinalizersWithLclEnv'). - --} - -tcNestedSplice :: ThStage -> PendingStuff -> Name - -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) - -- See Note [How brackets and nested splices are handled] - -- A splice inside brackets -tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) splice_name expr res_ty - = do { res_ty <- expTypeToType res_ty - ; let rep = getRuntimeRep res_ty - ; meta_exp_ty <- tcTExpTy m_var res_ty - ; expr' <- setStage pop_stage $ - setConstraintVar lie_var $ - tcMonoExpr expr (mkCheckExpType meta_exp_ty) - ; untypeq <- tcLookupId unTypeQName - ; let expr'' = mkHsApp - (mkLHsWrap (applyQuoteWrapper q) - (nlHsTyApp untypeq [rep, res_ty])) expr' - ; ps <- readMutVar ps_var - ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps) - - -- The returned expression is ignored; it's in the pending splices - ; return (panic "tcSpliceExpr") } - -tcNestedSplice _ _ splice_name _ _ - = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name) - -tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -tcTopSplice expr res_ty - = do { -- Typecheck the expression, - -- making sure it has type Q (T res_ty) - res_ty <- expTypeToType res_ty - ; q_type <- tcMetaTy qTyConName - -- Top level splices must still be of type Q (TExp a) - ; meta_exp_ty <- tcTExpTy q_type res_ty - ; q_expr <- tcTopSpliceExpr Typed $ - tcMonoExpr expr (mkCheckExpType meta_exp_ty) - ; lcl_env <- getLclEnv - ; let delayed_splice - = DelayedSplice lcl_env expr res_ty q_expr - ; return (HsSpliceE noExtField (XSplice (HsSplicedT delayed_splice))) - - } - - --- This is called in the zonker --- See Note [Running typed splices in the zonker] -runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) -runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr) - = setLclEnv lcl_env $ do { - zonked_ty <- zonkTcType res_ty - ; zonked_q_expr <- zonkTopLExpr q_expr - -- See Note [Collecting modFinalizers in typed splices]. - ; modfinalizers_ref <- newTcRef [] - -- Run the expression - ; expr2 <- setStage (RunSplice modfinalizers_ref) $ - runMetaE zonked_q_expr - ; mod_finalizers <- readTcRef modfinalizers_ref - ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers - -- We use orig_expr here and not q_expr when tracing as a call to - -- unsafeTExpCoerce is added to the original expression by the - -- typechecker when typed quotes are type checked. - ; traceSplice (SpliceInfo { spliceDescription = "expression" - , spliceIsDecl = False - , spliceSource = Just orig_expr - , spliceGenerated = ppr expr2 }) - -- Rename and typecheck the spliced-in expression, - -- making sure it has type res_ty - -- These steps should never fail; this is a *typed* splice - ; (res, wcs) <- - captureConstraints $ - addErrCtxt (spliceResultDoc zonked_q_expr) $ do - { (exp3, _fvs) <- rnLExpr expr2 - ; tcMonoExpr exp3 (mkCheckExpType zonked_ty)} - ; ev <- simplifyTop wcs - ; return $ unLoc (mkHsDictLet (EvBinds ev) res) - } - - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -spliceCtxtDoc :: HsSplice GhcRn -> SDoc -spliceCtxtDoc splice - = hang (text "In the Template Haskell splice") - 2 (pprSplice splice) - -spliceResultDoc :: LHsExpr GhcTc -> SDoc -spliceResultDoc expr - = sep [ text "In the result of the splice:" - , nest 2 (char '$' <> ppr expr) - , text "To see what the splice expanded to, use -ddump-splices"] - -------------------- -tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) --- Note [How top-level splices are handled] --- Type check an expression that is the body of a top-level splice --- (the caller will compile and run it) --- Note that set the level to Splice, regardless of the original level, --- before typechecking the expression. For example: --- f x = $( ...$(g 3) ... ) --- The recursive call to tcPolyExpr will simply expand the --- inner escape before dealing with the outer one - -tcTopSpliceExpr isTypedSplice tc_action - = checkNoErrs $ -- checkNoErrs: must not try to run the thing - -- if the type checker fails! - unsetGOptM Opt_DeferTypeErrors $ - -- Don't defer type errors. Not only are we - -- going to run this code, but we do an unsafe - -- coerce, so we get a seg-fault if, say we - -- splice a type into a place where an expression - -- is expected (#7276) - setStage (Splice isTypedSplice) $ - do { -- Typecheck the expression - (expr', wanted) <- captureConstraints tc_action - ; const_binds <- simplifyTop wanted - - -- Zonk it and tie the knot of dictionary bindings - ; return $ mkHsDictLet (EvBinds const_binds) expr' } - -{- -************************************************************************ -* * - Annotations -* * -************************************************************************ --} - -runAnnotation target expr = do - -- Find the classes we want instances for in order to call toAnnotationWrapper - loc <- getSrcSpanM - data_class <- tcLookupClass dataClassName - to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName - - -- Check the instances we require live in another module (we want to execute it..) - -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr - -- also resolves the LIE constraints to detect e.g. instance ambiguity - zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped ( - do { (expr', expr_ty) <- tcInferRhoNC expr - -- We manually wrap the typechecked expression in a call to toAnnotationWrapper - -- By instantiating the call >here< it gets registered in the - -- LIE consulted by tcTopSpliceExpr - -- and hence ensures the appropriate dictionary is bound by const_binds - ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] - ; let specialised_to_annotation_wrapper_expr - = L loc (mkHsWrap wrapper - (HsVar noExtField (L loc to_annotation_wrapper_id))) - ; return (L loc (HsApp noExtField - specialised_to_annotation_wrapper_expr expr')) - }) - - -- Run the appropriately wrapped expression to get the value of - -- the annotation and its dictionaries. The return value is of - -- type AnnotationWrapper by construction, so this conversion is - -- safe - serialized <- runMetaAW zonked_wrapped_expr' - return Annotation { - ann_target = target, - ann_value = serialized - } - -convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized) -convertAnnotationWrapper fhv = do - interp <- tcGetInterp - case interp of - ExternalInterp {} -> Right <$> runTH THAnnWrapper fhv -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> do - annotation_wrapper <- liftIO $ wormhole InternalInterp fhv - return $ Right $ - case unsafeCoerce annotation_wrapper of - AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> - -- Got the value and dictionaries: build the serialized value and - -- call it a day. We ensure that we seq the entire serialized value - -- in order that any errors in the user-written code for the - -- annotation are exposed at this point. This is also why we are - -- doing all this stuff inside the context of runMeta: it has the - -- facilities to deal with user error in a meta-level expression - seqSerialized serialized `seq` serialized - --- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms -seqSerialized :: Serialized -> () -seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` () - -#endif - -{- -************************************************************************ -* * -\subsection{Running an expression} -* * -************************************************************************ --} - -runQuasi :: TH.Q a -> TcM a -runQuasi act = TH.runQ act - -runRemoteModFinalizers :: ThModFinalizers -> TcM () -runRemoteModFinalizers (ThModFinalizers finRefs) = do - let withForeignRefs [] f = f [] - withForeignRefs (x : xs) f = withForeignRef x $ \r -> - withForeignRefs xs $ \rs -> f (r : rs) - interp <- tcGetInterp - case interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> do - qs <- liftIO (withForeignRefs finRefs $ mapM localRef) - runQuasi $ sequence_ qs -#endif - - ExternalInterp conf iserv -> withIServ_ conf iserv $ \i -> 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 -> - withForeignRefs finRefs $ \qrefs -> - writeIServ i (putMessage (RunModFinalizers st qrefs)) - () <- runRemoteTH i [] - readQResult i - -runQResult - :: (a -> String) - -> (Origin -> SrcSpan -> a -> b) - -> (ForeignHValue -> TcM a) - -> SrcSpan - -> ForeignHValue {- TH.Q a -} - -> TcM b -runQResult show_th f runQ expr_span hval - = do { th_result <- runQ hval - ; th_origin <- getThSpliceOrigin - ; traceTc "Got TH result:" (text (show_th th_result)) - ; return (f th_origin expr_span th_result) } - - ------------------ -runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn) - -> LHsExpr GhcTc - -> TcM hs_syn -runMeta unwrap e - = do { h <- getHooked runMetaHook defaultRunMeta - ; unwrap h e } - -defaultRunMeta :: MetaHook TcM -defaultRunMeta (MetaE r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp) -defaultRunMeta (MetaP r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat) -defaultRunMeta (MetaT r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType) -defaultRunMeta (MetaD r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec) -defaultRunMeta (MetaAW r) - = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper) - -- We turn off showing the code in meta-level exceptions because doing so exposes - -- the toAnnotationWrapper function that we slap around the user's code - ----------------- -runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper - -> TcM Serialized -runMetaAW = runMeta metaRequestAW - -runMetaE :: LHsExpr GhcTc -- Of type (Q Exp) - -> TcM (LHsExpr GhcPs) -runMetaE = runMeta metaRequestE - -runMetaP :: LHsExpr GhcTc -- Of type (Q Pat) - -> TcM (LPat GhcPs) -runMetaP = runMeta metaRequestP - -runMetaT :: LHsExpr GhcTc -- Of type (Q Type) - -> TcM (LHsType GhcPs) -runMetaT = runMeta metaRequestT - -runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] - -> TcM [LHsDecl GhcPs] -runMetaD = runMeta metaRequestD - ---------------- -runMeta' :: Bool -- Whether code should be printed in the exception message - -> (hs_syn -> SDoc) -- how to print the code - -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x - -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or - -- something like that - -> TcM hs_syn -- Of type t -runMeta' show_code ppr_hs run_and_convert expr - = do { traceTc "About to run" (ppr expr) - ; recordThSpliceUse -- seems to be the best place to do this, - -- we catch all kinds of splices and annotations. - - -- Check that we've had no errors of any sort so far. - -- For example, if we found an error in an earlier defn f, but - -- recovered giving it type f :: forall a.a, it'd be very dodgy - -- to carry ont. Mind you, the staging restrictions mean we won't - -- actually run f, but it still seems wrong. And, more concretely, - -- see #5358 for an example that fell over when trying to - -- reify a function with a "?" kind in it. (These don't occur - -- in type-correct programs. - ; failIfErrsM - - -- run plugins - ; hsc_env <- getTopEnv - ; expr' <- withPlugins (hsc_dflags hsc_env) spliceRunAction expr - - -- Desugar - ; ds_expr <- initDsTc (dsLExpr expr') - -- Compile and link it; might fail if linking fails - ; src_span <- getSrcSpanM - ; traceTc "About to run (desugared)" (ppr ds_expr) - ; either_hval <- tryM $ liftIO $ - GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr - ; case either_hval of { - Left exn -> fail_with_exn "compile and link" exn ; - Right hval -> do - - { -- Coerce it to Q t, and run it - - -- Running might fail if it throws an exception of any kind (hence tryAllM) - -- including, say, a pattern-match exception in the code we are running - -- - -- We also do the TH -> HS syntax conversion inside the same - -- exception-catching thing so that if there are any lurking - -- exceptions in the data structure returned by hval, we'll - -- encounter them inside the try - -- - -- See Note [Exceptions in TH] - let expr_span = getLoc expr - ; either_tval <- tryAllM $ - setSrcSpan expr_span $ -- Set the span so that qLocation can - -- see where this splice is - do { mb_result <- run_and_convert expr_span hval - ; case mb_result of - Left err -> failWithTc err - Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) - ; return $! result } } - - ; case either_tval of - Right v -> return v - Left se -> case fromException se of - Just IOEnvFailure -> failM -- Error already in Tc monad - _ -> fail_with_exn "run" se -- Exception - }}} - where - -- see Note [Concealed TH exceptions] - fail_with_exn :: Exception e => String -> e -> TcM a - fail_with_exn phase exn = do - exn_msg <- liftIO $ Panic.safeShowException exn - let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", - nest 2 (text exn_msg), - if show_code then text "Code:" <+> ppr expr else empty] - failWithTc msg - -{- -Note [Running typed splices in the zonker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -See #15471 for the full discussion. - -For many years typed splices were run immediately after they were type checked -however, this is too early as it means to zonk some type variables before -they can be unified with type variables in the surrounding context. - -For example, - -``` -module A where - -test_foo :: forall a . Q (TExp (a -> a)) -test_foo = [|| id ||] - -module B where - -import A - -qux = $$(test_foo) -``` - -We would expect `qux` to have inferred type `forall a . a -> a` but if -we run the splices too early the unified variables are zonked to `Any`. The -inferred type is the unusable `Any -> Any`. - -To run the splice, we must compile `test_foo` all the way to byte code. -But at the moment when the type checker is looking at the splice, test_foo -has type `Q (TExp (alpha -> alpha))` and we -certainly can't compile code involving unification variables! - -We could default `alpha` to `Any` but then we infer `qux :: Any -> Any` -which definitely is not what we want. Moreover, if we had - qux = [$$(test_foo), (\x -> x +1::Int)] -then `alpha` would have to be `Int`. - -Conclusion: we must defer taking decisions about `alpha` until the -typechecker is done; and *then* we can run the splice. It's fine to do it -later, because we know it'll produce type-correct code. - -Deferring running the splice until later, in the zonker, means that the -unification variables propagate upwards from the splice into the surrounding -context and are unified correctly. - -This is implemented by storing the arguments we need for running the splice -in a `DelayedSplice`. In the zonker, the arguments are passed to -`TcSplice.runTopSplice` and the expression inserted into the AST as normal. - - - -Note [Exceptions in TH] -~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have something like this - $( f 4 ) -where - f :: Int -> Q [Dec] - f n | n>3 = fail "Too many declarations" - | otherwise = ... - -The 'fail' is a user-generated failure, and should be displayed as a -perfectly ordinary compiler error message, not a panic or anything -like that. Here's how it's processed: - - * 'fail' is the monad fail. The monad instance for Q in TH.Syntax - effectively transforms (fail s) to - qReport True s >> fail - where 'qReport' comes from the Quasi class and fail from its monad - superclass. - - * The TcM monad is an instance of Quasi (see TcSplice), and it implements - (qReport True s) by using addErr to add an error message to the bag of errors. - The 'fail' in TcM raises an IOEnvFailure exception - - * 'qReport' forces the message to ensure any exception hidden in unevaluated - thunk doesn't get into the bag of errors. Otherwise the following splice - will trigger panic (#8987): - $(fail undefined) - See also Note [Concealed TH exceptions] - - * So, when running a splice, we catch all exceptions; then for - - an IOEnvFailure exception, we assume the error is already - in the error-bag (above) - - other errors, we add an error to the bag - and then fail - -Note [Concealed TH exceptions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When displaying the error message contained in an exception originated from TH -code, we need to make sure that the error message itself does not contain an -exception. For example, when executing the following splice: - - $( error ("foo " ++ error "bar") ) - -the message for the outer exception is a thunk which will throw the inner -exception when evaluated. - -For this reason, we display the message of a TH exception using the -'safeShowException' function, which recursively catches any exception thrown -when showing an error message. - - -To call runQ in the Tc monad, we need to make TcM an instance of Quasi: --} - -instance TH.Quasi TcM where - qNewName s = do { u <- newUnique - ; let i = toInteger (getKey u) - ; return (TH.mkNameU s i) } - - -- 'msg' is forced to ensure exceptions don't escape, - -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr (text msg) - qReport False msg = seqList msg $ addWarn NoReason (text msg) - - qLocation = do { m <- getModule - ; l <- getSrcSpanM - ; r <- case l of - UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" - (ppr l) - RealSrcSpan s _ -> return s - ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) - , TH.loc_module = moduleNameString (moduleName m) - , TH.loc_package = unitIdString (moduleUnitId m) - , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) - , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } - - qLookupName = lookupName - qReify = reify - qReifyFixity nm = lookupThName nm >>= reifyFixity - qReifyType = reifyTypeOfThing - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness nm = do { nm' <- lookupThName nm - ; dc <- tcLookupDataCon nm' - ; let bangs = dataConImplBangs dc - ; return (map reifyDecidedStrictness bangs) } - - -- For qRecover, discard error messages if - -- the recovery action is chosen. Otherwise - -- we'll only fail higher up. - qRecover recover main = tryTcDiscardingErrs recover main - - qAddDependentFile fp = do - ref <- fmap tcg_dependent_files getGblEnv - dep_files <- readTcRef ref - writeTcRef ref (fp:dep_files) - - qAddTempFile suffix = do - dflags <- getDynFlags - liftIO $ newTempName dflags TFL_GhcSession suffix - - qAddTopDecls thds = do - l <- getSrcSpanM - th_origin <- getThSpliceOrigin - let either_hval = convertToHsDecls th_origin l thds - ds <- case either_hval of - Left exn -> failWithTc $ - hang (text "Error in a declaration passed to addTopDecls:") - 2 exn - Right ds -> return ds - mapM_ (checkTopDecl . unLoc) ds - th_topdecls_var <- fmap tcg_th_topdecls getGblEnv - updTcRef th_topdecls_var (\topds -> ds ++ topds) - where - checkTopDecl :: HsDecl GhcPs -> TcM () - checkTopDecl (ValD _ binds) - = mapM_ bindName (collectHsBindBinders binds) - checkTopDecl (SigD _ _) - = return () - checkTopDecl (AnnD _ _) - = return () - checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) - = bindName name - checkTopDecl _ - = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" - - bindName :: RdrName -> TcM () - bindName (Exact n) - = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) - } - - bindName name = - addErr $ - hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU.")) - 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") - - qAddForeignFilePath lang fp = do - var <- fmap tcg_th_foreign_files getGblEnv - updTcRef var ((lang, fp) :) - - qAddModFinalizer fin = do - r <- liftIO $ mkRemoteRef fin - fref <- liftIO $ mkForeignRef r (freeRemoteRef r) - addModFinalizerRef fref - - qAddCorePlugin plugin = do - hsc_env <- getTopEnv - r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin) - let err = hang - (text "addCorePlugin: invalid plugin module " - <+> text (show plugin) - ) - 2 - (text "Plugins in the current package can't be specified.") - case r of - Found {} -> addErr err - FoundMultiple {} -> addErr err - _ -> return () - th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv - updTcRef th_coreplugins_var (plugin:) - - qGetQ :: forall a. Typeable a => TcM (Maybe a) - qGetQ = do - th_state_var <- fmap tcg_th_state getGblEnv - th_state <- readTcRef th_state_var - -- See #10596 for why we use a scoped type variable here. - return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) - - qPutQ x = do - th_state_var <- fmap tcg_th_state getGblEnv - updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) - - qIsExtEnabled = xoptM - - qExtsEnabled = - EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv - --- | Adds a mod finalizer reference to the local environment. -addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM () -addModFinalizerRef finRef = do - th_stage <- getStage - case th_stage of - RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :) - -- This case happens only if a splice is executed and the caller does - -- not set the 'ThStage' to 'RunSplice' to collect finalizers. - -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. - _ -> - pprPanic "addModFinalizer was called when no finalizers were collected" - (ppr th_stage) - --- | Releases the external interpreter state. -finishTH :: TcM () -finishTH = do - hsc_env <- getTopEnv - case hsc_interp hsc_env of - Nothing -> pure () -#if defined(HAVE_INTERNAL_INTERPRETER) - Just InternalInterp -> pure () -#endif - Just (ExternalInterp {}) -> do - tcg <- getGblEnv - writeTcRef (tcg_th_remote_state tcg) Nothing - - -runTHExp :: ForeignHValue -> TcM TH.Exp -runTHExp = runTH THExp - -runTHPat :: ForeignHValue -> TcM TH.Pat -runTHPat = runTH THPat - -runTHType :: ForeignHValue -> TcM TH.Type -runTHType = runTH THType - -runTHDec :: ForeignHValue -> TcM [TH.Dec] -runTHDec = runTH THDec - -runTH :: Binary a => THResultType -> ForeignHValue -> TcM a -runTH ty fhv = do - interp <- tcGetInterp - case interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> do - -- Run it in the local TcM - hv <- liftIO $ wormhole InternalInterp fhv - r <- runQuasi (unsafeCoerce hv :: TH.Q a) - return r -#endif - - ExternalInterp conf iserv -> - -- 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) - - --- | communicate with a remotely-running TH computation until it finishes. --- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. -runRemoteTH - :: IServInstance - -> [Messages] -- saved from nested calls to qRecover - -> TcM () -runRemoteTH iserv recovers = do - THMsg msg <- liftIO $ readIServ iserv getTHMessage - 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) - EndRecover caught_error -> do - let (prev_msgs@(prev_warns,prev_errs), rest) = case recovers of - [] -> panic "EndRecover" - a : b -> (a,b) - v <- getErrsVar - (warn_msgs,_) <- readTcRef v - -- keep the warnings only if there were no errors - writeTcRef v $ if caught_error - then prev_msgs - else (prev_warns `unionBags` warn_msgs, prev_errs) - runRemoteTH iserv rest - _other -> do - r <- handleTHMessage msg - liftIO $ writeIServ iserv (put r) - runRemoteTH iserv recovers - --- | Read a value of type QResult from the iserv -readQResult :: Binary a => IServInstance -> TcM a -readQResult i = do - qr <- liftIO $ readIServ i get - case qr of - QDone a -> return a - QException str -> liftIO $ throwIO (ErrorCall str) - QFail str -> fail str - -{- Note [TH recover with -fexternal-interpreter] - -Recover is slightly tricky to implement. - -The meaning of "recover a b" is - - Do a - - If it finished with no errors, then keep the warnings it generated - - If it failed, discard any messages it generated, and do b - -Note that "failed" here can mean either - (1) threw an exception (failTc) - (2) generated an error message (addErrTcM) - -The messages are managed by GHC in the TcM monad, whereas the -exception-handling is done in the ghc-iserv process, so we have to -coordinate between the two. - -On the server: - - emit a StartRecover message - - run "a; FailIfErrs" inside a try - - emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed - - if "a; FailIfErrs" failed, run "b" - -Back in GHC, when we receive: - - FailIfErrrs - failTc if there are any error messages (= failIfErrsM) - StartRecover - save the current messages and start with an empty set. - EndRecover caught_error - Restore the previous messages, - and merge in the new messages if caught_error is false. --} - --- | Retrieve (or create, if it hasn't been created already), the --- remote TH state. The TH state is a remote reference to an IORef --- QState living on the server, and we have to pass this to each RunTH --- call we make. --- --- 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 - hsc_env <- getTopEnv - fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH - writeTcRef (tcg_th_remote_state tcg) (Just fhv) - return fhv - -wrapTHResult :: TcM a -> TcM (THResult a) -wrapTHResult tcm = do - e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic - case e of - Left e -> return (THException (show e)) - Right a -> return (THComplete a) - -handleTHMessage :: THMessage a -> TcM a -handleTHMessage msg = case msg of - NewName a -> wrapTHResult $ TH.qNewName a - Report b str -> wrapTHResult $ TH.qReport b str - LookupName b str -> wrapTHResult $ TH.qLookupName b str - Reify n -> wrapTHResult $ TH.qReify n - ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n - ReifyType n -> wrapTHResult $ TH.qReifyType n - ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts - ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n - ReifyAnnotations lookup tyrep -> - wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) - ReifyModule m -> wrapTHResult $ TH.qReifyModule m - ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm - AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f - AddTempFile s -> wrapTHResult $ TH.qAddTempFile s - AddModFinalizer r -> do - hsc_env <- getTopEnv - wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef - AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str - AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs - AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str - IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext - ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled - FailIfErrs -> wrapTHResult failIfErrsM - _ -> panic ("handleTHMessage: unexpected message " ++ show msg) - -getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]] -getAnnotationsByTypeRep th_name tyrep - = do { name <- lookupThAnnLookup th_name - ; topEnv <- getTopEnv - ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing - ; tcg <- getGblEnv - ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep - ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep - ; return (selectedEpsHptAnns ++ selectedTcgAnns) } - -{- -************************************************************************ -* * - Instance Testing -* * -************************************************************************ --} - -reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] -reifyInstances th_nm th_tys - = addErrCtxt (text "In the argument of reifyInstances:" - <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ - do { loc <- getSrcSpanM - ; th_origin <- getThSpliceOrigin - ; rdr_ty <- cvt th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys) - -- #9262 says to bring vars into scope, like in HsForAllTy case - -- of rnHsTyKi - ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty - -- Rename to HsType Name - ; ((tv_names, rn_ty), _fvs) - <- checkNoErrs $ -- If there are out-of-scope Names here, then we - -- must error before proceeding to typecheck the - -- renamed type, as that will result in GHC - -- internal errors (#13837). - bindLRdrNames tv_rdrs $ \ tv_names -> - do { (rn_ty, fvs) <- rnLHsType doc rdr_ty - ; return ((tv_names, rn_ty), fvs) } - ; (_tvs, ty) - <- pushTcLevelM_ $ - solveEqualities $ -- Avoid error cascade if there are unsolved - bindImplicitTKBndrs_Skol tv_names $ - fst <$> tcLHsType rn_ty - ; ty <- zonkTcTypeToType ty - -- Substitute out the meta type variables - -- In particular, the type might have kind - -- variables inside it (#7477) - - ; traceTc "reifyInstances" (ppr ty $$ ppr (tcTypeKind ty)) - ; case splitTyConApp_maybe ty of -- This expands any type synonyms - Just (tc, tys) -- See #7910 - | Just cls <- tyConClass_maybe tc - -> do { inst_envs <- tcGetInstEnvs - ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys - ; traceTc "reifyInstances1" (ppr matches) - ; reifyClassInstances cls (map fst matches ++ unifies) } - | isOpenFamilyTyCon tc - -> do { inst_envs <- tcGetFamInstEnvs - ; let matches = lookupFamInstEnv inst_envs tc tys - ; traceTc "reifyInstances2" (ppr matches) - ; reifyFamilyInstances tc (map fim_instance matches) } - _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty)) - 2 (text "is not a class constraint or type family application")) } - 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 msg - Right ty -> return ty - -{- -************************************************************************ -* * - Reification -* * -************************************************************************ --} - -lookupName :: Bool -- True <=> type namespace - -- False <=> value namespace - -> String -> TcM (Maybe TH.Name) -lookupName is_type_name s - = do { lcl_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv lcl_env rdr_name of - Just n -> return (Just (reifyName n)) - Nothing -> do { mb_nm <- lookupGlobalOccRn_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' - - occ_fs :: FastString - occ_fs = mkFastString (TH.nameBase th_name) - - occ :: OccName - occ | is_type_name - = if isLexVarSym occ_fs || isLexCon occ_fs - then mkTcOccFS occ_fs - else mkTyVarOccFS occ_fs - | otherwise - = if isLexCon occ_fs then mkDataOccFS occ_fs - else mkVarOccFS occ_fs - - rdr_name = case TH.nameModule th_name of - Nothing -> mkRdrUnqual occ - Just mod -> mkRdrQual (mkModuleName mod) occ - -getThing :: TH.Name -> TcM TcTyThing -getThing th_name - = do { name <- lookupThName th_name - ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name) - ; tcLookupTh name } - -- 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 _ = panic "reify/ppr_ns" - -reify :: TH.Name -> TcM TH.Info -reify th_name - = do { traceTc "reify 1" (text (TH.showName th_name)) - ; thing <- getThing th_name - ; traceTc "reify 2" (ppr thing) - ; reifyThing thing } - -lookupThName :: TH.Name -> TcM Name -lookupThName th_name = do - mb_name <- lookupThName_maybe th_name - case mb_name of - Nothing -> failWithTc (notInScope th_name) - Just name -> return name - -lookupThName_maybe :: TH.Name -> TcM (Maybe Name) -lookupThName_maybe th_name - = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) - -- 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) } - where - lookup rdr_name - = do { -- Repeat much of lookupOccRn, because we want - -- to report errors in a TH-relevant way - ; rdr_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv rdr_env rdr_name of - Just name -> return (Just name) - Nothing -> lookupGlobalOccRn_maybe rdr_name } - -tcLookupTh :: Name -> TcM TcTyThing --- This is a specialised version of TcEnv.tcLookup; specialised mainly in that --- it gives a reify-related error message on failure, whereas in the normal --- tcLookup, failure is a bug. -tcLookupTh name - = do { (gbl_env, lcl_env) <- getEnvs - ; case lookupNameEnv (tcl_env lcl_env) name of { - Just thing -> return thing; - Nothing -> - - case lookupNameEnv (tcg_type_env gbl_env) name of { - Just thing -> return (AGlobal thing); - Nothing -> - - -- EZY: I don't think this choice matters, no TH in signatures! - if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name - then -- It's defined in this module - failWithTc (notInEnv name) - - else - do { mb_thing <- tcLookupImported_maybe name - ; case mb_thing of - Succeeded thing -> return (AGlobal thing) - Failed msg -> failWithTc msg - }}}} - -notInScope :: TH.Name -> SDoc -notInScope th_name = quotes (text (TH.pprint th_name)) <+> - text "is not in scope at a reify" - -- Ugh! Rather an indirect way to display the name - -notInEnv :: Name -> SDoc -notInEnv name = quotes (ppr name) <+> - text "is not in the type environment at a reify" - ------------------------------- -reifyRoles :: TH.Name -> TcM [TH.Role] -reifyRoles th_name - = do { thing <- getThing th_name - ; case thing of - AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) - _ -> failWithTc (text "No roles associated with" <+> (ppr thing)) - } - where - reify_role Nominal = TH.NominalR - reify_role Representational = TH.RepresentationalR - reify_role Phantom = TH.PhantomR - ------------------------------- -reifyThing :: TcTyThing -> TcM TH.Info --- The only reason this is monadic is for error reporting, --- which in turn is mainly for the case when TH can't express --- some random GHC extension - -reifyThing (AGlobal (AnId id)) - = 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) - } - -reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc -reifyThing (AGlobal (AConLike (RealDataCon dc))) - = do { let name = dataConName dc - ; ty <- reifyType (idType (dataConWrapId dc)) - ; return (TH.DataConI (reifyName name) ty - (reifyName (dataConOrigTyCon dc))) - } - -reifyThing (AGlobal (AConLike (PatSynCon ps))) - = do { let name = reifyName ps - ; ty <- reifyPatSynType (patSynSig ps) - ; return (TH.PatSynI name ty) } - -reifyThing (ATcId {tct_id = id}) - = do { ty1 <- 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 - ; ty2 <- reifyType ty1 - ; return (TH.TyVarI (reifyName tv) ty2) } - -reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing) - -------------------------------------------- -reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn -reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs - , cab_lhs = lhs - , cab_rhs = rhs }) - -- remove kind patterns (#8884) - = do { tvs' <- reifyTyVarsToMaybe tvs - ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs - ; lhs' <- reifyTypes lhs_types_only - ; annot_th_lhs <- zipWith3M annotThType (tyConArgsPolyKinded fam_tc) - lhs_types_only lhs' - ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs - ; rhs' <- reifyType rhs - ; return (TH.TySynEqn tvs' lhs_type rhs') } - -reifyTyCon :: TyCon -> TcM TH.Info -reifyTyCon tc - | Just cls <- tyConClass_maybe tc - = reifyClass cls - - | isFunTyCon tc - = return (TH.PrimTyConI (reifyName tc) 2 False) - - | isPrimTyCon tc - = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc)) - (isUnliftedTyCon tc)) - - | isTypeFamilyTyCon tc - = do { let tvs = tyConTyVars tc - res_kind = tyConResKind tc - resVar = famTcResVar tc - - ; kind' <- reifyKind res_kind - ; let (resultSig, injectivity) = - case resVar of - Nothing -> (TH.KindSig kind', Nothing) - Just name -> - let thName = reifyName name - injAnnot = tyConInjectivityInfo tc - sig = TH.TyVarSig (TH.KindedTV thName kind') - inj = case injAnnot of - NotInjective -> Nothing - Injective ms -> - Just (TH.InjectivityAnn thName injRHS) - where - injRHS = map (reifyName . tyVarName) - (filterByList ms tvs) - in (sig, inj) - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) - ; let tfHead = - TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity - ; if isOpenTypeFamilyTyCon tc - then do { fam_envs <- tcGetFamInstEnvs - ; instances <- reifyFamilyInstances tc - (familyInstances fam_envs tc) - ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) } - else do { eqns <- - case isClosedSynFamilyTyConWithAxiom_maybe tc of - Just ax -> mapM (reifyAxBranch tc) $ - fromBranches $ coAxiomBranches ax - Nothing -> return [] - ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns) - []) } } - - | isDataFamilyTyCon tc - = do { let res_kind = tyConResKind tc - - ; kind' <- fmap Just (reifyKind res_kind) - - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) - ; fam_envs <- tcGetFamInstEnvs - ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc) - ; return (TH.FamilyI - (TH.DataFamilyD (reifyName tc) tvs' kind') instances) } - - | Just (_, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym - = do { rhs' <- reifyType rhs - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) - ; return (TH.TyConI - (TH.TySynD (reifyName tc) tvs' rhs')) - } - - | otherwise - = do { cxt <- reifyCxt (tyConStupidTheta tc) - ; let tvs = tyConTyVars tc - dataCons = tyConDataCons tc - isGadt = isGadtSyntaxTyCon tc - ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons - ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc) - ; let name = reifyName tc - deriv = [] -- Don't know about deriving - decl | isNewTyCon tc = - TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv - | otherwise = - TH.DataD cxt name r_tvs Nothing cons deriv - ; return (TH.TyConI decl) } - -reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con -reifyDataCon isGadtDataCon tys dc - = do { let -- used for H98 data constructors - (ex_tvs, theta, arg_tys) - = dataConInstSig dc tys - -- used for GADTs data constructors - g_user_tvs' = dataConUserTyVars dc - (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty') - = dataConFullSig dc - (srcUnpks, srcStricts) - = mapAndUnzip reifySourceBang (dataConSrcBangs dc) - dcdBangs = zipWith TH.Bang srcUnpks srcStricts - fields = dataConFieldLabels dc - name = reifyName dc - -- Universal tvs present in eq_spec need to be filtered out, as - -- they will not appear anywhere in the type. - eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec) - - ; (univ_subst, _) - -- See Note [Freshen reified GADT constructors' universal tyvars] - <- freshenTyVarBndrs $ - filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs - ; let (tvb_subst, g_user_tvs) = substTyVarBndrs univ_subst g_user_tvs' - g_theta = substTys tvb_subst g_theta' - g_arg_tys = substTys tvb_subst g_arg_tys' - g_res_ty = substTy tvb_subst g_res_ty' - - ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys) - - ; main_con <- - if | not (null fields) && not isGadtDataCon -> - return $ TH.RecC name (zip3 (map reifyFieldLabel fields) - dcdBangs r_arg_tys) - | not (null fields) -> do - { res_ty <- reifyType g_res_ty - ; return $ TH.RecGadtC [name] - (zip3 (map (reifyName . flSelector) fields) - dcdBangs r_arg_tys) res_ty } - -- We need to check not isGadtDataCon here because GADT - -- constructors can be declared infix. - -- See Note [Infix GADT constructors] in TcTyClsDecls. - | dataConIsInfix dc && not isGadtDataCon -> - ASSERT( arg_tys `lengthIs` 2 ) do - { let [r_a1, r_a2] = r_arg_tys - [s1, s2] = dcdBangs - ; 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 } - | otherwise -> - return $ TH.NormalC name (dcdBangs `zip` r_arg_tys) - - ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta) - | otherwise = ASSERT( all isTyVar ex_tvs ) - -- no covars for haskell syntax - (ex_tvs, theta) - ret_con | null ex_tvs' && null theta' = return main_con - | otherwise = do - { cxt <- reifyCxt theta' - ; ex_tvs'' <- reifyTyVars ex_tvs' - ; return (TH.ForallC ex_tvs'' cxt main_con) } - ; ASSERT( arg_tys `equalLength` dcdBangs ) - ret_con } - -{- -Note [Freshen reified GADT constructors' universal tyvars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose one were to reify this GADT: - - data a :~: b where - Refl :: forall a b. (a ~ b) => a :~: b - -We ought to be careful here about the uniques we give to the occurrences of `a` -and `b` in this definition. That is because in the original DataCon, all uses -of `a` and `b` have the same unique, since `a` and `b` are both universally -quantified type variables--that is, they are used in both the (:~:) tycon as -well as in the constructor type signature. But when we turn the DataCon -definition into the reified one, the `a` and `b` in the constructor type -signature becomes differently scoped than the `a` and `b` in `data a :~: b`. - -While it wouldn't technically be *wrong* per se to re-use the same uniques for -`a` and `b` across these two different scopes, it's somewhat annoying for end -users of Template Haskell, since they wouldn't be able to rely on the -assumption that all TH names have globally distinct uniques (#13885). For this -reason, we freshen the universally quantified tyvars that go into the reified -GADT constructor type signature to give them distinct uniques from their -counterparts in the tycon. --} - ------------------------------- -reifyClass :: Class -> TcM TH.Info -reifyClass cls - = do { cxt <- reifyCxt theta - ; inst_envs <- tcGetInstEnvs - ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) - ; assocTys <- concatMapM reifyAT ats - ; ops <- concatMapM reify_op op_stuff - ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls)) - ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops) - ; return (TH.ClassI dec insts) } - where - (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls - fds' = map reifyFunDep fds - reify_op (op, def_meth) - = do { let (_, _, ty) = tcSplitMethodTy (idType op) - -- Use tcSplitMethodTy to get rid of the extraneous class - -- variables and predicates at the beginning of op's type - -- (see #15551). - ; ty' <- reifyType ty - ; let nm' = reifyName op - ; case def_meth of - Just (_, GenericDM gdm_ty) -> - do { gdm_ty' <- reifyType gdm_ty - ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] } - _ -> return [TH.SigD nm' ty'] } - - reifyAT :: ClassATItem -> TcM [TH.Dec] - reifyAT (ATI tycon def) = do - tycon' <- reifyTyCon tycon - case tycon' of - TH.FamilyI dec _ -> do - let (tyName, tyArgs) = tfNames dec - (dec :) <$> maybe (return []) - (fmap (:[]) . reifyDefImpl tyName tyArgs . fst) - def - _ -> pprPanic "reifyAT" (text (show tycon')) - - reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec - reifyDefImpl n args ty = - TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args)) - <$> reifyType ty - - tfNames :: TH.Dec -> (TH.Name, [TH.Name]) - tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _)) - = (n, map bndrName args) - tfNames d = pprPanic "tfNames" (text (show d)) - - bndrName :: TH.TyVarBndr -> TH.Name - bndrName (TH.PlainTV n) = n - bndrName (TH.KindedTV n _) = n - ------------------------------- --- | Annotate (with TH.SigT) a type if the first parameter is True --- and if the type contains a free variable. --- This is used to annotate type patterns for poly-kinded tyvars in --- reifying class and type instances. --- See @Note [Reified instances and explicit kind signatures]@. -annotThType :: Bool -- True <=> annotate - -> TyCoRep.Type -> TH.Type -> TcM TH.Type - -- tiny optimization: if the type is annotated, don't annotate again. -annotThType _ _ th_ty@(TH.SigT {}) = return th_ty -annotThType True ty th_ty - | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty - = do { let ki = tcTypeKind ty - ; th_ki <- reifyKind ki - ; return (TH.SigT th_ty th_ki) } -annotThType _ _ th_ty = return th_ty - --- | For every argument type that a type constructor accepts, --- report whether or not the argument is poly-kinded. This is used to --- eventually feed into 'annotThType'. --- See @Note [Reified instances and explicit kind signatures]@. -tyConArgsPolyKinded :: TyCon -> [Bool] -tyConArgsPolyKinded tc = - map (is_poly_ty . tyVarKind) tc_vis_tvs - -- See "Wrinkle: Oversaturated data family instances" in - -- @Note [Reified instances and explicit kind signatures]@ - ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs -- (1) in Wrinkle - ++ repeat True -- (2) in Wrinkle - where - is_poly_ty :: Type -> Bool - is_poly_ty ty = not $ - isEmptyVarSet $ - filterVarSet isTyVar $ - tyCoVarsOfType ty - - tc_vis_tvs :: [TyVar] - tc_vis_tvs = tyConVisibleTyVars tc - - tc_res_kind_vis_bndrs :: [TyCoBinder] - tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc - -{- -Note [Reified instances and explicit kind signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Reified class instances and type family instances often include extra kind -information to disambiguate instances. Here is one such example that -illustrates this (#8953): - - type family Poly (a :: k) :: Type - type instance Poly (x :: Bool) = Int - type instance Poly (x :: Maybe k) = Double - -If you're not careful, reifying these instances might yield this: - - type instance Poly x = Int - type instance Poly x = Double - -To avoid this, we go through some care to annotate things with extra kind -information. Some functions which accomplish this feat include: - -* annotThType: This annotates a type with a kind signature if the type contains - a free variable. -* tyConArgsPolyKinded: This checks every argument that a type constructor can - accept and reports if the type of the argument is poly-kinded. This - information is ultimately fed into annotThType. - ------ --- Wrinkle: Oversaturated data family instances ------ - -What constitutes an argument to a type constructor in the definition of -tyConArgsPolyKinded? For most type constructors, it's simply the visible -type variable binders (i.e., tyConVisibleTyVars). There is one corner case -we must keep in mind, however: data family instances can appear oversaturated -(#17296). For instance: - - data family Foo :: Type -> Type - data instance Foo x - - data family Bar :: k - data family Bar x - -For these sorts of data family instances, tyConVisibleTyVars isn't enough, -as they won't give you the kinds of the oversaturated arguments. We must -also consult: - -1. The kinds of the arguments in the result kind (i.e., the tyConResKind). - This will tell us, e.g., the kind of `x` in `Foo x` above. -2. If we go beyond the number of arguments in the result kind (like the - `x` in `Bar x`), then we conservatively assume that the argument's - kind is poly-kinded. - ------ --- Wrinkle: data family instances with return kinds ------ - -Another squirrelly corner case is this: - - data family Foo (a :: k) - data instance Foo :: Bool -> Type - data instance Foo :: Char -> Type - -If you're not careful, reifying these instances might yield this: - - data instance Foo - data instance Foo - -We can fix this ambiguity by reifying the instances' explicit return kinds. We -should only do this if necessary (see -Note [When does a tycon application need an explicit kind signature?] in GHC.Core.Type), -but more importantly, we *only* do this if either of the following are true: - -1. The data family instance has no constructors. -2. The data family instance is declared with GADT syntax. - -If neither of these are true, then reifying the return kind would yield -something like this: - - data instance (Bar a :: Type) = MkBar a - -Which is not valid syntax. --} - ------------------------------- -reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec] -reifyClassInstances cls insts - = mapM (reifyClassInstance (tyConArgsPolyKinded (classTyCon cls))) insts - -reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded - -- includes only *visible* tvs - -> ClsInst -> TcM TH.Dec -reifyClassInstance is_poly_tvs i - = do { cxt <- reifyCxt theta - ; let vis_types = filterOutInvisibleTypes cls_tc types - ; thtypes <- reifyTypes vis_types - ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes - ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes - ; return $ (TH.InstanceD over cxt head_ty []) } - where - (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun) - cls_tc = classTyCon cls - dfun = instanceDFunId i - over = case overlapMode (is_flag i) of - NoOverlap _ -> Nothing - Overlappable _ -> Just TH.Overlappable - Overlapping _ -> Just TH.Overlapping - Overlaps _ -> Just TH.Overlaps - Incoherent _ -> Just TH.Incoherent - ------------------------------- -reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] -reifyFamilyInstances fam_tc fam_insts - = mapM (reifyFamilyInstance (tyConArgsPolyKinded fam_tc)) fam_insts - -reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded - -- includes only *visible* tvs - -> FamInst -> TcM TH.Dec -reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor - , fi_axiom = ax - , fi_fam = fam }) - | let fam_tc = coAxiomTyCon ax - branch = coAxiomSingleBranch ax - , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch - = case flavor of - SynFamilyInst -> - -- remove kind patterns (#8884) - do { th_tvs <- reifyTyVarsToMaybe tvs - ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs - ; th_lhs <- reifyTypes lhs_types_only - ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only - th_lhs - ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs - ; th_rhs <- reifyType rhs - ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) } - - DataFamilyInst rep_tc -> - do { let -- eta-expand lhs types, because sometimes data/newtype - -- instances are eta-reduced; See #9692 - -- See Note [Eta reduction for data families] in GHC.Core.FamInstEnv - (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch - fam' = reifyName fam - dataCons = tyConDataCons rep_tc - isGadt = isGadtSyntaxTyCon rep_tc - ; th_tvs <- reifyTyVarsToMaybe ee_tvs - ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons - ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs - ; th_tys <- reifyTypes types_only - ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys - ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys - ; mb_sig <- - -- See "Wrinkle: data family instances with return kinds" in - -- Note [Reified instances and explicit kind signatures] - if (null cons || isGadtSyntaxTyCon rep_tc) - && tyConAppNeedsKindSig False fam_tc (length ee_lhs) - then do { let full_kind = tcTypeKind (mkTyConApp fam_tc ee_lhs) - ; th_full_kind <- reifyKind full_kind - ; pure $ Just th_full_kind } - else pure Nothing - ; return $ - if isNewTyCon rep_tc - then TH.NewtypeInstD [] th_tvs lhs_type mb_sig (head cons) [] - else TH.DataInstD [] th_tvs lhs_type mb_sig cons [] - } - ------------------------------- -reifyType :: TyCoRep.Type -> TcM TH.Type --- Monadic only because of failure -reifyType ty | tcIsLiftedTypeKind ty = return TH.StarT - -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it - -- with Constraint (#14869). -reifyType ty@(ForAllTy (Bndr _ argf) _) - = reify_for_all argf ty -reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } -reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) -reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here -reifyType ty@(AppTy {}) = do - let (ty_head, ty_args) = splitAppTys ty - ty_head' <- reifyType ty_head - ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args) - pure $ mkThAppTs ty_head' ty_args' - where - -- Make sure to filter out any invisible arguments. For instance, if you - -- reify the following: - -- - -- newtype T (f :: forall a. a -> Type) = MkT (f Bool) - -- - -- Then you should receive back `f Bool`, not `f Type Bool`, since the - -- `Type` argument is invisible (#15792). - filter_out_invisible_args :: Type -> [Type] -> [Type] - filter_out_invisible_args ty_head ty_args = - filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) - ty_args -reifyType ty@(FunTy { ft_af = af, ft_arg = t1, ft_res = t2 }) - | InvisArg <- af = reify_for_all Inferred ty -- Types like ((?x::Int) => Char -> Char) - | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } -reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH -reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty) - -reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type --- Arg of reify_for_all is always ForAllTy or a predicate FunTy -reify_for_all argf ty = do - tvs' <- reifyTyVars tvs - case argToForallVisFlag argf of - ForallVis -> do phi' <- reifyType phi - pure $ TH.ForallVisT tvs' phi' - ForallInvis -> do let (cxt, tau) = tcSplitPhiTy phi - cxt' <- reifyCxt cxt - tau' <- reifyType tau - pure $ TH.ForallT tvs' cxt' tau' - where - (tvs, phi) = tcSplitForAllTysSameVis argf ty - -reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit -reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) -reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s)) - -reifyTypes :: [Type] -> TcM [TH.Type] -reifyTypes = mapM reifyType - -reifyPatSynType - :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type --- reifies a pattern synonym's type and returns its *complete* type --- signature; see NOTE [Pattern synonym signatures and Template --- Haskell] -reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy) - = do { univTyVars' <- reifyTyVars univTyVars - ; req' <- reifyCxt req - ; exTyVars' <- reifyTyVars exTyVars - ; prov' <- reifyCxt prov - ; tau' <- reifyType (mkVisFunTys argTys resTy) - ; return $ TH.ForallT univTyVars' req' - $ TH.ForallT exTyVars' prov' tau' } - -reifyKind :: Kind -> TcM TH.Kind -reifyKind = reifyType - -reifyCxt :: [PredType] -> TcM [TH.Pred] -reifyCxt = mapM reifyType - -reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep -reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) - -reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr] -reifyTyVars tvs = mapM reify_tv tvs - where - -- even if the kind is *, we need to include a kind annotation, - -- in case a poly-kind would be inferred without the annotation. - -- See #8953 or test th/T8953 - reify_tv tv = TH.KindedTV name <$> reifyKind kind - where - kind = tyVarKind tv - name = reifyName tv - -reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr]) -reifyTyVarsToMaybe [] = pure Nothing -reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys - -reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type -reify_tc_app tc tys - = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys) - ; maybe_sig_t (mkThAppTs r_tc tys') } - where - arity = tyConArity tc - - r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2) - | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2) - | isPromotedTupleTyCon tc = TH.PromotedTupleT (arity `div` 2) - -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - | isTupleTyCon tc = if isPromotedDataCon tc - then TH.PromotedTupleT arity - else TH.TupleT arity - | tc `hasKey` constraintKindTyConKey - = TH.ConstraintT - | tc `hasKey` funTyConKey = TH.ArrowT - | tc `hasKey` listTyConKey = TH.ListT - | tc `hasKey` nilDataConKey = TH.PromotedNilT - | tc `hasKey` consDataConKey = TH.PromotedConsT - | tc `hasKey` heqTyConKey = TH.EqualityT - | tc `hasKey` eqPrimTyConKey = TH.EqualityT - | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon) - | isPromotedDataCon tc = TH.PromotedT (reifyName tc) - | otherwise = TH.ConT (reifyName tc) - - -- See Note [When does a tycon application need an explicit kind - -- signature?] in GHC.Core.TyCo.Rep - maybe_sig_t th_type - | tyConAppNeedsKindSig - False -- We don't reify types using visible kind applications, so - -- don't count specified binders as contributing towards - -- injective positions in the kind of the tycon. - tc (length tys) - = do { let full_kind = tcTypeKind (mkTyConApp tc tys) - ; th_full_kind <- reifyKind full_kind - ; return (TH.SigT th_type th_full_kind) } - | otherwise - = return th_type - ------------------------------- -reifyName :: NamedThing n => n -> TH.Name -reifyName thing - | isExternalName name - = mk_varg pkg_str mod_str occ_str - | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name)) - -- Many of the things we reify have local bindings, and - -- NameL's aren't supposed to appear in binding positions, so - -- we use NameU. When/if we start to reify nested things, that - -- have free variables, we may need to generate NameL's for them. - where - name = getName thing - mod = ASSERT( isExternalName name ) nameModule name - pkg_str = unitIdString (moduleUnitId mod) - mod_str = moduleNameString (moduleName mod) - occ_str = occNameString occ - occ = nameOccName name - mk_varg | OccName.isDataOcc occ = TH.mkNameG_d - | OccName.isVarOcc occ = TH.mkNameG_v - | OccName.isTcOcc occ = TH.mkNameG_tc - | 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 = unitIdString (moduleUnitId mod) - mod_str = moduleNameString (moduleName mod) - occ_str = unpackFS (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) - ------------------------------- -reifyFixity :: Name -> TcM (Maybe TH.Fixity) -reifyFixity name - = do { (found, fix) <- lookupFixityRn_help name - ; return (if found then Just (conv_fix fix) else Nothing) } - where - conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d) - conv_dir BasicTypes.InfixR = TH.InfixR - conv_dir BasicTypes.InfixL = TH.InfixL - conv_dir BasicTypes.InfixN = TH.InfixN - -reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness -reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness -reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack -reifyUnpackedness SrcUnpack = TH.SourceUnpack - -reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness -reifyStrictness NoSrcStrict = TH.NoSourceStrictness -reifyStrictness SrcStrict = TH.SourceStrict -reifyStrictness SrcLazy = TH.SourceLazy - -reifySourceBang :: DataCon.HsSrcBang - -> (TH.SourceUnpackedness, TH.SourceStrictness) -reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s) - -reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness -reifyDecidedStrictness HsLazy = TH.DecidedLazy -reifyDecidedStrictness HsStrict = TH.DecidedStrict -reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack - -reifyTypeOfThing :: TH.Name -> TcM TH.Type -reifyTypeOfThing th_name = do - thing <- getThing th_name - case thing of - AGlobal (AnId id) -> reifyType (idType id) - AGlobal (ATyCon tc) -> reifyKind (tyConKind tc) - AGlobal (AConLike (RealDataCon dc)) -> - reifyType (idType (dataConWrapId dc)) - AGlobal (AConLike (PatSynCon ps)) -> - reifyPatSynType (patSynSig ps) - ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType - ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType - -- Impossible cases, supposedly: - AGlobal (ACoAxiom _) -> panic "reifyTypeOfThing: ACoAxiom" - ATcTyCon _ -> panic "reifyTypeOfThing: ATcTyCon" - APromotionErr _ -> panic "reifyTypeOfThing: APromotionErr" - ------------------------------- -lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget -lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm) -lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn)) - = return $ ModuleTarget $ - mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn) - -reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a] -reifyAnnotations th_name - = do { name <- lookupThAnnLookup th_name - ; topEnv <- getTopEnv - ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing - ; tcg <- getGblEnv - ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name - ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name - ; return (selectedEpsHptAnns ++ selectedTcgAnns) } - ------------------------------- -modToTHMod :: Module -> TH.Module -modToTHMod m = TH.Module (TH.PkgName $ unitIdString $ moduleUnitId m) - (TH.ModName $ moduleNameString $ moduleName m) - -reifyModule :: TH.Module -> TcM TH.ModuleInfo -reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do - this_mod <- getModule - let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString) - if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod - where - reifyThisModule = do - usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports - return $ TH.ModuleInfo usages - - reifyFromIface reifMod = do - iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod - let usages = [modToTHMod m | usage <- mi_usages iface, - Just m <- [usageToModule (moduleUnitId reifMod) usage] ] - return $ TH.ModuleInfo usages - - usageToModule :: UnitId -> Usage -> Maybe Module - usageToModule _ (UsageFile {}) = Nothing - usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn - usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m - usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m - ------------------------------- -mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type -mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys - -noTH :: PtrString -> SDoc -> TcM a -noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+> - text "in Template Haskell:", - nest 2 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 - hsc_env <- getTopEnv - case hsc_interp hsc_env of - Nothing -> liftIO $ throwIO (InstallationError "Template haskell requires a target code interpreter") - Just i -> pure i diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot deleted file mode 100644 --- a/compiler/typecheck/TcSplice.hs-boot +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -module TcSplice where - -import GhcPrelude -import GHC.Types.Name -import GHC.Hs.Expr ( PendingRnSplice, DelayedSplice ) -import TcRnTypes( TcM , SpliceType ) -import TcType ( ExpRhoType ) -import GHC.Types.Annotations ( Annotation, CoreAnnTarget ) -import GHC.Hs.Extension ( GhcTcId, GhcRn, GhcPs, GhcTc ) - -import GHC.Hs ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, - LHsDecl, ThModFinalizers ) -import qualified Language.Haskell.TH as TH - -tcSpliceExpr :: HsSplice GhcRn - -> ExpRhoType - -> TcM (HsExpr GhcTcId) - -tcUntypedBracket :: HsExpr GhcRn - -> HsBracket GhcRn - -> [PendingRnSplice] - -> ExpRhoType - -> TcM (HsExpr GhcTcId) -tcTypedBracket :: HsExpr GhcRn - -> HsBracket GhcRn - -> ExpRhoType - -> TcM (HsExpr GhcTcId) - -runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) - -runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation - -tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId) - -runMetaE :: LHsExpr GhcTcId -> TcM (LHsExpr GhcPs) -runMetaP :: LHsExpr GhcTcId -> TcM (LPat GhcPs) -runMetaT :: LHsExpr GhcTcId -> TcM (LHsType GhcPs) -runMetaD :: LHsExpr GhcTcId -> TcM [LHsDecl GhcPs] - -lookupThName_maybe :: TH.Name -> TcM (Maybe Name) -runQuasi :: TH.Q a -> TcM a -runRemoteModFinalizers :: ThModFinalizers -> TcM () -finishTH :: TcM () diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs deleted file mode 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ /dev/null @@ -1,4914 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1996-1998 - - -TcTyClsDecls: Typecheck type and class declarations --} - -{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcTyClsDecls ( - tcTyAndClassDecls, - - -- Functions used by TcInstDcls to check - -- data/type family instance declarations - kcConDecls, tcConDecls, dataDeclChecks, checkValidTyCon, - tcFamTyPats, tcTyFamInstEqn, - tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, - unravelFamInstPats, addConsistencyConstraints, - wrongKindOfFamily - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import GHC.Driver.Types -import BuildTyCl -import TcRnMonad -import TcEnv -import TcValidity -import TcHsSyn -import TcTyDecls -import TcClassDcl -import {-# SOURCE #-} TcInstDcls( tcInstDecls1 ) -import TcDeriv (DerivInfo(..)) -import TcUnify ( checkTvConstraints ) -import TcHsType -import ClsInst( AssocInstInfo(..) ) -import TcMType -import TysWiredIn ( unitTy, makeRecoveryTyCon ) -import TcType -import GHC.Rename.Env( lookupConstructorFields ) -import FamInst -import GHC.Core.FamInstEnv -import GHC.Core.Coercion -import TcOrigin -import GHC.Core.Type -import GHC.Core.TyCo.Rep -- for checkValidRoles -import GHC.Core.TyCo.Ppr( pprTyVars, pprWithExplicitKindsWhen ) -import GHC.Core.Class -import GHC.Core.Coercion.Axiom -import GHC.Core.TyCon -import GHC.Core.DataCon -import GHC.Types.Id -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Module -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.Name.Env -import Outputable -import Maybes -import GHC.Core.Unify -import Util -import GHC.Types.SrcLoc -import ListSetOps -import GHC.Driver.Session -import GHC.Types.Unique -import GHC.Core.ConLike( ConLike(..) ) -import GHC.Types.Basic -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Foldable -import Data.Function ( on ) -import Data.Functor.Identity -import Data.List -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.Set as Set -import Data.Tuple( swap ) - -{- -************************************************************************ -* * -\subsection{Type checking for type and class declarations} -* * -************************************************************************ - -Note [Grouping of type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly -connected component of mutually dependent types and classes. We kind check and -type check each group separately to enhance kind polymorphism. Take the -following example: - - type Id a = a - data X = X (Id Int) - -If we were to kind check the two declarations together, we would give Id the -kind * -> *, since we apply it to an Int in the definition of X. But we can do -better than that, since Id really is kind polymorphic, and should get kind -forall (k::*). k -> k. Since it does not depend on anything else, it can be -kind-checked by itself, hence getting the most general kind. We then kind check -X, which works fine because we then know the polymorphic kind of Id, and simply -instantiate k to *. - -Note [Check role annotations in a second pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Role inference potentially depends on the types of all of the datacons declared -in a mutually recursive group. The validity of a role annotation, in turn, -depends on the result of role inference. Because the types of datacons might -be ill-formed (see #7175 and Note [Checking GADT return types]) we must check -*all* the tycons in a group for validity before checking *any* of the roles. -Thus, we take two passes over the resulting tycons, first checking for general -validity and then checking for valid role annotations. --} - -tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in - -- dependency order - -> TcM ( TcGblEnv -- Input env extended by types and - -- classes - -- and their implicit Ids,DataCons - , [InstInfo GhcRn] -- Source-code instance decls info - , [DerivInfo] -- Deriving info - ) --- Fails if there are any errors -tcTyAndClassDecls tyclds_s - -- The code recovers internally, but if anything gave rise to - -- an error we'd better stop now, to avoid a cascade - -- Type check each group in dependency order folding the global env - = checkNoErrs $ fold_env [] [] tyclds_s - where - fold_env :: [InstInfo GhcRn] - -> [DerivInfo] - -> [TyClGroup GhcRn] - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) - fold_env inst_info deriv_info [] - = do { gbl_env <- getGblEnv - ; return (gbl_env, inst_info, deriv_info) } - fold_env inst_info deriv_info (tyclds:tyclds_s) - = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds - ; setGblEnv tcg_env $ - -- remaining groups are typechecked in the extended global env. - fold_env (inst_info' ++ inst_info) - (deriv_info' ++ deriv_info) - tyclds_s } - -tcTyClGroup :: TyClGroup GhcRn - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) --- Typecheck one strongly-connected component of type, class, and instance decls --- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls -tcTyClGroup (TyClGroup { group_tyclds = tyclds - , group_roles = roles - , group_kisigs = kisigs - , group_instds = instds }) - = do { let role_annots = mkRoleAnnotEnv roles - - -- Step 1: Typecheck the standalone kind signatures and type/class declarations - ; traceTc "---- tcTyClGroup ---- {" empty - ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds)) - ; (tyclss, data_deriv_info) <- - tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution] - do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs - ; tcTyClDecls tyclds kisig_env role_annots } - - -- Step 1.5: Make sure we don't have any type synonym cycles - ; traceTc "Starting synonym cycle check" (ppr tyclss) - ; this_uid <- fmap thisPackage getDynFlags - ; checkSynCycles this_uid tyclss tyclds - ; traceTc "Done synonym cycle check" (ppr tyclss) - - -- Step 2: Perform the validity check on those types/classes - -- We can do this now because we are done with the recursive knot - -- Do it before Step 3 (adding implicit things) because the latter - -- expects well-formed TyCons - ; traceTc "Starting validity check" (ppr tyclss) - ; tyclss <- concatMapM checkValidTyCl tyclss - ; traceTc "Done validity check" (ppr tyclss) - ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss - -- See Note [Check role annotations in a second pass] - - ; traceTc "---- end tcTyClGroup ---- }" empty - - -- Step 3: Add the implicit things; - -- we want them in the environment because - -- they may be mentioned in interface files - ; gbl_env <- addTyConsToGblEnv tyclss - - -- Step 4: check instance declarations - ; (gbl_env', inst_info, datafam_deriv_info) <- - setGblEnv gbl_env $ - tcInstDecls1 instds - - ; let deriv_info = datafam_deriv_info ++ data_deriv_info - ; return (gbl_env', inst_info, deriv_info) } - - -tcTyClGroup (XTyClGroup nec) = noExtCon nec - --- Gives the kind for every TyCon that has a standalone kind signature -type KindSigEnv = NameEnv Kind - -tcTyClDecls - :: [LTyClDecl GhcRn] - -> KindSigEnv - -> RoleAnnotEnv - -> TcM ([TyCon], [DerivInfo]) -tcTyClDecls tyclds kisig_env role_annots - = 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 <- kcTyClGroup kisig_env tyclds - ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons)) - - -- Step 2: type-check all groups together, returning - -- the final TyCons and Classes - -- - -- NB: We have to be careful here to NOT eagerly unfold - -- type synonyms, as we have not tested for type synonym - -- loops yet and could fall into a black hole. - ; fixM $ \ ~(rec_tyclss, _) -> do - { tcg_env <- getGblEnv - ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss - - -- Populate environment with knot-tied ATyCon for TyCons - -- NB: if the decls mention any ill-staged data cons - -- (see Note [Recursion and promoting data constructors]) - -- we will have failed already in kcTyClGroup, so no worries here - ; (tycons, data_deriv_infos) <- - tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $ - - -- Also extend the local type envt with bindings giving - -- a TcTyCon for each each knot-tied TyCon or Class - -- See Note [Type checking recursive type and class declarations] - -- and Note [Type environment evolution] - tcExtendKindEnvWithTyCons tc_tycons $ - - -- Kind and type check declarations for this group - mapAndUnzipM (tcTyClDecl roles) tyclds - ; return (tycons, concat data_deriv_infos) - } } - where - ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma - , ppr (tyConBinders tc) <> comma - , ppr (tyConResKind tc) - , ppr (isTcTyCon tc) ]) - -zipRecTyClss :: [TcTyCon] - -> [TyCon] -- Knot-tied - -> [(Name,TyThing)] --- Build a name-TyThing mapping for the TyCons bound by decls --- being careful not to look at the knot-tied [TyThing] --- The TyThings in the result list must have a visible ATyCon, --- because typechecking types (in, say, tcTyClDecl) looks at --- this outer constructor -zipRecTyClss tc_tycons rec_tycons - = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ] - where - rec_tc_env :: NameEnv TyCon - rec_tc_env = foldr add_tc emptyNameEnv rec_tycons - - add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon - add_tc tc env = foldr add_one_tc env (tc : tyConATs tc) - - add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon - add_one_tc tc env = extendNameEnv env (tyConName tc) tc - - get name = case lookupNameEnv rec_tc_env name of - Just tc -> tc - other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other) - -{- -************************************************************************ -* * - Kind checking -* * -************************************************************************ - -Note [Kind checking for type and class decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Kind checking is done thus: - - 1. Make up a kind variable for each parameter of the declarations, - and extend the kind environment (which is in the TcLclEnv) - - 2. Kind check the declarations - -We need to kind check all types in the mutually recursive group -before we know the kind of the type variables. For example: - - class C a where - op :: D b => a -> b -> b - - class D c where - bop :: (Monad c) => ... - -Here, the kind of the locally-polymorphic type variable "b" -depends on *all the uses of class D*. For example, the use of -Monad c in bop's type signature means that D must have kind Type->Type. - -Note: we don't treat type synonyms specially (we used to, in the past); -in particular, even if we have a type synonym cycle, we still kind check -it normally, and test for cycles later (checkSynCycles). The reason -we can get away with this is because we have more systematic TYPE r -inference, which means that we can do unification between kinds that -aren't lifted (this historically was not true.) - -The downside of not directly reading off the kinds of the RHS of -type synonyms in topological order is that we don't transparently -support making synonyms of types with higher-rank kinds. But -you can always specify a CUSK directly to make this work out. -See tc269 for an example. - -Note [CUSKs and PolyKinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T (a :: *) = MkT (S a) -- Has CUSK - data S a = MkS (T Int) (S a) -- No CUSK - -Via inferInitialKinds we get - T :: * -> * - S :: kappa -> * - -Then we call kcTyClDecl on each decl in the group, to constrain the -kind unification variables. BUT we /skip/ the RHS of any decl with -a CUSK. Here we skip the RHS of T, so we eventually get - S :: forall k. k -> * - -This gets us more polymorphism than we would otherwise get, similar -(but implemented strangely differently from) the treatment of type -signatures in value declarations. - -However, we only want to do so when we have PolyKinds. -When we have NoPolyKinds, we don't skip those decls, because we have defaulting -(#16609). Skipping won't bring us more polymorphism when we have defaulting. -Consider - - data T1 a = MkT1 T2 -- No CUSK - data T2 = MkT2 (T1 Maybe) -- Has CUSK - -If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved. -With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the -program type-checks. -But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens -in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking -(T1 Maybe) will throw a type error. - -Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip. - -Open type families -~~~~~~~~~~~~~~~~~~ -This treatment of type synonyms only applies to Haskell 98-style synonyms. -General type functions can be recursive, and hence, appear in `alg_decls'. - -The kind of an open type family is solely determinded by its kind signature; -hence, only kind signatures participate in the construction of the initial -kind environment (as constructed by `inferInitialKind'). In fact, we ignore -instances of families altogether in the following. However, we need to include -the kinds of *associated* families into the construction of the initial kind -environment. (This is handled by `allDecls'). - -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 TcTyClsDecls), we come - upon knowledge of the eventual tycon in bits and pieces. - - S1) First, we use inferInitialKinds to look over the user-provided - kind signature of a tycon (including, for example, the number - of parameters written to the tycon) to get an initial shape of - the tycon's kind. We record that shape in a TcTyCon. - - For CUSK tycons, the TcTyCon has the final, generalised kind. - For non-CUSK tycons, the TcTyCon has as its tyConBinders only - the explicit arguments given -- no kind variables, etc. - - S2) Then, using these initial kinds, we kind-check the body of the - tycon (class methods, data constructors, etc.), filling in the - metavariables in the tycon's initial kind. - - S3) We then generalize to get the (non-CUSK) tycon's final, fixed - kind. Finally, once this has happened for all tycons in a - mutually recursive group, we can desugar the lot. - - For convenience, we store partially-known tycons in TcTyCons, which - might store meta-variables. These TcTyCons are stored in the local - environment in TcTyClsDecls, until the real full TyCons can be created - during desugaring. A desugared program should never have a TcTyCon. - -3. In a TcTyCon, everything is zonked after the kind-checking pass (S2). - -4. 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 - TcHsType.splitTelescopeTvs!) - - Instead of trying, we just store the list of type variables to - bring into scope, in the tyConScopedTyVars field of the TcTyCon. - These tyvars are brought into scope in TcHsType.bindTyClTyVars. - - 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. -If there is a separate kind signature, or a CUSK, we take an entirely -different code path. - -For inference, consider - class C (f :: k) x where - type T f - op :: D f => blah - class D (g :: j) y where - op :: C g => y -> blah - -Here C and D are considered mutually recursive. Neither has a CUSK. -Just before generalisation we have the (un-quantified) kinds - C :: k1 -> k2 -> Constraint - T :: k1 -> Type - D :: k1 -> Type -> Constraint -Notice that f's kind and g's kind have been unified to 'k1'. We say -that k1 is the "representative" of k in C's decl, and of j in D's decl. - -Now when quantifying, we'd like to end up with - C :: forall {k2}. forall k. k -> k2 -> Constraint - T :: forall k. k -> Type - D :: forall j. j -> Type -> Constraint - -That is, we want to swizzle the representative to have the Name given -by the user. Partly this is to improve error messages and the output of -:info in GHCi. But it is /also/ important because the code for a -default method may mention the class variable(s), but at that point -(tcClassDecl2), we only have the final class tyvars available. -(Alternatively, we could record the scoped type variables in the -TyCon, but it's a nuisance to do so.) - -Notes: - -* On the input to generaliseTyClDecl, the mapping between the - user-specified Name and the representative TyVar is recorded in the - tyConScopedTyVars of the TcTyCon. NB: you first need to zonk to see - this representative TyVar. - -* The swizzling is actually performed by swizzleTcTyConBndrs - -* We must do the swizzling across the whole class decl. Consider - class C f where - type S (f :: k) - type T f - Here f's kind k is a parameter of C, and its identity is shared - with S and T. So if we swizzle the representative k at all, we - must do so consistently for the entire declaration. - - Hence the call to check_duplicate_tc_binders is in generaliseTyClDecl, - rather than in generaliseTcTyCon. - -There are errors to catch here. Suppose we had - class E (f :: j) (g :: k) where - op :: SameKind f g -> blah - -Then, just before generalisation we will have the (unquantified) - E :: k1 -> k1 -> Constraint - -That's bad! Two distinctly-named tyvars (j and k) have ended up with -the same representative k1. So when swizzling, we check (in -check_duplicate_tc_binders) that two distinct source names map -to the same representative. - -Here's an interesting case: - class C1 f where - type S (f :: k1) - type T (f :: k2) -Here k1 and k2 are different Names, but they end up mapped to the -same representative TyVar. To make the swizzling consistent (remember -we must have a single k across C1, S and T) we reject the program. - -Another interesting case - class C2 f where - type S (f :: k) (p::Type) - type T (f :: k) (p::Type->Type) - -Here the two k's (and the two p's) get distinct Uniques, because they -are seen by the renamer as locally bound in S and T resp. But again -the two (distinct) k's end up bound to the same representative TyVar. -You might argue that this should be accepted, but it's definitely -rejected (via an entirely different code path) if you add a kind sig: - type C2' :: j -> Constraint - class C2' f where - type S (f :: k) (p::Type) -We get - • Expected kind ‘j’, but ‘f’ has kind ‘k’ - • In the associated type family declaration for ‘S’ - -So we reject C2 too, even without the kind signature. We have -to do a bit of work to get a good error message, since both k's -look the same to the user. - -Another case - class C3 (f :: k1) where - type S (f :: k2) - -This will be rejected too. - - -Note [Type environment evolution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As we typecheck a group of declarations the type environment evolves. -Consider for example: - data B (a :: Type) = MkB (Proxy 'MkB) - -We do the following steps: - - 1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the - type env with promotion errors - B :-> TyConPE - MkB :-> DataConPE - - 2. kcTyCLGroup - - Do inferInitialKinds, which will signal a promotion - error if B is used in any of the kinds needed to initialise - B's kind (e.g. (a :: Type)) here - - - Extend the type env with these initial kinds (monomorphic for - decls that lack a CUSK) - B :-> TcTyCon - (thereby overriding the B :-> TyConPE binding) - and do kcLTyClDecl on each decl to get equality constraints on - all those initial kinds - - - Generalise the initial kind, making a poly-kinded TcTyCon - - 3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded - TcTyCons, again overriding the promotion-error bindings. - - But note that the data constructor promotion errors are still in place - so that (in our example) a use of MkB will still be signalled as - an error. - - 4. Typecheck the decls. - - 5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons - - -Note [Missed opportunity to retain higher-rank kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In 'kcTyClGroup', there is a missed opportunity to make kind -inference work in a few more cases. The idea is analogous -to Note [Single function non-recursive binding special-case]: - - * If we have an SCC with a single decl, which is non-recursive, - instead of creating a unification variable representing the - kind of the decl and unifying it with the rhs, we can just - read the type directly of the rhs. - - * Furthermore, we can update our SCC analysis to ignore - dependencies on declarations which have CUSKs: we don't - have to kind-check these all at once, since we can use - the CUSK to initialize the kind environment. - -Unfortunately this requires reworking a bit of the code in -'kcLTyClDecl' so I've decided to punt unless someone shouts about it. - -Note [Don't process associated types in getInitialKind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously, we processed associated types in the thing_inside in getInitialKind, -but this was wrong -- we want to do ATs sepearately. -The consequence for not doing it this way is #15142: - - class ListTuple (tuple :: Type) (as :: [(k, Type)]) where - type ListToTuple as :: Type - -We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify -kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring -`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't -unified with Type. And then, when we generalize the kind of ListToTuple (which -indeed has a CUSK, according to the rules), we skolemize the free metavariable -kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple, -because the solveEqualities in kcInferDeclHeader is at TcLevel 1 and so kappa[1] -will unify with Type. - -Bottom line: as associated types should have no effect on a CUSK enclosing class, -we move processing them to a separate action, run after the outer kind has -been generalized. - --} - -kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM [TcTyCon] - --- Kind check this group, kind generalize, and return the resulting local env --- This binds the TyCons and Classes of the group, but not the DataCons --- See Note [Kind checking for type and class decls] --- and Note [Inferring kinds for type declarations] -kcTyClGroup kisig_env decls - = do { mod <- getModule - ; traceTc "---- kcTyClGroup ---- {" - (text "module" <+> ppr mod $$ vcat (map ppr decls)) - - -- Kind checking; - -- 1. Bind kind variables for decls - -- 2. Kind-check decls - -- 3. Generalise the inferred kinds - -- See Note [Kind checking for type and class decls] - - ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds - -- See Note [CUSKs and PolyKinds] - ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls - - get_kind d - | Just ki <- lookupNameEnv kisig_env (tcdName (unLoc d)) - = Right (d, SAKS ki) - - | cusks_enabled && hsDeclHasCusk (unLoc d) - = Right (d, CUSK) - - | otherwise = Left d - - ; checked_tcs <- checkInitialKinds kinded_decls - ; inferred_tcs - <- tcExtendKindEnvWithTyCons checked_tcs $ - pushTcLevelM_ $ -- We are going to kind-generalise, so - -- unification variables in here must - -- be one level in - solveEqualities $ - do { -- Step 1: Bind kind variables for all decls - mono_tcs <- inferInitialKinds kindless_decls - - ; traceTc "kcTyClGroup: initial kinds" $ - ppr_tc_kinds mono_tcs - - -- Step 2: Set extended envt, kind-check the decls - -- NB: the environment extension overrides the tycon - -- promotion-errors bindings - -- See Note [Type environment evolution] - ; tcExtendKindEnvWithTyCons mono_tcs $ - mapM_ kcLTyClDecl kindless_decls - - ; return mono_tcs } - - -- Step 3: generalisation - -- Finally, go through each tycon and give it its final kind, - -- with all the required, specified, and inferred variables - -- in order. - ; let inferred_tc_env = mkNameEnv $ - map (\tc -> (tyConName tc, tc)) inferred_tcs - ; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env) - kindless_decls - - ; let poly_tcs = checked_tcs ++ generalized_tcs - ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs) - ; return poly_tcs } - where - ppr_tc_kinds tcs = vcat (map pp_tc tcs) - pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc) - -type ScopedPairs = [(Name, TcTyVar)] - -- The ScopedPairs for a TcTyCon are precisely - -- specified-tvs ++ required-tvs - -- You can distinguish them because there are tyConArity required-tvs - -generaliseTyClDecl :: NameEnv TcTyCon -> LTyClDecl GhcRn -> TcM [TcTyCon] --- See Note [Swizzling the tyvars before generaliseTcTyCon] -generaliseTyClDecl inferred_tc_env (L _ decl) - = 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 - - -- 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 - - -- Swizzle - ; swizzled_infos <- tcAddDeclCtxt decl (swizzleTcTyConBndrs tc_infos) - - -- And finally generalise - ; mapAndReportM generaliseTcTyCon swizzled_infos } - where - tycld_names :: TyClDecl GhcRn -> [Name] - tycld_names decl = tcdName decl : at_names decl - - at_names :: TyClDecl GhcRn -> [Name] - at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats - at_names _ = [] -- Only class decls have associated types - - skolemise_tc_tycon :: Name -> TcM (TcTyCon, ScopedPairs) - -- Zonk and skolemise the Specified and Required binders - skolemise_tc_tycon tc_name - = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name - -- This lookup should not fail - ; scoped_prs <- mapSndM zonkAndSkolemise (tcTyConScopedTyVars tc) - ; return (tc, scoped_prs) } - - zonk_tc_tycon :: (TcTyCon, ScopedPairs) -> TcM (TcTyCon, ScopedPairs, TcKind) - zonk_tc_tycon (tc, scoped_prs) - = do { scoped_prs <- mapSndM zonkTcTyVarToTyVar scoped_prs - -- We really have to do this again, even though - -- we have just done zonkAndSkolemise - ; res_kind <- zonkTcType (tyConResKind tc) - ; return (tc, scoped_prs, res_kind) } - -swizzleTcTyConBndrs :: [(TcTyCon, ScopedPairs, TcKind)] - -> TcM [(TcTyCon, ScopedPairs, TcKind)] -swizzleTcTyConBndrs tc_infos - | all no_swizzle swizzle_prs - -- This fast path happens almost all the time - -- See Note [Non-cloning for tyvar binders] in TcHsType - = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr (map fstOf3 tc_infos)) - ; return tc_infos } - - | otherwise - = do { check_duplicate_tc_binders - - ; traceTc "swizzleTcTyConBndrs" $ - vcat [ text "before" <+> ppr_infos tc_infos - , text "swizzle_prs" <+> ppr swizzle_prs - , text "after" <+> ppr_infos swizzled_infos ] - - ; return swizzled_infos } - - where - swizzled_infos = [ (tc, mapSnd swizzle_var scoped_prs, swizzle_ty kind) - | (tc, scoped_prs, kind) <- tc_infos ] - - swizzle_prs :: [(Name,TyVar)] - -- Pairs the user-specifed Name with its representative TyVar - -- See Note [Swizzling the tyvars before generaliseTcTyCon] - swizzle_prs = [ pr | (_, prs, _) <- tc_infos, pr <- prs ] - - no_swizzle :: (Name,TyVar) -> Bool - no_swizzle (nm, tv) = nm == tyVarName tv - - ppr_infos infos = vcat [ ppr tc <+> pprTyVars (map snd prs) - | (tc, prs, _) <- infos ] - - -- Check for duplicates - -- E.g. data SameKind (a::k) (b::k) - -- data T (a::k1) (b::k2) = MkT (SameKind a b) - -- Here k1 and k2 start as TyVarTvs, and get unified with each other - -- If this happens, things get very confused later, so fail fast - check_duplicate_tc_binders :: TcM () - check_duplicate_tc_binders = unless (null err_prs) $ - do { mapM_ report_dup err_prs; failM } - - -------------- Error reporting ------------ - err_prs :: [(Name,Name)] - err_prs = [ (n1,n2) - | pr :| prs <- findDupsEq ((==) `on` snd) swizzle_prs - , (n1,_):(n2,_):_ <- [nubBy ((==) `on` fst) (pr:prs)] ] - -- This nubBy avoids bogus error reports when we have - -- [("f", f), ..., ("f",f)....] in swizzle_prs - -- which happens with class C f where { type T f } - - report_dup :: (Name,Name) -> TcM () - report_dup (n1,n2) - = setSrcSpan (getSrcSpan n2) $ addErrTc $ - hang (text "Different names for the same type variable:") 2 info - where - info | nameOccName n1 /= nameOccName n2 - = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2) - | otherwise -- Same OccNames! See C2 in - -- Note [Swizzling the tyvars before generaliseTcTyCon] - = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1) - , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ] - - -------------- The swizzler ------------ - -- This does a deep traverse, simply doing a - -- Name-to-Name change, governed by swizzle_env - -- The 'swap' is what gets from the representative TyVar - -- back to the original user-specified Name - swizzle_env = mkVarEnv (map swap swizzle_prs) - - swizzleMapper :: TyCoMapper () Identity - swizzleMapper = TyCoMapper { tcm_tyvar = swizzle_tv - , tcm_covar = swizzle_cv - , tcm_hole = swizzle_hole - , tcm_tycobinder = swizzle_bndr - , tcm_tycon = swizzle_tycon } - swizzle_hole _ hole = pprPanic "swizzle_hole" (ppr hole) - -- These types are pre-zonked - swizzle_tycon tc = pprPanic "swizzle_tc" (ppr tc) - -- TcTyCons can't appear in kinds (yet) - swizzle_tv _ tv = return (mkTyVarTy (swizzle_var tv)) - swizzle_cv _ cv = return (mkCoVarCo (swizzle_var cv)) - - swizzle_bndr _ tcv _ - = return ((), swizzle_var tcv) - - swizzle_var :: Var -> Var - swizzle_var v - | Just nm <- lookupVarEnv swizzle_env v - = updateVarType swizzle_ty (v `setVarName` nm) - | otherwise - = updateVarType swizzle_ty v - - (map_type, _, _, _) = mapTyCo swizzleMapper - swizzle_ty ty = runIdentity (map_type ty) - - -generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon -generaliseTcTyCon (tc, scoped_prs, tc_res_kind) - -- See Note [Required, Specified, and Inferred for types] - = setSrcSpan (getSrcSpan tc) $ - addTyConCtxt tc $ - do { -- Step 1: Separate Specified from Required variables - -- NB: spec_req_tvs = spec_tvs ++ req_tvs - -- And req_tvs is 1-1 with tyConTyVars - -- See Note [Scoped tyvars in a TcTyCon] in GHC.Core.TyCon - ; let spec_req_tvs = map snd scoped_prs - n_spec = length spec_req_tvs - tyConArity tc - (spec_tvs, req_tvs) = splitAt n_spec spec_req_tvs - sorted_spec_tvs = scopedSort spec_tvs - -- NB: We can't do the sort until we've zonked - -- Maintain the L-R order of scoped_tvs - - -- Step 2a: find all the Inferred variables we want to quantify over - ; dvs1 <- candidateQTyVarsOfKinds $ - (tc_res_kind : map tyVarKind spec_req_tvs) - ; let dvs2 = dvs1 `delCandidates` spec_req_tvs - - -- Step 2b: quantify, mainly meaning skolemise the free variables - -- Returned 'inferred' are scope-sorted and skolemised - ; inferred <- quantifyTyVars dvs2 - - ; traceTc "generaliseTcTyCon: pre zonk" - (vcat [ text "tycon =" <+> ppr tc - , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs - , text "tc_res_kind =" <+> ppr tc_res_kind - , text "dvs1 =" <+> ppr dvs1 - , text "inferred =" <+> pprTyVars inferred ]) - - -- Step 3: Final zonk (following kind generalisation) - -- See Note [Swizzling the tyvars before generaliseTcTyCon] - ; ze <- emptyZonkEnv - ; (ze, inferred) <- zonkTyBndrsX ze inferred - ; (ze, sorted_spec_tvs) <- zonkTyBndrsX ze sorted_spec_tvs - ; (ze, req_tvs) <- zonkTyBndrsX ze req_tvs - ; tc_res_kind <- zonkTcTypeToTypeX ze tc_res_kind - - ; traceTc "generaliseTcTyCon: post zonk" $ - vcat [ text "tycon =" <+> ppr tc - , text "inferred =" <+> pprTyVars inferred - , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs - , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs - , text "req_tvs =" <+> ppr req_tvs - , text "zonk-env =" <+> ppr ze ] - - -- Step 4: Make the TyConBinders. - ; let dep_fv_set = candidateKindVars dvs1 - inferred_tcbs = mkNamedTyConBinders Inferred inferred - specified_tcbs = mkNamedTyConBinders Specified sorted_spec_tvs - required_tcbs = map (mkRequiredTyConBinder dep_fv_set) req_tvs - - -- Step 5: Assemble the final list. - final_tcbs = concat [ inferred_tcbs - , specified_tcbs - , required_tcbs ] - - -- Step 6: Make the result TcTyCon - tycon = mkTcTyCon (tyConName tc) final_tcbs tc_res_kind - (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs)) - True {- it's generalised now -} - (tyConFlavour tc) - - ; traceTc "generaliseTcTyCon done" $ - vcat [ text "tycon =" <+> ppr tc - , text "tc_res_kind =" <+> ppr tc_res_kind - , text "dep_fv_set =" <+> ppr dep_fv_set - , text "inferred_tcbs =" <+> ppr inferred_tcbs - , text "specified_tcbs =" <+> ppr specified_tcbs - , text "required_tcbs =" <+> ppr required_tcbs - , text "final_tcbs =" <+> ppr final_tcbs ] - - -- Step 7: Check for validity. - -- We do this here because we're about to put the tycon into the - -- the environment, and we don't want anything malformed there - ; checkTyConTelescope tycon - - ; return tycon } - -{- Note [Required, Specified, and Inferred for types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Each forall'd type variable in a type or kind is one of - - * Required: an argument must be provided at every call site - - * Specified: the argument can be inferred at call sites, but - may be instantiated with visible type/kind application - - * Inferred: the must be inferred at call sites; it - is unavailable for use with visible type/kind application. - -Why have Inferred at all? Because we just can't make user-facing -promises about the ordering of some variables. These might swizzle -around even between minor released. By forbidding visible type -application, we ensure users aren't caught unawares. - -Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. - -The question for this Note is this: - given a TyClDecl, how are its quantified type variables classified? -Much of the debate is memorialized in #15743. - -Here is our design choice. When inferring the ordering of variables -for a TyCl declaration (that is, for those variables that he user -has not specified the order with an explicit `forall`), we use the -following order: - - 1. Inferred variables - 2. Specified variables; in the left-to-right order in which - the user wrote them, modified by scopedSort (see below) - to put them in depdendency order. - 3. Required variables before a top-level :: - 4. All variables after a top-level :: - -If this ordering does not make a valid telescope, we reject the definition. - -Example: - data SameKind :: k -> k -> * - data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) - -For Bad: - - a, c, d, x are Required; they are explicitly listed by the user - as the positional arguments of Bad - - b is Specified; it appears explicitly in a kind signature - - k, the kind of a, is Inferred; it is not mentioned explicitly at all - -Putting variables in the order Inferred, Specified, Required -gives us this telescope: - Inferred: k - Specified: b : Proxy a - Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d) - -But this order is ill-scoped, because b's kind mentions a, which occurs -after b in the telescope. So we reject Bad. - -Associated types -~~~~~~~~~~~~~~~~ -For associated types everything above is determined by the -associated-type declaration alone, ignoring the class header. -Here is an example (#15592) - class C (a :: k) b where - type F (x :: b a) - -In the kind of C, 'k' is Specified. But what about F? -In the kind of F, - - * Should k be Inferred or Specified? It's Specified for C, - but not mentioned in F's declaration. - - * In which order should the Specified variables a and b occur? - It's clearly 'a' then 'b' in C's declaration, but the L-R ordering - in F's declaration is 'b' then 'a'. - -In both cases we make the choice by looking at F's declaration alone, -so it gets the kind - F :: forall {k}. forall b a. b a -> Type - -How it works -~~~~~~~~~~~~ -These design choices are implemented by two completely different code -paths for - - * Declarations with a standalone kind signature or a complete user-specified - kind signature (CUSK). Handled by the kcCheckDeclHeader. - - * Declarations without a kind signature (standalone or CUSK) are handled by - kcInferDeclHeader; see Note [Inferring kinds for type declarations]. - -Note that neither code path worries about point (4) above, as this -is nicely handled by not mangling the res_kind. (Mangling res_kinds is done -*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.) - -We can tell Inferred apart from Specified by looking at the scoped -tyvars; Specified are always included there. - -Design alternatives -~~~~~~~~~~~~~~~~~~~ -* For associated types we considered putting the class variables - before the local variables, in a nod to the treatment for class - methods. But it got too compilicated; see #15592, comment:21ff. - -* We rigidly require the ordering above, even though we could be much more - permissive. Relevant musings are at - https://gitlab.haskell.org/ghc/ghc/issues/15743#note_161623 - The bottom line conclusion is that, if the user wants a different ordering, - then can specify it themselves, and it is better to be predictable and dumb - than clever and capricious. - - I (Richard) conjecture we could be fully permissive, allowing all classes - of variables to intermix. We would have to augment ScopedSort to refuse to - reorder Required variables (or check that it wouldn't have). But this would - allow more programs. See #15743 for examples. Interestingly, Idris seems - to allow this intermixing. The intermixing would be fully specified, in that - we can be sure that inference wouldn't change between versions. However, - would users be able to predict it? That I cannot answer. - -Test cases (and tickets) relevant to these design decisions -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - T15591* - T15592* - T15743* - -Note [Inferring kinds for type declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This note deals with /inference/ for type declarations -that do not have a CUSK. 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) - -We do kind inference as follows: - -* Step 1: inferInitialKinds, and in particular kcInferDeclHeader. - Make a unification variable for each of the Required and Specified - type variables in the header. - - Record the connection between the Names the user wrote and the - fresh unification variables in the tcTyConScopedTyVars field - of the TcTyCon we are making - [ (a, aa) - , (k1, kk1) - , (k2, kk2) - , (x, xx) ] - (I'm using the convention that double letter like 'aa' or 'kk' - mean a unification variable.) - - These unification variables - - Are TyVarTvs: that is, unification variables that can - unify only with other type variables. - See Note [Signature skolems] in TcType - - - Have complete fresh Names; see TcMType - Note [Unification variables need fresh Names] - - Assign initial monomorphic kinds to S, T - T :: kk1 -> * -> kk2 -> * - S :: kk3 -> * -> kk4 -> * - -* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and - T, with these monomorphic kinds. Now kind-check the declarations, - and solve the resulting equalities. The goal here is to discover - constraints on all these unification variables. - - Here we find that kk1 := kk3, and kk2 := kk4. - - This is why we can't use skolems for kk1 etc; they have to - unify with each other. - -* Step 3: generaliseTcTyCon. Generalise each TyCon in turn. - We find the free variables of the kind, skolemise them, - sort them out into Inferred/Required/Specified (see the above - Note [Required, Specified, and Inferred for types]), - and perform some validity checks. - - This makes the utterly-final TyConBinders for the TyCon. - - All this is very similar at the level of terms: see TcBinds - Note [Quantified variables in partial type signatures] - - But there some tricky corners: Note [Tricky scoping in generaliseTcTyCon] - -* Step 4. Extend the type environment with a TcTyCon for S and T, now - with their utterly-final polymorphic kinds (needed for recursive - occurrences of S, T). Now typecheck the declarations, and build the - final AlgTyCon for S and T resp. - -The first three steps are in kcTyClGroup; the fourth is in -tcTyClDecls. - -There are some wrinkles - -* Do not default TyVarTvs. We always want to kind-generalise over - TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is - not allowed to unify with a type; it must stand for a type - variable. Hence the check in TcSimplify.defaultTyVarTcS, and - TcMType.defaultTyVar. Here's another example (#14555): - data Exp :: [TYPE rep] -> TYPE rep -> Type where - Lam :: Exp (a:xs) b -> Exp xs (a -> b) - We want to kind-generalise over the 'rep' variable. - #14563 is another example. - -* Duplicate type variables. Consider #11203 - data SameKind :: k -> k -> * - data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) - Here we will unify k1 with k2, but this time doing so is an error, - because k1 and k2 are bound in the same declaration. - - We spot this during validity checking (findDupTyVarTvs), - in generaliseTcTyCon. - -* Required arguments. Even the Required arguments should be made - into TyVarTvs, not skolems. Consider - data T k (a :: k) - Here, k is a Required, dependent variable. For uniformity, it is helpful - to have k be a TyVarTv, in parallel with other dependent variables. - -* Duplicate skolemisation is expected. When generalising in Step 3, - we may find that one of the variables we want to quantify has - already been skolemised. For example, suppose we have already - generalise S. When we come to T we'll find that kk1 (now the same as - kk3) has already been skolemised. - - That's fine -- but it means that - a) when collecting quantification candidates, in - candidateQTyVarsOfKind, we must collect skolems - b) quantifyTyVars should be a no-op on such a skolem - -Note [Tricky scoping in generaliseTcTyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider #16342 - class C (a::ka) x where - cop :: D a x => x -> Proxy a -> Proxy a - cop _ x = x :: Proxy (a::ka) - - class D (b::kb) y where - dop :: C b y => y -> Proxy b -> Proxy b - dop _ x = x :: Proxy (b::kb) - -C and D are mutually recursive, by the time we get to -generaliseTcTyCon we'll have unified kka := kkb. - -But when typechecking the default declarations for 'cop' and 'dop' in -tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope. -But at that point all we have is the utterly-final Class itself. - -Conclusion: the classTyVars of a class must have the same Name as -that originally assigned by the user. In our example, C must have -classTyVars {a, ka, x} while D has classTyVars {a, kb, y}. Despite -the fact that kka and kkb got unified! - -We achieve this sleight of hand in generaliseTcTyCon, using -the specialised function zonkRecTyVarBndrs. We make the call - zonkRecTyVarBndrs [ka,a,x] [kkb,aa,xxx] -where the [ka,a,x] are the Names originally assigned by the user, and -[kkb,aa,xx] are the corresponding (post-zonking, skolemised) TcTyVars. -zonkRecTyVarBndrs builds a recursive ZonkEnv that binds - kkb :-> (ka :: ) - aa :-> (a :: ) - etc -That is, it maps each skolemised TcTyVars to the utterly-final -TyVar to put in the class, with its correct user-specified name. -When generalising D we'll do the same thing, but the ZonkEnv will map - kkb :-> (kb :: ) - bb :-> (b :: ) - etc -Note that 'kkb' again appears in the domain of the mapping, but this -time mapped to 'kb'. That's how C and D end up with differently-named -final TyVars despite the fact that we unified kka:=kkb - -zonkRecTyVarBndrs we need to do knot-tying because of the need to -apply this same substitution to the kind of each. - -Note [Inferring visible dependent quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T k :: k -> Type where - MkT1 :: T Type Int - MkT2 :: T (Type -> Type) Maybe - -This looks like it should work. However, it is polymorphically recursive, -as the uses of T in the constructor types specialize the k in the kind -of T. This trips up our dear users (#17131, #17541), and so we add -a "landmark" context (which cannot be suppressed) whenever we -spot inferred visible dependent quantification (VDQ). - -It's hard to know when we've actually been tripped up by polymorphic recursion -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 -TcHsType 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). - -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. - - --} - --------------- -tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a -tcExtendKindEnvWithTyCons tcs - = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ] - --------------- -mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv --- Maps each tycon/datacon to a suitable promotion error --- tc :-> APromotionErr TyConPE --- dc :-> APromotionErr RecDataConPE --- See Note [Recursion and promoting data constructors] - -mkPromotionErrorEnv decls - = foldr (plusNameEnv . mk_prom_err_env . unLoc) - emptyNameEnv decls - -mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv -mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) - = unitNameEnv nm (APromotionErr ClassPE) - `plusNameEnv` - mkNameEnv [ (familyDeclName at, APromotionErr TyConPE) - | L _ at <- ats ] - -mk_prom_err_env (DataDecl { tcdLName = L _ name - , tcdDataDefn = HsDataDefn { dd_cons = cons } }) - = unitNameEnv name (APromotionErr TyConPE) - `plusNameEnv` - mkNameEnv [ (con, APromotionErr RecDataConPE) - | L _ con' <- cons - , L _ con <- getConNames con' ] - -mk_prom_err_env decl - = unitNameEnv (tcdName decl) (APromotionErr TyConPE) - -- Works for family declarations too - --------------- -inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon] --- Returns a TcTyCon for each TyCon bound by the decls, --- each with its initial kind - -inferInitialKinds decls - = do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls) - ; tcs <- concatMapM infer_initial_kind decls - ; traceTc "inferInitialKinds done }" empty - ; return tcs } - where - infer_initial_kind = addLocM (getInitialKind InitialKindInfer) - --- Check type/class declarations against their standalone kind signatures or --- CUSKs, producing a generalized TcTyCon for each. -checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon] -checkInitialKinds decls - = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls) - ; tcs <- concatMapM check_initial_kind decls - ; traceTc "checkInitialKinds done }" empty - ; return tcs } - where - check_initial_kind (ldecl, msig) = - addLocM (getInitialKind (InitialKindCheck msig)) ldecl - --- | Get the initial kind of a TyClDecl, either generalized or non-generalized, --- depending on the 'InitialKindStrategy'. -getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon] - --- Allocate a fresh kind variable for each TyCon and Class --- For each tycon, return a TcTyCon with kind k --- where k is the kind of tc, derived from the LHS --- of the definition (and probably including --- kind unification variables) --- Example: data T a b = ... --- return (T, kv1 -> kv2 -> kv3) --- --- This pass deals with (ie incorporates into the kind it produces) --- * The kind signatures on type-variable binders --- * The result kinds signature on a TyClDecl --- --- No family instances are passed to checkInitialKinds/inferInitialKinds -getInitialKind strategy - (ClassDecl { tcdLName = L _ name - , tcdTyVars = ktvs - , tcdATs = ats }) - = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $ - return (TheKind constraintKind) - ; let parent_tv_prs = tcTyConScopedTyVars cls - -- See Note [Don't process associated types in getInitialKind] - ; inner_tcs <- - tcExtendNameTyVarEnv parent_tv_prs $ - mapM (addLocM (getAssocFamInitialKind cls)) ats - ; return (cls : inner_tcs) } - where - getAssocFamInitialKind cls = - case strategy of - InitialKindInfer -> get_fam_decl_initial_kind (Just cls) - InitialKindCheck _ -> check_initial_kind_assoc_fam cls - -getInitialKind strategy - (DataDecl { tcdLName = L _ name - , tcdTyVars = ktvs - , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig - , dd_ND = new_or_data } }) - = do { let flav = newOrDataToFlavour new_or_data - ctxt = DataKindCtxt name - ; tc <- kcDeclHeader strategy name flav ktvs $ - case m_sig of - Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig - Nothing -> return $ dataDeclDefaultResultKind new_or_data - ; return [tc] } - -getInitialKind InitialKindInfer (FamDecl { tcdFam = decl }) - = do { tc <- get_fam_decl_initial_kind Nothing decl - ; return [tc] } - -getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam = - FamilyDecl { fdLName = unLoc -> name - , fdTyVars = ktvs - , fdResultSig = unLoc -> resultSig - , fdInfo = info } } ) - = do { let flav = getFamFlav Nothing info - ctxt = TyFamResKindCtxt name - ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $ - case famResultKindSignature resultSig of - Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig - Nothing -> - case msig of - CUSK -> return (TheKind liftedTypeKind) - SAKS _ -> return AnyKind - ; return [tc] } - -getInitialKind strategy - (SynDecl { tcdLName = L _ name - , tcdTyVars = ktvs - , tcdRhs = rhs }) - = do { let ctxt = TySynKindCtxt name - ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $ - case hsTyKindSig rhs of - Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig - Nothing -> return AnyKind - ; return [tc] } - -getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec -getInitialKind _ (FamDecl {tcdFam = XFamilyDecl nec}) = noExtCon nec -getInitialKind _ (XTyClDecl nec) = noExtCon nec - -get_fam_decl_initial_kind - :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls - -> FamilyDecl GhcRn - -> TcM TcTyCon -get_fam_decl_initial_kind mb_parent_tycon - FamilyDecl { fdLName = L _ name - , fdTyVars = ktvs - , fdResultSig = L _ resultSig - , fdInfo = info } - = kcDeclHeader InitialKindInfer name flav ktvs $ - case resultSig of - KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki - TyVarSig _ (L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki - _ -- open type families have * return kind by default - | tcFlavourIsOpen flav -> return (TheKind liftedTypeKind) - -- closed type families have their return kind inferred - -- by default - | otherwise -> return AnyKind - where - flav = getFamFlav mb_parent_tycon info - ctxt = TyFamResKindCtxt name -get_fam_decl_initial_kind _ (XFamilyDecl nec) = noExtCon nec - --- See Note [Standalone kind signatures for associated types] -check_initial_kind_assoc_fam - :: TcTyCon -- parent class - -> FamilyDecl GhcRn - -> TcM TcTyCon -check_initial_kind_assoc_fam cls - FamilyDecl - { fdLName = unLoc -> name - , fdTyVars = ktvs - , fdResultSig = unLoc -> resultSig - , fdInfo = info } - = kcDeclHeader (InitialKindCheck CUSK) name flav ktvs $ - case famResultKindSignature resultSig of - Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig - Nothing -> return (TheKind liftedTypeKind) - where - ctxt = TyFamResKindCtxt name - flav = getFamFlav (Just cls) info -check_initial_kind_assoc_fam _ (XFamilyDecl nec) = noExtCon nec - -{- Note [Standalone kind signatures for associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -If associated types had standalone kind signatures, would they wear them - ----------------------------+------------------------------ - like this? (OUT) | or like this? (IN) ----------------------------+------------------------------ - type T :: Type -> Type | class C a where - class C a where | type T :: Type -> Type - type T a | type T a - -The (IN) variant is syntactically ambiguous: - - class C a where - type T :: a -- standalone kind signature? - type T :: a -- declaration header? - -The (OUT) variant does not suffer from this issue, but it might not be the -direction in which we want to take Haskell: we seek to unify type families and -functions, and, by extension, associated types with class methods. And yet we -give class methods their signatures inside the class, not outside. Neither do -we have the counterpart of InstanceSigs for StandaloneKindSignatures. - -For now, we dodge the question by using CUSKs for associated types instead of -standalone kind signatures. This is a simple addition to the rule we used to -have before standalone kind signatures: - - old rule: associated type has a CUSK iff its parent class has a CUSK - new rule: associated type has a CUSK iff its parent class has a CUSK or a standalone kind signature - --} - --- See Note [Data declaration default result kind] -dataDeclDefaultResultKind :: NewOrData -> ContextKind -dataDeclDefaultResultKind NewType = OpenKind - -- See Note [Implementation of UnliftedNewtypes], point . -dataDeclDefaultResultKind DataType = TheKind liftedTypeKind - -{- Note [Data declaration default result kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When the user has not written an inline result kind annotation on a data -declaration, we assume it to be 'Type'. That is, the following declarations -D1 and D2 are considered equivalent: - - data D1 where ... - data D2 :: Type where ... - -The consequence of this assumption is that we reject D3 even though we -accept D4: - - data D3 where - MkD3 :: ... -> D3 param - - data D4 :: Type -> Type where - MkD4 :: ... -> D4 param - -However, there's a twist: for newtypes, we must relax -the assumed result kind to (TYPE r): - - newtype D5 where - MkD5 :: Int# -> D5 - -See Note [Implementation of UnliftedNewtypes], STEP 1 and it's sub-note -. --} - ---------------------------------- -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] - -- Called only for declarations without a signature (no CUSKs or SAKs here) -kcLTyClDecl (L loc decl) - = setSrcSpan loc $ - do { tycon <- tcLookupTcTyCon tc_name - ; traceTc "kcTyClDecl {" (ppr tc_name) - ; addVDQNote tycon $ -- See Note [Inferring visible dependent quantification] - addErrCtxt (tcMkDeclCtxt decl) $ - kcTyClDecl decl tycon - ; traceTc "kcTyClDecl done }" (ppr tc_name) } - where - tc_name = tcdName decl - -kcTyClDecl :: TyClDecl GhcRn -> TcTyCon -> TcM () --- This function is used solely for its side effect on kind variables --- NB kind signatures on the type variables and --- result kind signature have already been dealt with --- by inferInitialKind, so we can ignore them here. - -kcTyClDecl (DataDecl { tcdLName = (L _ name) - , tcdDataDefn = defn }) tyCon - | HsDataDefn { dd_cons = cons@((L _ (ConDeclGADT {})) : _) - , dd_ctxt = (L _ []) - , dd_ND = new_or_data } <- defn - = -- See Note [Implementation of UnliftedNewtypes] STEP 2 - kcConDecls new_or_data (tyConResKind tyCon) cons - - -- hs_tvs and dd_kindSig already dealt with in inferInitialKind - -- This must be a GADT-style decl, - -- (see invariants of DataDefn declaration) - -- so (a) we don't need to bring the hs_tvs into scope, because the - -- ConDecls bind all their own variables - -- (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it - - | HsDataDefn { dd_ctxt = ctxt - , dd_cons = cons - , dd_ND = new_or_data } <- defn - = bindTyClTyVars name $ \ _ _ _ -> - do { _ <- tcHsContext ctxt - ; kcConDecls new_or_data (tyConResKind tyCon) cons - } - -kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon - = bindTyClTyVars name $ \ _ _ res_kind -> - discardResult $ tcCheckLHsType rhs (TheKind res_kind) - -- NB: check against the result kind that we allocated - -- in inferInitialKinds. - -kcTyClDecl (ClassDecl { tcdLName = L _ name - , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon - = bindTyClTyVars name $ \ _ _ _ -> - do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocM_ kc_sig) sigs } - where - kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType skol_info nms op_ty - kc_sig _ = return () - - skol_info = TyConSkol ClassFlavour name - -kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc --- closed type families look at their equations, but other families don't --- do anything here - = case fd_info of - ClosedTypeFamily (Just eqns) -> mapM_ (kcTyFamInstEqn fam_tc) eqns - _ -> return () -kcTyClDecl (FamDecl _ (XFamilyDecl nec)) _ = noExtCon nec -kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) _ = noExtCon nec -kcTyClDecl (XTyClDecl nec) _ = noExtCon nec - -------------------- - --- Type check the types of the arguments to a data constructor. --- This includes doing kind unification if the type is a newtype. --- See Note [Implementation of UnliftedNewtypes] for why we need --- the first two arguments. -kcConArgTys :: NewOrData -> Kind -> [LHsType GhcRn] -> TcM () -kcConArgTys new_or_data res_kind arg_tys = do - { let exp_kind = getArgExpKind new_or_data res_kind - ; mapM_ (flip tcCheckLHsType exp_kind . getBangType) arg_tys - -- See Note [Implementation of UnliftedNewtypes], STEP 2 - } - -kcConDecls :: NewOrData - -> Kind -- The result kind signature - -> [LConDecl GhcRn] -- The data constructors - -> TcM () -kcConDecls new_or_data res_kind cons - = mapM_ (wrapLocM_ (kcConDecl new_or_data final_res_kind)) cons - where - (_, final_res_kind) = splitPiTys res_kind - -- See Note [kcConDecls result kind] - --- Kind check a data constructor. In additional to the data constructor, --- we also need to know about whether or not its corresponding type was --- declared with data or newtype, and we need to know the result kind of --- this type. See Note [Implementation of UnliftedNewtypes] for why --- we need the first two arguments. -kcConDecl :: NewOrData - -> Kind -- Result kind of the type constructor - -- Usually Type but can be TYPE UnliftedRep - -- or even TYPE r, in the case of unlifted newtype - -> ConDecl GhcRn - -> TcM () -kcConDecl new_or_data res_kind (ConDeclH98 - { con_name = name, con_ex_tvs = ex_tvs - , con_mb_cxt = ex_ctxt, con_args = args }) - = addErrCtxt (dataConCtxtName [name]) $ - discardResult $ - bindExplicitTKBndrs_Tv ex_tvs $ - do { _ <- tcHsMbContext ex_ctxt - ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) - -- We don't need to check the telescope here, - -- because that's done in tcConDecl - } - -kcConDecl new_or_data res_kind (ConDeclGADT - { con_names = names, con_qvars = qtvs, con_mb_cxt = cxt - , con_args = args, con_res_ty = res_ty }) - | HsQTvs { hsq_ext = implicit_tkv_nms - , hsq_explicit = explicit_tkv_nms } <- qtvs - = -- Even though the GADT-style data constructor's type is closed, - -- we must still kind-check the type, because that may influence - -- the inferred kind of the /type/ constructor. Example: - -- data T f a where - -- MkT :: f a -> T f a - -- If we don't look at MkT we won't get the correct kind - -- for the type constructor T - addErrCtxt (dataConCtxtName names) $ - discardResult $ - bindImplicitTKBndrs_Tv implicit_tkv_nms $ - bindExplicitTKBndrs_Tv explicit_tkv_nms $ - -- Why "_Tv"? See Note [Kind-checking for GADTs] - do { _ <- tcHsMbContext cxt - ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) - ; _ <- tcHsOpenType res_ty - ; return () } -kcConDecl _ _ (ConDeclGADT _ _ _ (XLHsQTyVars nec) _ _ _ _) = noExtCon nec -kcConDecl _ _ (XConDecl nec) = noExtCon nec - -{- Note [kcConDecls result kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We might have e.g. - data T a :: Type -> Type where ... -or - newtype instance N a :: Type -> Type where .. -in which case, the 'res_kind' passed to kcConDecls will be - Type->Type - -We must look past those arrows, or even foralls, to the Type in the -corner, to pass to kcConDecl c.f. #16828. Hence the splitPiTys here. - -I am a bit concerned about tycons with a declaration like - data T a :: Type -> forall k. k -> Type where ... - -It does not have a CUSK, so kcInferDeclHeader will make a TcTyCon -with tyConResKind of Type -> forall k. k -> Type. Even that is fine: -the splitPiTys will look past the forall. But I'm bothered about -what if the type "in the corner" mentions k? This is incredibly -obscure but something like this could be bad: - data T a :: Type -> foral k. k -> TYPE (F k) where ... - -I bet we are not quite right here, but my brain suffered a buffer -overflow and I thought it best to nail the common cases right now. - -Note [Recursion and promoting data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't want to allow promotion in a strongly connected component -when kind checking. - -Consider: - data T f = K (f (K Any)) - -When kind checking the `data T' declaration the local env contains the -mappings: - T -> ATcTyCon - K -> APromotionErr - -APromotionErr is only used for DataCons, and only used during type checking -in tcTyClGroup. - -Note [Kind-checking for GADTs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data Proxy a where - MkProxy1 :: forall k (b :: k). Proxy b - MkProxy2 :: forall j (c :: j). Proxy c - -It seems reasonable that this should be accepted. But something very strange -is going on here: when we're kind-checking this declaration, we need to unify -the kind of `a` with k and j -- even though k and j's scopes are local to the type of -MkProxy{1,2}. The best approach we've come up with is to use TyVarTvs during -the kind-checking pass. First off, note that it's OK if the kind-checking pass -is too permissive: we'll snag the problems in the type-checking pass later. -(This extra permissiveness might happen with something like - - data SameKind :: k -> k -> Type - data Bad a where - MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b) - -which would be accepted if k1 and k2 were TyVarTvs. This is correctly rejected -in the second pass, though. Test case: polykinds/TyVarTvKinds3) -Recall that the kind-checking pass exists solely to collect constraints -on the kinds and to power unification. - -To achieve the use of TyVarTvs, we must be careful to use specialized functions -that produce TyVarTvs, not ordinary skolems. This is why we need -kcExplicitTKBndrs and kcImplicitTKBndrs in TcHsType, separate from their -tc... variants. - -The drawback of this approach is sometimes it will accept a definition that -a (hypothetical) declarative specification would likely reject. As a general -rule, we don't want to allow polymorphic recursion without a CUSK. Indeed, -the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs -approach allows a limited form of polymorphic recursion *without* a CUSK. - -To wit: - data T a = forall k (b :: k). MkT (T b) Int - (test case: dependent/should_compile/T14066a) - -Note that this is polymorphically recursive, with the recursive occurrence -of T used at a kind other than a's kind. The approach outlined here accepts -this definition, because this kind is still a kind variable (and so the -TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a -way to describe exactly what declarations will be accepted and which will -be rejected (without a CUSK). However, the accepted definitions are indeed -well-kinded and any rejected definitions would be accepted with a CUSK, -and so this wrinkle need not cause anyone to lose sleep. - -************************************************************************ -* * -\subsection{Type checking} -* * -************************************************************************ - -Note [Type checking recursive type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At this point we have completed *kind-checking* of a mutually -recursive group of type/class decls (done in kcTyClGroup). However, -we discarded the kind-checked types (eg RHSs of data type decls); -note that kcTyClDecl returns (). There are two reasons: - - * It's convenient, because we don't have to rebuild a - kinded HsDecl (a fairly elaborate type) - - * It's necessary, because after kind-generalisation, the - TyCons/Classes may now be kind-polymorphic, and hence need - to be given kind arguments. - -Example: - data T f a = MkT (f a) (T f a) -During kind-checking, we give T the kind T :: k1 -> k2 -> * -and figure out constraints on k1, k2 etc. Then we generalise -to get T :: forall k. (k->*) -> k -> * -So now the (T f a) in the RHS must be elaborated to (T k f a). - -However, during tcTyClDecl of T (above) we will be in a recursive -"knot". So we aren't allowed to look at the TyCon T itself; we are only -allowed to put it (lazily) in the returned structures. But when -kind-checking the RHS of T's decl, we *do* need to know T's kind (so -that we can correctly elaboarate (T k f a). How can we get T's kind -without looking at T? Delicate answer: during tcTyClDecl, we extend - - *Global* env with T -> ATyCon (the (not yet built) final TyCon for T) - *Local* env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T) - -Then: - - * During TcHsType.tcTyVar we look in the *local* env, to get the - fully-known, not knot-tied TcTyCon for T. - - * Then, in TcHsSyn.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 -TyCons or Classes of this recursive group. Earlier, finished groups, -live in the global env only. - -See also Note [Kind checking recursive type and class declarations] - -Note [Kind checking recursive type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before we can type-check the decls, we must kind check them. This -is done by establishing an "initial kind", which is a rather uninformed -guess at a tycon's kind (by counting arguments, mainly) and then -using this initial kind for recursive occurrences. - -The initial kind is stored in exactly the same way during -kind-checking as it is during type-checking (Note [Type checking -recursive type and class declarations]): in the *local* environment, -with ATcTyCon. But we still must store *something* in the *global* -environment. Even though we discard the result of kind-checking, we -sometimes need to produce error messages. These error messages will -want to refer to the tycons being checked, except that they don't -exist yet, and it would be Terribly Annoying to get the error messages -to refer back to HsSyn. So we create a TcTyCon and put it in the -global env. This tycon can print out its name and knows its kind, but -any other action taken on it will panic. Note that TcTyCons are *not* -knot-tied, unlike the rather valid but knot-tied ones that occur -during type-checking. - -Note [Declarations for wired-in things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For wired-in things we simply ignore the declaration -and take the wired-in information. That avoids complications. -e.g. the need to make the data constructor worker name for - a constraint tuple match the wired-in one - -Note [Implementation of UnliftedNewtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Expected behavior of UnliftedNewtypes: - -* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0013-unlifted-newtypes.rst -* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/98 - -What follows is a high-level overview of the implementation of the -proposal. - -STEP 1: Getting the initial kind, as done by inferInitialKind. We have -two sub-cases: - -* With a SAK/CUSK: no change in kind-checking; the tycon is given the kind - the user writes, whatever it may be. - -* Without a SAK/CUSK: If there is no kind signature, the tycon is given - a kind `TYPE r`, for a fresh unification variable `r`. We do this even - when -XUnliftedNewtypes is not on; see , below. - -STEP 2: Kind-checking, as done by kcTyClDecl. This step is skipped for CUSKs. -The key function here is kcConDecl, which looks at an individual constructor -declaration. When we are processing a newtype (but whether or not -XUnliftedNewtypes -is enabled; see , below), we generate a correct ContextKind -for the checking argument types: see getArgExpKind. - -Examples of newtypes affected by STEP 2, assuming -XUnliftedNewtypes is -enabled (we use r0 to denote a unification variable): - -newtype Foo rep = MkFoo (forall (a :: TYPE rep). a) -+ kcConDecl unifies (TYPE r0) with (TYPE rep), where (TYPE r0) - is the kind that inferInitialKind invented for (Foo rep). - -data Color = Red | Blue -type family Interpret (x :: Color) :: RuntimeRep where - Interpret 'Red = 'IntRep - Interpret 'Blue = 'WordRep -data family Foo (x :: Color) :: TYPE (Interpret x) -newtype instance Foo 'Red = FooRedC Int# -+ kcConDecl unifies TYPE (Interpret 'Red) with TYPE 'IntRep - -Note that, in the GADT case, we might have a kind signature with arrows -(newtype XYZ a b :: Type -> Type where ...). We want only the final -component of the kind for checking in kcConDecl, so we call etaExpandAlgTyCon -in kcTyClDecl. - -STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function -here is tcConDecl. Once again, we must use getArgExpKind to ensure that the -representation type's kind matches that of the newtype, for two reasons: - - A. It is possible that a GADT has a CUSK. (Note that this is *not* - possible for H98 types.) Recall that CUSK types don't go through - kcTyClDecl, so we might not have done this kind check. - B. We need to produce the coercion to put on the argument type - if the kinds are different (for both H98 and GADT). - -Example of (B): - -type family F a where - F Int = LiftedRep - -newtype N :: TYPE (F Int) where - MkN :: Int -> N - -We really need to have the argument to MkN be (Int |> TYPE (sym axF)), where -axF :: F Int ~ LiftedRep. That way, the argument kind is the same as the -newtype kind, which is the principal correctness condition for newtypes. - -Wrinkle: Consider (#17021, typecheck/should_fail/T17021) - - type family Id (x :: a) :: a where - Id x = x - - newtype T :: TYPE (Id LiftedRep) where - MkT :: Int -> T - - In the type of MkT, we must end with (Int |> TYPE (sym axId)) -> T, never Int -> (T |> - TYPE axId); otherwise, the result type of the constructor wouldn't match the - datatype. However, type-checking the HsType T might reasonably result in - (T |> hole). We thus must ensure that this cast is dropped, forcing the - type-checker to add one to the Int instead. - - Why is it always safe to drop the cast? This result type is type-checked by - tcHsOpenType, so its kind definitely looks like TYPE r, for some r. It is - important that even after dropping the cast, the type's kind has the form - TYPE r. This is guaranteed by restrictions on the kinds of datatypes. - For example, a declaration like `newtype T :: Id Type` is rejected: a - newtype's final kind always has the form TYPE r, just as we want. - -Note that this is possible in the H98 case only for a data family, because -the H98 syntax doesn't permit a kind signature on the newtype itself. - -There are also some changes for deailng with families: - -1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if - UnliftedNewtypes is on. This allows us to write things like: - data family Foo :: TYPE 'IntRep - -2. In a newtype instance (with -XUnliftedNewtypes), if the user does - not write a kind signature, we want to allow the possibility that - the kind is not Type, so we use newOpenTypeKind instead of liftedTypeKind. - This is done in tcDataFamInstHeader in TcInstDcls. Example: - - data family Bar (a :: RuntimeRep) :: TYPE a - newtype instance Bar 'IntRep = BarIntC Int# - newtype instance Bar 'WordRep :: TYPE 'WordRep where - BarWordC :: Word# -> Bar 'WordRep - - The data instance corresponding to IntRep does not specify a kind signature, - so tc_kind_sig just returns `TYPE r0` (where `r0` is a fresh metavariable). - The data instance corresponding to WordRep does have a kind signature, so - we use that kind signature. - -3. A data family and its newtype instance may be declared with slightly - different kinds. See point 7 in Note [Datatype return kinds]. - -There's also a change in the renamer: - -* In GHC.RenameSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means - for a newtype to have a CUSK. This is necessary since UnliftedNewtypes - means that, for newtypes without kind signatures, we must use the field - inside the data constructor to determine the result kind. - See Note [Unlifted Newtypes and CUSKs] for more detail. - -For completeness, it was also necessary to make coerce work on -unlifted types, resolving #13595. - -: It's tempting to think that the expected kind for a newtype -constructor argument when -XUnliftedNewtypes is *not* enabled should just be Type. -But this leads to difficulty in suggesting to enable UnliftedNewtypes. Here is -an example: - - newtype A = MkA Int# - -If we expect the argument to MkA to have kind Type, then we get a kind-mismatch -error. The problem is that there is no way to connect this mismatch error to --XUnliftedNewtypes, and suggest enabling the extension. So, instead, we allow -the A to type-check, but then find the problem when doing validity checking (and -where we get make a suitable error message). One potential worry is - - {-# LANGUAGE PolyKinds #-} - newtype B a = MkB a - -This turns out OK, because unconstrained RuntimeReps default to LiftedRep, just -as we would like. Another potential problem comes in a case like - - -- no UnliftedNewtypes - - data family D :: k - newtype instance D = MkD Any - -Here, we want inference to tell us that k should be instantiated to Type in -the instance. With the approach described here (checking for Type only in -the validity checker), that will not happen. But I cannot think of a non-contrived -example that will notice this lack of inference, so it seems better to improve -error messages than be able to infer this instantiation. - --} - -tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) -tcTyClDecl roles_info (L loc decl) - | Just thing <- wiredInNameTyThing_maybe (tcdName decl) - = case thing of -- See Note [Declarations for wired-in things] - ATyCon tc -> return (tc, wiredInDerivInfo tc decl) - _ -> pprPanic "tcTyClDecl" (ppr thing) - - | otherwise - = setSrcSpan loc $ tcAddDeclCtxt decl $ - do { traceTc "---- tcTyClDecl ---- {" (ppr decl) - ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl - ; traceTc "---- tcTyClDecl end ---- }" (ppr tc) - ; return (tc, deriv_infos) } - -noDerivInfos :: a -> (a, [DerivInfo]) -noDerivInfos a = (a, []) - -wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo] -wiredInDerivInfo tycon decl - | DataDecl { tcdDataDefn = dataDefn } <- decl - , HsDataDefn { dd_derivs = derivs } <- dataDefn - = [ DerivInfo { di_rep_tc = tycon - , di_scoped_tvs = - if isFunTyCon tycon || isPrimTyCon tycon - then [] -- no tyConTyVars - else mkTyVarNamePairs (tyConTyVars tycon) - , di_clauses = unLoc derivs - , di_ctxt = tcMkDeclCtxt decl } ] -wiredInDerivInfo _ _ = [] - - -- "type family" declarations -tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) -tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) - = fmap noDerivInfos $ - tcFamDecl1 parent fd - - -- "type" synonym declaration -tcTyClDecl1 _parent roles_info - (SynDecl { tcdLName = L _ tc_name - , tcdRhs = rhs }) - = ASSERT( isNothing _parent ) - fmap noDerivInfos $ - tcTySynRhs roles_info tc_name rhs - - -- "data/newtype" declaration -tcTyClDecl1 _parent roles_info - decl@(DataDecl { tcdLName = L _ tc_name - , tcdDataDefn = defn }) - = ASSERT( isNothing _parent ) - tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn - -tcTyClDecl1 _parent roles_info - (ClassDecl { tcdLName = L _ class_name - , tcdCtxt = hs_ctxt - , tcdMeths = meths - , tcdFDs = fundeps - , tcdSigs = sigs - , tcdATs = ats - , tcdATDefs = at_defs }) - = ASSERT( isNothing _parent ) - do { clas <- tcClassDecl1 roles_info class_name hs_ctxt - meths fundeps sigs ats at_defs - ; return (noDerivInfos (classTyCon clas)) } - -tcTyClDecl1 _ _ (XTyClDecl nec) = noExtCon nec - - -{- ********************************************************************* -* * - Class declarations -* * -********************************************************************* -} - -tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn - -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn] - -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn] - -> TcM Class -tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs - = fixM $ \ clas -> - -- We need the knot because 'clas' is passed into tcClassATs - bindTyClTyVars class_name $ \ _ binders res_kind -> - do { checkClassKindSig res_kind - ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders) - ; let tycon_name = class_name -- We use the same name - roles = roles_info tycon_name -- for TyCon and Class - - ; (ctxt, fds, sig_stuff, at_stuff) - <- pushTcLevelM_ $ - solveEqualities $ - checkTvConstraints skol_info (binderVars binders) $ - -- The checkTvConstraints is needed bring into scope the - -- skolems bound by the class decl header (#17841) - do { ctxt <- tcHsContext hs_ctxt - ; fds <- mapM (addLocM tc_fundep) fundeps - ; sig_stuff <- tcClassSigs class_name sigs meths - ; at_stuff <- tcClassATs class_name clas ats at_defs - ; return (ctxt, fds, sig_stuff, at_stuff) } - - -- The solveEqualities 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 <- emptyZonkEnv - ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff - -- ToDo: do we need to zonk at_stuff? - - -- TODO: Allow us to distinguish between abstract class, - -- and concrete class with no methods (maybe by - -- specifying a trailing where or not - - ; mindef <- tcClassMinimalDef class_name sigs sig_stuff - ; is_boot <- tcIsHsBootOrSig - ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff - = Nothing - | otherwise - = Just (ctxt, at_stuff, sig_stuff, mindef) - - ; clas <- buildClass class_name binders roles fds body - ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$ - ppr fds) - ; return clas } - where - skol_info = TyConSkol ClassFlavour class_name - tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; - ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ; - ; return (tvs1', tvs2') } - - -{- Note [Associated type defaults] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The following is an example of associated type defaults: - class C a where - data D a - - type F a b :: * - type F a b = [a] -- Default - -Note that we can get default definitions only for type families, not data -families. --} - -tcClassATs :: Name -- The class name (not knot-tied) - -> Class -- The class parent of this associated type - -> [LFamilyDecl GhcRn] -- Associated types. - -> [LTyFamDefltDecl GhcRn] -- Associated type defaults. - -> TcM [ClassATItem] -tcClassATs class_name cls ats at_defs - = do { -- Complain about associated type defaults for non associated-types - sequence_ [ failWithTc (badATErr class_name n) - | n <- map at_def_tycon at_defs - , not (n `elemNameSet` at_names) ] - ; mapM tc_at ats } - where - at_def_tycon :: LTyFamDefltDecl GhcRn -> Name - at_def_tycon = tyFamInstDeclName . unLoc - - at_fam_name :: LFamilyDecl GhcRn -> Name - at_fam_name = familyDeclName . unLoc - - at_names = mkNameSet (map at_fam_name ats) - - at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn] - -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' - at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv - (at_def_tycon at_def) [at_def]) - emptyNameEnv at_defs - - tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at - ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) - `orElse` [] - ; atd <- tcDefaultAssocDecl fam_tc at_defs - ; return (ATI fam_tc atd) } - -------------------------- -tcDefaultAssocDecl :: - TyCon -- ^ Family TyCon (not knot-tied) - -> [LTyFamDefltDecl GhcRn] -- ^ Defaults - -> TcM (Maybe (KnotTied Type, SrcSpan)) -- ^ Type checked RHS -tcDefaultAssocDecl _ [] - = return Nothing -- No default declaration - -tcDefaultAssocDecl _ (d1:_:_) - = failWithTc (text "More than one default declaration for" - <+> ppr (tyFamInstDeclName (unLoc d1))) - -tcDefaultAssocDecl fam_tc - [L loc (TyFamInstDecl { tfid_eqn = - HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = L _ tc_name - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty }}})] - = -- See Note [Type-checking default assoc decls] - setSrcSpan loc $ - tcAddFamInstCtxt (text "default type instance") tc_name $ - do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name) - ; let fam_tc_name = tyConName fam_tc - vis_arity = length (tyConVisibleTyVars fam_tc) - vis_pats = numVisibleArgs hs_pats - - -- Kind of family check - ; ASSERT( fam_tc_name == tc_name ) - checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - - -- Arity check - ; checkTc (vis_pats == vis_arity) - (wrongNumberOfParmsErr vis_arity) - - -- Typecheck RHS - -- - -- You might think we should pass in some AssocInstInfo, as we're looking - -- at an associated type. But this would be wrong, because an associated - -- type default LHS can mention *different* type variables than the - -- enclosing class. So it's treated more as a freestanding beast. - ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated - imp_vars (mb_expl_bndrs `orElse` []) - hs_pats hs_rhs_ty - - ; let fam_tvs = tyConTyVars fam_tc - ppr_eqn = ppr_default_eqn pats rhs_ty - pats_vis = tyConArgFlags fam_tc pats - ; traceTc "tcDefaultAssocDecl 2" (vcat - [ text "fam_tvs" <+> ppr fam_tvs - , text "qtvs" <+> ppr qtvs - , text "pats" <+> ppr pats - , text "rhs_ty" <+> ppr rhs_ty - ]) - ; pat_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis - ; check_all_distinct_tvs ppr_eqn $ zip pat_tvs pats_vis - ; let subst = zipTvSubst pat_tvs (mkTyVarTys fam_tvs) - ; pure $ Just (substTyUnchecked subst rhs_ty, loc) - -- We also perform other checks for well-formedness and validity - -- later, in checkValidClass - } - where - -- Checks that a pattern on the LHS of a default is a type - -- variable. If so, return the underlying type variable, and if - -- not, throw an error. - -- See Note [Type-checking default assoc decls] - extract_tv :: SDoc -- The pretty-printed default equation - -- (only used for error message purposes) - -> Type -- The particular type pattern from which to extract - -- its underlying type variable - -> ArgFlag -- The visibility of the type pattern - -- (only used for error message purposes) - -> TcM TyVar - extract_tv ppr_eqn pat pat_vis = - case getTyVar_maybe pat of - Just tv -> pure tv - Nothing -> failWithTc $ - pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ - hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:") - 2 (vcat [ppr_eqn, suggestion]) - - - -- Checks that no type variables in an associated default declaration are - -- duplicated. If that is the case, throw an error. - -- See Note [Type-checking default assoc decls] - check_all_distinct_tvs :: - SDoc -- The pretty-printed default equation (only used - -- for error message purposes) - -> [(TyVar, ArgFlag)] -- The type variable arguments in the associated - -- default declaration, along with their respective - -- visibilities (the latter are only used for error - -- message purposes) - -> TcM () - check_all_distinct_tvs ppr_eqn pat_tvs_vis = - let dups = findDupsEq ((==) `on` fst) pat_tvs_vis in - traverse_ - (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $ - pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ - hang (text "Illegal duplicate variable" - <+> quotes (ppr pat_tv) <+> text "in:") - 2 (vcat [ppr_eqn, suggestion])) - dups - - ppr_default_eqn :: [Type] -> Type -> SDoc - ppr_default_eqn pats rhs_ty = - quotes (text "type" <+> ppr (mkTyConApp fam_tc pats) - <+> equals <+> ppr rhs_ty) - - suggestion :: SDoc - suggestion = text "The arguments to" <+> quotes (ppr fam_tc) - <+> text "must all be distinct type variables" - -tcDefaultAssocDecl _ [L _ (TyFamInstDecl (HsIB _ (XFamEqn x)))] = noExtCon x -tcDefaultAssocDecl _ [L _ (TyFamInstDecl (XHsImplicitBndrs x))] = noExtCon x - - -{- Note [Type-checking default assoc decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this default declaration for an associated type - - class C a where - type F (a :: k) b :: Type - type F (x :: j) y = Proxy x -> y - -Note that the class variable 'a' doesn't scope over the default assoc -decl (rather oddly I think), and (less oddly) neither does the second -argument 'b' of the associated type 'F', or the kind variable 'k'. -Instead, the default decl is treated more like a top-level type -instance. - -However we store the default rhs (Proxy x -> y) in F's TyCon, using -F's own type variables, so we need to convert it to (Proxy a -> b). -We do this by creating a substitution [j |-> k, x |-> a, b |-> y] and -applying this substitution to the RHS. - -In order to create this substitution, we must first ensure that all of -the arguments in the default instance consist of distinct type variables. -One might think that this is a simple task that could be implemented earlier -in the compiler, perhaps in the parser or the renamer. However, there are some -tricky corner cases that really do require the full power of typechecking to -weed out, as the examples below should illustrate. - -First, we must check that all arguments are type variables. As a motivating -example, consider this erroneous program (inspired by #11361): - - class C a where - type F (a :: k) b :: Type - type F x b = x - -If you squint, you'll notice that the kind of `x` is actually Type. However, -we cannot substitute from [Type |-> k], so we reject this default. - -Next, we must check that all arguments are distinct. Here is another offending -example, this time taken from #13971: - - class C2 (a :: j) where - type F2 (a :: j) (b :: k) - type F2 (x :: z) y = SameKind x y - data SameKind :: k -> k -> Type - -All of the arguments in the default equation for `F2` are type variables, so -that passes the first check. However, if we were to build this substitution, -then both `j` and `k` map to `z`! In terms of visible kind application, it's as -if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear -that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is -also rejected. - -Since the LHS of an associated type family default is always just variables, -it won't contain any tycons. Accordingly, the patterns used in the substitution -won't actually be knot-tied, even though we're in the knot. This is too -delicate for my taste, but it works. - -Note [Datatype return kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several poorly lit corners around datatype/newtype return kinds. -This Note explains these. Within this note, always understand "instance" -to mean data or newtype instance, and understand "family" to mean data -family. No type families or classes here. Some examples: - -data T a :: where ... -- See Point 4 -newtype T a :: where ... -- See Point 5 - -data family T a :: -- See Point 6 - -data instance T [a] :: where ... -- See Point 4 -newtype instance T [a] :: where ... -- See Point 5 - -1. Where this applies: Only GADT syntax for data/newtype/instance declarations - can have declared return kinds. This Note does not apply to Haskell98 - syntax. - -2. Where these kinds come from: Return kinds are processed through several - different code paths: - - data/newtypes: The return kind is part of the TyCon kind, gotten either - by checkInitialKind (standalone kind signature / CUSK) or - inferInitialKind. It is extracted by bindTyClTyVars in tcTyClDecl1. It is - then passed to tcDataDefn. - - families: The return kind is either written in a standalone signature - or extracted from a family declaration in getInitialKind. - If a family declaration is missing a result kind, it is assumed to be - Type. This assumption is in getInitialKind for CUSKs or - get_fam_decl_initial_kind for non-signature & non-CUSK cases. - - instances: The data family already has a known kind. The return kind - of an instance is then calculated by applying the data family tycon - to the patterns provided, as computed by the typeKind lhs_ty in the - end of tcDataFamInstHeader. In the case of an instance written in GADT - syntax, there are potentially *two* return kinds: the one computed from - applying the data family tycon to the patterns, and the one given by - the user. This second kind is checked by the tc_kind_sig function within - tcDataFamInstHeader. - -3. Eta-expansion: Any forall-bound variables and function arguments in a result kind - become parameters to the type. That is, when we say - - data T a :: Type -> Type where ... - - we really mean for T to have two parameters. The second parameter - is produced by processing the return kind in etaExpandAlgTyCon, - called in tcDataDefn for data/newtypes and in tcDataFamInstDecl - for instances. This is true for data families as well, though their - arity only matters for pretty-printing. - - See also Note [TyConBinders for the result kind signatures of a data type] - in TcHsType. - -4. Datatype return kind restriction: A data/data-instance return kind must end - in a type that, after type-synonym expansion, yields `TYPE LiftedRep`. By - "end in", we mean we strip any foralls and function arguments off before - checking: this remaining part of the type is returned from - etaExpandAlgTyCon. Note that we do *not* do type family reduction here. - Examples: - - data T1 :: Type -- good - data T2 :: Bool -> Type -- good - data T3 :: Bool -> forall k. Type -- strange, but still accepted - data T4 :: forall k. k -> Type -- good - data T5 :: Bool -- bad - data T6 :: Type -> Bool -- bad - - type Arrow = (->) - data T7 :: Arrow Bool Type -- good - - type family ARROW where - ARROW = (->) - data T8 :: ARROW Bool Type -- bad - - type Star = Type - data T9 :: Bool -> Star -- good - - type family F a where - F Int = Bool - F Bool = Type - data T10 :: Bool -> F Bool -- bad - - This check is done in checkDataKindSig. For data declarations, this - call is in tcDataDefn; for data instances, this call is in tcDataFamInstDecl. - - However, because data instances in GADT syntax can have two return kinds (see - point (2) above), we must check both return kinds. The user-written return - kind is checked in tc_kind_sig within tcDataFamInstHeader. Examples: - - data family D (a :: Nat) :: k -- good (see Point 6) - - data instance D 1 :: Type -- good - data instance D 2 :: F Bool -- bad - -5. Newtype return kind restriction: If -XUnliftedNewtypes is on, then - a newtype/newtype-instance return kind must end in TYPE xyz, for some - xyz (after type synonym expansion). The "xyz" may include type families, - but the TYPE part must be visible with expanding type families (only synonyms). - This kind is unified with the kind of the representation type (the type - of the one argument to the one constructor). See also steps (2) and (3) - of Note [Implementation of UnliftedNewtypes]. - - If -XUnliftedNewtypes is not on, then newtypes are treated just like datatypes. - - The checks are done in the same places as for datatypes. - Examples (assume -XUnliftedNewtypes): - - newtype N1 :: Type -- good - newtype N2 :: Bool -> Type -- good - newtype N3 :: forall r. Bool -> TYPE r -- good - - type family F (t :: Type) :: RuntimeRep - newtype N4 :: forall t -> TYPE (F t) -- good - - type family STAR where - STAR = Type - newtype N5 :: Bool -> STAR -- bad - -6. Family return kind restrictions: The return kind of a data family must - be either TYPE xyz (for some xyz) or a kind variable. The idea is that - instances may specialise the kind variable to fit one of the restrictions - above. This is checked by the call to checkDataKindSig in tcFamDecl1. - Examples: - - data family D1 :: Type -- good - data family D2 :: Bool -> Type -- good - data family D3 k :: k -- good - data family D4 :: forall k -> k -- good - data family D5 :: forall k. k -> k -- good - data family D6 :: forall r. TYPE r -- good - data family D7 :: Bool -> STAR -- bad (see STAR from point 5) - -7. Two return kinds for instances: If an instance has two return kinds, - one from the family declaration and one from the instance declaration - (see point (2) above), they are unified. More accurately, we make sure - that the kind of the applied data family is a subkind of the user-written - kind. TcHsType.checkExpectedKind normally does this check for types, but - that's overkill for our needs here. Instead, we just instantiate any - invisible binders in the (instantiated) kind of the data family - (called lhs_kind in tcDataFamInstHeader) with tcInstInvisibleTyBinders - and then unify the resulting kind with the kind written by the user. - This unification naturally produces a coercion, which we can drop, as - the kind annotation on the instance is redundant (except perhaps for - effects of unification). - - Example: - - data Color = Red | Blue - type family Interpret (x :: Color) :: RuntimeRep where - Interpret 'Red = 'IntRep - Interpret 'Blue = 'WordRep - data family Foo (x :: Color) :: TYPE (Interpret x) - newtype instance Foo 'Red :: TYPE IntRep where - FooRedC :: Int# -> Foo 'Red - - Here we get that Foo 'Red :: TYPE (Interpret Red) and we have to - unify the kind with TYPE IntRep. - - Example requiring subkinding: - - data family D :: forall k. k - data instance D :: Type -- forall k. k <: Type - data instance D :: Type -> Type -- forall k. k <: Type -> Type - -- NB: these do not overlap - - This all is Wrinkle (3) in Note [Implementation of UnliftedNewtypes]. - --} - -{- ********************************************************************* -* * - Type family declarations -* * -********************************************************************* -} - -tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon -tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info - , fdLName = tc_lname@(L _ tc_name) - , fdResultSig = L _ sig - , fdInjectivityAnn = inj }) - | DataFamily <- fam_info - = bindTyClTyVars tc_name $ \ _ binders res_kind -> do - { traceTc "data family:" (ppr tc_name) - ; checkFamFlag tc_name - - -- Check that the result kind is OK - -- We allow things like - -- data family T (a :: Type) :: forall k. k -> Type - -- We treat T as having arity 1, but result kind forall k. k -> Type - -- But we want to check that the result kind finishes in - -- Type or a kind-variable - -- For the latter, consider - -- data family D a :: forall k. Type -> k - -- When UnliftedNewtypes is enabled, we loosen this restriction - -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1). - -- See also Note [Datatype return kinds] - ; let (_, final_res_kind) = splitPiTys res_kind - ; checkDataKindSig DataFamilySort final_res_kind - ; tc_rep_name <- newTyConRepName tc_name - ; let inj = Injective $ replicate (length binders) True - tycon = mkFamilyTyCon tc_name binders - res_kind - (resultVariableName sig) - (DataFamilyTyCon tc_rep_name) - parent inj - ; return tycon } - - | OpenTypeFamily <- fam_info - = bindTyClTyVars tc_name $ \ _ binders res_kind -> do - { traceTc "open type family:" (ppr tc_name) - ; checkFamFlag tc_name - ; inj' <- tcInjectivity binders inj - ; checkResultSigFlag tc_name sig -- check after injectivity for better errors - ; let tycon = mkFamilyTyCon tc_name binders res_kind - (resultVariableName sig) OpenSynFamilyTyCon - parent inj' - ; return tycon } - - | ClosedTypeFamily mb_eqns <- fam_info - = -- Closed type families are a little tricky, because they contain the definition - -- of both the type family and the equations for a CoAxiom. - do { traceTc "Closed type family:" (ppr tc_name) - -- the variables in the header scope only over the injectivity - -- declaration but this is not involved here - ; (inj', binders, res_kind) - <- bindTyClTyVars tc_name $ \ _ binders res_kind -> - do { inj' <- tcInjectivity binders inj - ; return (inj', binders, res_kind) } - - ; checkFamFlag tc_name -- make sure we have -XTypeFamilies - ; checkResultSigFlag tc_name sig - - -- If Nothing, this is an abstract family in a hs-boot file; - -- but eqns might be empty in the Just case as well - ; case mb_eqns of - Nothing -> - return $ mkFamilyTyCon tc_name binders res_kind - (resultVariableName sig) - AbstractClosedSynFamilyTyCon parent - inj' - Just eqns -> do { - - -- Process the equations, creating CoAxBranches - ; let tc_fam_tc = mkTcTyCon tc_name binders res_kind - noTcTyConScopedTyVars - False {- this doesn't matter here -} - ClosedTypeFamilyFlavour - - ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns - -- Do not attempt to drop equations dominated by earlier - -- ones here; in the case of mutual recursion with a data - -- type, we get a knot-tying failure. Instead we check - -- for this afterwards, in TcValidity.checkValidCoAxiom - -- Example: tc265 - - -- Create a CoAxiom, with the correct src location. - ; co_ax_name <- newFamInstAxiomName tc_lname [] - - ; let mb_co_ax - | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list - | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) - - fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig) - (ClosedSynFamilyTyCon mb_co_ax) parent inj' - - -- We check for instance validity later, when doing validity - -- checking for the tycon. Exception: checking equations - -- overlap done by dropDominatedAxioms - ; return fam_tc } } - -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker -#endif -tcFamDecl1 _ (XFamilyDecl nec) = noExtCon nec - --- | Maybe return a list of Bools that say whether a type family was declared --- injective in the corresponding type arguments. Length of the list is equal to --- the number of arguments (including implicit kind/coercion arguments). --- True on position --- N means that a function is injective in its Nth argument. False means it is --- not. -tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) - -> TcM Injectivity -tcInjectivity _ Nothing - = return NotInjective - - -- User provided an injectivity annotation, so for each tyvar argument we - -- check whether a type family was declared injective in that argument. We - -- return a list of Bools, where True means that corresponding type variable - -- was mentioned in lInjNames (type family is injective in that argument) and - -- False means that it was not mentioned in lInjNames (type family is not - -- injective in that type variable). We also extend injectivity information to - -- kind variables, so if a user declares: - -- - -- type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a - -- - -- then we mark both `a` and `k1` as injective. - -- NB: the return kind is considered to be *input* argument to a type family. - -- Since injectivity allows to infer input arguments from the result in theory - -- we should always mark the result kind variable (`k3` in this example) as - -- injective. The reason is that result type has always an assigned kind and - -- therefore we can always infer the result kind if we know the result type. - -- But this does not seem to be useful in any way so we don't do it. (Another - -- reason is that the implementation would not be straightforward.) -tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) - = setSrcSpan loc $ - do { let tvs = binderVars tcbs - ; dflags <- getDynFlags - ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) - (text "Illegal injectivity annotation" $$ - text "Use TypeFamilyDependencies to allow this") - ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames - ; inj_tvs <- mapM zonkTcTyVarToTyVar 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 - ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs - , ppr inj_ktvs, ppr inj_bools ]) - ; return $ Injective inj_bools } - -tcTySynRhs :: RolesInfo -> Name - -> LHsType GhcRn -> TcM TyCon -tcTySynRhs roles_info tc_name hs_ty - = bindTyClTyVars tc_name $ \ _ binders res_kind -> - do { env <- getLclEnv - ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) - ; rhs_ty <- pushTcLevelM_ $ - solveEqualities $ - tcCheckLHsType hs_ty (TheKind res_kind) - ; rhs_ty <- zonkTcTypeToType rhs_ty - ; let roles = roles_info tc_name - tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty - ; return tycon } - -tcDataDefn :: SDoc -> RolesInfo -> Name - -> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo]) - -- NB: not used for newtype/data instances (whether associated or not) -tcDataDefn err_ctxt roles_info tc_name - (HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = ctxt - , dd_kindSig = mb_ksig -- Already in tc's kind - -- via inferInitialKinds - , dd_cons = cons - , dd_derivs = derivs }) - = bindTyClTyVars tc_name $ \ tctc tycon_binders res_kind -> - -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need - -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon' - -- - -- The TyCon tyvars must scope over - -- - the stupid theta (dd_ctxt) - -- - for H98 constructors only, the ConDecl - -- But it does no harm to bring them into scope - -- over GADT ConDecls as well; and it's awkward not to - do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons - -- see Note [Datatype return kinds] - ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind - - ; tcg_env <- getGblEnv - ; let hsc_src = tcg_src tcg_env - ; unless (mk_permissive_kind hsc_src cons) $ - checkDataKindSig (DataDeclSort new_or_data) final_res_kind - - ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt - ; stupid_theta <- zonkTcTypesToTypes stupid_tc_theta - ; kind_signatures <- xoptM LangExt.KindSignatures - - -- Check that we don't use kind signatures without Glasgow extensions - ; when (isJust mb_ksig) $ - checkTc (kind_signatures) (badSigTyDecl tc_name) - - ; tycon <- fixM $ \ tycon -> do - { let final_bndrs = tycon_binders `chkAppend` extra_bndrs - res_ty = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs)) - roles = roles_info tc_name - ; data_cons <- tcConDecls - tycon - new_or_data - final_bndrs - final_res_kind - res_ty - cons - ; tc_rhs <- mk_tc_rhs hsc_src tycon data_cons - ; tc_rep_nm <- newTyConRepName tc_name - ; return (mkAlgTyCon tc_name - final_bndrs - final_res_kind - roles - (fmap unLoc cType) - stupid_theta tc_rhs - (VanillaAlgTyCon tc_rep_nm) - gadt_syntax) } - ; let deriv_info = DerivInfo { di_rep_tc = tycon - , di_scoped_tvs = tcTyConScopedTyVars tctc - , di_clauses = unLoc derivs - , di_ctxt = err_ctxt } - ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs) - ; return (tycon, [deriv_info]) } - where - -- Abstract data types in hsig files can have arbitrary kinds, - -- because they may be implemented by type synonyms - -- (which themselves can have arbitrary kinds, not just *). See #13955. - -- - -- Note that this is only a property that data type declarations possess, - -- so one could not have, say, a data family instance in an hsig file that - -- has kind `Bool`. Therefore, this check need only occur in the code that - -- typechecks data type declarations. - mk_permissive_kind HsigFile [] = True - mk_permissive_kind _ _ = False - - -- In hs-boot, a 'data' declaration with no constructors - -- indicates a nominally distinct abstract data type. - mk_tc_rhs HsBootFile _ [] - = return AbstractTyCon - - mk_tc_rhs HsigFile _ [] -- ditto - = return AbstractTyCon - - mk_tc_rhs _ tycon data_cons - = case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs tc_name tycon (head data_cons) -tcDataDefn _ _ _ (XHsDataDefn nec) = noExtCon nec - - -------------------------- -kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () --- Used for the equations of a closed type family only --- Not used for data/type instances -kcTyFamInstEqn tc_fam_tc - (L loc (HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty }})) - = setSrcSpan loc $ - do { traceTc "kcTyFamInstEqn" (vcat - [ text "tc_name =" <+> ppr eqn_tc_name - , text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc) - , text "hsib_vars =" <+> ppr imp_vars - , text "feqn_bndrs =" <+> ppr mb_expl_bndrs - , text "feqn_pats =" <+> ppr hs_pats ]) - -- this check reports an arity error instead of a kind error; easier for user - ; let vis_pats = numVisibleArgs hs_pats - ; checkTc (vis_pats == vis_arity) $ - wrongNumberOfParmsErr vis_arity - ; discardResult $ - bindImplicitTKBndrs_Q_Tv imp_vars $ - bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $ - do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats - ; tcCheckLHsType hs_rhs_ty (TheKind res_kind) } - -- Why "_Tv" here? Consider (#14066 - -- type family Bar x y where - -- Bar (x :: a) (y :: b) = Int - -- Bar (x :: c) (y :: d) = Bool - -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately - } - where - vis_arity = length (tyConVisibleTyVars tc_fam_tc) - -kcTyFamInstEqn _ (L _ (XHsImplicitBndrs nec)) = noExtCon nec -kcTyFamInstEqn _ (L _ (HsIB _ (XFamEqn nec))) = noExtCon nec - - --------------------------- -tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn - -> TcM (KnotTied CoAxBranch) --- Needs to be here, not in TcInstDcls, because closed families --- (typechecked here) have TyFamInstEqns - -tcTyFamInstEqn fam_tc mb_clsinfo - (L loc (HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty }})) - = ASSERT( getName fam_tc == eqn_tc_name ) - setSrcSpan loc $ - do { traceTc "tcTyFamInstEqn" $ - vcat [ ppr fam_tc <+> ppr hs_pats - , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc) - , case mb_clsinfo of - NotAssociated -> empty - InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ] - - -- First, check the arity of visible arguments - -- If we wait until validity checking, we'll get kind errors - -- below when an arity error will be much easier to understand. - ; let vis_arity = length (tyConVisibleTyVars fam_tc) - vis_pats = numVisibleArgs hs_pats - ; checkTc (vis_pats == vis_arity) $ - wrongNumberOfParmsErr vis_arity - ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo - imp_vars (mb_expl_bndrs `orElse` []) - hs_pats hs_rhs_ty - -- Don't print results they may be knot-tied - -- (tcFamInstEqnGuts zonks to Type) - ; return (mkCoAxBranch qtvs [] [] fam_tc pats rhs_ty - (map (const Nominal) qtvs) - loc) } - -tcTyFamInstEqn _ _ _ = panic "tcTyFamInstEqn" - -{- -Kind check type patterns and kind annotate the embedded type variables. - type instance F [a] = rhs - - * Here we check that a type instance matches its kind signature, but we do - not check whether there is a pattern for each type index; the latter - check is only required for type synonym instances. - -Note [Instantiating a family tycon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's possible that kind-checking the result of a family tycon applied to -its patterns will instantiate the tycon further. For example, we might -have - - type family F :: k where - F = Int - F = Maybe - -After checking (F :: forall k. k) (with no visible patterns), we still need -to instantiate the k. With data family instances, this problem can be even -more intricate, due to Note [Arity of data families] in GHC.Core.FamInstEnv. See -indexed-types/should_compile/T12369 for an example. - -So, the kind-checker must return the new skolems and args (that is, Type -or (Type -> Type) for the equations above) and the instantiated kind. - -Note [Generalising in tcTyFamInstEqnGuts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have something like - type instance forall (a::k) b. F t1 t2 = rhs - -Then imp_vars = [k], exp_bndrs = [a::k, b] - -We want to quantify over - * k, a, and b (all user-specified) - * and any inferred free kind vars from - - the kinds of k, a, b - - the types t1, t2 - -However, unlike a type signature like - f :: forall (a::k). blah - -we do /not/ care about the Inferred/Specified designation -or order for the final quantified tyvars. Type-family -instances are not invoked directly in Haskell source code, -so visible type application etc plays no role. - -So, the simple thing is - - gather candidates from [k, a, b] and pats - - quantify over them - -Hence the slightly mysterious call: - candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs) - -Simple, neat, but a little non-obvious! - -See also Note [Re-quantify type variables in rules] in TcRules, which explains -a very similar design when generalising over the type of a rewrite rule. --} - --------------------------- -tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo - -> [Name] -> [LHsTyVarBndr GhcRn] -- Implicit and explicicit binder - -> HsTyPats GhcRn -- Patterns - -> LHsType GhcRn -- RHS - -> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs) --- Used only for type families, not data families -tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty - = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc) - - -- By now, for type families (but not data families) we should - -- have checked that the number of patterns matches tyConArity - - -- This code is closely related to the code - -- in TcHsType.kcCheckDeclHeader_cusk - ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty))) - <- pushTcLevelM_ $ - solveEqualities $ - bindImplicitTKBndrs_Q_Skol imp_vars $ - bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ - do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats - -- Ensure that the instance is consistent with its - -- parent class (#16008) - ; addConsistencyConstraints mb_clsinfo lhs_ty - ; rhs_ty <- tcCheckLHsType hs_rhs_ty (TheKind rhs_kind) - ; return (lhs_ty, rhs_ty) } - - -- See Note [Generalising in tcTyFamInstEqnGuts] - -- This code (and the stuff immediately above) is very similar - -- to that in tcDataFamInstHeader. Maybe we should abstract the - -- common code; but for the moment I concluded that it's - -- clearer to duplicate it. Still, if you fix a bug here, - -- check there too! - ; let scoped_tvs = imp_tvs ++ exp_tvs - ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) - ; qtvs <- quantifyTyVars dvs - - ; traceTc "tcTyFamInstEqnGuts 2" $ - vcat [ ppr fam_tc - , text "scoped_tvs" <+> pprTyVars scoped_tvs - , text "lhs_ty" <+> ppr lhs_ty - , text "dvs" <+> ppr dvs - , text "qtvs" <+> pprTyVars qtvs ] - - ; (ze, qtvs) <- zonkTyBndrs qtvs - ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty - ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty - - ; let pats = unravelFamInstPats lhs_ty - -- Note that we do this after solveEqualities - -- so that any strange coercions inside lhs_ty - -- have been solved before we attempt to unravel it - ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs) - ; return (qtvs, pats, rhs_ty) } - ------------------ -tcFamTyPats :: TyCon - -> HsTyPats GhcRn -- Patterns - -> TcM (TcType, TcKind) -- (lhs_type, lhs_kind) --- Used for both type and data families -tcFamTyPats fam_tc hs_pats - = do { traceTc "tcFamTyPats {" $ - vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ] - - ; let fun_ty = mkTyConApp fam_tc [] - - ; (fam_app, res_kind) <- unsetWOptM Opt_WarnPartialTypeSignatures $ - setXOptM LangExt.PartialTypeSignatures $ - -- See Note [Wildcards in family instances] in - -- GHC.Rename.Source - tcInferApps typeLevelMode lhs_fun fun_ty hs_pats - - ; traceTc "End tcFamTyPats }" $ - vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ] - - ; return (fam_app, res_kind) } - where - fam_name = tyConName fam_tc - fam_arity = tyConArity fam_tc - lhs_fun = noLoc (HsTyVar noExtField NotPromoted (noLoc fam_name)) - -unravelFamInstPats :: TcType -> [TcType] --- Decompose fam_app to get the argument patterns --- --- We expect fam_app to look like (F t1 .. tn) --- tcInferApps is capable of returning ((F ty1 |> co) ty2), --- but that can't happen here because we already checked the --- arity of F matches the number of pattern -unravelFamInstPats fam_app - = case splitTyConApp_maybe fam_app of - Just (_, pats) -> pats - Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance" - -- The Nothing case cannot happen for type families, because - -- we don't call unravelFamInstPats until we've solved the - -- equalities. For data families, it shouldn't happen either, - -- we need to fail hard and early if it does. See trac issue #15905 - -- for an example of this happening. - -addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM () --- In the corresponding positions of the class and type-family, --- ensure the the family argument is the same as the class argument --- E.g class C a b c d where --- F c x y a :: Type --- Here the first arg of F should be the same as the third of C --- and the fourth arg of F should be the same as the first of C --- --- We emit /Derived/ constraints (a bit like fundeps) to encourage --- unification to happen, but without actually reporting errors. --- If, despite the efforts, corresponding positions do not match, --- checkConsistentFamInst will complain -addConsistencyConstraints mb_clsinfo fam_app - | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo - , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app - = do { let eqs = [ (cls_ty, pat) - | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats - , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ] - ; traceTc "addConsistencyConstraints" (ppr eqs) - ; emitDerivedEqs AssocFamPatOrigin eqs } - -- Improve inference - -- Any mis-match is reports by checkConsistentFamInst - | otherwise - = return () - -{- Note [Constraints in patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: This isn't the whole story. See comment in tcFamTyPats. - -At first glance, it seems there is a complicated story to tell in tcFamTyPats -around constraint solving. After all, type family patterns can now do -GADT pattern-matching, which is jolly complicated. But, there's a key fact -which makes this all simple: everything is at top level! There cannot -be untouchable type variables. There can't be weird interaction between -case branches. There can't be global skolems. - -This means that the semantics of type-level GADT matching is a little -different than term level. If we have - - data G a where - MkGBool :: G Bool - -And then - - type family F (a :: G k) :: k - type instance F MkGBool = True - -we get - - axF : F Bool (MkGBool ) ~ True - -Simple! No casting on the RHS, because we can affect the kind parameter -to F. - -If we ever introduce local type families, this all gets a lot more -complicated, and will end up looking awfully like term-level GADT -pattern-matching. - - -** The new story ** - -Here is really what we want: - -The matcher really can't deal with covars in arbitrary spots in coercions. -But it can deal with covars that are arguments to GADT data constructors. -So we somehow want to allow covars only in precisely those spots, then use -them as givens when checking the RHS. TODO (RAE): Implement plan. - -Note [Quantified kind variables of a family pattern] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider type family KindFam (p :: k1) (q :: k1) - data T :: Maybe k1 -> k2 -> * - type instance KindFam (a :: Maybe k) b = T a b -> Int -The HsBSig for the family patterns will be ([k], [a]) - -Then in the family instance we want to - * Bring into scope [ "k" -> k:*, "a" -> a:k ] - * Kind-check the RHS - * Quantify the type instance over k and k', as well as a,b, thus - type instance [k, k', a:Maybe k, b:k'] - KindFam (Maybe k) k' a b = T k k' a b -> Int - -Notice that in the third step we quantify over all the visibly-mentioned -type variables (a,b), but also over the implicitly mentioned kind variables -(k, k'). In this case one is bound explicitly but often there will be -none. The role of the kind signature (a :: Maybe k) is to add a constraint -that 'a' must have that kind, and to bring 'k' into scope. - - - -************************************************************************ -* * - Data types -* * -************************************************************************ --} - -dataDeclChecks :: Name -> NewOrData - -> LHsContext GhcRn -> [LConDecl GhcRn] - -> TcM Bool -dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons - = do { -- Check that we don't use GADT syntax in H98 world - gadtSyntax_ok <- xoptM LangExt.GADTSyntax - ; let gadt_syntax = consUseGadtSyntax cons - ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name) - - -- Check that the stupid theta is empty for a GADT-style declaration - ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name) - - -- Check that a newtype has exactly one constructor - -- Do this before checking for empty data decls, so that - -- we don't suggest -XEmptyDataDecls for newtypes - ; checkTc (new_or_data == DataType || isSingleton cons) - (newtypeConError tc_name (length cons)) - - -- 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) - ; return gadt_syntax } - - ------------------------------------ -consUseGadtSyntax :: [LConDecl a] -> Bool -consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True -consUseGadtSyntax _ = False - -- All constructors have same shape - ------------------------------------ -tcConDecls :: KnotTied TyCon -> NewOrData - -> [TyConBinder] -> TcKind -- binders and result kind of tycon - -> KnotTied Type -> [LConDecl GhcRn] -> TcM [DataCon] -tcConDecls rep_tycon new_or_data tmpl_bndrs res_kind res_tmpl - = concatMapM $ addLocM $ - tcConDecl rep_tycon (mkTyConTagMap rep_tycon) - tmpl_bndrs res_kind res_tmpl new_or_data - -- It's important that we pay for tag allocation here, once per TyCon, - -- See Note [Constructor tag allocation], fixes #14657 - -tcConDecl :: KnotTied TyCon -- Representation tycon. Knot-tied! - -> NameEnv ConTag - -> [TyConBinder] -> TcKind -- tycon binders and result kind - -> KnotTied Type - -- Return type template (T tys), where T is the family TyCon - -> NewOrData - -> ConDecl GhcRn - -> TcM [DataCon] - -tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data - (ConDeclH98 { con_name = name - , con_ex_tvs = explicit_tkv_nms - , con_mb_cxt = hs_ctxt - , con_args = hs_args }) - = addErrCtxt (dataConCtxtName [name]) $ - do { -- NB: the tyvars from the declaration header are in scope - - -- Get hold of the existential type variables - -- e.g. data T a = forall k (b::k) f. MkT a (f b) - -- Here tmpl_bndrs = {a} - -- hs_qvars = HsQTvs { hsq_implicit = {k} - -- , hsq_explicit = {f,b} } - - ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ]) - - ; (exp_tvs, (ctxt, arg_tys, field_lbls, stricts)) - <- pushTcLevelM_ $ - solveEqualities $ - bindExplicitTKBndrs_Skol explicit_tkv_nms $ - do { ctxt <- tcHsMbContext hs_ctxt - ; let exp_kind = getArgExpKind new_or_data res_kind - ; btys <- tcConArgs exp_kind hs_args - ; field_lbls <- lookupConstructorFields (unLoc name) - ; let (arg_tys, stricts) = unzip btys - ; return (ctxt, arg_tys, field_lbls, stricts) - } - - -- exp_tvs have explicit, user-written binding sites - -- the kvs below are those kind variables entirely unmentioned by the user - -- and discovered only by generalization - - ; kvs <- kindGeneralizeAll (mkSpecForAllTys (binderVars tmpl_bndrs) $ - mkSpecForAllTys exp_tvs $ - mkPhiTy ctxt $ - mkVisFunTys arg_tys $ - unitTy) - -- That type is a lie, of course. (It shouldn't end in ()!) - -- And we could construct a proper result type from the info - -- at hand. But the result would mention only the tmpl_tvs, - -- and so it just creates more work to do it right. Really, - -- we're only doing this to find the right kind variables to - -- quantify over, and this type is fine for that purpose. - - -- Zonk to Types - ; (ze, qkvs) <- zonkTyBndrs kvs - ; (ze, user_qtvs) <- zonkTyBndrsX ze exp_tvs - ; arg_tys <- zonkTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt - - ; fam_envs <- tcGetFamInstEnvs - - -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here - ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) - ; let - univ_tvbs = tyConTyVarBinders tmpl_bndrs - univ_tvs = binderVars univ_tvbs - ex_tvbs = mkTyVarBinders Inferred qkvs ++ - mkTyVarBinders Specified user_qtvs - ex_tvs = qkvs ++ user_qtvs - -- For H98 datatypes, the user-written tyvar binders are precisely - -- the universals followed by the existentials. - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - user_tvbs = univ_tvbs ++ ex_tvbs - buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfixH98 name hs_args - ; rep_nm <- newTyConRepName name - - ; buildDataCon fam_envs name is_infix rep_nm - stricts Nothing field_lbls - univ_tvs ex_tvs user_tvbs - [{- no eq_preds -}] ctxt arg_tys - res_tmpl rep_tycon tag_map - -- NB: we put data_tc, the type constructor gotten from the - -- constructor type signature into the data constructor; - -- that way checkValidDataCon can complain if it's wrong. - } - ; traceTc "tcConDecl 2" (ppr name) - ; mapM buildOneDataCon [name] - } - -tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data - -- NB: don't use res_kind here, as it's ill-scoped. Instead, we get - -- the res_kind by typechecking the result type. - (ConDeclGADT { con_names = names - , con_qvars = qtvs - , con_mb_cxt = cxt, con_args = hs_args - , con_res_ty = hs_res_ty }) - | HsQTvs { hsq_ext = implicit_tkv_nms - , hsq_explicit = explicit_tkv_nms } <- qtvs - = addErrCtxt (dataConCtxtName names) $ - do { traceTc "tcConDecl 1 gadt" (ppr names) - ; let (L _ name : _) = names - - ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) - <- pushTcLevelM_ $ -- We are going to generalise - solveEqualities $ -- We won't get another crack, and we don't - -- want an error cascade - bindImplicitTKBndrs_Skol implicit_tkv_nms $ - bindExplicitTKBndrs_Skol explicit_tkv_nms $ - do { ctxt <- tcHsMbContext cxt - ; casted_res_ty <- tcHsOpenType hs_res_ty - ; res_ty <- if not debugIsOn then return $ discardCast casted_res_ty - else case splitCastTy_maybe casted_res_ty of - Just (ty, _) -> do unlifted_nts <- xoptM LangExt.UnliftedNewtypes - MASSERT( unlifted_nts ) - MASSERT( new_or_data == NewType ) - return ty - _ -> return casted_res_ty - -- See Note [Datatype return kinds] - ; let exp_kind = getArgExpKind new_or_data (typeKind res_ty) - ; btys <- tcConArgs exp_kind hs_args - ; let (arg_tys, stricts) = unzip btys - ; field_lbls <- lookupConstructorFields name - ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) - } - ; imp_tvs <- zonkAndScopedSort imp_tvs - ; let user_tvs = imp_tvs ++ exp_tvs - - ; tkvs <- kindGeneralizeAll (mkSpecForAllTys user_tvs $ - mkPhiTy ctxt $ - mkVisFunTys arg_tys $ - res_ty) - - -- Zonk to Types - ; (ze, tkvs) <- zonkTyBndrs tkvs - ; (ze, user_tvs) <- zonkTyBndrsX ze user_tvs - ; arg_tys <- zonkTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; res_ty <- zonkTcTypeToTypeX ze res_ty - - ; let (univ_tvs, ex_tvs, tkvs', user_tvs', eq_preds, arg_subst) - = rejigConRes tmpl_bndrs res_tmpl tkvs user_tvs res_ty - -- NB: this is a /lazy/ binding, so we pass six thunks to - -- buildDataCon without yet forcing the guards in rejigConRes - -- See Note [Checking GADT return types] - - -- Compute the user-written tyvar binders. These have the same - -- tyvars as univ_tvs/ex_tvs, but perhaps in a different order. - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - tkv_bndrs = mkTyVarBinders Inferred tkvs' - user_tv_bndrs = mkTyVarBinders Specified user_tvs' - all_user_bndrs = tkv_bndrs ++ user_tv_bndrs - - ctxt' = substTys arg_subst ctxt - arg_tys' = substTys arg_subst arg_tys - res_ty' = substTy arg_subst res_ty - - - ; fam_envs <- tcGetFamInstEnvs - - -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here - ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) - ; let - buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfixGADT name hs_args - ; rep_nm <- newTyConRepName name - - ; buildDataCon fam_envs name is_infix - rep_nm - stricts Nothing field_lbls - univ_tvs ex_tvs all_user_bndrs eq_preds - ctxt' arg_tys' res_ty' rep_tycon tag_map - -- NB: we put data_tc, the type constructor gotten from the - -- constructor type signature into the data constructor; - -- that way checkValidDataCon can complain if it's wrong. - } - ; traceTc "tcConDecl 2" (ppr names) - ; mapM buildOneDataCon names - } -tcConDecl _ _ _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars nec) _ _ _ _) - = noExtCon nec -tcConDecl _ _ _ _ _ _ (XConDecl nec) = noExtCon nec - --- | Produce an "expected kind" for the arguments of a data/newtype. --- If the declaration is indeed for a newtype, --- then this expected kind will be the kind provided. Otherwise, --- it is OpenKind for datatypes and liftedTypeKind. --- Why do we not check for -XUnliftedNewtypes? See point --- in Note [Implementation of UnliftedNewtypes] -getArgExpKind :: NewOrData -> Kind -> ContextKind -getArgExpKind NewType res_ki = TheKind res_ki -getArgExpKind DataType _ = OpenKind - -tcConIsInfixH98 :: Name - -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) - -> TcM Bool -tcConIsInfixH98 _ details - = case details of - InfixCon {} -> return True - _ -> return False - -tcConIsInfixGADT :: Name - -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) - -> TcM Bool -tcConIsInfixGADT con details - = case details of - InfixCon {} -> return True - RecCon {} -> return False - PrefixCon arg_tys -- See Note [Infix GADT constructors] - | isSymOcc (getOccName con) - , [_ty1,_ty2] <- arg_tys - -> do { fix_env <- getFixityEnv - ; return (con `elemNameEnv` fix_env) } - | otherwise -> return False - -tcConArgs :: ContextKind -- expected kind of arguments - -- always OpenKind for datatypes, but unlifted newtypes - -- might have a specific kind - -> HsConDeclDetails GhcRn - -> TcM [(TcType, HsSrcBang)] -tcConArgs exp_kind (PrefixCon btys) - = mapM (tcConArg exp_kind) btys -tcConArgs exp_kind (InfixCon bty1 bty2) - = do { bty1' <- tcConArg exp_kind bty1 - ; bty2' <- tcConArg exp_kind bty2 - ; return [bty1', bty2'] } -tcConArgs exp_kind (RecCon fields) - = mapM (tcConArg exp_kind) btys - where - -- We need a one-to-one mapping from field_names to btys - combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) - (unLoc fields) - explode (ns,ty) = zip ns (repeat ty) - exploded = concatMap explode combined - (_,btys) = unzip exploded - - -tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes, - -- but might be an unlifted type with UnliftedNewtypes - -> LHsType GhcRn -> TcM (TcType, HsSrcBang) -tcConArg exp_kind bty - = do { traceTc "tcConArg 1" (ppr bty) - ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind - ; traceTc "tcConArg 2" (ppr bty) - ; return (arg_ty, getBangStrictness bty) } - -{- -Note [Infix GADT constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not currently have syntax to declare an infix constructor in GADT syntax, -but it makes a (small) difference to the Show instance. So as a slightly -ad-hoc solution, we regard a GADT data constructor as infix if - a) it is an operator symbol - b) it has two arguments - c) there is a fixity declaration for it -For example: - infix 6 (:--:) - data T a where - (:--:) :: t1 -> t2 -> T Int - - -Note [Checking GADT return types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is a delicacy around checking the return types of a datacon. The -central problem is dealing with a declaration like - - data T a where - MkT :: T a -> Q a - -Note that the return type of MkT is totally bogus. When creating the T -tycon, we also need to create the MkT datacon, which must have a "rejigged" -return type. That is, the MkT datacon's type must be transformed to have -a uniform return type with explicit coercions for GADT-like type parameters. -This rejigging is what rejigConRes does. The problem is, though, that checking -that the return type is appropriate is much easier when done over *Type*, -not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully -defined yet. - -So, we want to make rejigConRes lazy and then check the validity of -the return type in checkValidDataCon. To do this we /always/ return a -6-tuple from rejigConRes (so that we can compute the return type from it, which -checkValidDataCon needs), but the first three fields may be bogus if -the return type isn't valid (the last equation for rejigConRes). - -This is better than an earlier solution which reduced the number of -errors reported in one pass. See #7175, and #10836. --} - --- Example --- data instance T (b,c) where --- TI :: forall e. e -> T (e,e) --- --- The representation tycon looks like this: --- data :R7T b c where --- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 --- In this case orig_res_ty = T (e,e) - -rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type -- Template for result type; e.g. - -- data instance T [a] b c ... - -- gives template ([a,b,c], T [a] b c) - -> [TyVar] -- The constructor's inferred type variables - -> [TyVar] -- The constructor's user-written, specified - -- type variables - -> KnotTied Type -- res_ty - -> ([TyVar], -- Universal - [TyVar], -- Existential (distinct OccNames from univs) - [TyVar], -- The constructor's rejigged, user-written, - -- inferred type variables - [TyVar], -- The constructor's rejigged, user-written, - -- specified type variables - [EqSpec], -- Equality predicates - TCvSubst) -- Substitution to apply to argument types - -- We don't check that the TyCon given in the ResTy is - -- the same as the parent tycon, because checkValidDataCon will do it --- NB: All arguments may potentially be knot-tied -rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty - -- E.g. data T [a] b c where - -- MkT :: forall x y z. T [(x,y)] z z - -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs - -- (NB: unlike the H98 case, the dc_tvs are not all existential) - -- Then we generate - -- Univ tyvars Eq-spec - -- a a~(x,y) - -- b b~z - -- z - -- Existentials are the leftover type vars: [x,y] - -- The user-written type variables are what is listed in the forall: - -- [x, y, z] (all specified). We must rejig these as well. - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - -- So we return ( [a,b,z], [x,y] - -- , [], [x,y,z] - -- , [a~(x,y),b~z], ) - | Just subst <- tcMatchTy res_tmpl res_ty - = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst - raw_ex_tvs = dc_tvs `minusList` univ_tvs - (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs - - -- After rejigging the existential tyvars, the resulting substitution - -- gives us exactly what we need to rejig the user-written tyvars, - -- since the dcUserTyVarBinders invariant guarantees that the - -- substitution has *all* the tyvars in its domain. - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - subst_user_tvs = map (getTyVar "rejigConRes" . substTyVar arg_subst) - substed_inferred_tvs = subst_user_tvs dc_inferred_tvs - substed_specified_tvs = subst_user_tvs dc_specified_tvs - - substed_eqs = map (substEqSpec arg_subst) raw_eqs - in - (univ_tvs, substed_ex_tvs, substed_inferred_tvs, substed_specified_tvs, - substed_eqs, arg_subst) - - | otherwise - -- If the return type of the data constructor doesn't match the parent - -- type constructor, or the arity is wrong, the tcMatchTy will fail - -- e.g data T a b where - -- T1 :: Maybe a -- Wrong tycon - -- T2 :: T [a] -- Wrong arity - -- We are detect that later, in checkValidDataCon, but meanwhile - -- we must do *something*, not just crash. So we do something simple - -- albeit bogus, relying on checkValidDataCon to check the - -- bad-result-type error before seeing that the other fields look odd - -- See Note [Checking GADT return types] - = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_inferred_tvs, dc_specified_tvs, - [], emptyTCvSubst) - where - dc_tvs = dc_inferred_tvs ++ dc_specified_tvs - tmpl_tvs = binderVars tmpl_bndrs - -{- Note [mkGADTVars] -~~~~~~~~~~~~~~~~~~~~ -Running example: - -data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where - MkT :: forall (x1 : *) (y :: x1) (z :: *). - T x1 * (Proxy (y :: x1), z) z - -We need the rejigged type to be - - MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2). - forall (y :: x1) (z :: *). - (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z) - => T x1 k2 a b - -You might naively expect that z should become a universal tyvar, -not an existential. (After all, x1 becomes a universal tyvar.) -But z has kind * while b has kind k2, so the return type - T x1 k2 a z -is ill-kinded. Another way to say it is this: the universal -tyvars must have exactly the same kinds as the tyConTyVars. - -So we need an existential tyvar and a heterogeneous equality -constraint. (The b ~ z is a bit redundant with the k2 ~ * that -comes before in that b ~ z implies k2 ~ *. I'm sure we could do -some analysis that could eliminate k2 ~ *. But we don't do this -yet.) - -The data con signature has already been fully kind-checked. -The return type - - T x1 * (Proxy (y :: x1), z) z -becomes - qtkvs = [x1 :: *, y :: x1, z :: *] - res_tmpl = T x1 * (Proxy x1 y, z) z - -We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We -know this match will succeed because of the validity check (actually done -later, but laziness saves us -- see Note [Checking GADT return types]). -Thus, we get - - subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z } - -Now, we need to figure out what the GADT equalities should be. In this case, -we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a -renaming. The others should be GADT equalities. We also need to make -sure that the universally-quantified variables of the datacon match up -with the tyvars of the tycon, as required for Core context well-formedness. -(This last bit is why we have to rejig at all!) - -`choose` walks down the tycon tyvars, figuring out what to do with each one. -It carries two substitutions: - - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables - mentioned in the datacon signature. - - r_sub's domain is *result* tyvars, names written by the programmer in - the datacon signature. The final rejigged type will use these names, but - the subst is still needed because sometimes the printed name of these variables - is different. (See choose_tv_name, below.) - -Before explaining the details of `choose`, let's just look at its operation -on our example: - - choose [] [] {} {} [k1, k2, a, b] - --> -- first branch of `case` statement - choose - univs: [x1 :: *] - eq_spec: [] - t_sub: {k1 |-> x1} - r_sub: {x1 |-> x1} - t_tvs: [k2, a, b] - --> -- second branch of `case` statement - choose - univs: [k2 :: *, x1 :: *] - eq_spec: [k2 ~ *] - t_sub: {k1 |-> x1, k2 |-> k2} - r_sub: {x1 |-> x1} - t_tvs: [a, b] - --> -- second branch of `case` statement - choose - univs: [a :: k2, k2 :: *, x1 :: *] - eq_spec: [ a ~ (Proxy x1 y, z) - , k2 ~ * ] - t_sub: {k1 |-> x1, k2 |-> k2, a |-> a} - r_sub: {x1 |-> x1} - t_tvs: [b] - --> -- second branch of `case` statement - choose - univs: [b :: k2, a :: k2, k2 :: *, x1 :: *] - eq_spec: [ b ~ z - , a ~ (Proxy x1 y, z) - , k2 ~ * ] - t_sub: {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z} - r_sub: {x1 |-> x1} - t_tvs: [] - --> -- end of recursion - ( [x1 :: *, k2 :: *, a :: k2, b :: k2] - , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z] - , {x1 |-> x1} ) - -`choose` looks up each tycon tyvar in the matching (it *must* be matched!). - -* If it finds a bare result tyvar (the first branch of the `case` - statement), it checks to make sure that the result tyvar isn't yet - in the list of univ_tvs. If it is in that list, then we have a - repeated variable in the return type, and we in fact need a GADT - equality. - -* It then checks to make sure that the kind of the result tyvar - matches the kind of the template tyvar. This check is what forces - `z` to be existential, as it should be, explained above. - -* Assuming no repeated variables or kind-changing, we wish to use the - variable name given in the datacon signature (that is, `x1` not - `k1`), not the tycon signature (which may have been made up by - GHC). So, we add a mapping from the tycon tyvar to the result tyvar - to t_sub. - -* If we discover that a mapping in `subst` gives us a non-tyvar (the - second branch of the `case` statement), then we have a GADT equality - to create. We create a fresh equality, but we don't extend any - substitutions. The template variable substitution is meant for use - in universal tyvar kinds, and these shouldn't be affected by any - GADT equalities. - -This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways -of simplifying it: - -1) The first branch of the `case` statement is really an optimization, used -in order to get fewer GADT equalities. It might be possible to make a GADT -equality for *every* univ. tyvar, even if the equality is trivial, and then -either deal with the bigger type or somehow reduce it later. - -2) This algorithm strives to use the names for type variables as specified -by the user in the datacon signature. If we always used the tycon tyvar -names, for example, this would be simplified. This change would almost -certainly degrade error messages a bit, though. --} - --- ^ From information about a source datacon definition, extract out --- what the universal variables and the GADT equalities should be. --- See Note [mkGADTVars]. -mkGADTVars :: [TyVar] -- ^ The tycon vars - -> [TyVar] -- ^ The datacon vars - -> TCvSubst -- ^ The matching between the template result type - -- and the actual result type - -> ( [TyVar] - , [EqSpec] - , TCvSubst ) -- ^ The univ. variables, the GADT equalities, - -- and a subst to apply to the GADT equalities - -- and existentials. -mkGADTVars tmpl_tvs dc_tvs subst - = choose [] [] empty_subst empty_subst tmpl_tvs - where - in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs) - `unionInScope` getTCvInScope subst - empty_subst = mkEmptyTCvSubst in_scope - - choose :: [TyVar] -- accumulator of univ tvs, reversed - -> [EqSpec] -- accumulator of GADT equalities, reversed - -> TCvSubst -- template substitution - -> TCvSubst -- res. substitution - -> [TyVar] -- template tvs (the univ tvs passed in) - -> ( [TyVar] -- the univ_tvs - , [EqSpec] -- GADT equalities - , TCvSubst ) -- a substitution to fix kinds in ex_tvs - - choose univs eqs _t_sub r_sub [] - = (reverse univs, reverse eqs, r_sub) - choose univs eqs t_sub r_sub (t_tv:t_tvs) - | Just r_ty <- lookupTyVar subst t_tv - = case getTyVar_maybe r_ty of - Just r_tv - | not (r_tv `elem` univs) - , tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv)) - -> -- simple, well-kinded variable substitution. - choose (r_tv:univs) eqs - (extendTvSubst t_sub t_tv r_ty') - (extendTvSubst r_sub r_tv r_ty') - t_tvs - where - r_tv1 = setTyVarName r_tv (choose_tv_name r_tv t_tv) - r_ty' = mkTyVarTy r_tv1 - - -- Not a simple substitution: make an equality predicate - _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs) - (extendTvSubst t_sub t_tv (mkTyVarTy t_tv')) - -- We've updated the kind of t_tv, - -- so add it to t_sub (#14162) - r_sub t_tvs - where - t_tv' = updateTyVarKind (substTy t_sub) t_tv - - | otherwise - = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst) - - -- choose an appropriate name for a univ tyvar. - -- This *must* preserve the Unique of the result tv, so that we - -- can detect repeated variables. It prefers user-specified names - -- over system names. A result variable with a system name can - -- happen with GHC-generated implicit kind variables. - choose_tv_name :: TyVar -> TyVar -> Name - choose_tv_name r_tv t_tv - | isSystemName r_tv_name - = setNameUnique t_tv_name (getUnique r_tv_name) - - | otherwise - = r_tv_name - - where - r_tv_name = getName r_tv - t_tv_name = getName t_tv - -{- -Note [Substitution in template variables kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -data G (a :: Maybe k) where - MkG :: G Nothing - -With explicit kind variables - -data G k (a :: Maybe k) where - MkG :: G k1 (Nothing k1) - -Note how k1 is distinct from k. So, when we match the template -`G k a` against `G k1 (Nothing k1)`, we get a subst -[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two -mappings, we surely don't want to add (k, k1) to the list of -GADT equalities -- that would be overly complex and would create -more untouchable variables than we need. So, when figuring out -which tyvars are GADT-like and which aren't (the fundamental -job of `choose`), we want to treat `k` as *not* GADT-like. -Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1) -instead of (a :: Maybe k). This is the reason for dealing -with a substitution in here. - -However, we do not *always* want to substitute. Consider - -data H (a :: k) where - MkH :: H Int - -With explicit kind variables: - -data H k (a :: k) where - MkH :: H * Int - -Here, we have a kind-indexed GADT. The subst in question is -[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s -kind, because that would give a constructor with the type - -MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a - -The problem here is that a's kind is wrong -- it needs to be k, not *! -So, if the matching for a variable is anything but another bare variable, -we drop the mapping from the substitution before proceeding. This -was not an issue before kind-indexed GADTs because this case could -never happen. - -************************************************************************ -* * - Validity checking -* * -************************************************************************ - -Validity checking is done once the mutually-recursive knot has been -tied, so we can look at things freely. --} - -checkValidTyCl :: TyCon -> TcM [TyCon] --- The returned list is either a singleton (if valid) --- or a list of "fake tycons" (if not); the fake tycons --- include any implicits, like promoted data constructors --- See Note [Recover from validity error] -checkValidTyCl tc - = setSrcSpan (getSrcSpan tc) $ - addTyConCtxt tc $ - recoverM recovery_code $ - do { traceTc "Starting validity for tycon" (ppr tc) - ; checkValidTyCon tc - ; traceTc "Done validity for tycon" (ppr tc) - ; return [tc] } - where - recovery_code -- See Note [Recover from validity error] - = do { traceTc "Aborted validity for tycon" (ppr tc) - ; return (concatMap mk_fake_tc $ - ATyCon tc : implicitTyConThings tc) } - - mk_fake_tc (ATyCon tc) - | isClassTyCon tc = [tc] -- Ugh! Note [Recover from validity error] - | otherwise = [makeRecoveryTyCon tc] - mk_fake_tc (AConLike (RealDataCon dc)) - = [makeRecoveryTyCon (promoteDataCon dc)] - mk_fake_tc _ = [] - -{- Note [Recover from validity error] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We recover from a validity error in a type or class, which allows us -to report multiple validity errors. In the failure case we return a -TyCon of the right kind, but with no interesting behaviour -(makeRecoveryTyCon). Why? Suppose we have - type T a = Fun -where Fun is a type family of arity 1. The RHS is invalid, but we -want to go on checking validity of subsequent type declarations. -So we replace T with an abstract TyCon which will do no harm. -See indexed-types/should_fail/BadSock and #10896 - -Some notes: - -* We must make fakes for promoted DataCons too. Consider (#15215) - data T a = MkT ... - data S a = ...T...MkT.... - If there is an error in the definition of 'T' we add a "fake type - constructor" to the type environment, so that we can continue to - typecheck 'S'. But we /were not/ adding a fake anything for 'MkT' - and so there was an internal error when we met 'MkT' in the body of - 'S'. - -* Painfully, we *don't* want to do this for classes. - Consider tcfail041: - class (?x::Int) => C a where ... - instance C Int - The class is invalid because of the superclass constraint. But - we still want it to look like a /class/, else the instance bleats - that the instance is mal-formed because it hasn't got a class in - the head. - - This is really bogus; now we have in scope a Class that is invalid - in some way, with unknown downstream consequences. A better - alternative might be to make a fake class TyCon. A job for another day. --} - -------------------------- --- For data types declared with record syntax, we require --- that each constructor that has a field 'f' --- (a) has the same result type --- (b) has the same type for 'f' --- module alpha conversion of the quantified type variables --- of the constructor. --- --- Note that we allow existentials to match because the --- fields can never meet. E.g --- data T where --- T1 { f1 :: b, f2 :: a, f3 ::Int } :: T --- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T --- Here we do not complain about f1,f2 because they are existential - -checkValidTyCon :: TyCon -> TcM () -checkValidTyCon tc - | isPrimTyCon tc -- Happens when Haddock'ing GHC.Prim - = return () - - | isWiredIn tc -- validity-checking wired-in tycons is a waste of - -- time. More importantly, a wired-in tycon might - -- violate assumptions. Example: (~) has a superclass - -- mentioning (~#), which is ill-kinded in source Haskell - = traceTc "Skipping validity check for wired-in" (ppr tc) - - | otherwise - = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc)) - ; if | Just cl <- tyConClass_maybe tc - -> checkValidClass cl - - | Just syn_rhs <- synTyConRhs_maybe tc - -> do { checkValidType syn_ctxt syn_rhs - ; checkTySynRhs syn_ctxt syn_rhs } - - | Just fam_flav <- famTyConFlav_maybe tc - -> case fam_flav of - { ClosedSynFamilyTyCon (Just ax) - -> tcAddClosedTypeFamilyDeclCtxt tc $ - checkValidCoAxiom ax - ; ClosedSynFamilyTyCon Nothing -> return () - ; AbstractClosedSynFamilyTyCon -> - do { hsBoot <- tcIsHsBootOrSig - ; checkTc hsBoot $ - text "You may define an abstract closed type family" $$ - text "only in a .hs-boot file" } - ; DataFamilyTyCon {} -> return () - ; OpenSynFamilyTyCon -> return () - ; BuiltInSynFamTyCon _ -> return () } - - | otherwise -> do - { -- Check the context on the data decl - traceTc "cvtc1" (ppr tc) - ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) - - ; traceTc "cvtc2" (ppr tc) - - ; dflags <- getDynFlags - ; existential_ok <- xoptM LangExt.ExistentialQuantification - ; gadt_ok <- xoptM LangExt.GADTs - ; let ex_ok = existential_ok || gadt_ok - -- Data cons can have existential context - ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons - ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc) - - -- Check that fields with the same name share a type - ; mapM_ check_fields groups }} - where - syn_ctxt = TySynCtxt name - name = tyConName tc - data_cons = tyConDataCons tc - - groups = equivClasses cmp_fld (concatMap get_fields data_cons) - cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2 - get_fields con = dataConFieldLabels con `zip` repeat con - -- dataConFieldLabels may return the empty list, which is fine - - -- See Note [GADT record selectors] in TcTyDecls - -- We must check (a) that the named field has the same - -- type in each constructor - -- (b) that those constructors have the same result type - -- - -- However, the constructors may have differently named type variable - -- and (worse) we don't know how the correspond to each other. E.g. - -- C1 :: forall a b. { f :: a, g :: b } -> T a b - -- C2 :: forall d c. { f :: c, g :: c } -> T c d - -- - -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's - -- result type against other candidates' types BOTH WAYS ROUND. - -- If they magically agrees, take the substitution and - -- apply them to the latter ones, and see if they match perfectly. - check_fields ((label, con1) :| other_fields) - -- These fields all have the same name, but are from - -- different constructors in the data type - = recoverM (return ()) $ mapM_ checkOne other_fields - -- Check that all the fields in the group have the same type - -- NB: this check assumes that all the constructors of a given - -- data type use the same type variables - where - res1 = dataConOrigResTy con1 - fty1 = dataConFieldType con1 lbl - lbl = flLabel label - - checkOne (_, con2) -- Do it both ways to ensure they are structurally identical - = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2 - ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 } - where - res2 = dataConOrigResTy con2 - fty2 = dataConFieldType con2 lbl - -checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM () --- Checks the partial record field selector, and warns. --- See Note [Checking partial record field] -checkPartialRecordField all_cons fld - = setSrcSpan loc $ - warnIfFlag Opt_WarnPartialFields - (not is_exhaustive && not (startsWithUnderscore occ_name)) - (sep [text "Use of partial record field selector" <> colon, - nest 2 $ quotes (ppr occ_name)]) - where - sel_name = flSelector fld - loc = getSrcSpan sel_name - occ_name = getOccName sel_name - - (cons_with_field, cons_without_field) = partition has_field all_cons - has_field con = fld `elem` (dataConFieldLabels con) - is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field - - con1 = ASSERT( not (null cons_with_field) ) head cons_with_field - (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1 - eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) - inst_tys = substTyVars eq_subst univ_tvs - -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) } - where - mb_subst1 = tcMatchTy res1 res2 - mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 - -------------------------------- -checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () -checkValidDataCon dflags existential_ok tc con - = setSrcSpan (getSrcSpan con) $ - addErrCtxt (dataConCtxt con) $ - do { -- Check that the return type of the data constructor - -- matches the type constructor; eg reject this: - -- data T a where { MkT :: Bogus a } - -- It's important to do this first: - -- see Note [Checking GADT return types] - -- and c.f. Note [Check role annotations in a second pass] - let tc_tvs = tyConTyVars tc - res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) - orig_res_ty = dataConOrigResTy con - ; traceTc "checkValidDataCon" (vcat - [ ppr con, ppr tc, ppr tc_tvs - , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl) - , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)]) - - - ; checkTc (isJust (tcMatchTy res_ty_tmpl orig_res_ty)) - (badDataConTyCon con res_ty_tmpl) - -- Note that checkTc aborts if it finds an error. This is - -- critical to avoid panicking when we call dataConUserType - -- on an un-rejiggable datacon! - - ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con)) - - -- Check that the result type is a *monotype* - -- e.g. reject this: MkT :: T (forall a. a->a) - -- Reason: it's really the argument of an equality constraint - ; checkValidMonoType orig_res_ty - - -- If we are dealing with a newtype, we allow levity polymorphism - -- regardless of whether or not UnliftedNewtypes is enabled. A - -- later check in checkNewDataCon handles this, producing a - -- better error message than checkForLevPoly would. - ; unless (isNewTyCon tc) - (mapM_ (checkForLevPoly empty) (dataConOrigArgTys con)) - - -- Extra checks for newtype data constructors. Importantly, these - -- checks /must/ come before the call to checkValidType below. This - -- is because checkValidType invokes the constraint solver, and - -- invoking the solver on an ill formed newtype constructor can - -- confuse GHC to the point of panicking. See #17955 for an example. - ; when (isNewTyCon tc) (checkNewDataCon con) - - -- Check all argument types for validity - ; checkValidType ctxt (dataConUserType con) - - -- Check that existentials are allowed if they are used - ; checkTc (existential_ok || isVanillaDataCon con) - (badExistential con) - - -- Check that UNPACK pragmas and bangs work out - -- E.g. reject data T = MkT {-# UNPACK #-} Int -- No "!" - -- data T = MkT {-# UNPACK #-} !a -- Can't unpack - ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..] - - -- Check the dcUserTyVarBinders invariant - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon - -- checked here because we sometimes build invalid DataCons before - -- erroring above here - ; when debugIsOn $ - do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con - user_tvs = dataConUserTyVars con - user_tvbs_invariant - = Set.fromList (filterEqSpec eq_spec univs ++ exs) - == Set.fromList user_tvs - ; MASSERT2( user_tvbs_invariant - , vcat ([ ppr con - , ppr univs - , ppr exs - , ppr eq_spec - , ppr user_tvs ])) } - - ; traceTc "Done validity of data con" $ - vcat [ ppr con - , text "Datacon user type:" <+> ppr (dataConUserType con) - , text "Datacon rep type:" <+> ppr (dataConRepType con) - , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con)) - , case tyConFamInst_maybe (dataConTyCon con) of - Nothing -> text "not family" - Just (f, _) -> ppr (tyConBinders f) ] - } - where - ctxt = ConArgCtxt (dataConName con) - - check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM () - check_bang (HsSrcBang _ _ SrcLazy) _ n - | not (xopt LangExt.StrictData dflags) - = addErrTc - (bad_bang n (text "Lazy annotation (~) without StrictData")) - check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n - | isSrcUnpacked want_unpack, not is_strict - = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'")) - | isSrcUnpacked want_unpack - , case rep_bang of { HsUnpack {} -> False; _ -> True } - -- If not optimising, we don't unpack (rep_bang is never - -- HsUnpack), so don't complain! This happens, e.g., in Haddock. - -- See dataConSrcToImplBang. - , not (gopt Opt_OmitInterfacePragmas dflags) - -- When typechecking an indefinite package in Backpack, we - -- may attempt to UNPACK an abstract type. The test here will - -- conclude that this is unusable, but it might become usable - -- when we actually fill in the abstract type. As such, don't - -- warn in this case (it gives users the wrong idea about whether - -- or not UNPACK on abstract types is supported; it is!) - , unitIdIsDefinite (thisPackage dflags) - = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma")) - where - is_strict = case strict_mark of - NoSrcStrict -> xopt LangExt.StrictData dflags - bang -> isSrcStrict bang - - check_bang _ _ _ - = return () - - bad_bang n herald - = hang herald 2 (text "on the" <+> speakNth n - <+> text "argument of" <+> quotes (ppr con)) -------------------------------- -checkNewDataCon :: DataCon -> TcM () --- Further checks for the data constructor of a newtype -checkNewDataCon con - = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) - -- One argument - - ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - ; let allowedArgType = - unlifted_newtypes || isLiftedType_maybe arg_ty1 == Just True - ; checkTc allowedArgType $ vcat - [ text "A newtype cannot have an unlifted argument type" - , text "Perhaps you intended to use UnliftedNewtypes" - ] - - ; check_con (null eq_spec) $ - text "A newtype constructor must have a return type of form T a1 ... an" - -- Return type is (T a b c) - - ; check_con (null theta) $ - text "A newtype constructor cannot have a context in its type" - - ; check_con (null ex_tvs) $ - text "A newtype constructor cannot have existential type variables" - -- No existentials - - ; checkTc (all ok_bang (dataConSrcBangs con)) - (newtypeStrictError con) - -- No strictness annotations - } - where - (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) - = dataConFullSig con - check_con what msg - = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con)) - - (arg_ty1 : _) = arg_tys - - ok_bang (HsSrcBang _ _ SrcStrict) = False - ok_bang (HsSrcBang _ _ SrcLazy) = False - ok_bang _ = True - -------------------------------- -checkValidClass :: Class -> TcM () -checkValidClass cls - = do { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods - ; multi_param_type_classes <- xoptM LangExt.MultiParamTypeClasses - ; nullary_type_classes <- xoptM LangExt.NullaryTypeClasses - ; fundep_classes <- xoptM LangExt.FunctionalDependencies - ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses - - -- Check that the class is unary, unless multiparameter type classes - -- are enabled; also recognize deprecated nullary type classes - -- 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) - - -- Check the super-classes - ; checkValidTheta (ClassSCCtxt (className cls)) theta - - -- Now check for cyclic superclasses - -- If there are superclass cycles, checkClassCycleErrs bails. - ; unless undecidable_super_classes $ - case checkClassCycles cls of - Just err -> setSrcSpan (getSrcSpan cls) $ - addErrTc err - Nothing -> return () - - -- Check the class operations. - -- But only if there have been no earlier errors - -- See Note [Abort when superclass cycle is detected] - ; whenNoErrs $ - mapM_ (check_op constrained_class_methods) op_stuff - - -- Check the associated type defaults are well-formed and instantiated - ; mapM_ check_at at_stuff } - where - (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls - cls_arity = length (tyConVisibleTyVars (classTyCon cls)) - -- Ignore invisible variables - cls_tv_set = mkVarSet tyvars - - check_op constrained_class_methods (sel_id, dm) - = setSrcSpan (getSrcSpan sel_id) $ - addErrCtxt (classOpCtxt sel_id op_ty) $ do - { traceTc "class op type" (ppr op_ty) - ; checkValidType ctxt op_ty - -- This implements the ambiguity check, among other things - -- Example: tc223 - -- class Error e => Game b mv e | b -> mv e where - -- newBoard :: MonadState b m => m () - -- Here, MonadState has a fundep m->b, so newBoard is fine - - -- a method cannot be levity polymorphic, as we have to store the - -- method in a dictionary - -- example of what this prevents: - -- class BoundedX (a :: TYPE r) where minBound :: a - -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad - ; checkForLevPoly empty tau1 - - ; unless constrained_class_methods $ - mapM_ check_constraint (tail (cls_pred:op_theta)) - - ; check_dm ctxt sel_id cls_pred tau2 dm - } - where - ctxt = FunSigCtxt op_name True -- Report redundant class constraints - op_name = idName sel_id - op_ty = idType sel_id - (_,cls_pred,tau1) = tcSplitMethodTy op_ty - -- See Note [Splitting nested sigma types in class type signatures] - (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1 - - check_constraint :: TcPredType -> TcM () - check_constraint pred -- See Note [Class method constraints] - = when (not (isEmptyVarSet pred_tvs) && - pred_tvs `subVarSet` cls_tv_set) - (addErrTc (badMethPred sel_id pred)) - where - pred_tvs = tyCoVarsOfType pred - - check_at (ATI fam_tc m_dflt_rhs) - = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) - (noClassTyVarErr 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, - -- since there is no possible ambiguity (#10020) - - -- Check that any default declarations for associated types are valid - ; whenIsJust m_dflt_rhs $ \ (rhs, loc) -> - setSrcSpan loc $ - tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $ - checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs } - where - fam_tvs = tyConTyVars fam_tc - - check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM () - -- Check validity of the /top-level/ generic-default type - -- E.g for class C a where - -- default op :: forall b. (a~b) => blah - -- we do not want to do an ambiguity check on a type with - -- a free TyVar 'a' (#11608). See TcType - -- Note [TyVars and TcTyVars during type checking] in TcType - -- Hence the mkDefaultMethodType to close the type. - check_dm ctxt sel_id vanilla_cls_pred vanilla_tau - (Just (dm_name, dm_spec@(GenericDM dm_ty))) - = setSrcSpan (getSrcSpan dm_name) $ do - -- We have carefully set the SrcSpan on the generic - -- default-method Name to be that of the generic - -- default type signature - - -- First, we check that that the method's default type signature - -- aligns with the non-default type signature. - -- See Note [Default method type signatures must align] - let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls - -- Note that the second field of this tuple contains the context - -- of the default type signature, making it apparent that we - -- ignore method contexts completely when validity-checking - -- default type signatures. See the end of - -- Note [Default method type signatures must align] - -- to learn why this is OK. - -- - -- See also - -- Note [Splitting nested sigma types in class type signatures] - -- for an explanation of why we don't use tcSplitSigmaTy here. - (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty - - -- Given this class definition: - -- - -- class C a b where - -- op :: forall p q. (Ord a, D p q) - -- => a -> b -> p -> (a, b) - -- default op :: forall r s. E r - -- => a -> b -> s -> (a, b) - -- - -- We want to match up two types of the form: - -- - -- Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb) - -- Default type sig: C a b => a -> b -> s -> (a, b) - -- - -- Notice that the two type signatures can be quantified over - -- different class type variables! Therefore, it's important that - -- we include the class predicate parts to match up a with aa and - -- b with bb. - vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau - dm_phi_ty = mkPhiTy [cls_pred] dm_tau - - traceTc "check_dm" $ vcat - [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty - , text "dm_phi_ty" <+> ppr dm_phi_ty ] - - -- Actually checking that the types align is done with a call to - -- tcMatchTys. We need to get a match in both directions to rule - -- out degenerate cases like these: - -- - -- class Foo a where - -- foo1 :: a -> b - -- default foo1 :: a -> Int - -- - -- foo2 :: a -> Int - -- default foo2 :: a -> b - unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty] - [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $ - 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") - - -- Now do an ambiguity check on the default type signature. - checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec) - check_dm _ _ _ _ _ = return () - -checkFamFlag :: Name -> TcM () --- Check that we don't use families without -XTypeFamilies --- The parser won't even parse them, but I suppose a GHC API --- client might have a go! -checkFamFlag tc_name - = do { idx_tys <- xoptM LangExt.TypeFamilies - ; checkTc idx_tys err_msg } - where - err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) - 2 (text "Enable TypeFamilies to allow indexed type families") - -checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM () -checkResultSigFlag tc_name (TyVarSig _ tvb) - = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies - ; checkTc ty_fam_deps $ - hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name)) - 2 (text "Enable TypeFamilyDependencies to allow result variable names") } -checkResultSigFlag _ _ = return () -- other cases OK - -{- Note [Class method constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Haskell 2010 is supposed to reject - class C a where - op :: Eq a => a -> a -where the method type constrains only the class variable(s). (The extension --XConstrainedClassMethods switches off this check.) But regardless -we should not reject - class C a where - op :: (?x::Int) => a -> a -as pointed out in #11793. So the test here rejects the program if - * -XConstrainedClassMethods is off - * the tyvars of the constraint are non-empty - * all the tyvars are class tyvars, none are locally quantified - -Note [Abort when superclass cycle is detected] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must avoid doing the ambiguity check for the methods (in -checkValidClass.check_op) when there are already errors accumulated. -This is because one of the errors may be a superclass cycle, and -superclass cycles cause canonicalization to loop. Here is a -representative example: - - class D a => C a where - meth :: D a => () - class C a => D a - -This fixes #9415, #9739 - -Note [Default method type signatures must align] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC enforces the invariant that a class method's default type signature -must "align" with that of the method's non-default type signature, as per -GHC #12918. For instance, if you have: - - class Foo a where - bar :: forall b. Context => a -> b - -Then a default type signature for bar must be alpha equivalent to -(forall b. a -> b). That is, the types must be the same modulo differences in -contexts. So the following would be acceptable default type signatures: - - default bar :: forall b. Context1 => a -> b - default bar :: forall x. Context2 => a -> x - -But the following are NOT acceptable default type signatures: - - default bar :: forall b. b -> a - default bar :: forall x. x - default bar :: a -> Int - -Note that a is bound by the class declaration for Foo itself, so it is -not allowed to differ in the default type signature. - -The default type signature (default bar :: a -> Int) deserves special mention, -since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To -write this, you need to declare the default type signature like so: - - default bar :: forall b. (b ~ Int). a -> b - -As noted in #12918, there are several reasons to do this: - -1. It would make no sense to have a type that was flat-out incompatible with - the non-default type signature. For instance, if you had: - - class Foo a where - bar :: a -> Int - default bar :: a -> Bool - - Then that would always fail in an instance declaration. So this check - nips such cases in the bud before they have the chance to produce - confusing error messages. - -2. Internally, GHC uses TypeApplications to instantiate the default method in - an instance. See Note [Default methods in instances] in TcInstDcls. - Thus, GHC needs to know exactly what the universally quantified type - variables are, and when instantiated that way, the default method's type - must match the expected type. - -3. Aesthetically, by only allowing the default type signature to differ in its - context, we are making it more explicit the ways in which the default type - signature is less polymorphic than the non-default type signature. - -You might be wondering: why are the contexts allowed to be different, but not -the rest of the type signature? That's because default implementations often -rely on assumptions that the more general, non-default type signatures do not. -For instance, in the Enum class declaration: - - class Enum a where - enum :: [a] - default enum :: (Generic a, GEnum (Rep a)) => [a] - enum = map to genum - - class GEnum f where - genum :: [f a] - -The default implementation for enum only works for types that are instances of -Generic, and for which their generic Rep type is an instance of GEnum. But -clearly enum doesn't _have_ to use this implementation, so naturally, the -context for enum is allowed to be different to accommodate this. As a result, -when we validity-check default type signatures, we ignore contexts completely. - -Note that when checking whether two type signatures match, we must take care to -split as many foralls as it takes to retrieve the tau types we which to check. -See Note [Splitting nested sigma types in class type signatures]. - -Note [Splitting nested sigma types in class type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this type synonym and class definition: - - type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t - - class Each s t a b where - each :: Traversal s t a b - default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b - -It might seem obvious that the tau types in both type signatures for `each` -are the same, but actually getting GHC to conclude this is surprisingly tricky. -That is because in general, the form of a class method's non-default type -signature is: - - forall a. C a => forall d. D d => E a b - -And the general form of a default type signature is: - - forall f. F f => E a f -- The variable `a` comes from the class - -So it you want to get the tau types in each type signature, you might find it -reasonable to call tcSplitSigmaTy twice on the non-default type signature, and -call it once on the default type signature. For most classes and methods, this -will work, but Each is a bit of an exceptional case. The way `each` is written, -it doesn't quantify any additional type variables besides those of the Each -class itself, so the non-default type signature for `each` is actually this: - - forall s t a b. Each s t a b => Traversal s t a b - -Notice that there _appears_ to only be one forall. But there's actually another -forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy -twice, you'll also go under the forall in Traversal! That is, you'll end up -with: - - (a -> f b) -> s -> f t - -A problem arises because you only call tcSplitSigmaTy once on the default type -signature for `each`, which gives you - - Traversal s t a b - -Or, equivalently: - - forall f. Applicative f => (a -> f b) -> s -> f t - -This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will -say that the tau types for `each` are not equal. - -A solution to this problem is to use tcSplitNestedSigmaTys instead of -tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it -sees until it can't go any further, so if you called it on the default type -signature for `each`, it would return (a -> f b) -> s -> f t like we desired. - -Note [Checking partial record field] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This check checks the partial record field selector, and warns (#7169). - -For example: - - data T a = A { m1 :: a, m2 :: a } | B { m1 :: a } - -The function 'm2' is partial record field, and will fail when it is applied to -'B'. The warning identifies such partial fields. The check is performed at the -declaration of T, not at the call-sites of m2. - -The warning can be suppressed by prefixing the field-name with an underscore. -For example: - - data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a } - -************************************************************************ -* * - Checking role validity -* * -************************************************************************ --} - -checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM () -checkValidRoleAnnots role_annots tc - | isTypeSynonymTyCon tc = check_no_roles - | isFamilyTyCon tc = check_no_roles - | isAlgTyCon tc = check_roles - | otherwise = return () - where - -- Role annotations are given only on *explicit* variables, - -- but a tycon stores roles for all variables. - -- So, we drop the implicit roles (which are all Nominal, anyway). - name = tyConName tc - roles = tyConRoles tc - (vis_roles, vis_vars) = unzip $ mapMaybe pick_vis $ - zip roles (tyConBinders tc) - role_annot_decl_maybe = lookupRoleAnnot role_annots name - - pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar) - pick_vis (role, tvb) - | isVisibleTyConBinder tvb = Just (role, binderVar tvb) - | otherwise = Nothing - - check_roles - = whenIsJust role_annot_decl_maybe $ - \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> - addRoleAnnotCtxt name $ - setSrcSpan loc $ do - { role_annots_ok <- xoptM LangExt.RoleAnnotations - ; checkTc role_annots_ok $ needXRoleAnnotations tc - ; checkTc (vis_vars `equalLength` the_role_annots) - (wrongNumberOfRoles 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 - -- IncoherentInstances to have them. See #8773, #14292 - ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances - ; checkTc ( incoherent_roles_ok - || (not $ isClassTyCon tc) - || (all (== Nominal) vis_roles)) - incoherentRoles - - ; lint <- goptM Opt_DoCoreLinting - ; when lint $ checkValidRoles tc } - - check_no_roles - = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl - -checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM () -checkRoleAnnot _ (L _ Nothing) _ = return () -checkRoleAnnot tv (L _ (Just r1)) r2 - = when (r1 /= r2) $ - addErrTc $ badRoleAnnot (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 TcTyDecls -checkValidRoles :: TyCon -> TcM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint -checkValidRoles tc - | isAlgTyCon tc - -- tyConDataCons returns an empty list for data families - = mapM_ check_dc_roles (tyConDataCons tc) - | Just rhs <- synTyConRhs_maybe tc - = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs - | otherwise - = return () - where - check_dc_roles datacon - = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc)) - ; mapM_ (check_ty_roles role_env Representational) $ - eqSpecPreds eq_spec ++ theta ++ arg_tys } - -- See Note [Role-checking data constructor arguments] in TcTyDecls - where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) - = dataConFullSig datacon - univ_roles = zipVarEnv univ_tvs (tyConRoles tc) - -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs - ex_roles = mkVarEnv (map (, Nominal) ex_tvs) - role_env = univ_roles `plusVarEnv` ex_roles - - check_ty_roles env role ty - | Just ty' <- coreView ty -- #14101 - = check_ty_roles env role ty' - - 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" - - check_ty_roles env Representational (TyConApp tc tys) - = let roles' = tyConRoles tc in - zipWithM_ (maybe_check_ty_roles env) roles' tys - - check_ty_roles env Nominal (TyConApp _ tys) - = mapM_ (check_ty_roles env Nominal) tys - - check_ty_roles _ Phantom ty@(TyConApp {}) - = pprPanic "check_ty_roles" (ppr ty) - - check_ty_roles env role (AppTy ty1 ty2) - = check_ty_roles env role ty1 - >> check_ty_roles env Nominal ty2 - - check_ty_roles env role (FunTy _ ty1 ty2) - = check_ty_roles env role ty1 - >> check_ty_roles env role ty2 - - check_ty_roles env role (ForAllTy (Bndr tv _) ty) - = check_ty_roles env Nominal (tyVarKind tv) - >> check_ty_roles (extendVarEnv env tv Nominal) role ty - - check_ty_roles _ _ (LitTy {}) = return () - - check_ty_roles env role (CastTy t _) - = check_ty_roles env role t - - check_ty_roles _ role (CoercionTy co) - = unless (role == Phantom) $ - report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role - - maybe_check_ty_roles env role ty - = when (role == Nominal || role == Representational) $ - check_ty_roles env role ty - - report_error doc - = addErrTc $ vcat [text "Internal error in role inference:", - doc, - text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] - -{- -************************************************************************ -* * - Error messages -* * -************************************************************************ --} - -tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc -tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl, - text "declaration for", quotes (ppr (tcdName decl))] - -addVDQNote :: TcTyCon -> TcM a -> TcM a --- See Note [Inferring visible dependent quantification] --- Only types without a signature (CUSK or SAK) here -addVDQNote tycon thing_inside - | ASSERT2( isTcTyCon tycon, ppr tycon ) - ASSERT2( not (tcTyConIsPoly tycon), ppr tycon $$ ppr tc_kind ) - has_vdq - = addLandmarkErrCtxt vdq_warning thing_inside - | otherwise - = thing_inside - where - -- Check whether a tycon has visible dependent quantification. - -- This will *always* be a TcTyCon. Furthermore, it will *always* - -- be an ungeneralised TcTyCon, straight out of kcInferDeclHeader. - -- Thus, all the TyConBinders will be anonymous. Thus, the - -- free variables of the tycon's kind will be the same as the free - -- variables from all the binders. - has_vdq = any is_vdq_tcb (tyConBinders tycon) - tc_kind = tyConKind tycon - kind_fvs = tyCoVarsOfType tc_kind - - is_vdq_tcb tcb = (binderVar tcb `elemVarSet` kind_fvs) && - isVisibleTyConBinder tcb - - vdq_warning = vcat - [ text "NB: Type" <+> quotes (ppr tycon) <+> - text "was inferred to use visible dependent quantification." - , text "Most types with visible dependent quantification are" - , text "polymorphically recursive and need a standalone kind" - , text "signature. Perhaps supply one, with StandaloneKindSignatures." - ] - -tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a -tcAddDeclCtxt decl thing_inside - = addErrCtxt (tcMkDeclCtxt decl) thing_inside - -tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a -tcAddTyFamInstCtxt decl - = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl) - -tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc -tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn = - HsIB { hsib_body = eqn }}) - = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance") - (unLoc (feqn_tycon eqn)) -tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs nec)) - = noExtCon nec - -tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a -tcAddDataFamInstCtxt decl - = addErrCtxt (tcMkDataFamInstCtxt decl) - -tcMkFamInstCtxt :: SDoc -> Name -> SDoc -tcMkFamInstCtxt flavour tycon - = hsep [ text "In the" <+> flavour <+> text "declaration for" - , quotes (ppr tycon) ] - -tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a -tcAddFamInstCtxt flavour tycon thing_inside - = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside - -tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a -tcAddClosedTypeFamilyDeclCtxt tc - = addErrCtxt ctxt - where - ctxt = text "In the equations for closed type family" <+> - quotes (ppr tc) - -resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc -resultTypeMisMatch field_name con1 con2 - = 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 -> SDoc -fieldTypeMisMatch field_name con1 con2 - = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, - text "give different types for field", quotes (ppr field_name)] - -dataConCtxtName :: [Located Name] -> SDoc -dataConCtxtName [con] - = text "In the definition of data constructor" <+> quotes (ppr con) -dataConCtxtName con - = text "In the definition of data constructors" <+> interpp'SP con - -dataConCtxt :: Outputable a => a -> SDoc -dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con) - -classOpCtxt :: Var -> Type -> SDoc -classOpCtxt sel_id tau = sep [text "When checking the class method:", - nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] - -classArityErr :: Int -> Class -> SDoc -classArityErr n cls - | n == 0 = mkErr "No" "no-parameter" - | otherwise = mkErr "Too many" "multi-parameter" - where - mkErr howMany allowWhat = - vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls), - parens (text ("Enable MultiParamTypeClasses to allow " - ++ allowWhat ++ " classes"))] - -classFunDepsErr :: Class -> SDoc -classFunDepsErr cls - = vcat [text "Fundeps in class" <+> quotes (ppr cls), - parens (text "Enable FunctionalDependencies to allow fundeps")] - -badMethPred :: Id -> TcPredType -> SDoc -badMethPred sel_id pred - = 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 -> SDoc -noClassTyVarErr clas fam_tc - = 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 -> SDoc -badDataConTyCon data_con res_ty_tmpl - | ASSERT( all isTyVar tvs ) - tcIsForAllTy actual_res_ty - = nested_foralls_contexts_suggestion - | isJust (tcSplitPredFunTy_maybe actual_res_ty) - = nested_foralls_contexts_suggestion - | otherwise - = 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 - - -- This suggestion is useful for suggesting how to correct code like what - -- was reported in #12087: - -- - -- data F a where - -- MkF :: Ord a => Eq a => a -> F a - -- - -- Although nested foralls or contexts are allowed in function type - -- signatures, it is much more difficult to engineer GADT constructor type - -- signatures to allow something similar, so we error in the latter case. - -- Nevertheless, we can at least suggest how a user might reshuffle their - -- exotic GADT constructor type signature so that GHC will accept. - nested_foralls_contexts_suggestion = - text "GADT constructor type signature cannot contain nested" - <+> quotes forAllLit <> text "s or contexts" - $+$ hang (text "Suggestion: instead use this type signature:") - 2 (ppr (dataConName data_con) <+> dcolon <+> ppr suggested_ty) - - -- To construct a type that GHC would accept (suggested_ty), we: - -- - -- 1) Find the existentially quantified type variables and the class - -- predicates from the datacon. (NB: We don't need the universally - -- quantified type variables, since rejigConRes won't substitute them in - -- the result type if it fails, as in this scenario.) - -- 2) Split apart the return type (which is headed by a forall or a - -- context) using tcSplitNestedSigmaTys, collecting the type variables - -- and class predicates we find, as well as the rho type lurking - -- underneath the nested foralls and contexts. - -- 3) Smash together the type variables and class predicates from 1) and - -- 2), and prepend them to the rho type from 2). - (tvs, theta, rho) = tcSplitNestedSigmaTys (dataConUserType data_con) - suggested_ty = mkSpecSigmaTy tvs theta rho - -badGadtDecl :: Name -> SDoc -badGadtDecl tc_name - = 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 -> SDoc -badExistential con - = 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 (dataConUserType con) - , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ]) - -badStupidTheta :: Name -> SDoc -badStupidTheta tc_name - = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) - -newtypeConError :: Name -> Int -> SDoc -newtypeConError tycon n - = sep [text "A newtype must have exactly one constructor,", - nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] - -newtypeStrictError :: DataCon -> SDoc -newtypeStrictError con - = sep [text "A newtype constructor cannot have a strictness annotation,", - nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"] - -newtypeFieldErr :: DataCon -> Int -> SDoc -newtypeFieldErr con_name n_flds - = sep [text "The constructor of a newtype must have exactly one field", - nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds] - -badSigTyDecl :: Name -> SDoc -badSigTyDecl tc_name - = vcat [ text "Illegal kind signature" <+> - quotes (ppr tc_name) - , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] - -emptyConDeclsErr :: Name -> SDoc -emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> text "has no constructors", - nest 2 $ text "(EmptyDataDecls permits this)"] - -wrongKindOfFamily :: TyCon -> SDoc -wrongKindOfFamily family - = 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 TcValidity. -wrongNumberOfParmsErr :: Arity -> SDoc -wrongNumberOfParmsErr max_args - = text "Number of parameters must match family declaration; expected" - <+> ppr max_args - -badRoleAnnot :: Name -> Role -> Role -> SDoc -badRoleAnnot var annot inferred - = 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 -> SDoc -wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) - = 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) -wrongNumberOfRoles _ (L _ (XRoleAnnotDecl nec)) = noExtCon nec - - -illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () -illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) - = setErrCtxt [] $ - setSrcSpan loc $ - addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ - text "they are allowed only for datatypes and classes.") -illegalRoleAnnotDecl (L _ (XRoleAnnotDecl nec)) = noExtCon nec - -needXRoleAnnotations :: TyCon -> SDoc -needXRoleAnnotations tc - = text "Illegal role annotation for" <+> ppr tc <> char ';' $$ - text "did you intend to use RoleAnnotations?" - -incoherentRoles :: SDoc -incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+> - text "for class parameters can lead to incoherence.") $$ - (text "Use IncoherentInstances to allow this; bad role found") - -addTyConCtxt :: TyCon -> TcM a -> TcM a -addTyConCtxt tc = addTyConFlavCtxt name flav - where - name = getName tc - flav = tyConFlavour tc - -addRoleAnnotCtxt :: Name -> TcM a -> TcM a -addRoleAnnotCtxt name - = addErrCtxt $ - text "while checking a role annotation for" <+> quotes (ppr name) diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs deleted file mode 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ /dev/null @@ -1,1032 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 - - -Analysis functions over data types. Specifically, detecting recursive types. - -This stuff is only used for source-code decls; it's recorded in interface -files for imported data types. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcTyDecls( - RolesInfo, - inferRoles, - checkSynCycles, - checkClassCycles, - - -- * Implicits - addTyConsToGblEnv, mkDefaultMethodType, - - -- * Record selectors - tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnMonad -import TcEnv -import TcBinds( tcValBinds ) -import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) ) -import TcType -import GHC.Core.Predicate -import TysWiredIn( unitTy ) -import GHC.Core.Make( rEC_SEL_ERROR_ID ) -import GHC.Hs -import GHC.Core.Class -import GHC.Core.Type -import GHC.Driver.Types -import GHC.Core.TyCon -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set hiding (unitFV) -import GHC.Types.Name.Reader ( mkVarUnqual ) -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Core.Coercion ( ltRole ) -import GHC.Types.Basic -import GHC.Types.SrcLoc -import GHC.Types.Unique ( mkBuiltinUnique ) -import Outputable -import Util -import Maybes -import Bag -import FastString -import FV -import GHC.Types.Module - -import Control.Monad - -{- -************************************************************************ -* * - Cycles in type synonym declarations -* * -************************************************************************ --} - -synonymTyConsOfType :: Type -> [TyCon] --- Does not look through type synonyms at all --- Return a list of synonym tycons --- Keep this synchronized with 'expandTypeSynonyms' -synonymTyConsOfType ty - = nameEnvElts (go ty) - where - go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim - go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys - go (LitTy _) = emptyNameEnv - go (TyVarTy _) = emptyNameEnv - go (AppTy a b) = go a `plusNameEnv` go b - go (FunTy _ a b) = go a `plusNameEnv` go b - go (ForAllTy _ ty) = go ty - go (CastTy ty co) = go ty `plusNameEnv` go_co co - go (CoercionTy co) = go_co co - - -- Note [TyCon cycles through coercions?!] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Although, in principle, it's possible for a type synonym loop - -- could go through a coercion (since a coercion can refer to - -- a TyCon or Type), it doesn't seem possible to actually construct - -- a Haskell program which tickles this case. Here is an example - -- program which causes a coercion: - -- - -- type family Star where - -- Star = Type - -- - -- data T :: Star -> Type - -- data S :: forall (a :: Type). T a -> Type - -- - -- Here, the application 'T a' must first coerce a :: Type to a :: Star, - -- witnessed by the type family. But if we now try to make Type refer - -- to a type synonym which in turn refers to Star, we'll run into - -- trouble: we're trying to define and use the type constructor - -- in the same recursive group. Possibly this restriction will be - -- lifted in the future but for now, this code is "just for completeness - -- sake". - go_mco MRefl = emptyNameEnv - go_mco (MCo co) = go_co co - - go_co (Refl ty) = go ty - go_co (GRefl _ ty mco) = go ty `plusNameEnv` go_mco mco - go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs - go_co (AppCo co co') = go_co co `plusNameEnv` go_co co' - go_co (ForAllCo _ co co') = go_co co `plusNameEnv` go_co co' - go_co (FunCo _ co co') = go_co co `plusNameEnv` go_co co' - go_co (CoVarCo _) = emptyNameEnv - go_co (HoleCo {}) = emptyNameEnv - go_co (AxiomInstCo _ _ cs) = go_co_s cs - go_co (UnivCo p _ ty ty') = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty' - go_co (SymCo co) = go_co co - go_co (TransCo co co') = go_co co `plusNameEnv` go_co co' - go_co (NthCo _ _ co) = go_co co - go_co (LRCo _ co) = go_co co - go_co (InstCo co co') = go_co co `plusNameEnv` go_co co' - go_co (KindCo co) = go_co co - go_co (SubCo co) = go_co co - go_co (AxiomRuleCo _ cs) = go_co_s cs - - go_prov (PhantomProv co) = go_co co - go_prov (ProofIrrelProv co) = go_co co - go_prov (PluginProv _) = emptyNameEnv - - go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc - | otherwise = emptyNameEnv - go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys - go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos - --- | A monad for type synonym cycle checking, which keeps --- 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) } - deriving (Functor) - -type SynCycleState = NameSet - -instance Applicative SynCycleM where - pure x = SynCycleM $ \state -> Right (x, state) - (<*>) = ap - -instance Monad SynCycleM where - m >>= f = SynCycleM $ \state -> - case runSynCycleM m state of - Right (x, state') -> - runSynCycleM (f x) state' - Left err -> Left err - -failSynCycleM :: SrcSpan -> SDoc -> SynCycleM () -failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err) - --- | Test if a 'Name' is acyclic, short-circuiting if we've --- seen it already. -checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM () -checkNameIsAcyclic n m = SynCycleM $ \s -> - if n `elemNameSet` s - then Right ((), s) -- short circuit - else case runSynCycleM m s of - Right ((), s') -> Right ((), extendNameSet s' n) - Left err -> Left err - --- | Checks if any of the passed in 'TyCon's have cycles. --- Takes the 'UnitId' of the home package (as we can avoid --- checking those TyCons: cycles never go through foreign packages) and --- the corresponding @LTyClDecl Name@ for each 'TyCon', so we --- can give better error messages. -checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () -checkSynCycles this_uid tcs tyclds = do - case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of - Left (loc, err) -> setSrcSpan loc $ failWithTc err - Right _ -> return () - where - -- Try our best to print the LTyClDecl for locally defined things - lcl_decls = mkNameEnv (zip (map tyConName tcs) tyclds) - - -- Short circuit if we've already seen this Name and concluded - -- it was acyclic. - go :: NameSet -> [TyCon] -> TyCon -> SynCycleM () - go so_far seen_tcs tc = - checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc - - -- Expand type synonyms, complaining if you find the same - -- type synonym a second time. - go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM () - go' so_far seen_tcs tc - | n `elemNameSet` so_far - = failSynCycleM (getSrcSpan (head seen_tcs)) $ - sep [ text "Cycle in type synonym declarations:" - , nest 2 (vcat (map ppr_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. - -- - -- This won't hold once we get recursive packages with Backpack, - -- but for now it's fine. - | not (isHoleModule mod || - moduleUnitId mod == this_uid || - isInteractiveModule mod) - = return () - | Just ty <- synTyConRhs_maybe tc = - go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty - | otherwise = return () - where - n = tyConName tc - mod = nameModule n - ppr_decl tc = - case lookupNameEnv lcl_decls n of - Just (L loc decl) -> ppr loc <> colon <+> ppr decl - Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n - <+> text "from external module" - where - n = tyConName tc - - go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM () - go_ty so_far seen_tcs ty = - mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty) - -{- Note [Superclass cycle check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The superclass cycle check for C decides if we can statically -guarantee that expanding C's superclass cycles transitively is -guaranteed to terminate. This is a Haskell98 requirement, -but one that we lift with -XUndecidableSuperClasses. - -The worry is that a superclass cycle could make the type checker loop. -More precisely, with a constraint (Given or Wanted) - C ty1 .. tyn -one approach is to instantiate all of C's superclasses, transitively. -We can only do so if that set is finite. - -This potential loop occurs only through superclasses. This, for -example, is fine - class C a where - op :: C b => a -> b -> b -even though C's full definition uses C. - -Making the check static also makes it conservative. Eg - type family F a - class F a => C a -Here an instance of (F a) might mention C: - type instance F [a] = C a -and now we'd have a loop. - -The static check works like this, starting with C - * Look at C's superclass predicates - * If any is a type-function application, - or is headed by a type variable, fail - * If any has C at the head, fail - * If any has a type class D at the head, - make the same test with D - -A tricky point is: what if there is a type variable at the head? -Consider this: - class f (C f) => C f - class c => Id c -and now expand superclasses for constraint (C Id): - C Id - --> Id (C Id) - --> C Id - --> .... -Each step expands superclasses one layer, and clearly does not terminate. --} - -checkClassCycles :: Class -> Maybe SDoc --- Nothing <=> ok --- Just err <=> possible cycle error -checkClassCycles cls - = do { (definite_cycle, err) <- go (unitNameSet (getName 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]) } - 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 - -- - -- NB: this code duplicates TcType.transSuperClasses, but - -- with more error message generation clobber - -- Make sure the two stay in sync. - go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc) - go so_far cls tys = firstJusts $ - map (go_pred so_far) $ - immSuperClasses cls tys - - go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc) - -- Nothing <=> ok - -- Just (True, err) <=> definite cycle - -- Just (False, err) <=> possible cycle - go_pred so_far pred -- NB: tcSplitTyConApp looks through synonyms - | 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))) - | otherwise - = Nothing - - go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc) - 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 cls <- tyConClass_maybe tc - = go_cls so_far cls tys - | otherwise -- Equality predicate, for example - = Nothing - - go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc) - go_cls so_far cls tys - | cls_nm `elemNameSet` so_far - = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls)) - | isCTupleClass cls - = go so_far cls tys - | otherwise - = do { (b,err) <- go (so_far `extendNameSet` cls_nm) cls tys - ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls) - $$ err) } - where - cls_nm = getName cls - -{- -************************************************************************ -* * - Role inference -* * -************************************************************************ - -Note [Role inference] -~~~~~~~~~~~~~~~~~~~~~ -The role inference algorithm datatype definitions to infer the roles on the -parameters. Although these roles are stored in the tycons, we can perform this -algorithm on the built tycons, as long as we don't peek at an as-yet-unknown -roles field! Ah, the magic of laziness. - -First, we choose appropriate initial roles. For families and classes, roles -(including initial roles) are N. For datatypes, we start with the role in the -role annotation (if any), or otherwise use Phantom. This is done in -initialRoleEnv1. - -The function irGroup then propagates role information until it reaches a -fixpoint, preferring N over (R or P) and R over P. To aid in this, we have a -monad RoleM, which is a combination reader and state monad. In its state are -the current RoleEnv, which gets updated by role propagation, and an update -bit, which we use to know whether or not we've reached the fixpoint. The -environment of RoleM contains the tycon whose parameters we are inferring, and -a VarEnv from parameters to their positions, so we can update the RoleEnv. -Between tycons, this reader information is missing; it is added by -addRoleInferenceInfo. - -There are two kinds of tycons to consider: algebraic ones (excluding classes) -and type synonyms. (Remember, families don't participate -- all their parameters -are N.) An algebraic tycon processes each of its datacons, in turn. Note that -a datacon's universally quantified parameters might be different from the parent -tycon's parameters, so we use the datacon's univ parameters in the mapping from -vars to positions. Note also that we don't want to infer roles for existentials -(they're all at N, too), so we put them in the set of local variables. As an -optimisation, we skip any tycons whose roles are already all Nominal, as there -nowhere else for them to go. For synonyms, we just analyse their right-hand sides. - -irType walks through a type, looking for uses of a variable of interest and -propagating role information. Because anything used under a phantom position -is at phantom and anything used under a nominal position is at nominal, the -irType function can assume that anything it sees is at representational. (The -other possibilities are pruned when they're encountered.) - -The rest of the code is just plumbing. - -How do we know that this algorithm is correct? It should meet the following -specification: - -Let Z be a role context -- a mapping from variables to roles. The following -rules define the property (Z |- t : r), where t is a type and r is a role: - -Z(a) = r' r' <= r -------------------------- RCVar -Z |- a : r - ----------- RCConst -Z |- T : r -- T is a type constructor - -Z |- t1 : r -Z |- t2 : N --------------- RCApp -Z |- t1 t2 : r - -forall i<=n. (r_i is R or N) implies Z |- t_i : r_i -roles(T) = r_1 .. r_n ----------------------------------------------------- RCDApp -Z |- T t_1 .. t_n : R - -Z, a:N |- t : r ----------------------- RCAll -Z |- forall a:k.t : r - - -We also have the following rules: - -For all datacon_i in type T, where a_1 .. a_n are universally quantified -and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p, -then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R, -then roles(T) = r_1 .. r_n - -roles(->) = R, R -roles(~#) = N, N - -With -dcore-lint on, the output of this algorithm is checked in checkValidRoles, -called from checkValidTycon. - -Note [Role-checking data constructor arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a where - MkT :: Eq b => F a -> (a->a) -> T (G a) - -Then we want to check the roles at which 'a' is used -in MkT's type. We want to work on the user-written type, -so we need to take into account - * the arguments: (F a) and (a->a) - * the context: C a b - * the result type: (G a) -- this is in the eq_spec - - -Note [Coercions in role inference] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Is (t |> co1) representationally equal to (t |> co2)? Of course they are! Changing -the kind of a type is totally irrelevant to the representation of that type. So, -we want to totally ignore coercions when doing role inference. This includes omitting -any type variables that appear in nominal positions but only within coercions. --} - -type RolesInfo = Name -> [Role] - -type RoleEnv = NameEnv [Role] -- from tycon names to roles - --- This, and any of the functions it calls, must *not* look at the roles --- field of a tycon we are inferring roles about! --- See Note [Role inference] -inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role] -inferRoles hsc_src annots tycons - = let role_env = initialRoleEnv hsc_src annots tycons - role_env' = irGroup role_env tycons in - \name -> case lookupNameEnv role_env' name of - Just roles -> roles - Nothing -> pprPanic "inferRoles" (ppr name) - -initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv -initialRoleEnv hsc_src annots = extendNameEnvList emptyNameEnv . - map (initialRoleEnv1 hsc_src annots) - -initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role]) -initialRoleEnv1 hsc_src annots_env tc - | isFamilyTyCon tc = (name, map (const Nominal) bndrs) - | isAlgTyCon tc = (name, default_roles) - | isTypeSynonymTyCon tc = (name, default_roles) - | otherwise = pprPanic "initialRoleEnv1" (ppr tc) - where name = tyConName tc - bndrs = tyConBinders tc - argflags = map tyConBinderArgFlag bndrs - num_exps = count isVisibleArgFlag argflags - - -- if the number of annotations in the role annotation decl - -- is wrong, just ignore it. We check this in the validity check. - role_annots - = case lookupRoleAnnot annots_env name of - Just (L _ (RoleAnnotDecl _ _ annots)) - | annots `lengthIs` num_exps -> map unLoc annots - _ -> replicate num_exps Nothing - default_roles = build_default_roles argflags role_annots - - build_default_roles (argf : argfs) (m_annot : ras) - | isVisibleArgFlag argf - = (m_annot `orElse` default_role) : build_default_roles argfs ras - build_default_roles (_argf : argfs) ras - = Nominal : build_default_roles argfs ras - build_default_roles [] [] = [] - build_default_roles _ _ = pprPanic "initialRoleEnv1 (2)" - (vcat [ppr tc, ppr role_annots]) - - default_role - | isClassTyCon tc = Nominal - -- Note [Default roles for abstract TyCons in hs-boot/hsig] - | HsBootFile <- hsc_src - , isAbstractTyCon tc = Representational - | HsigFile <- hsc_src - , isAbstractTyCon tc = Nominal - | otherwise = Phantom - --- Note [Default roles for abstract TyCons in hs-boot/hsig] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- What should the default role for an abstract TyCon be? --- --- Originally, we inferred phantom role for abstract TyCons --- in hs-boot files, because the type variables were never used. --- --- This was silly, because the role of the abstract TyCon --- was required to match the implementation, and the roles of --- data types are almost never phantom. Thus, in ticket #9204, --- the default was changed so be representational (the most common case). If --- the implementing data type was actually nominal, you'd get an easy --- to understand error, and add the role annotation yourself. --- --- Then Backpack was added, and with it we added role *subtyping* --- the matching judgment: if an abstract TyCon has a nominal --- parameter, it's OK to implement it with a representational --- parameter. But now, the representational default is not a good --- one, because you should *only* request representational if --- you're planning to do coercions. To be maximally flexible --- with what data types you will accept, you want the default --- for hsig files is nominal. We don't allow role subtyping --- with hs-boot files (it's good practice to give an exactly --- accurate role here, because any types that use the abstract --- type will propagate the role information.) - -irGroup :: RoleEnv -> [TyCon] -> RoleEnv -irGroup env tcs - = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in - if update - then irGroup env' tcs - else env' - -irTyCon :: TyCon -> RoleM () -irTyCon tc - | isAlgTyCon tc - = do { old_roles <- lookupRoles tc - ; unless (all (== Nominal) old_roles) $ -- also catches data families, - -- which don't want or need role inference - irTcTyVars tc $ - do { mapM_ (irType emptyVarSet) (tyConStupidTheta tc) -- See #8958 - ; whenIsJust (tyConClass_maybe tc) irClass - ; mapM_ irDataCon (visibleDataCons $ algTyConRhs tc) }} - - | Just ty <- synTyConRhs_maybe tc - = irTcTyVars tc $ - irType emptyVarSet ty - - | otherwise - = return () - --- any type variable used in an associated type must be Nominal -irClass :: Class -> RoleM () -irClass cls - = mapM_ ir_at (classATs cls) - where - cls_tvs = classTyVars cls - cls_tv_set = mkVarSet cls_tvs - - ir_at at_tc - = mapM_ (updateRole Nominal) nvars - where nvars = filter (`elemVarSet` cls_tv_set) $ tyConTyVars at_tc - --- See Note [Role inference] -irDataCon :: DataCon -> RoleM () -irDataCon datacon - = setRoleInferenceVars univ_tvs $ - irExTyVars ex_tvs $ \ ex_var_set -> - mapM_ (irType ex_var_set) - (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ arg_tys) - -- See Note [Role-checking data constructor arguments] - where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) - = dataConFullSig datacon - -irType :: VarSet -> Type -> RoleM () -irType = go - where - go lcls ty | Just ty' <- coreView ty -- #14101 - = go lcls ty' - go lcls (TyVarTy tv) = unless (tv `elemVarSet` lcls) $ - updateRole Representational tv - go lcls (AppTy t1 t2) = go lcls t1 >> markNominal lcls t2 - go lcls (TyConApp tc tys) = do { roles <- lookupRolesX tc - ; zipWithM_ (go_app lcls) roles tys } - go lcls (ForAllTy tvb ty) = do { let tv = binderVar tvb - lcls' = extendVarSet lcls tv - ; markNominal lcls (tyVarKind tv) - ; go lcls' ty } - go lcls (FunTy _ arg res) = go lcls arg >> go lcls res - go _ (LitTy {}) = return () - -- See Note [Coercions in role inference] - go lcls (CastTy ty _) = go lcls ty - go _ (CoercionTy _) = return () - - go_app _ Phantom _ = return () -- nothing to do here - go_app lcls Nominal ty = markNominal lcls ty -- all vars below here are N - go_app lcls Representational ty = go lcls ty - -irTcTyVars :: TyCon -> RoleM a -> RoleM a -irTcTyVars tc thing - = setRoleInferenceTc (tyConName tc) $ go (tyConTyVars tc) - where - go [] = thing - go (tv:tvs) = do { markNominal emptyVarSet (tyVarKind tv) - ; addRoleInferenceVar tv $ go tvs } - -irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a -irExTyVars orig_tvs thing = go emptyVarSet orig_tvs - where - go lcls [] = thing lcls - go lcls (tv:tvs) = do { markNominal lcls (tyVarKind tv) - ; go (extendVarSet lcls tv) tvs } - -markNominal :: TyVarSet -- local variables - -> Type -> RoleM () -markNominal lcls ty = let nvars = fvVarList (FV.delFVs lcls $ get_ty_vars ty) in - mapM_ (updateRole Nominal) nvars - where - -- get_ty_vars gets all the tyvars (no covars!) from a type *without* - -- recurring into coercions. Recall: coercions are totally ignored during - -- role inference. See [Coercions in role inference] - get_ty_vars :: Type -> FV - get_ty_vars (TyVarTy tv) = unitFV tv - get_ty_vars (AppTy t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 - get_ty_vars (FunTy _ t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 - get_ty_vars (TyConApp _ tys) = mapUnionFV get_ty_vars tys - get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty) - get_ty_vars (LitTy {}) = emptyFV - get_ty_vars (CastTy ty _) = get_ty_vars ty - get_ty_vars (CoercionTy _) = emptyFV - --- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps -lookupRolesX :: TyCon -> RoleM [Role] -lookupRolesX tc - = do { roles <- lookupRoles tc - ; return $ roles ++ repeat Nominal } - --- gets the roles either from the environment or the tycon -lookupRoles :: TyCon -> RoleM [Role] -lookupRoles tc - = do { env <- getRoleEnv - ; case lookupNameEnv env (tyConName tc) of - Just roles -> return roles - Nothing -> return $ tyConRoles tc } - --- tries to update a role; won't ever update a role "downwards" -updateRole :: Role -> TyVar -> RoleM () -updateRole role tv - = do { var_ns <- getVarNs - ; name <- getTyConName - ; case lookupVarEnv var_ns tv of - Nothing -> pprPanic "updateRole" (ppr name $$ ppr tv $$ ppr var_ns) - Just n -> updateRoleEnv name n role } - --- the state in the RoleM monad -data RoleInferenceState = RIS { role_env :: RoleEnv - , update :: Bool } - --- the environment in the RoleM monad -type VarPositions = VarEnv Int - --- See [Role inference] -newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon - -> VarPositions - -> Int -- size of VarPositions - -> RoleInferenceState - -> (a, RoleInferenceState) } - deriving (Functor) - -instance Applicative RoleM where - pure x = RM $ \_ _ _ state -> (x, state) - (<*>) = ap - -instance Monad RoleM where - a >>= f = RM $ \m_info vps nvps state -> - let (a', state') = unRM a m_info vps nvps state in - unRM (f a') m_info vps nvps state' - -runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool) -runRoleM env thing = (env', update) - where RIS { role_env = env', update = update } - = snd $ unRM thing Nothing emptyVarEnv 0 state - state = RIS { role_env = env - , update = False } - -setRoleInferenceTc :: Name -> RoleM a -> RoleM a -setRoleInferenceTc name thing = RM $ \m_name vps nvps state -> - ASSERT( isNothing m_name ) - ASSERT( isEmptyVarEnv vps ) - ASSERT( nvps == 0 ) - unRM thing (Just name) vps nvps state - -addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a -addRoleInferenceVar tv thing - = RM $ \m_name vps nvps state -> - ASSERT( isJust m_name ) - unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state - -setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a -setRoleInferenceVars tvs thing - = RM $ \m_name _vps _nvps state -> - ASSERT( isJust m_name ) - unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars") - state - -getRoleEnv :: RoleM RoleEnv -getRoleEnv = RM $ \_ _ _ state@(RIS { role_env = env }) -> (env, state) - -getVarNs :: RoleM VarPositions -getVarNs = RM $ \_ vps _ state -> (vps, state) - -getTyConName :: RoleM Name -getTyConName = RM $ \m_name _ _ state -> - case m_name of - Nothing -> panic "getTyConName" - Just name -> (name, state) - -updateRoleEnv :: Name -> Int -> Role -> RoleM () -updateRoleEnv name n role - = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((), - case lookupNameEnv role_env name of - Nothing -> pprPanic "updateRoleEnv" (ppr name) - Just roles -> let (before, old_role : after) = splitAt n roles in - if role `ltRole` old_role - then let roles' = before ++ role : after - role_env' = extendNameEnv role_env name roles' in - RIS { role_env = role_env', update = True } - else state ) - - -{- ********************************************************************* -* * - Building implicits -* * -********************************************************************* -} - -addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv --- Given a [TyCon], add to the TcGblEnv --- * extend the TypeEnv with the tycons --- * extend the TypeEnv with their implicitTyThings --- * extend the TypeEnv with any default method Ids --- * add bindings for record selectors -addTyConsToGblEnv tyclss - = tcExtendTyConEnv tyclss $ - tcExtendGlobalEnvImplicit implicit_things $ - tcExtendGlobalValEnv def_meth_ids $ - do { traceTc "tcAddTyCons" $ vcat - [ text "tycons" <+> ppr tyclss - , text "implicits" <+> ppr implicit_things ] - ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss) - ; return gbl_env } - where - implicit_things = concatMap implicitTyConThings tyclss - def_meth_ids = mkDefaultMethodIds tyclss - -mkDefaultMethodIds :: [TyCon] -> [Id] --- We want to put the default-method Ids (both vanilla and generic) --- into the type environment so that they are found when we typecheck --- the filled-in default methods of each instance declaration --- See Note [Default method Ids and Template Haskell] -mkDefaultMethodIds tycons - = [ mkExportedVanillaId dm_name (mkDefaultMethodType cls sel_id dm_spec) - | tc <- tycons - , Just cls <- [tyConClass_maybe tc] - , (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ] - -mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type --- Returns the top-level type of the default method -mkDefaultMethodType _ sel_id VanillaDM = idType sel_id -mkDefaultMethodType cls _ (GenericDM dm_ty) = mkSigmaTy tv_bndrs [pred] dm_ty - where - pred = mkClassPred cls (mkTyVarTys (binderVars cls_bndrs)) - cls_bndrs = tyConBinders (classTyCon cls) - tv_bndrs = tyConTyVarBinders cls_bndrs - -- NB: the Class doesn't have TyConBinders; we reach into its - -- TyCon to get those. We /do/ need the TyConBinders because - -- we need the correct visibility: these default methods are - -- used in code generated by the fill-in for missing - -- methods in instances (TcInstDcls.mkDefMethBind), and - -- then typechecked. So we need the right visibility info - -- (#13998) - -{- -************************************************************************ -* * - Building record selectors -* * -************************************************************************ --} - -{- -Note [Default method Ids and Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#4169): - class Numeric a where - fromIntegerNum :: a - fromIntegerNum = ... - - ast :: Q [Dec] - ast = [d| instance Numeric Int |] - -When we typecheck 'ast' we have done the first pass over the class decl -(in tcTyClDecls), but we have not yet typechecked the default-method -declarations (because they can mention value declarations). So we -must bring the default method Ids into scope first (so they can be seen -when typechecking the [d| .. |] quote, and typecheck them later. --} - -{- -************************************************************************ -* * - Building record selectors -* * -************************************************************************ --} - -tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv -tcRecSelBinds sel_bind_prs - = tcExtendGlobalValEnv [sel_id | (L _ (IdSig _ sel_id)) <- sigs] $ - do { (rec_sel_binds, tcg_env) <- discardWarnings $ - tcValBinds TopLevel binds sigs getGblEnv - ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } - where - sigs = [ L loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs - , let loc = getSrcSpan sel_id ] - binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] - -mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)] --- NB We produce *un-typechecked* bindings, rather like 'deriving' --- This makes life easier, because the later type checking will add --- all necessary type abstractions and applications -mkRecSelBinds tycons - = map mkRecSelBind [ (tc,fld) | tc <- tycons - , fld <- tyConFieldLabels tc ] - -mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn) -mkRecSelBind (tycon, fl) - = mkOneRecordSelector all_cons (RecSelData tycon) fl - where - all_cons = map RealDataCon (tyConDataCons tycon) - -mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel - -> (Id, LHsBind GhcRn) -mkOneRecordSelector all_cons idDetails fl - = (sel_id, L loc sel_bind) - where - loc = getSrcSpan sel_name - lbl = flLabel fl - sel_name = flSelector fl - - sel_id = mkExportedLocalId rec_details sel_name sel_ty - rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty } - - -- Find a representative constructor, con1 - cons_w_field = conLikesWithFields all_cons [lbl] - con1 = ASSERT( not (null cons_w_field) ) head cons_w_field - - -- Selector type; Note [Polymorphic selectors] - field_ty = conLikeFieldType con1 lbl - data_tvs = tyCoVarsOfTypesWellScoped inst_tys - data_tv_set= mkVarSet data_tvs - is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set) - (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty - sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] - | otherwise = mkSpecForAllTys data_tvs $ - mkPhiTy (conLikeStupidTheta con1) $ -- Urgh! - mkVisFunTy data_ty $ - mkSpecForAllTys field_tvs $ - mkPhiTy field_theta $ - -- req_theta is empty for normal DataCon - mkPhiTy req_theta $ - field_tau - - -- 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 - where - alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname) - [] unit_rhs] - | otherwise = map mk_match cons_w_field ++ deflt - mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) - [L loc (mk_sel_pat con)] - (L loc (HsVar noExtField (L loc field_var))) - mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) - rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } - rec_field = noLoc (HsRecField - { hsRecFieldLbl - = L loc (FieldOcc sel_name - (L loc $ mkVarUnqual lbl)) - , hsRecFieldArg - = L loc (VarPat noExtField (L loc field_var)) - , hsRecPun = False }) - sel_lname = L loc sel_name - field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc - - -- Add catch-all default case unless the case is exhaustive - -- We do this explicitly so that we get a nice error message that - -- mentions this particular record selector - deflt | all dealt_with all_cons = [] - | otherwise = [mkSimpleMatch CaseAlt - [L loc (WildPat noExtField)] - (mkHsApp (L loc (HsVar noExtField - (L loc (getName rEC_SEL_ERROR_ID)))) - (L loc (HsLit noExtField msg_lit)))] - - -- Do not add a default case unless there are unmatched - -- constructors. We must take account of GADTs, else we - -- get overlap warning messages from the pattern-match checker - -- NB: we need to pass type args for the *representation* TyCon - -- to dataConCannotMatch, hence the calculation of inst_tys - -- This matters in data families - -- data instance T Int a where - -- A :: { fld :: Int } -> T Int Bool - -- B :: { fld :: Int } -> T Int Char - dealt_with :: ConLike -> Bool - dealt_with (PatSynCon _) = False -- We can't predict overlap - dealt_with con@(RealDataCon dc) = - con `elem` cons_w_field || dataConCannotMatch inst_tys dc - - (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1 - - eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) - inst_tys = substTyVars eq_subst univ_tvs - - unit_rhs = mkLHsTupleExpr [] - msg_lit = HsStringPrim NoSourceText (bytesFS lbl) - -{- -Note [Polymorphic selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We take care to build the type of a polymorphic selector in the right -order, so that visible type application works. - - data Ord a => T a = MkT { field :: forall b. (Num a, Show b) => (a, b) } - -We want - - field :: forall a. Ord a => T a -> forall b. (Num a, Show b) => (a, b) - -Note [Naughty record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "naughty" field is one for which we can't define a record -selector, because an existential type variable would escape. For example: - data T = forall a. MkT { x,y::a } -We obviously can't define - x (MkT v _) = v -Nevertheless we *do* put a RecSelId into the type environment -so that if the user tries to use 'x' as a selector we can bleat -helpfully, rather than saying unhelpfully that 'x' is not in scope. -Hence the sel_naughty flag, to identify record selectors that don't really exist. - -In general, a field is "naughty" if its type mentions a type variable that -isn't in the result type of the constructor. Note that this *allows* -GADT record selectors (Note [GADT record selectors]) whose types may look -like sel :: T [a] -> a - -For naughty selectors we make a dummy binding - sel = () -so that the later type-check will add them to the environment, and they'll be -exported. The function is never called, because the typechecker spots the -sel_naughty field. - -Note [GADT record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For GADTs, we require that all constructors with a common field 'f' have the same -result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon] -E.g. - data T where - T1 { f :: Maybe a } :: T [a] - T2 { f :: Maybe a, y :: b } :: T [a] - T3 :: T Int - -and now the selector takes that result type as its argument: - f :: forall a. T [a] -> Maybe a - -Details: the "real" types of T1,T2 are: - T1 :: forall r a. (r~[a]) => a -> T r - T2 :: forall r a b. (r~[a]) => a -> b -> T r - -So the selector loooks like this: - f :: forall a. T [a] -> Maybe a - f (a:*) (t:T [a]) - = case t of - T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g)) - T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g)) - T3 -> error "T3 does not have field f" - -Note the forall'd tyvars of the selector are just the free tyvars -of the result type; there may be other tyvars in the constructor's -type (e.g. 'b' in T2). - -Note the need for casts in the result! - -Note [Selector running example] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's OK to combine GADTs and type families. Here's a running example: - - data instance T [a] where - T1 { fld :: b } :: T [Maybe b] - -The representation type looks like this - data :R7T a where - T1 { fld :: b } :: :R7T (Maybe b) - -and there's coercion from the family type to the representation type - :CoR7T a :: T [a] ~ :R7T a - -The selector we want for fld looks like this: - - fld :: forall b. T [Maybe b] -> b - fld = /\b. \(d::T [Maybe b]). - case d `cast` :CoR7T (Maybe b) of - T1 (x::b) -> x - -The scrutinee of the case has type :R7T (Maybe b), which can be -gotten by applying the eq_spec to the univ_tvs of the data con. - --} diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs deleted file mode 100644 --- a/compiler/typecheck/TcTypeNats.hs +++ /dev/null @@ -1,992 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module TcTypeNats - ( typeNatTyCons - , typeNatCoAxiomRules - , BuiltInSynFamily(..) - - -- If you define a new built-in type family, make sure to export its TyCon - -- from here as well. - -- See Note [Adding built-in type families] - , typeNatAddTyCon - , typeNatMulTyCon - , typeNatExpTyCon - , typeNatLeqTyCon - , typeNatSubTyCon - , typeNatDivTyCon - , typeNatModTyCon - , typeNatLogTyCon - , typeNatCmpTyCon - , typeSymbolCmpTyCon - , typeSymbolAppendTyCon - ) where - -import GhcPrelude - -import GHC.Core.Type -import Pair -import TcType ( TcType, tcEqType ) -import GHC.Core.TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon - , Injectivity(..) ) -import GHC.Core.Coercion ( Role(..) ) -import Constraint ( Xi ) -import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn ) -import GHC.Types.Name ( Name, BuiltInSyntax(..) ) -import TysWiredIn -import TysPrim ( mkTemplateAnonTyConBinders ) -import PrelNames ( gHC_TYPELITS - , gHC_TYPENATS - , typeNatAddTyFamNameKey - , typeNatMulTyFamNameKey - , typeNatExpTyFamNameKey - , typeNatLeqTyFamNameKey - , typeNatSubTyFamNameKey - , typeNatDivTyFamNameKey - , typeNatModTyFamNameKey - , typeNatLogTyFamNameKey - , typeNatCmpTyFamNameKey - , typeSymbolCmpTyFamNameKey - , typeSymbolAppendFamNameKey - ) -import FastString ( FastString - , fsLit, nilFS, nullFS, unpackFS, mkFastString, appendFS - ) -import qualified Data.Map as Map -import Data.Maybe ( isJust ) -import Control.Monad ( guard ) -import Data.List ( isPrefixOf, isSuffixOf ) - -{- -Note [Type-level literals] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are currently two forms of type-level literals: natural numbers, and -symbols (even though this module is named TcTypeNats, it covers both). - -Type-level literals are supported by CoAxiomRules (conditional axioms), which -power the built-in type families (see Note [Adding built-in type families]). -Currently, all built-in type families are for the express purpose of supporting -type-level literals. - -See also the Wiki page: - - https://gitlab.haskell.org/ghc/ghc/wikis/type-nats - -Note [Adding built-in type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are a few steps to adding a built-in type family: - -* Adding a unique for the type family TyCon - - These go in PrelNames. It will likely be of the form - @myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that - has not been chosen before in PrelNames. There are several examples already - in PrelNames—see, for instance, typeNatAddTyFamNameKey. - -* Adding the type family TyCon itself - - This goes in TcTypeNats. There are plenty of examples of how to define - these—see, for instance, typeNatAddTyCon. - - Once your TyCon has been defined, be sure to: - - - Export it from TcTypeNats. (Not doing so caused #14632.) - - Include it in the typeNatTyCons list, defined in TcTypeNats. - -* Exposing associated type family axioms - - When defining the type family TyCon, you will need to define an axiom for - the type family in general (see, for instance, axAddDef), and perhaps other - auxiliary axioms for special cases of the type family (see, for instance, - axAdd0L and axAdd0R). - - After you have defined all of these axioms, be sure to include them in the - typeNatCoAxiomRules list, defined in TcTypeNats. - (Not doing so caused #14934.) - -* Define the type family somewhere - - Finally, you will need to define the type family somewhere, likely in @base@. - Currently, all of the built-in type families are defined in GHC.TypeLits or - GHC.TypeNats, so those are likely candidates. - - Since the behavior of your built-in type family is specified in TcTypeNats, - you should give an open type family definition with no instances, like so: - - type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat - - Changing the argument and result kinds as appropriate. - -* Update the relevant test cases - - The GHC test suite will likely need to be updated after you add your built-in - type family. For instance: - - - The T9181 test prints the :browse contents of GHC.TypeLits, so if you added - a test there, the expected output of T9181 will need to change. - - The TcTypeNatSimple and TcTypeSymbolSimple tests have compile-time unit - tests, as well as TcTypeNatSimpleRun and TcTypeSymbolSimpleRun, which have - runtime unit tests. Consider adding further unit tests to those if your - built-in type family deals with Nats or Symbols, respectively. --} - -{------------------------------------------------------------------------------- -Built-in type constructors for functions on type-level nats --} - --- The list of built-in type family TyCons that GHC uses. --- If you define a built-in type family, make sure to add it to this list. --- See Note [Adding built-in type families] -typeNatTyCons :: [TyCon] -typeNatTyCons = - [ typeNatAddTyCon - , typeNatMulTyCon - , typeNatExpTyCon - , typeNatLeqTyCon - , typeNatSubTyCon - , typeNatDivTyCon - , typeNatModTyCon - , typeNatLogTyCon - , typeNatCmpTyCon - , typeSymbolCmpTyCon - , typeSymbolAppendTyCon - ] - -typeNatAddTyCon :: TyCon -typeNatAddTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamAdd - , sfInteractTop = interactTopAdd - , sfInteractInert = interactInertAdd - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "+") - typeNatAddTyFamNameKey typeNatAddTyCon - -typeNatSubTyCon :: TyCon -typeNatSubTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamSub - , sfInteractTop = interactTopSub - , sfInteractInert = interactInertSub - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "-") - typeNatSubTyFamNameKey typeNatSubTyCon - -typeNatMulTyCon :: TyCon -typeNatMulTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamMul - , sfInteractTop = interactTopMul - , sfInteractInert = interactInertMul - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "*") - typeNatMulTyFamNameKey typeNatMulTyCon - -typeNatDivTyCon :: TyCon -typeNatDivTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamDiv - , sfInteractTop = interactTopDiv - , sfInteractInert = interactInertDiv - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Div") - typeNatDivTyFamNameKey typeNatDivTyCon - -typeNatModTyCon :: TyCon -typeNatModTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamMod - , sfInteractTop = interactTopMod - , sfInteractInert = interactInertMod - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod") - typeNatModTyFamNameKey typeNatModTyCon - - - - - -typeNatExpTyCon :: TyCon -typeNatExpTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamExp - , sfInteractTop = interactTopExp - , sfInteractInert = interactInertExp - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "^") - typeNatExpTyFamNameKey typeNatExpTyCon - -typeNatLogTyCon :: TyCon -typeNatLogTyCon = mkTypeNatFunTyCon1 name - BuiltInSynFamily - { sfMatchFam = matchFamLog - , sfInteractTop = interactTopLog - , sfInteractInert = interactInertLog - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2") - typeNatLogTyFamNameKey typeNatLogTyCon - - - -typeNatLeqTyCon :: TyCon -typeNatLeqTyCon = - mkFamilyTyCon name - (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) - boolTy - Nothing - (BuiltInSynFamTyCon ops) - Nothing - NotInjective - - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "<=?") - typeNatLeqTyFamNameKey typeNatLeqTyCon - ops = BuiltInSynFamily - { sfMatchFam = matchFamLeq - , sfInteractTop = interactTopLeq - , sfInteractInert = interactInertLeq - } - -typeNatCmpTyCon :: TyCon -typeNatCmpTyCon = - mkFamilyTyCon name - (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) - orderingKind - Nothing - (BuiltInSynFamTyCon ops) - Nothing - NotInjective - - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "CmpNat") - typeNatCmpTyFamNameKey typeNatCmpTyCon - ops = BuiltInSynFamily - { sfMatchFam = matchFamCmpNat - , sfInteractTop = interactTopCmpNat - , sfInteractInert = \_ _ _ _ -> [] - } - -typeSymbolCmpTyCon :: TyCon -typeSymbolCmpTyCon = - mkFamilyTyCon name - (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ]) - orderingKind - Nothing - (BuiltInSynFamTyCon ops) - Nothing - NotInjective - - where - name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpSymbol") - typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon - ops = BuiltInSynFamily - { sfMatchFam = matchFamCmpSymbol - , sfInteractTop = interactTopCmpSymbol - , sfInteractInert = \_ _ _ _ -> [] - } - -typeSymbolAppendTyCon :: TyCon -typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamAppendSymbol - , sfInteractTop = interactTopAppendSymbol - , sfInteractInert = interactInertAppendSymbol - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol") - typeSymbolAppendFamNameKey typeSymbolAppendTyCon - - - --- Make a unary built-in constructor of kind: Nat -> Nat -mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon -mkTypeNatFunTyCon1 op tcb = - mkFamilyTyCon op - (mkTemplateAnonTyConBinders [ typeNatKind ]) - typeNatKind - Nothing - (BuiltInSynFamTyCon tcb) - Nothing - NotInjective - - --- Make a binary built-in constructor of kind: Nat -> Nat -> Nat -mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon -mkTypeNatFunTyCon2 op tcb = - mkFamilyTyCon op - (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) - typeNatKind - Nothing - (BuiltInSynFamTyCon tcb) - Nothing - NotInjective - --- Make a binary built-in constructor of kind: Symbol -> Symbol -> Symbol -mkTypeSymbolFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon -mkTypeSymbolFunTyCon2 op tcb = - mkFamilyTyCon op - (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ]) - typeSymbolKind - Nothing - (BuiltInSynFamTyCon tcb) - Nothing - NotInjective - - -{------------------------------------------------------------------------------- -Built-in rules axioms --------------------------------------------------------------------------------} - --- If you add additional rules, please remember to add them to --- `typeNatCoAxiomRules` also. --- See Note [Adding built-in type families] -axAddDef - , axMulDef - , axExpDef - , axLeqDef - , axCmpNatDef - , axCmpSymbolDef - , axAppendSymbolDef - , axAdd0L - , axAdd0R - , axMul0L - , axMul0R - , axMul1L - , axMul1R - , axExp1L - , axExp0R - , axExp1R - , axLeqRefl - , axCmpNatRefl - , axCmpSymbolRefl - , axLeq0L - , axSubDef - , axSub0R - , axAppendSymbol0R - , axAppendSymbol0L - , axDivDef - , axDiv1 - , axModDef - , axMod1 - , axLogDef - :: CoAxiomRule - -axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon $ - \x y -> Just $ num (x + y) - -axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon $ - \x y -> Just $ num (x * y) - -axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon $ - \x y -> Just $ num (x ^ y) - -axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon $ - \x y -> Just $ bool (x <= y) - -axCmpNatDef = mkBinAxiom "CmpNatDef" typeNatCmpTyCon - $ \x y -> Just $ ordering (compare x y) - -axCmpSymbolDef = - CoAxiomRule - { coaxrName = fsLit "CmpSymbolDef" - , coaxrAsmpRoles = [Nominal, Nominal] - , coaxrRole = Nominal - , coaxrProves = \cs -> - do [Pair s1 s2, Pair t1 t2] <- return cs - s2' <- isStrLitTy s2 - t2' <- isStrLitTy t2 - return (mkTyConApp typeSymbolCmpTyCon [s1,t1] === - ordering (compare s2' t2')) } - -axAppendSymbolDef = CoAxiomRule - { coaxrName = fsLit "AppendSymbolDef" - , coaxrAsmpRoles = [Nominal, Nominal] - , coaxrRole = Nominal - , coaxrProves = \cs -> - do [Pair s1 s2, Pair t1 t2] <- return cs - s2' <- isStrLitTy s2 - t2' <- isStrLitTy t2 - let z = mkStrLitTy (appendFS s2' t2') - return (mkTyConApp typeSymbolAppendTyCon [s1, t1] === z) - } - -axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $ - \x y -> fmap num (minus x y) - -axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon $ - \x y -> do guard (y /= 0) - return (num (div x y)) - -axModDef = mkBinAxiom "ModDef" typeNatModTyCon $ - \x y -> do guard (y /= 0) - return (num (mod x y)) - -axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon $ - \x -> do (a,_) <- genLog x 2 - return (num a) - -axAdd0L = mkAxiom1 "Add0L" $ \(Pair s t) -> (num 0 .+. s) === t -axAdd0R = mkAxiom1 "Add0R" $ \(Pair s t) -> (s .+. num 0) === t -axSub0R = mkAxiom1 "Sub0R" $ \(Pair s t) -> (s .-. num 0) === t -axMul0L = mkAxiom1 "Mul0L" $ \(Pair s _) -> (num 0 .*. s) === num 0 -axMul0R = mkAxiom1 "Mul0R" $ \(Pair s _) -> (s .*. num 0) === num 0 -axMul1L = mkAxiom1 "Mul1L" $ \(Pair s t) -> (num 1 .*. s) === t -axMul1R = mkAxiom1 "Mul1R" $ \(Pair s t) -> (s .*. num 1) === t -axDiv1 = mkAxiom1 "Div1" $ \(Pair s t) -> (tDiv s (num 1) === t) -axMod1 = mkAxiom1 "Mod1" $ \(Pair s _) -> (tMod s (num 1) === num 0) - -- XXX: Shouldn't we check that _ is 0? -axExp1L = mkAxiom1 "Exp1L" $ \(Pair s _) -> (num 1 .^. s) === num 1 -axExp0R = mkAxiom1 "Exp0R" $ \(Pair s _) -> (s .^. num 0) === num 1 -axExp1R = mkAxiom1 "Exp1R" $ \(Pair s t) -> (s .^. num 1) === t -axLeqRefl = mkAxiom1 "LeqRefl" $ \(Pair s _) -> (s <== s) === bool True -axCmpNatRefl = mkAxiom1 "CmpNatRefl" - $ \(Pair s _) -> (cmpNat s s) === ordering EQ -axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl" - $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ -axLeq0L = mkAxiom1 "Leq0L" $ \(Pair s _) -> (num 0 <== s) === bool True -axAppendSymbol0R = mkAxiom1 "Concat0R" - $ \(Pair s t) -> (mkStrLitTy nilFS `appendSymbol` s) === t -axAppendSymbol0L = mkAxiom1 "Concat0L" - $ \(Pair s t) -> (s `appendSymbol` mkStrLitTy nilFS) === t - --- The list of built-in type family axioms that GHC uses. --- If you define new axioms, make sure to include them in this list. --- See Note [Adding built-in type families] -typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule -typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x)) - [ axAddDef - , axMulDef - , axExpDef - , axLeqDef - , axCmpNatDef - , axCmpSymbolDef - , axAppendSymbolDef - , axAdd0L - , axAdd0R - , axMul0L - , axMul0R - , axMul1L - , axMul1R - , axExp1L - , axExp0R - , axExp1R - , axLeqRefl - , axCmpNatRefl - , axCmpSymbolRefl - , axLeq0L - , axSubDef - , axSub0R - , axAppendSymbol0R - , axAppendSymbol0L - , axDivDef - , axDiv1 - , axModDef - , axMod1 - , axLogDef - ] - - - -{------------------------------------------------------------------------------- -Various utilities for making axioms and types --------------------------------------------------------------------------------} - -(.+.) :: Type -> Type -> Type -s .+. t = mkTyConApp typeNatAddTyCon [s,t] - -(.-.) :: Type -> Type -> Type -s .-. t = mkTyConApp typeNatSubTyCon [s,t] - -(.*.) :: Type -> Type -> Type -s .*. t = mkTyConApp typeNatMulTyCon [s,t] - -tDiv :: Type -> Type -> Type -tDiv s t = mkTyConApp typeNatDivTyCon [s,t] - -tMod :: Type -> Type -> Type -tMod s t = mkTyConApp typeNatModTyCon [s,t] - -(.^.) :: Type -> Type -> Type -s .^. t = mkTyConApp typeNatExpTyCon [s,t] - -(<==) :: Type -> Type -> Type -s <== t = mkTyConApp typeNatLeqTyCon [s,t] - -cmpNat :: Type -> Type -> Type -cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t] - -cmpSymbol :: Type -> Type -> Type -cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t] - -appendSymbol :: Type -> Type -> Type -appendSymbol s t = mkTyConApp typeSymbolAppendTyCon [s, t] - -(===) :: Type -> Type -> Pair Type -x === y = Pair x y - -num :: Integer -> Type -num = mkNumLitTy - -bool :: Bool -> Type -bool b = if b then mkTyConApp promotedTrueDataCon [] - else mkTyConApp promotedFalseDataCon [] - -isBoolLitTy :: Type -> Maybe Bool -isBoolLitTy tc = - do (tc,[]) <- splitTyConApp_maybe tc - case () of - _ | tc == promotedFalseDataCon -> return False - | tc == promotedTrueDataCon -> return True - | otherwise -> Nothing - -orderingKind :: Kind -orderingKind = mkTyConApp orderingTyCon [] - -ordering :: Ordering -> Type -ordering o = - case o of - LT -> mkTyConApp promotedLTDataCon [] - EQ -> mkTyConApp promotedEQDataCon [] - GT -> mkTyConApp promotedGTDataCon [] - -isOrderingLitTy :: Type -> Maybe Ordering -isOrderingLitTy tc = - do (tc1,[]) <- splitTyConApp_maybe tc - case () of - _ | tc1 == promotedLTDataCon -> return LT - | tc1 == promotedEQDataCon -> return EQ - | tc1 == promotedGTDataCon -> return GT - | otherwise -> Nothing - -known :: (Integer -> Bool) -> TcType -> Bool -known p x = case isNumLitTy x of - Just a -> p a - Nothing -> False - - -mkUnAxiom :: String -> TyCon -> (Integer -> Maybe Type) -> CoAxiomRule -mkUnAxiom str tc f = - CoAxiomRule - { coaxrName = fsLit str - , coaxrAsmpRoles = [Nominal] - , coaxrRole = Nominal - , coaxrProves = \cs -> - do [Pair s1 s2] <- return cs - s2' <- isNumLitTy s2 - z <- f s2' - return (mkTyConApp tc [s1] === z) - } - - - --- For the definitional axioms -mkBinAxiom :: String -> TyCon -> - (Integer -> Integer -> Maybe Type) -> CoAxiomRule -mkBinAxiom str tc f = - CoAxiomRule - { coaxrName = fsLit str - , coaxrAsmpRoles = [Nominal, Nominal] - , coaxrRole = Nominal - , coaxrProves = \cs -> - do [Pair s1 s2, Pair t1 t2] <- return cs - s2' <- isNumLitTy s2 - t2' <- isNumLitTy t2 - z <- f s2' t2' - return (mkTyConApp tc [s1,t1] === z) - } - - - -mkAxiom1 :: String -> (TypeEqn -> TypeEqn) -> CoAxiomRule -mkAxiom1 str f = - CoAxiomRule - { coaxrName = fsLit str - , coaxrAsmpRoles = [Nominal] - , coaxrRole = Nominal - , coaxrProves = \case [eqn] -> Just (f eqn) - _ -> Nothing - } - - -{------------------------------------------------------------------------------- -Evaluation --------------------------------------------------------------------------------} - -matchFamAdd :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamAdd [s,t] - | Just 0 <- mbX = Just (axAdd0L, [t], t) - | Just 0 <- mbY = Just (axAdd0R, [s], s) - | Just x <- mbX, Just y <- mbY = - Just (axAddDef, [s,t], num (x + y)) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamAdd _ = Nothing - -matchFamSub :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamSub [s,t] - | Just 0 <- mbY = Just (axSub0R, [s], s) - | Just x <- mbX, Just y <- mbY, Just z <- minus x y = - Just (axSubDef, [s,t], num z) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamSub _ = Nothing - -matchFamMul :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamMul [s,t] - | Just 0 <- mbX = Just (axMul0L, [t], num 0) - | Just 0 <- mbY = Just (axMul0R, [s], num 0) - | Just 1 <- mbX = Just (axMul1L, [t], t) - | Just 1 <- mbY = Just (axMul1R, [s], s) - | Just x <- mbX, Just y <- mbY = - Just (axMulDef, [s,t], num (x * y)) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamMul _ = Nothing - -matchFamDiv :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamDiv [s,t] - | Just 1 <- mbY = Just (axDiv1, [s], s) - | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axDivDef, [s,t], num (div x y)) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamDiv _ = Nothing - -matchFamMod :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamMod [s,t] - | Just 1 <- mbY = Just (axMod1, [s], num 0) - | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axModDef, [s,t], num (mod x y)) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamMod _ = Nothing - - - -matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamExp [s,t] - | Just 0 <- mbY = Just (axExp0R, [s], num 1) - | Just 1 <- mbX = Just (axExp1L, [t], num 1) - | Just 1 <- mbY = Just (axExp1R, [s], s) - | Just x <- mbX, Just y <- mbY = - Just (axExpDef, [s,t], num (x ^ y)) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamExp _ = Nothing - -matchFamLog :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamLog [s] - | Just x <- mbX, Just (n,_) <- genLog x 2 = Just (axLogDef, [s], num n) - where mbX = isNumLitTy s -matchFamLog _ = Nothing - - -matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamLeq [s,t] - | Just 0 <- mbX = Just (axLeq0L, [t], bool True) - | Just x <- mbX, Just y <- mbY = - Just (axLeqDef, [s,t], bool (x <= y)) - | tcEqType s t = Just (axLeqRefl, [s], bool True) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamLeq _ = Nothing - -matchFamCmpNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamCmpNat [s,t] - | Just x <- mbX, Just y <- mbY = - Just (axCmpNatDef, [s,t], ordering (compare x y)) - | tcEqType s t = Just (axCmpNatRefl, [s], ordering EQ) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamCmpNat _ = Nothing - -matchFamCmpSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamCmpSymbol [s,t] - | Just x <- mbX, Just y <- mbY = - Just (axCmpSymbolDef, [s,t], ordering (compare x y)) - | tcEqType s t = Just (axCmpSymbolRefl, [s], ordering EQ) - where mbX = isStrLitTy s - mbY = isStrLitTy t -matchFamCmpSymbol _ = Nothing - -matchFamAppendSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamAppendSymbol [s,t] - | Just x <- mbX, nullFS x = Just (axAppendSymbol0R, [t], t) - | Just y <- mbY, nullFS y = Just (axAppendSymbol0L, [s], s) - | Just x <- mbX, Just y <- mbY = - Just (axAppendSymbolDef, [s,t], mkStrLitTy (appendFS x y)) - where - mbX = isStrLitTy s - mbY = isStrLitTy t -matchFamAppendSymbol _ = Nothing - -{------------------------------------------------------------------------------- -Interact with axioms --------------------------------------------------------------------------------} - -interactTopAdd :: [Xi] -> Xi -> [Pair Type] -interactTopAdd [s,t] r - | Just 0 <- mbZ = [ s === num 0, t === num 0 ] -- (s + t ~ 0) => (s ~ 0, t ~ 0) - | Just x <- mbX, Just z <- mbZ, Just y <- minus z x = [t === num y] -- (5 + t ~ 8) => (t ~ 3) - | Just y <- mbY, Just z <- mbZ, Just x <- minus z y = [s === num x] -- (s + 5 ~ 8) => (s ~ 3) - where - mbX = isNumLitTy s - mbY = isNumLitTy t - mbZ = isNumLitTy r -interactTopAdd _ _ = [] - -{- -Note [Weakened interaction rule for subtraction] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A simpler interaction here might be: - - `s - t ~ r` --> `t + r ~ s` - -This would enable us to reuse all the code for addition. -Unfortunately, this works a little too well at the moment. -Consider the following example: - - 0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0) - -This (correctly) spots that the constraint cannot be solved. - -However, this may be a problem if the constraint did not -need to be solved in the first place! Consider the following example: - -f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5 -f = id - -Currently, GHC is strict while evaluating functions, so this does not -work, because even though the `If` should evaluate to `5 - 0`, we -also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`, -which fails. - -So, for the time being, we only add an improvement when the RHS is a constant, -which happens to work OK for the moment, although clearly we need to do -something more general. --} -interactTopSub :: [Xi] -> Xi -> [Pair Type] -interactTopSub [s,t] r - | Just z <- mbZ = [ s === (num z .+. t) ] -- (s - t ~ 5) => (5 + t ~ s) - where - mbZ = isNumLitTy r -interactTopSub _ _ = [] - - - - - -interactTopMul :: [Xi] -> Xi -> [Pair Type] -interactTopMul [s,t] r - | Just 1 <- mbZ = [ s === num 1, t === num 1 ] -- (s * t ~ 1) => (s ~ 1, t ~ 1) - | Just x <- mbX, Just z <- mbZ, Just y <- divide z x = [t === num y] -- (3 * t ~ 15) => (t ~ 5) - | Just y <- mbY, Just z <- mbZ, Just x <- divide z y = [s === num x] -- (s * 3 ~ 15) => (s ~ 5) - where - mbX = isNumLitTy s - mbY = isNumLitTy t - mbZ = isNumLitTy r -interactTopMul _ _ = [] - -interactTopDiv :: [Xi] -> Xi -> [Pair Type] -interactTopDiv _ _ = [] -- I can't think of anything... - -interactTopMod :: [Xi] -> Xi -> [Pair Type] -interactTopMod _ _ = [] -- I can't think of anything... - -interactTopExp :: [Xi] -> Xi -> [Pair Type] -interactTopExp [s,t] r - | Just 0 <- mbZ = [ s === num 0 ] -- (s ^ t ~ 0) => (s ~ 0) - | Just x <- mbX, Just z <- mbZ, Just y <- logExact z x = [t === num y] -- (2 ^ t ~ 8) => (t ~ 3) - | Just y <- mbY, Just z <- mbZ, Just x <- rootExact z y = [s === num x] -- (s ^ 2 ~ 9) => (s ~ 3) - where - mbX = isNumLitTy s - mbY = isNumLitTy t - mbZ = isNumLitTy r -interactTopExp _ _ = [] - -interactTopLog :: [Xi] -> Xi -> [Pair Type] -interactTopLog _ _ = [] -- I can't think of anything... - - - -interactTopLeq :: [Xi] -> Xi -> [Pair Type] -interactTopLeq [s,t] r - | Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ] -- (s <= 0) => (s ~ 0) - where - mbY = isNumLitTy t - mbZ = isBoolLitTy r -interactTopLeq _ _ = [] - -interactTopCmpNat :: [Xi] -> Xi -> [Pair Type] -interactTopCmpNat [s,t] r - | Just EQ <- isOrderingLitTy r = [ s === t ] -interactTopCmpNat _ _ = [] - -interactTopCmpSymbol :: [Xi] -> Xi -> [Pair Type] -interactTopCmpSymbol [s,t] r - | Just EQ <- isOrderingLitTy r = [ s === t ] -interactTopCmpSymbol _ _ = [] - -interactTopAppendSymbol :: [Xi] -> Xi -> [Pair Type] -interactTopAppendSymbol [s,t] r - -- (AppendSymbol a b ~ "") => (a ~ "", b ~ "") - | Just z <- mbZ, nullFS z = - [s === mkStrLitTy nilFS, t === mkStrLitTy nilFS ] - - -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar") - | Just x <- fmap unpackFS mbX, Just z <- fmap unpackFS mbZ, x `isPrefixOf` z = - [ t === mkStrLitTy (mkFastString $ drop (length x) z) ] - - -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo") - | Just y <- fmap unpackFS mbY, Just z <- fmap unpackFS mbZ, y `isSuffixOf` z = - [ t === mkStrLitTy (mkFastString $ take (length z - length y) z) ] - - where - mbX = isStrLitTy s - mbY = isStrLitTy t - mbZ = isStrLitTy r - -interactTopAppendSymbol _ _ = [] - -{------------------------------------------------------------------------------- -Interaction with inerts --------------------------------------------------------------------------------} - -interactInertAdd :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertAdd [x1,y1] z1 [x2,y2] z2 - | sameZ && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 -interactInertAdd _ _ _ _ = [] - -interactInertSub :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertSub [x1,y1] z1 [x2,y2] z2 - | sameZ && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 -interactInertSub _ _ _ _ = [] - -interactInertMul :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertMul [x1,y1] z1 [x2,y2] z2 - | sameZ && known (/= 0) x1 && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && known (/= 0) y1 && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 - -interactInertMul _ _ _ _ = [] - -interactInertDiv :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertDiv _ _ _ _ = [] - -interactInertMod :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertMod _ _ _ _ = [] - -interactInertExp :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertExp [x1,y1] z1 [x2,y2] z2 - | sameZ && known (> 1) x1 && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && known (> 0) y1 && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 - -interactInertExp _ _ _ _ = [] - -interactInertLog :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertLog _ _ _ _ = [] - - -interactInertLeq :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertLeq [x1,y1] z1 [x2,y2] z2 - | bothTrue && tcEqType x1 y2 && tcEqType y1 x2 = [ x1 === y1 ] - | bothTrue && tcEqType y1 x2 = [ (x1 <== y2) === bool True ] - | bothTrue && tcEqType y2 x1 = [ (x2 <== y1) === bool True ] - where bothTrue = isJust $ do True <- isBoolLitTy z1 - True <- isBoolLitTy z2 - return () - -interactInertLeq _ _ _ _ = [] - - -interactInertAppendSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2 - | sameZ && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 -interactInertAppendSymbol _ _ _ _ = [] - - - -{- ----------------------------------------------------------------------------- -These inverse functions are used for simplifying propositions using -concrete natural numbers. ------------------------------------------------------------------------------ -} - --- | Subtract two natural numbers. -minus :: Integer -> Integer -> Maybe Integer -minus x y = if x >= y then Just (x - y) else Nothing - --- | Compute the exact logarithm of a natural number. --- The logarithm base is the second argument. -logExact :: Integer -> Integer -> Maybe Integer -logExact x y = do (z,True) <- genLog x y - return z - - --- | Divide two natural numbers. -divide :: Integer -> Integer -> Maybe Integer -divide _ 0 = Nothing -divide x y = case divMod x y of - (a,0) -> Just a - _ -> Nothing - --- | Compute the exact root of a natural number. --- The second argument specifies which root we are computing. -rootExact :: Integer -> Integer -> Maybe Integer -rootExact x y = do (z,True) <- genRoot x y - return z - - - -{- | Compute the n-th root of a natural number, rounded down to -the closest natural number. The boolean indicates if the result -is exact (i.e., True means no rounding was done, False means rounded down). -The second argument specifies which root we are computing. -} -genRoot :: Integer -> Integer -> Maybe (Integer, Bool) -genRoot _ 0 = Nothing -genRoot x0 1 = Just (x0, True) -genRoot x0 root = Just (search 0 (x0+1)) - where - search from to = let x = from + div (to - from) 2 - a = x ^ root - in case compare a x0 of - EQ -> (x, True) - LT | x /= from -> search x to - | otherwise -> (from, False) - GT | x /= to -> search from x - | otherwise -> (from, False) - -{- | Compute the logarithm of a number in the given base, rounded down to the -closest integer. The boolean indicates if we the result is exact -(i.e., True means no rounding happened, False means we rounded down). -The logarithm base is the second argument. -} -genLog :: Integer -> Integer -> Maybe (Integer, Bool) -genLog x 0 = if x == 1 then Just (0, True) else Nothing -genLog _ 1 = Nothing -genLog 0 _ = Nothing -genLog x base = Just (exactLoop 0 x) - where - exactLoop s i - | i == 1 = (s,True) - | i < base = (s,False) - | otherwise = - let s1 = s + 1 - in s1 `seq` case divMod i base of - (j,r) - | r == 0 -> exactLoop s1 j - | otherwise -> (underLoop s1 j, False) - - underLoop s i - | i < base = s - | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base) diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs deleted file mode 100644 --- a/compiler/typecheck/TcTypeable.hs +++ /dev/null @@ -1,759 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -module TcTypeable(mkTypeableBinds, tyConIsTypeable) where - -#include "HsVersions.h" - -import GhcPrelude -import GHC.Platform - -import GHC.Types.Basic ( Boxity(..), neverInlinePragma, SourceText(..) ) -import GHC.Iface.Env( newGlobalBinder ) -import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) -import TcEnv -import TcEvidence ( mkWpTyApps ) -import TcRnMonad -import TcType -import GHC.Driver.Types ( lookupId ) -import PrelNames -import TysPrim ( primTyCons ) -import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon - , vecCountTyCon, vecElemTyCon - , nilDataCon, consDataCon ) -import GHC.Types.Name -import GHC.Types.Id -import GHC.Core.Type -import GHC.Core.TyCon -import GHC.Core.DataCon -import GHC.Types.Module -import GHC.Hs -import GHC.Driver.Session -import Bag -import GHC.Types.Var ( VarBndr(..) ) -import GHC.Core.Map -import Constants -import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) -import Outputable -import FastString ( FastString, mkFastString, fsLit ) - -import Control.Monad.Trans.State -import Control.Monad.Trans.Class (lift) -import Data.Maybe ( isJust ) -import Data.Word( Word64 ) - -{- Note [Grand plan for Typeable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The overall plan is this: - -1. Generate a binding for each module p:M - (done in TcTypeable by mkModIdBindings) - M.$trModule :: GHC.Types.Module - M.$trModule = Module "p" "M" - ("tr" is short for "type representation"; see GHC.Types) - - We might want to add the filename too. - This can be used for the lightweight stack-tracing stuff too - - Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv - -2. Generate a binding for every data type declaration T in module M, - M.$tcT :: GHC.Types.TyCon - M.$tcT = TyCon ...fingerprint info... - $trModule - "T" - 0# - kind_rep - - Here 0# is the number of arguments expected by the tycon to fully determine - its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a - recipe for computing the kind of an instantiation of the tycon (see - Note [Representing TyCon kinds: KindRep] later in this file for details). - - We define (in GHC.Core.TyCon) - - type TyConRepName = Name - - to use for these M.$tcT "tycon rep names". Note that these must be - treated as "never exported" names by Backpack (see - Note [Handling never-exported TyThings under Backpack]). Consequently - they get slightly special treatment in GHC.Iface.Rename.rnIfaceDecl. - -3. Record the TyConRepName in T's TyCon, including for promoted - data and type constructors, and kinds like * and #. - - The TyConRepName is not an "implicit Id". It's more like a record - selector: the TyCon knows its name but you have to go to the - interface file to find its type, value, etc - -4. Solve Typeable constraints. This is done by a custom Typeable solver, - currently in TcInteract, that use M.$tcT so solve (Typeable T). - -There are many wrinkles: - -* The timing of when we produce this bindings is rather important: they must be - defined after the rest of the module has been typechecked since we need to be - able to lookup Module and TyCon in the type environment and we may be - currently compiling GHC.Types (where they are defined). - -* GHC.Prim doesn't have any associated object code, so we need to put the - representations for types defined in this module elsewhere. We chose this - place to be GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for - injecting the bindings for the GHC.Prim representions when compiling - GHC.Types. - -* TyCon.tyConRepModOcc is responsible for determining where to find - the representation binding for a given type. This is where we handle - the special case for GHC.Prim. - -* To save space and reduce dependencies, we need use quite low-level - representations for TyCon and Module. See GHC.Types - Note [Runtime representation of modules and tycons] - -* The KindReps can unfortunately get quite large. Moreover, the simplifier will - float out various pieces of them, resulting in numerous top-level bindings. - Consequently we mark the KindRep bindings as noinline, ensuring that the - float-outs don't make it into the interface file. This is important since - there is generally little benefit to inlining KindReps and they would - otherwise strongly affect compiler performance. - -* In general there are lots of things of kind *, * -> *, and * -> * -> *. To - reduce the number of bindings we need to produce, we generate their KindReps - once in GHC.Types. These are referred to as "built-in" KindReps below. - -* Even though KindReps aren't inlined, this scheme still has more of an effect on - compilation time than I'd like. This is especially true in the case of - families of type constructors (e.g. tuples and unboxed sums). The problem is - particularly bad in the case of sums, since each arity-N tycon brings with it - N promoted datacons, each with a KindRep whose size also scales with N. - Consequently we currently simply don't allow sums to be Typeable. - - In general we might consider moving some or all of this generation logic back - to the solver since the performance hit we take in doing this at - type-definition time is non-trivial and Typeable isn't very widely used. This - is discussed in #13261. - --} - --- | Generate the Typeable bindings for a module. This is the only --- entry-point of this module and is invoked by the typechecker driver in --- 'tcRnSrcDecls'. --- --- See Note [Grand plan for Typeable] in TcTypeable. -mkTypeableBinds :: TcM TcGblEnv -mkTypeableBinds - = do { dflags <- getDynFlags - ; if gopt Opt_NoTypeableBinds dflags then getGblEnv else do - { -- Create a binding for $trModule. - -- Do this before processing any data type declarations, - -- which need tcg_tr_module to be initialised - ; tcg_env <- mkModIdBindings - -- Now we can generate the TyCon representations... - -- First we handle the primitive TyCons if we are compiling GHC.Types - ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos - - -- Then we produce bindings for the user-defined types in this module. - ; setGblEnv tcg_env $ - do { mod <- getModule - ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env) - mod_id = case tcg_tr_module tcg_env of -- Should be set by now - Just mod_id -> mod_id - Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons) - ; traceTc "mkTypeableBinds" (ppr tycons) - ; this_mod_todos <- todoForTyCons mod mod_id tycons - ; mkTypeRepTodoBinds (this_mod_todos : prim_todos) - } } } - where - needs_typeable_binds tc - | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon] - = False - | otherwise = - isAlgTyCon tc - || isDataFamilyTyCon tc - || isClassTyCon tc - - -{- ********************************************************************* -* * - Building top-level binding for $trModule -* * -********************************************************************* -} - -mkModIdBindings :: TcM TcGblEnv -mkModIdBindings - = do { mod <- getModule - ; loc <- getSrcSpanM - ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc - ; trModuleTyCon <- tcLookupTyCon trModuleTyConName - ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon []) - ; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod - - ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv - ; return (tcg_env { tcg_tr_module = Just mod_id } - `addTypecheckedBinds` [unitBag mod_bind]) } - -mkModIdRHS :: Module -> TcM (LHsExpr GhcTc) -mkModIdRHS mod - = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName - ; trNameLit <- mkTrNameLit - ; return $ nlHsDataCon trModuleDataCon - `nlHsApp` trNameLit (unitIdFS (moduleUnitId mod)) - `nlHsApp` trNameLit (moduleNameFS (moduleName mod)) - } - -{- ********************************************************************* -* * - Building type-representation bindings -* * -********************************************************************* -} - --- | Information we need about a 'TyCon' to generate its representation. We --- carry the 'Id' in order to share it between the generation of the @TyCon@ and --- @KindRep@ bindings. -data TypeableTyCon - = TypeableTyCon - { tycon :: !TyCon - , tycon_rep_id :: !Id - } - --- | A group of 'TyCon's in need of type-rep bindings. -data TypeRepTodo - = TypeRepTodo - { mod_rep_expr :: LHsExpr GhcTc -- ^ Module's typerep binding - , pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint - , mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint - , todo_tycons :: [TypeableTyCon] - -- ^ The 'TyCon's in need of bindings kinds - } - | ExportedKindRepsTodo [(Kind, Id)] - -- ^ Build exported 'KindRep' bindings for the given set of kinds. - -todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo -todoForTyCons mod mod_id tycons = do - trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName - let mk_rep_id :: TyConRepName -> Id - mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy - - let typeable_tycons :: [TypeableTyCon] - typeable_tycons = - [ TypeableTyCon { tycon = tc'' - , tycon_rep_id = mk_rep_id rep_name - } - | tc <- tycons - , tc' <- tc : tyConATs tc - -- We need type representations for any associated types - , let promoted = map promoteDataCon (tyConDataCons tc') - , tc'' <- tc' : promoted - -- Don't make bindings for data-family instance tycons. - -- Do, however, make them for their promoted datacon (see #13915). - , not $ isFamInstTyCon tc'' - , Just rep_name <- pure $ tyConRepName_maybe tc'' - , tyConIsTypeable tc'' - ] - return TypeRepTodo { mod_rep_expr = nlHsVar mod_id - , pkg_fingerprint = pkg_fpr - , mod_fingerprint = mod_fpr - , todo_tycons = typeable_tycons - } - where - mod_fpr = fingerprintString $ moduleNameString $ moduleName mod - pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod - -todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo -todoForExportedKindReps kinds = do - trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName - let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy) - return $ ExportedKindRepsTodo $ map mkId kinds - --- | Generate TyCon bindings for a set of type constructors -mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv -mkTypeRepTodoBinds [] = getGblEnv -mkTypeRepTodoBinds todos - = do { stuff <- collect_stuff - - -- First extend the type environment with all of the bindings - -- which we are going to produce since we may need to refer to them - -- while generating kind representations (namely, when we want to - -- represent a TyConApp in a kind, we must be able to look up the - -- TyCon associated with the applied type constructor). - ; let produced_bndrs :: [Id] - produced_bndrs = [ tycon_rep_id - | todo@(TypeRepTodo{}) <- todos - , TypeableTyCon {..} <- todo_tycons todo - ] ++ - [ rep_id - | ExportedKindRepsTodo kinds <- todos - , (_, rep_id) <- kinds - ] - ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv - - ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc] - mk_binds todo@(TypeRepTodo {}) = - mapM (mkTyConRepBinds stuff todo) (todo_tycons todo) - mk_binds (ExportedKindRepsTodo kinds) = - mkExportedKindReps stuff kinds >> return [] - - ; (gbl_env, binds) <- setGblEnv gbl_env - $ runKindRepM (mapM mk_binds todos) - ; return $ gbl_env `addTypecheckedBinds` concat binds } - --- | Generate bindings for the type representation of a wired-in 'TyCon's --- defined by the virtual "GHC.Prim" module. This is where we inject the --- representation bindings for these primitive types into "GHC.Types" --- --- See Note [Grand plan for Typeable] in this module. -mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo]) -mkPrimTypeableTodos - = do { mod <- getModule - ; if mod == gHC_TYPES - then do { -- Build Module binding for GHC.Prim - trModuleTyCon <- tcLookupTyCon trModuleTyConName - ; let ghc_prim_module_id = - mkExportedVanillaId trGhcPrimModuleName - (mkTyConTy trModuleTyCon) - - ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id - <$> mkModIdRHS gHC_PRIM - - -- Extend our environment with above - ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id] - getGblEnv - ; let gbl_env' = gbl_env `addTypecheckedBinds` - [unitBag ghc_prim_module_bind] - - -- Build TypeRepTodos for built-in KindReps - ; todo1 <- todoForExportedKindReps builtInKindReps - -- Build TypeRepTodos for types in GHC.Prim - ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id - ghcPrimTypeableTyCons - ; return ( gbl_env' , [todo1, todo2]) - } - else do gbl_env <- getGblEnv - return (gbl_env, []) - } - --- | This is the list of primitive 'TyCon's for which we must generate bindings --- in "GHC.Types". This should include all types defined in "GHC.Prim". --- --- The majority of the types we need here are contained in 'primTyCons'. --- However, not all of them: in particular unboxed tuples are absent since we --- don't want to include them in the original name cache. See --- Note [Built-in syntax and the OrigNameCache] in GHC.Iface.Env for more. -ghcPrimTypeableTyCons :: [TyCon] -ghcPrimTypeableTyCons = concat - [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ] - , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE] - , map sumTyCon [2..mAX_SUM_SIZE] - , primTyCons - ] - -data TypeableStuff - = Stuff { platform :: Platform -- ^ Target platform - , trTyConDataCon :: DataCon -- ^ of @TyCon@ - , trNameLit :: FastString -> LHsExpr GhcTc - -- ^ To construct @TrName@s - -- The various TyCon and DataCons of KindRep - , kindRepTyCon :: TyCon - , kindRepTyConAppDataCon :: DataCon - , kindRepVarDataCon :: DataCon - , kindRepAppDataCon :: DataCon - , kindRepFunDataCon :: DataCon - , kindRepTYPEDataCon :: DataCon - , kindRepTypeLitSDataCon :: DataCon - , typeLitSymbolDataCon :: DataCon - , typeLitNatDataCon :: DataCon - } - --- | Collect various tidbits which we'll need to generate TyCon representations. -collect_stuff :: TcM TypeableStuff -collect_stuff = do - platform <- targetPlatform <$> getDynFlags - trTyConDataCon <- tcLookupDataCon trTyConDataConName - kindRepTyCon <- tcLookupTyCon kindRepTyConName - kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName - kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName - kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName - kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName - kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName - kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName - typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName - typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName - trNameLit <- mkTrNameLit - return Stuff {..} - --- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we --- can save the work of repeating lookups when constructing many TyCon --- representations. -mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc) -mkTrNameLit = do - trNameSDataCon <- tcLookupDataCon trNameSDataConName - let trNameLit :: FastString -> LHsExpr GhcTc - trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon - `nlHsApp` nlHsLit (mkHsStringPrimLit fs) - return trNameLit - --- | Make Typeable bindings for the given 'TyCon'. -mkTyConRepBinds :: TypeableStuff -> TypeRepTodo - -> TypeableTyCon -> KindRepM (LHsBinds GhcTc) -mkTyConRepBinds stuff todo (TypeableTyCon {..}) - = do -- Make a KindRep - let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon) - liftTc $ traceTc "mkTyConKindRepBinds" - (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind) - let ctx = mkDeBruijnContext (map binderVar bndrs) - kind_rep <- getKindRep stuff ctx kind - - -- Make the TyCon binding - let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep - tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs - return $ unitBag tycon_rep_bind - --- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type --- families and polytypes. -tyConIsTypeable :: TyCon -> Bool -tyConIsTypeable tc = - isJust (tyConRepName_maybe tc) - && kindIsTypeable (dropForAlls $ tyConKind tc) - --- | Is a particular 'Kind' representable by @Typeable@? Here we look for --- polytypes and types containing casts (which may be, for instance, a type --- family). -kindIsTypeable :: Kind -> Bool --- We handle types of the form (TYPE LiftedRep) specifically to avoid --- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr) --- to be typeable without inspecting rr, but this exhibits bad behavior --- when rr is a type family. -kindIsTypeable ty - | Just ty' <- coreView ty = kindIsTypeable ty' -kindIsTypeable ty - | isLiftedTypeKind ty = True -kindIsTypeable (TyVarTy _) = True -kindIsTypeable (AppTy a b) = kindIsTypeable a && kindIsTypeable b -kindIsTypeable (FunTy _ a b) = kindIsTypeable a && kindIsTypeable b -kindIsTypeable (TyConApp tc args) = tyConIsTypeable tc - && all kindIsTypeable args -kindIsTypeable (ForAllTy{}) = False -kindIsTypeable (LitTy _) = True -kindIsTypeable (CastTy{}) = False - -- See Note [Typeable instances for casted types] -kindIsTypeable (CoercionTy{}) = False - --- | Maps kinds to 'KindRep' bindings. This binding may either be defined in --- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing') --- or a binding which we generated in the current module (in which case it will --- be 'Just' the RHS of the binding). -type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc)) - --- | A monad within which we will generate 'KindRep's. Here we keep an --- environment containing 'KindRep's which we've already generated so we can --- re-use them opportunistically. -newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a } - deriving (Functor, Applicative, Monad) - -liftTc :: TcRn a -> KindRepM a -liftTc = KindRepM . lift - --- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they --- can be reused across modules. -builtInKindReps :: [(Kind, Name)] -builtInKindReps = - [ (star, starKindRepName) - , (mkVisFunTy star star, starArrStarKindRepName) - , (mkVisFunTys [star, star] star, starArrStarArrStarKindRepName) - ] - where - star = liftedTypeKind - -initialKindRepEnv :: TcRn KindRepEnv -initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps - where - add_kind_rep acc (k,n) = do - id <- tcLookupId n - return $! extendTypeMap acc k (id, Nothing) - --- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's. -mkExportedKindReps :: TypeableStuff - -> [(Kind, Id)] -- ^ the kinds to generate bindings for - -> KindRepM () -mkExportedKindReps stuff = mapM_ kindrep_binding - where - empty_scope = mkDeBruijnContext [] - - kindrep_binding :: (Kind, Id) -> KindRepM () - kindrep_binding (kind, rep_bndr) = do - -- We build the binding manually here instead of using mkKindRepRhs - -- since the latter would find the built-in 'KindRep's in the - -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv'). - rhs <- mkKindRepRhs stuff empty_scope kind - addKindRepBind empty_scope kind rep_bndr rhs - -addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM () -addKindRepBind in_scope k bndr rhs = - KindRepM $ modify' $ - \env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs) - --- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking --- environment. -runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a) -runKindRepM (KindRepM action) = do - kindRepEnv <- initialKindRepEnv - (res, reps_env) <- runStateT action kindRepEnv - let rep_binds = foldTypeMap to_bind_pair [] reps_env - to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest - to_bind_pair (_, Nothing) rest = rest - tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv - let binds = map (uncurry mkVarBind) rep_binds - tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds] - return (tcg_env', res) - --- | Produce or find a 'KindRep' for the given kind. -getKindRep :: TypeableStuff -> CmEnv -- ^ in-scope kind variables - -> Kind -- ^ the kind we want a 'KindRep' for - -> KindRepM (LHsExpr GhcTc) -getKindRep stuff@(Stuff {..}) in_scope = go - where - go :: Kind -> KindRepM (LHsExpr GhcTc) - go = KindRepM . StateT . go' - - go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv) - go' k env - -- Look through type synonyms - | Just k' <- tcView k = go' k' env - - -- We've already generated the needed KindRep - | Just (id, _) <- lookupTypeMapWithScope env in_scope k - = return (nlHsVar id, env) - - -- We need to construct a new KindRep binding - | otherwise - = do -- Place a NOINLINE pragma on KindReps since they tend to be quite - -- large and bloat interface files. - rep_bndr <- (`setInlinePragma` neverInlinePragma) - <$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon) - - -- do we need to tie a knot here? - flip runStateT env $ unKindRepM $ do - rhs <- mkKindRepRhs stuff in_scope k - addKindRepBind in_scope k rep_bndr rhs - return $ nlHsVar rep_bndr - --- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and --- in-scope kind variable set. -mkKindRepRhs :: TypeableStuff - -> CmEnv -- ^ in-scope kind variables - -> Kind -- ^ the kind we want a 'KindRep' for - -> KindRepM (LHsExpr GhcTc) -- ^ RHS expression -mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep - where - new_kind_rep k - -- We handle (TYPE LiftedRep) etc separately to make it - -- clear to consumers (e.g. serializers) that there is - -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep) - | not (tcIsConstraintKind k) - -- Typeable respects the Constraint/Type distinction - -- so do not follow the special case here - , Just arg <- kindRep_maybe k - , Just (tc, []) <- splitTyConApp_maybe arg - , Just dc <- isPromotedDataCon_maybe tc - = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc - - new_kind_rep (TyVarTy v) - | Just idx <- lookupCME in_scope v - = return $ nlHsDataCon kindRepVarDataCon - `nlHsApp` nlHsIntLit (fromIntegral idx) - | otherwise - = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v) - - new_kind_rep (AppTy t1 t2) - = do rep1 <- getKindRep stuff in_scope t1 - rep2 <- getKindRep stuff in_scope t2 - return $ nlHsDataCon kindRepAppDataCon - `nlHsApp` rep1 `nlHsApp` rep2 - - new_kind_rep k@(TyConApp tc tys) - | Just rep_name <- tyConRepName_maybe tc - = do rep_id <- liftTc $ lookupId rep_name - tys' <- mapM (getKindRep stuff in_scope) tys - return $ nlHsDataCon kindRepTyConAppDataCon - `nlHsApp` nlHsVar rep_id - `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys' - | otherwise - = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k) - - new_kind_rep (ForAllTy (Bndr var _) ty) - = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty) - - new_kind_rep (FunTy _ t1 t2) - = do rep1 <- getKindRep stuff in_scope t1 - rep2 <- getKindRep stuff in_scope t2 - return $ nlHsDataCon kindRepFunDataCon - `nlHsApp` rep1 `nlHsApp` rep2 - - new_kind_rep (LitTy (NumTyLit n)) - = return $ nlHsDataCon kindRepTypeLitSDataCon - `nlHsApp` nlHsDataCon typeLitNatDataCon - `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n) - - new_kind_rep (LitTy (StrTyLit s)) - = return $ nlHsDataCon kindRepTypeLitSDataCon - `nlHsApp` nlHsDataCon typeLitSymbolDataCon - `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s) - - -- See Note [Typeable instances for casted types] - new_kind_rep (CastTy ty co) - = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co) - - new_kind_rep (CoercionTy co) - = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co) - --- | Produce the right-hand-side of a @TyCon@ representation. -mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo - -> TyCon -- ^ the 'TyCon' we are producing a binding for - -> LHsExpr GhcTc -- ^ its 'KindRep' - -> LHsExpr GhcTc -mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep - = nlHsDataCon trTyConDataCon - `nlHsApp` nlHsLit (word64 platform high) - `nlHsApp` nlHsLit (word64 platform low) - `nlHsApp` mod_rep_expr todo - `nlHsApp` trNameLit (mkFastString tycon_str) - `nlHsApp` nlHsLit (int n_kind_vars) - `nlHsApp` kind_rep - where - n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon) - tycon_str = add_tick (occNameString (getOccName tycon)) - add_tick s | isPromotedDataCon tycon = '\'' : s - | otherwise = s - - -- This must match the computation done in - -- Data.Typeable.Internal.mkTyConFingerprint. - Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo - , mod_fingerprint todo - , fingerprintString tycon_str - ] - - int :: Int -> HsLit GhcTc - int n = HsIntPrim (SourceText $ show n) (toInteger n) - -word64 :: Platform -> Word64 -> HsLit GhcTc -word64 platform n = case platformWordSize platform of - PW4 -> HsWord64Prim NoSourceText (toInteger n) - PW8 -> HsWordPrim NoSourceText (toInteger n) - -{- -Note [Representing TyCon kinds: KindRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One of the operations supported by Typeable is typeRepKind, - - typeRepKind :: TypeRep (a :: k) -> TypeRep k - -Implementing this is a bit tricky for poly-kinded types like - - data Proxy (a :: k) :: Type - -- Proxy :: forall k. k -> Type - -The TypeRep encoding of `Proxy Type Int` looks like this: - - $tcProxy :: GHC.Types.TyCon - $trInt :: TypeRep Int - TrType :: TypeRep Type - - $trProxyType :: TypeRep (Proxy Type :: Type -> Type) - $trProxyType = TrTyCon $tcProxy - [TrType] -- kind variable instantiation - (tyConKind $tcProxy [TrType]) -- The TypeRep of - -- Type -> Type - - $trProxy :: TypeRep (Proxy Type Int) - $trProxy = TrApp $trProxyType $trInt TrType - - $tkProxy :: GHC.Types.KindRep - $tkProxy = KindRepFun (KindRepVar 0) - (KindRepTyConApp (KindRepTYPE LiftedRep) []) - -Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent -polymorphic types. So instead - - * $trProxyType uses 'TrTyCon' to apply Proxy to (the representations) - of all its kind arguments. We can't represent a tycon that is - applied to only some of its kind arguments. - - * In $tcProxy, the GHC.Types.TyCon structure for Proxy, we store a - GHC.Types.KindRep, which represents the polymorphic kind of Proxy - Proxy :: forall k. k->Type - - * A KindRep is just a recipe that we can instantiate with the - argument kinds, using Data.Typeable.Internal.tyConKind and - store in the relevant 'TypeRep' constructor. - - Data.Typeable.Internal.typeRepKind looks up the stored kinds. - - * In a KindRep, the kind variables are represented by 0-indexed - de Bruijn numbers: - - type KindBndr = Int -- de Bruijn index - - data KindRep = KindRepTyConApp TyCon [KindRep] - | KindRepVar !KindBndr - | KindRepApp KindRep KindRep - | KindRepFun KindRep KindRep - ... - -Note [Typeable instances for casted types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At present, GHC does not manufacture TypeReps for types containing casts -(#16835). In theory, GHC could do so today, but it might be dangerous tomorrow. - -In today's GHC, we normalize all types before computing their TypeRep. -For example: - - type family F a - type instance F Int = Type - - data D = forall (a :: F Int). MkD a - - tr :: TypeRep (MkD Bool) - tr = typeRep - -When computing the TypeRep for `MkD Bool` (or rather, -`MkD (Bool |> Sym (FInt[0]))`), we simply discard the cast to obtain the -TypeRep for `MkD Bool`. - -Why does this work? If we have a type definition with casts, then the -only coercions that those casts can mention are either Refl, type family -axioms, built-in axioms, and coercions built from those roots. Therefore, -type family (and built-in) axioms will apply precisely when type normalization -succeeds (i.e, the type family applications are reducible). Therefore, it -is safe to ignore the cast entirely when constructing the TypeRep. - -This approach would be fragile in a future where GHC permits other forms of -coercions to appear in casts (e.g., coercion quantification as described -in #15710). If GHC permits local assumptions to appear in casts that cannot be -reduced with conventional normalization, then discarding casts would become -unsafe. It would be unfortunate for the Typeable solver to become a roadblock -obstructing such a future, so we deliberately do not implement the ability -for TypeReps to represent types with casts at the moment. - -If we do wish to allow this in the future, it will likely require modeling -casts and coercions in TypeReps themselves. --} - -mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc -mkList ty = foldr consApp (nilExpr ty) - where - cons = consExpr ty - consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc - consApp x xs = cons `nlHsApp` x `nlHsApp` xs - - nilExpr :: Type -> LHsExpr GhcTc - nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon) - - consExpr :: Type -> LHsExpr GhcTc - consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon) diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs deleted file mode 100644 --- a/compiler/typecheck/TcUnify.hs +++ /dev/null @@ -1,2332 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Type subsumption and unification --} - -{-# LANGUAGE CPP, DeriveFunctor, MultiWayIf, TupleSections, - ScopedTypeVariables #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcUnify ( - -- Full-blown subsumption - tcWrapResult, tcWrapResultO, tcSkolemise, tcSkolemiseET, - tcSubTypeHR, tcSubTypeO, tcSubType_NC, tcSubTypeDS, - tcSubTypeDS_NC_O, tcSubTypeET, - checkConstraints, checkTvConstraints, - buildImplicationFor, emitResidualTvConstraint, - - -- Various unifications - unifyType, unifyKind, - uType, promoteTcType, - swapOverTyVars, canSolveByUnification, - - -------------------------------- - -- Holes - tcInferInst, tcInferNoInst, - matchExpectedListTy, - matchExpectedTyConApp, - matchExpectedAppTy, - matchExpectedFunTys, - matchActualFunTys, matchActualFunTysPart, - matchExpectedFunKind, - - metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..) - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr( debugPprType ) -import TcMType -import TcRnMonad -import TcType -import GHC.Core.Type -import GHC.Core.Coercion -import TcEvidence -import Constraint -import GHC.Core.Predicate -import TcOrigin -import GHC.Types.Name( isSystemName ) -import Inst -import GHC.Core.TyCon -import TysWiredIn -import TysPrim( tYPE ) -import GHC.Types.Var as Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import ErrUtils -import GHC.Driver.Session -import GHC.Types.Basic -import Bag -import Util -import qualified GHC.LanguageExtensions as LangExt -import Outputable - -import Data.Maybe( isNothing ) -import Control.Monad -import Control.Arrow ( second ) - -{- -************************************************************************ -* * - 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. - --} - --- Use this one when you have an "expected" type. -matchExpectedFunTys :: forall a. - SDoc -- See Note [Herald for matchExpectedFunTys] - -> Arity - -> ExpRhoType -- deeply skolemised - -> ([ExpSigmaType] -> ExpRhoType -> TcM a) - -- must fill in these ExpTypes here - -> TcM (a, HsWrapper) --- 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 arity orig_ty thing_inside - = case orig_ty of - Check ty -> go [] arity ty - _ -> defer [] arity orig_ty - where - go acc_arg_tys 0 ty - = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType ty) - ; return (result, idHsWrapper) } - - go acc_arg_tys n ty - | Just ty' <- tcView ty = go acc_arg_tys n ty' - - go acc_arg_tys n (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) - = ASSERT( af == VisArg ) - do { (result, wrap_res) <- go (mkCheckExpType arg_ty : acc_arg_tys) - (n-1) res_ty - ; return ( result - , mkWpFun idHsWrapper wrap_res arg_ty res_ty doc ) } - where - doc = text "When inferring the argument type of a function with type" <+> - quotes (ppr orig_ty) - - 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 $ - defer acc_arg_tys n (mkCheckExpType ty) - - ------------ - defer :: [ExpSigmaType] -> Arity -> ExpRhoType -> TcM (a, HsWrapper) - defer acc_arg_tys n fun_ty - = do { more_arg_tys <- replicateM n newInferExpTypeNoInst - ; res_ty <- newInferExpTypeInst - ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty - ; more_arg_tys <- mapM readExpType more_arg_tys - ; res_ty <- readExpType res_ty - ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty - ; wrap <- tcSubTypeDS AppOrigin GenSigCtxt unif_fun_ty fun_ty - -- Not a good origin at all :-( - ; return (result, wrap) } - - ------------ - mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc) - mk_ctxt env = do { (env', ty) <- zonkTidyTcType env orig_tc_ty - ; let (args, _) = tcSplitFunTys ty - n_actual = length args - (env'', orig_ty') = tidyOpenType env' orig_tc_ty - ; return ( env'' - , mk_fun_tys_msg orig_ty' ty n_actual arity herald) } - where - orig_tc_ty = checkingExpType "matchExpectedFunTys" orig_ty - -- this is safe b/c we're called from "go" - --- Like 'matchExpectedFunTys', but used when you have an "actual" type, --- for example in function application -matchActualFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys] - -> CtOrigin - -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType - -> Arity - -> TcSigmaType - -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) --- If matchActualFunTys n ty = (wrap, [t1,..,tn], ty_r) --- then wrap : ty ~> (t1 -> ... -> tn -> ty_r) -matchActualFunTys herald ct_orig mb_thing arity ty - = matchActualFunTysPart herald ct_orig mb_thing arity ty [] arity - --- | Variant of 'matchActualFunTys' that works when supplied only part --- (that is, to the right of some arrows) of the full function type -matchActualFunTysPart :: SDoc -- See Note [Herald for matchExpectedFunTys] - -> CtOrigin - -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType - -> Arity - -> TcSigmaType - -> [TcSigmaType] -- reversed args. See (*) below. - -> Arity -- overall arity of the function, for errs - -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) -matchActualFunTysPart herald ct_orig mb_thing arity orig_ty - orig_old_args full_arity - = go arity orig_old_args orig_ty --- 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 - --- (*) Sometimes it's necessary to call matchActualFunTys with only part --- (that is, to the right of some arrows) of the type of the function in --- question. (See TcExpr.tcArgs.) This argument is the reversed list of --- arguments already seen (that is, not part of the TcSigmaType passed --- in elsewhere). - - where - -- This function has a bizarre mechanic: it accumulates arguments on - -- the way down and also builds an argument list on the way up. Why: - -- 1. The returns args list and the accumulated args list might be different. - -- The accumulated args include all the arg types for the function, - -- including those from before this function was called. The returned - -- list should include only those arguments produced by this call of - -- matchActualFunTys - -- - -- 2. The HsWrapper can be built only on the way up. It seems (more) - -- bizarre to build the HsWrapper but not the arg_tys. - -- - -- Refactoring is welcome. - go :: Arity - -> [TcSigmaType] -- accumulator of arguments (reversed) - -> TcSigmaType -- the remainder of the type as we're processing - -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) - go 0 _ ty = return (idHsWrapper, [], ty) - - go n acc_args ty - | not (null tvs && null theta) - = do { (wrap1, rho) <- topInstantiate ct_orig ty - ; (wrap2, arg_tys, res_ty) <- go n acc_args rho - ; return (wrap2 <.> wrap1, arg_tys, res_ty) } - where - (tvs, theta, _) = tcSplitSigmaTy ty - - go n acc_args ty - | Just ty' <- tcView ty = go n acc_args ty' - - go n acc_args (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) - = ASSERT( af == VisArg ) - do { (wrap_res, tys, ty_r) <- go (n-1) (arg_ty : acc_args) res_ty - ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r doc - , arg_ty : tys, ty_r ) } - where - doc = text "When inferring the argument type of a function with type" <+> - quotes (ppr orig_ty) - - go n acc_args ty@(TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty' -> go n acc_args ty' - Flexi -> defer n 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 n acc_args ty = addErrCtxtM (mk_ctxt (reverse acc_args) ty) $ - defer n ty - - ------------ - defer n fun_ty - = do { arg_tys <- replicateM n newOpenFlexiTyVarTy - ; res_ty <- newOpenFlexiTyVarTy - ; let unif_fun_ty = mkVisFunTys arg_tys res_ty - ; co <- unifyType mb_thing fun_ty unif_fun_ty - ; return (mkWpCastN co, arg_tys, res_ty) } - - ------------ - mk_ctxt :: [TcSigmaType] -> TcSigmaType -> TidyEnv -> TcM (TidyEnv, MsgDoc) - mk_ctxt arg_tys res_ty env - = do { let ty = mkVisFunTys arg_tys res_ty - ; (env1, zonked) <- zonkTidyTcType env ty - -- zonking might change # of args - ; let (zonked_args, _) = tcSplitFunTys zonked - n_actual = length zonked_args - (env2, unzonked) = tidyOpenType env1 ty - ; return ( env2 - , mk_fun_tys_msg unzonked zonked n_actual full_arity herald) } - -mk_fun_tys_msg :: TcType -- the full type passed in (unzonked) - -> TcType -- the full type passed in (zonked) - -> Arity -- the # of args found - -> Arity -- the # of args wanted - -> SDoc -- overall herald - -> SDoc -mk_fun_tys_msg full_ty ty n_args full_arity herald - = herald <+> speakNOf full_arity (text "argument") <> comma $$ - if n_args == full_arity - then text "its type is" <+> quotes (pprType full_ty) <> - comma $$ - text "it is specialized to" <+> quotes (pprType ty) - else sep [text "but its type" <+> quotes (pprType ty), - if n_args == 0 then text "has none" - else text "has only" <+> speakN n_args] - ----------------------- -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 - = ASSERT(tc /= funTyCon) go orig_ty - where - go ty - | Just ty' <- tcView ty - = go ty' - - go ty@(TyConApp tycon args) - | tc == tycon -- Common case - = return (mkTcNomReflCo 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' <- tcView ty = go ty' - - | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty - = return (mkTcNomReflCo 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 = tcTypeKind orig_ty - kind1 = mkVisFunTy liftedTypeKind orig_kind - kind2 = liftedTypeKind -- m :: * -> k - -- arg type :: * - -{- -************************************************************************ -* * - 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 coercion function - co_fn :: actual_ty ~ expected_ty -which takes an HsExpr of type actual_ty into one of type -expected_ty. - -These functions do not actually check for subsumption. They check if -expected_ty is an appropriate annotation to use for something of type -actual_ty. This difference matters when thinking about visible type -application. For example, - - forall a. a -> forall b. b -> b - DOES NOT SUBSUME - forall a b. a -> b -> b - -because the type arguments appear in a different order. (Neither does -it work the other way around.) BUT, these types are appropriate annotations -for one another. Because the user directs annotations, it's OK if some -arguments shuffle around -- after all, it's what the user wants. -Bottom line: none of this changes with visible type application. - -There are a number of wrinkles (below). - -Notice that Wrinkle 1 and 2 both require eta-expansion, which technically -may increase termination. We just put up with this, in exchange for getting -more predictable type inference. - -Wrinkle 1: Note [Deep skolemisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want (forall a. Int -> a -> a) <= (Int -> forall a. a->a) -(see section 4.6 of "Practical type inference for higher rank types") -So we must deeply-skolemise the RHS before we instantiate the LHS. - -That is why tc_sub_type starts with a call to tcSkolemise (which does the -deep skolemisation), and then calls the DS variant (which assumes -that expected_ty is deeply skolemised) - -Wrinkle 2: Note [Co/contra-variance of subsumption checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider g :: (Int -> Int) -> Int - f1 :: (forall a. a -> a) -> Int - f1 = g - - f2 :: (forall a. a -> a) -> Int - f2 x = g x -f2 will typecheck, and it would be odd/fragile if f1 did not. -But f1 will only typecheck if we have that - (Int->Int) -> Int <= (forall a. a->a) -> Int -And that is only true if we do the full co/contravariant thing -in the subsumption check. That happens in the FunTy case of -tcSubTypeDS_NC_O, and is the sole reason for the WpFun form of -HsWrapper. - -Another powerful reason for doing this co/contra stuff is visible -in #9569, involving instantiation of constraint variables, -and again involving eta-expansion. - -Wrinkle 3: Note [Higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider tc150: - f y = \ (x::forall a. a->a). blah -The following happens: -* We will infer the type of the RHS, ie with a res_ty = alpha. -* Then the lambda will split alpha := beta -> gamma. -* And then we'll check tcSubType IsSwapped beta (forall a. a->a) - -So it's important that we unify beta := forall a. a->a, rather than -skolemising the type. --} - - --- | Call this variant when you are in a higher-rank situation and --- you know the right-hand type is deeply skolemised. -tcSubTypeHR :: CtOrigin -- ^ of the actual type - -> Maybe (HsExpr GhcRn) -- ^ If present, it has type ty_actual - -> TcSigmaType -> ExpRhoType -> TcM HsWrapper -tcSubTypeHR orig = tcSubTypeDS_NC_O orig GenSigCtxt - ------------------------- -tcSubTypeET :: CtOrigin -> UserTypeCtxt - -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper --- If wrap = tc_sub_type_et t1 t2 --- => wrap :: t1 ~> t2 -tcSubTypeET orig ctxt (Check ty_actual) ty_expected - = tc_sub_tc_type eq_orig orig ctxt ty_actual ty_expected - where - eq_orig = TypeEqOrigin { uo_actual = ty_expected - , uo_expected = ty_actual - , uo_thing = Nothing - , uo_visible = True } - -tcSubTypeET _ _ (Infer inf_res) ty_expected - = ASSERT2( not (ir_inst inf_res), ppr inf_res $$ ppr ty_expected ) - -- An (Infer inf_res) ExpSigmaType passed into tcSubTypeET never - -- has the ir_inst field set. Reason: in patterns (which is what - -- tcSubTypeET is used for) do not aggressively instantiate - do { co <- fill_infer_result ty_expected inf_res - -- Since ir_inst is false, we can skip fillInferResult - -- and go straight to fill_infer_result - - ; return (mkWpCastN (mkTcSymCo co)) } - ------------------------- -tcSubTypeO :: CtOrigin -- ^ of the actual type - -> UserTypeCtxt -- ^ of the expected type - -> TcSigmaType - -> ExpRhoType - -> TcM HsWrapper -tcSubTypeO orig ctxt ty_actual ty_expected - = addSubTypeCtxt ty_actual ty_expected $ - do { traceTc "tcSubTypeDS_O" (vcat [ pprCtOrigin orig - , pprUserTypeCtxt ctxt - , ppr ty_actual - , ppr ty_expected ]) - ; tcSubTypeDS_NC_O orig ctxt Nothing 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 - -- might not be filled if we're debugging. ugh. - ; mb_ty_expected <- readExpType_maybe ty_expected - ; (tidy_env, ty_expected) <- case mb_ty_expected of - Just ty -> second mkCheckExpType <$> - zonkTidyTcType tidy_env ty - Nothing -> return (tidy_env, ty_expected) - ; ty_expected <- readExpType ty_expected - ; (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) } - ---------------- --- The "_NC" variants do not add a typechecker-error context; --- the caller is assumed to do that - -tcSubType_NC :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper --- Checks that actual <= expected --- Returns HsWrapper :: actual ~ expected -tcSubType_NC ctxt ty_actual ty_expected - = do { traceTc "tcSubType_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) - ; tc_sub_tc_type origin origin ctxt ty_actual ty_expected } - where - origin = TypeEqOrigin { uo_actual = ty_actual - , uo_expected = ty_expected - , uo_thing = Nothing - , uo_visible = True } - -tcSubTypeDS :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> ExpRhoType -> TcM HsWrapper --- Just like tcSubType, but with the additional precondition that --- ty_expected is deeply skolemised (hence "DS") -tcSubTypeDS orig ctxt ty_actual ty_expected - = addSubTypeCtxt ty_actual ty_expected $ - do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) - ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected } - -tcSubTypeDS_NC_O :: CtOrigin -- origin used for instantiation only - -> UserTypeCtxt - -> Maybe (HsExpr GhcRn) - -> TcSigmaType -> ExpRhoType -> TcM HsWrapper --- Just like tcSubType, but with the additional precondition that --- ty_expected is deeply skolemised -tcSubTypeDS_NC_O inst_orig ctxt m_thing ty_actual ty_expected - = case ty_expected of - Infer inf_res -> fillInferResult inst_orig ty_actual inf_res - Check ty -> tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty - where - eq_orig = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty - , uo_thing = ppr <$> m_thing - , uo_visible = True } - ---------------- -tc_sub_tc_type :: CtOrigin -- used when calling uType - -> CtOrigin -- used when instantiating - -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper --- If wrap = tc_sub_type t1 t2 --- => wrap :: t1 ~> t2 -tc_sub_tc_type eq_orig inst_orig ctxt ty_actual ty_expected - | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] - , not (possibly_poly ty_actual) - = do { traceTc "tc_sub_tc_type (drop to equality)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; mkWpCastN <$> - uType TypeLevel eq_orig ty_actual ty_expected } - - | otherwise -- This is the general case - = do { traceTc "tc_sub_tc_type (general case)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; (sk_wrap, inner_wrap) <- tcSkolemise ctxt ty_expected $ - \ _ sk_rho -> - tc_sub_type_ds eq_orig inst_orig ctxt - ty_actual sk_rho - ; return (sk_wrap <.> inner_wrap) } - where - possibly_poly ty - | isForAllTy ty = True - | Just (_, res) <- splitFunTy_maybe ty = possibly_poly res - | otherwise = False - -- NB *not* tcSplitFunTy, because here we want - -- to decompose type-class arguments too - - definitely_poly ty - | (tvs, theta, tau) <- tcSplitSigmaTy ty - , (tv:_) <- tvs - , null theta - , isInsolubleOccursCheck NomEq tv tau - = True - | otherwise - = False - -{- Note [Don't skolemise unnecessarily] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are trying to solve - (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. - -So roughly: - * if the ty_expected has an outermost forall - (i.e. skolemisation is the next thing we'd do) - * and the ty_actual has no top-level polymorphism (but looking deeply) -then we can revert to simple equality. But we need to be careful. -These examples are all fine: - - * (Char -> forall a. a->a) <= (forall a. Char -> a -> a) - Polymorphism is buried in ty_actual - - * (Char->Char) <= (forall a. Char -> Char) - ty_expected isn't really polymorphic - - * (Char->Char) <= (forall a. (a~Char) => a -> a) - ty_expected isn't really polymorphic - - * (Char->Char) <= (forall a. F [a] Char -> Char) - where type instance F [x] t = t - ty_expected isn't really polymorphic - -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 - * ty_expected is /definitely/ polymorphic --} - ---------------- -tc_sub_type_ds :: CtOrigin -- used when calling uType - -> CtOrigin -- used when instantiating - -> UserTypeCtxt -> TcSigmaType -> TcRhoType -> 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 eq_orig 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 - go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e - | Just ty_e' <- tcView ty_e = go ty_a ty_e' - - go (TyVarTy tv_a) ty_e - = do { lookup_res <- lookupTcTyVar tv_a - ; case lookup_res of - Filled ty_a' -> - do { traceTc "tcSubTypeDS_NC_O following filled act meta-tyvar:" - (ppr tv_a <+> text "-->" <+> ppr ty_a') - ; tc_sub_type_ds eq_orig inst_orig ctxt ty_a' ty_e } - Unfilled _ -> unify } - - -- Historical note (Sept 16): there was a case here for - -- go ty_a (TyVarTy alpha) - -- which, in the impredicative case unified alpha := ty_a - -- where th_a is a polytype. Not only is this probably bogus (we - -- simply do not have decent story for impredicative types), but it - -- caused #12616 because (also bizarrely) 'deriving' code had - -- -XImpredicativeTypes on. I deleted the entire case. - - go (FunTy { ft_af = VisArg, ft_arg = act_arg, ft_res = act_res }) - (FunTy { ft_af = VisArg, ft_arg = exp_arg, ft_res = exp_res }) - = -- See Note [Co/contra-variance of subsumption checking] - do { res_wrap <- tc_sub_type_ds eq_orig inst_orig ctxt act_res exp_res - ; arg_wrap <- tc_sub_tc_type eq_orig given_orig GenSigCtxt exp_arg act_arg - -- GenSigCtxt: See Note [Setting the argument context] - ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res doc) } - -- arg_wrap :: exp_arg ~> act_arg - -- res_wrap :: act-res ~> exp_res - where - given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg []) - doc = text "When checking that" <+> quotes (ppr ty_actual) <+> - text "is more polymorphic than" <+> quotes (ppr ty_expected) - - 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 - (eq_orig { uo_actual = in_rho - , uo_expected = ty_expected }) - inst_orig ctxt in_rho ty_e - ; return (body_wrap <.> in_wrap) } - - | otherwise -- Revert to unification - = inst_and_unify - -- 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_and_unify = do { (wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual - - -- If we haven't recurred through an arrow, then - -- the eq_orig will list ty_actual. In this case, - -- we want to update the origin to reflect the - -- instantiation. If we *have* recurred through - -- an arrow, it's better not to update. - ; let eq_orig' = case eq_orig of - TypeEqOrigin { uo_actual = orig_ty_actual } - | orig_ty_actual `tcEqType` ty_actual - , not (isIdHsWrapper wrap) - -> eq_orig { uo_actual = rho_a } - _ -> eq_orig - - ; cow <- uType TypeLevel eq_orig' rho_a ty_expected - ; return (mkWpCastN cow <.> wrap) } - - - -- use versions without synonyms expanded - unify = mkWpCastN <$> uType TypeLevel eq_orig ty_actual ty_expected - -{- Note [Settting 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] --} - ------------------ --- needs both un-type-checked (for origins) and type-checked (for wrapping) --- expressions -tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr GhcTcId) -tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr - --- | Sometimes we don't have a @HsExpr Name@ to hand, and this is more --- convenient. -tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr GhcTcId) -tcWrapResultO orig rn_expr expr actual_ty res_ty - = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty - , text "Expected:" <+> ppr res_ty ]) - ; cow <- tcSubTypeDS_NC_O orig GenSigCtxt - (Just rn_expr) actual_ty res_ty - ; return (mkHsWrap cow expr) } - - -{- ********************************************************************** -%* * - ExpType functions: tcInfer, fillInferResult -%* * -%********************************************************************* -} - --- | Infer a type using a fresh ExpType --- See also Note [ExpType] in TcMType --- Does not attempt to instantiate the inferred type -tcInferNoInst :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tcInferNoInst = tcInfer False - -tcInferInst :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType) -tcInferInst = tcInfer True - -tcInfer :: Bool -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tcInfer instantiate tc_check - = do { res_ty <- newInferExpType instantiate - ; result <- tc_check res_ty - ; res_ty <- readExpType res_ty - ; return (result, res_ty) } - -fillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper --- If wrap = fillInferResult t1 t2 --- => wrap :: t1 ~> t2 --- See Note [Deep instantiation of InferResult] -fillInferResult orig ty inf_res@(IR { ir_inst = instantiate_me }) - | instantiate_me - = do { (wrap, rho) <- deeplyInstantiate orig ty - ; co <- fill_infer_result rho inf_res - ; return (mkWpCastN co <.> wrap) } - - | otherwise - = do { co <- fill_infer_result ty inf_res - ; return (mkWpCastN co) } - -fill_infer_result :: TcType -> InferResult -> TcM TcCoercionN --- If wrap = fill_infer_result t1 t2 --- => wrap :: t1 ~> t2 -fill_infer_result orig_ty (IR { ir_uniq = u, ir_lvl = res_lvl - , ir_ref = ref }) - = do { (ty_co, ty_to_fill_with) <- promoteTcType res_lvl orig_ty - - ; traceTc "Filling ExpType" $ - ppr u <+> text ":=" <+> ppr ty_to_fill_with - - ; when debugIsOn (check_hole ty_to_fill_with) - - ; writeTcRef ref (Just ty_to_fill_with) - - ; return ty_co } - where - check_hole ty -- Debug check only - = do { let ty_lvl = tcTypeLevel ty - ; MASSERT2( not (ty_lvl `strictlyDeeperThan` res_lvl), - ppr u $$ ppr res_lvl $$ ppr ty_lvl $$ - ppr ty <+> dcolon <+> ppr (tcTypeKind ty) $$ ppr orig_ty ) - ; cts <- readTcRef ref - ; case cts of - Just already_there -> pprPanic "writeExpType" - (vcat [ ppr u - , ppr ty - , ppr already_there ]) - Nothing -> return () } - -{- Note [Deep instantiation of InferResult] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In some cases we want to deeply instantiate before filling in -an InferResult, and in some cases not. That's why InferReult -has the ir_inst flag. - -ir_inst = True: deeply instantiate ----------------------------------- - -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. - -ir_inst = False: do not instantiate ------------------------------------ - -1. Consider this (which uses visible type application): - - (let { f :: forall a. a -> a; f x = x } in f) @Int - - We'll call TcExpr.tcInferFun to infer the type of the (let .. in f) - And we don't want to instantiate the type of 'f' when we reach it, - else the outer visible type application won't work - -2. :type +v. When we say - - :type +v const @Int - - we really want `forall b. Int -> b -> Int`. Note that this is *not* - instantiated. - -3. Pattern bindings. For example: - - foo x - | blah <- const @Int - = (blah x False, blah x 'z') - - Note that `blah` is polymorphic. (This isn't a terribly compelling - reason, but the choice of ir_inst does matter here.) - -Discussion ----------- -We thought that we should just remove the ir_inst flag, in favor of -always instantiating. Essentially: motivations (1) and (3) for ir_inst = False -are not terribly exciting. However, motivation (2) is quite important. -Furthermore, there really was not much of a simplification of the code -in removing ir_inst, and working around it to enable flows like what we -see in (2) is annoying. This was done in #17173. - --} - -{- ********************************************************************* -* * - Promoting types -* * -********************************************************************* -} - -promoteTcType :: TcLevel -> TcType -> TcM (TcCoercion, TcType) --- See Note [Promoting a type] --- 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 -promoteTcType dest_lvl ty - = do { cur_lvl <- getTcLevel - ; if (cur_lvl `sameDepthAs` dest_lvl) - then dont_promote_it - 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 (tYPE 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) } - - dont_promote_it :: TcM (TcCoercion, TcType) - dont_promote_it -- Check that ty :: TYPE rr, for some (fresh) rr - = do { res_kind <- newOpenTypeKind - ; let ty_kind = tcTypeKind ty - kind_orig = TypeEqOrigin { uo_actual = ty_kind - , uo_expected = res_kind - , uo_thing = Nothing - , uo_visible = False } - ; ki_co <- uType KindLevel kind_orig (tcTypeKind ty) res_kind - ; let co = mkTcGReflRightCo Nominal ty ki_co - ; return (co, ty `mkCastTy` ki_co) } - -{- 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. --} - -{- ********************************************************************* -* * - Generalisation -* * -********************************************************************* -} - --- | Take an "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@. -tcSkolemise :: UserTypeCtxt -> TcSigmaType - -> ([TcTyVar] -> TcType -> TcM result) - -- ^ These are only ever used for scoped type variables. - -> TcM (HsWrapper, result) - -- ^ The expression has type: spec_ty -> expected_ty - -tcSkolemise ctxt expected_ty thing_inside - -- We expect expected_ty to be a forall-type - -- If not, the call is a no-op - = do { traceTc "tcSkolemise" Outputable.empty - ; (wrap, tv_prs, given, rho') <- deeplySkolemise expected_ty - - ; lvl <- getTcLevel - ; when debugIsOn $ - traceTc "tcSkolemise" $ vcat [ - ppr lvl, - text "expected_ty" <+> ppr expected_ty, - text "inst tyvars" <+> ppr tv_prs, - text "given" <+> ppr given, - text "inst type" <+> ppr rho' ] - - -- Generally we must check that the "forall_tvs" haven't been constrained - -- The interesting bit here is that we must include the free variables - -- of the expected_ty. Here's an example: - -- runST (newVar True) - -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool)) - -- for (newVar True), with s fresh. Then we unify with the runST's arg type - -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool. - -- So now s' isn't unconstrained because it's linked to a. - -- - -- However [Oct 10] now that the untouchables are a range of - -- TcTyVars, all this is handled automatically with no need for - -- extra faffing around - - ; let tvs' = map snd tv_prs - skol_info = SigSkol ctxt expected_ty tv_prs - - ; (ev_binds, result) <- checkConstraints skol_info tvs' given $ - thing_inside tvs' rho' - - ; 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 'tcSkolemise' that takes an ExpType -tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType - -> (ExpRhoType -> TcM result) - -> TcM (HsWrapper, result) -tcSkolemiseET _ et@(Infer {}) thing_inside - = (idHsWrapper, ) <$> thing_inside et -tcSkolemiseET ctxt (Check ty) thing_inside - = tcSkolemise ctxt ty $ \_ -> thing_inside . mkCheckExpType - -checkConstraints :: SkolemInfo - -> [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 - -- tcPolyExpr, which uses tcSkolemise 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 Nothing skol_tvs tclvl wanted - ; return result } - -emitResidualTvConstraint :: SkolemInfo -> Maybe SDoc -> [TcTyVar] - -> TcLevel -> WantedConstraints -> TcM () -emitResidualTvConstraint skol_info m_telescope skol_tvs tclvl wanted - | isEmptyWC wanted - , isNothing m_telescope || skol_tvs `lengthAtMost` 1 - -- If m_telescope is (Just d), we must do the bad-telescope check, - -- so we must /not/ discard the implication even if there are no - -- wanted constraints. See Note [Checking telescopes] in Constraint. - -- Lacking this check led to #16247 - = return () - - | otherwise - = do { ev_binds <- newNoTcEvBinds - ; implic <- newImplication - ; let status | insolubleWC wanted = IC_Insoluble - | otherwise = IC_Unsolved - -- If the inner constraints are insoluble, - -- we should mark the outer one similarly, - -- so that insolubleWC works on the outer one - - ; emitImplication $ - implic { ic_status = status - , ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_no_eqs = True - , ic_telescope = m_telescope - , ic_wanted = wanted - , ic_binds = ev_binds - , ic_info = skol_info } } - -implicationNeeded :: SkolemInfo -> [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 :: SkolemInfo -> 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 -> SkolemInfo -> [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 - = ASSERT2( 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 } - - ; 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 TcErrors. - 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 [D] b1 ~ b2, even though the two functions have - literally nothing to do with each other. #14185 is an example. - Building an implication keeps them separage. --} - -{- -************************************************************************ -* * - Boxy unification -* * -************************************************************************ - -The exported functions are all defined as versions of some -non-exported generic functions. --} - -unifyType :: Maybe (HsExpr GhcRn) -- ^ If present, has type 'ty1' - -> TcTauType -> TcTauType -> TcM TcCoercionN --- Actual and expected types --- Returns a coercion : ty1 ~ ty2 -unifyType thing ty1 ty2 = traceTc "utype" (ppr ty1 $$ ppr ty2 $$ ppr thing) >> - uType TypeLevel origin ty1 ty2 - where - origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 - , uo_thing = ppr <$> thing - , uo_visible = True } -- always called from a visible context - -unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN -unifyKind thing ty1 ty2 = traceTc "ukind" (ppr ty1 $$ ppr ty2 $$ ppr thing) >> - uType KindLevel origin ty1 ty2 - where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 - , uo_thing = ppr <$> thing - , uo_visible = True } -- also always from a visible context - ---------------- - -{- -%************************************************************************ -%* * - 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] -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 <- lookupTcTyVar tv1 - ; case lookup_res of - Filled ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1) - ; go ty1 ty2 } - Unfilled _ -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 } - go ty1 (TyVarTy tv2) - = do { lookup_res <- lookupTcTyVar tv2 - ; case lookup_res of - Filled ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2) - ; go ty1 ty2 } - Unfilled _ -> 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' <- tcView ty1 = go ty1' ty2 - | Just ty2' <- tcView ty2 = go ty1 ty2' - - -- Functions (or predicate functions) just check the two parts - go (FunTy _ fun1 arg1) (FunTy _ fun2 arg2) - = do { co_l <- uType t_or_k origin fun1 fun2 - ; co_r <- uType t_or_k origin arg1 arg2 - ; return $ mkFunCo Nominal 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 - = ASSERT2( 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 (mustBeSaturated 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 (mustBeSaturated 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 (Just 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 <- tcGetTyVar_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 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 { dflags <- getDynFlags - ; cur_lvl <- getTcLevel - ; go dflags cur_lvl } - where - go dflags cur_lvl - | canSolveByUnification cur_lvl tv1 ty2 - , MTVU_OK ty2' <- metaTyVarUpdateOK dflags tv1 ty2 - = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2') (tyVarKind tv1) - ; traceTc "uUnfilledVar2 ok" $ - vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) - , ppr ty2 <+> dcolon <+> ppr (tcTypeKind ty2) - , ppr (isTcReflCo co_k), ppr co_k ] - - ; if isTcReflCo 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 (mkTcNomReflCo ty2') } - - else defer } -- This cannot be solved now. See TcCanonical - -- Note [Equalities with incompatible kinds] - - | otherwise - = 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 } - - ty1 = mkTyVarTy tv1 - kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k) - - defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2 - -swapOverTyVars :: TcTyVar -> TcTyVar -> Bool -swapOverTyVars tv1 tv2 - -- 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 --- See Note [TyVar/TyVar orientation] -lhsPriority tv - = ASSERT2( isTyVar tv, ppr tv) - case tcTyVarDetails tv of - RuntimeUnk -> 0 - SkolemTv {} -> 0 - MetaTv { mtv_info = info } -> case info of - FlatSkolTv -> 1 - TyVarTv -> 2 - TauTv -> 3 - FlatMetaTv -> 4 -{- Note [TyVar/TyVar orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (a ~ b), should we orient the CTyEqCan 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 use - - in the eager unifier, in TcUnify.uUnfilledVar1 - - in the constraint solver, in TcCanonical.canEqTyVarHomo - -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, TcSimplify.floatEqualities - looks for meta tyvars on the left - - Tie-breaking rules for MetaTvs: - - FlatMetaTv = 4: always put on the left. - See Note [Fmv Orientation Invariant] - - NB: FlatMetaTvs always have the current level, never an - outer one. So nothing can be deeper than a FlatMetaTv. - - - TauTv = 3: if we have tyv_tv ~ tau_tv, - put tau_tv on the left because there are fewer - restrictions on updating TauTvs. Or to say it another - way, then we won't lose the TyVarTv flag - - - TyVarTv = 2: remember, flat-skols are *only* updated by - the unflattener, never unified, so TyVarTvs come next - - - FlatSkolTv = 1: put on the left in preference to a SkolemTv. - See Note [Eliminate flat-skols] - -* Names. If the level and priority comparisons are all - equal, try to eliminate a TyVars 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 [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 TcSMonad 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 [Fmv Orientation Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * We always orient a constraint - fmv ~ alpha - with fmv on the left, even if alpha is - a touchable unification variable - -Reason: doing it the other way round would unify alpha:=fmv, but that -really doesn't add any info to alpha. But a later constraint alpha ~ -Int might unlock everything. Comment:9 of #12526 gives a detailed -example. - -WARNING: I've gone to and fro on this one several times. -I'm now pretty sure that unifying alpha:=fmv is a bad idea! -So orienting with fmvs on the left is a good thing. - -This example comes from IndTypesPerfMerge. (Others include -T10226, T10009.) - From the ambiguity check for - f :: (F a ~ a) => a - we get: - [G] F a ~ a - [WD] F alpha ~ alpha, alpha ~ a - - From Givens we get - [G] F a ~ fsk, fsk ~ a - - Now if we flatten we get - [WD] alpha ~ fmv, F alpha ~ fmv, alpha ~ a - - Now, if we unified alpha := fmv, we'd get - [WD] F fmv ~ fmv, [WD] fmv ~ a - And now we are stuck. - -So instead the Fmv Orientation Invariant puts the fmv on the -left, giving - [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a - - Now we get alpha:=a, and everything works out - -Note [Eliminate flat-skols] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have [G] Num (F [a]) -then we flatten to - [G] Num fsk - [G] F [a] ~ fsk -where fsk is a flatten-skolem (FlatSkolTv). Suppose we have - type instance F [a] = a -then we'll reduce the second constraint to - [G] a ~ fsk -and then replace all uses of 'a' with fsk. That's bad because -in error messages instead of saying 'a' we'll say (F [a]). In all -places, including those where the programmer wrote 'a' in the first -place. Very confusing! See #7862. - -Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate -the fsk. - -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 - -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 to too nice to discard altogether, so I'm leaving these -notes. SLPJ Jan 18. --} - --- @trySpontaneousSolve wi@ solves equalities where one side is a --- touchable unification variable. --- Returns True <=> spontaneous solve happened -canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool -canSolveByUnification tclvl tv xi - | isTouchableMetaTyVar tclvl tv - = case metaTyVarInfo tv of - TyVarTv -> is_tyvar xi - _ -> True - - | otherwise -- Untouchable - = False - where - is_tyvar xi - = case tcGetTyVar_maybe xi of - Nothing -> False - Just tv -> case tcTyVarDetails tv of - MetaTv { mtv_info = info } - -> case info of - TyVarTv -> True - _ -> False - SkolemTv {} -> True - RuntimeUnk -> True - -{- 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. (We're not helped by the fact that -the flattener re-flattens all the arguments every time around.) 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. - -Note [Refactoring hazard: checkTauTvUpdate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -I (Richard E.) have a sad story about refactoring this code, retained here -to prevent others (or a future me!) from falling into the same traps. - -It all started with #11407, which was caused by the fact that the TyVarTy -case of defer_me didn't look in the kind. But it seemed reasonable to -simply remove the defer_me check instead. - -It referred to two Notes (since removed) that were out of date, and the -fast_check code in occurCheckExpand seemed to do just about the same thing as -defer_me. The one piece that defer_me did that wasn't repeated by -occurCheckExpand was the type-family check. (See Note [Prevent unification -with type families].) So I checked the result of occurCheckExpand for any -type family occurrences and deferred if there were any. This was done -in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 . - -This approach turned out not to be performant, because the expanded -type was bigger than the original type, and tyConsOfType (needed to -see if there are any type family occurrences) looks through type -synonyms. So it then struck me that we could dispense with the -defer_me check entirely. This simplified the code nicely, and it cut -the allocations in T5030 by half. But, as documented in Note [Prevent -unification with type families], this destroyed performance in -T3064. Regardless, I missed this regression and the change was -committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d . - -Bottom lines: - * defer_me is back, but now fixed w.r.t. #11407. - * Tread carefully before you start to refactor here. There can be - lots of hard-to-predict consequences. - -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 TcInteract, -function @occ_check_ok@. - -Note [Non-TcTyVars in TcUnify] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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 TcTyClsDecls"). 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. --} - -data LookupTyVarResult -- The result of a lookupTcTyVar call - = Unfilled TcTyVarDetails -- SkolemTv or virgin MetaTv - | Filled TcType - -lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult -lookupTcTyVar tyvar - | MetaTv { mtv_ref = ref } <- details - = do { meta_details <- readMutVar ref - ; case meta_details of - Indirect ty -> return (Filled ty) - Flexi -> do { is_touchable <- isTouchableTcM tyvar - -- Note [Unifying untouchables] - ; if is_touchable then - return (Unfilled details) - else - return (Unfilled vanillaSkolemTv) } } - | otherwise - = return (Unfilled details) - where - details = tcTyVarDetails tyvar - -{- -Note [Unifying untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat an untouchable type variable as if it was a skolem. That -ensures it won't unify with anything. It's a slight hack, because -we return a made-up TcTyVarDetails, but I think it works smoothly. --} - --- | Breaks apart a function kind into its pieces. -matchExpectedFunKind - :: Outputable fun - => fun -- ^ 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' <- tcView 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 _ arg res) - = do { co <- go (n-1) res - ; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co) } - - go n other - = defer n other - - defer n k - = do { arg_kinds <- newMetaKindVars n - ; res_kind <- newMetaKindVar - ; let new_fun = mkVisFunTys arg_kinds res_kind - origin = TypeEqOrigin { uo_actual = k - , uo_expected = new_fun - , uo_thing = Just (ppr hs_ty) - , uo_visible = True - } - ; uType KindLevel origin k new_fun } - -{- ********************************************************************* -* * - Occurrence checking -* * -********************************************************************* -} - - -{- Note [Occurrence checking: look inside kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are considering unifying - (alpha :: *) ~ Int -> (beta :: alpha -> alpha) -This may be an error (what is that alpha doing inside beta's kind?), -but we must not make the mistake of actually unifying or we'll -build an infinite data structure. So when looking for occurrences -of alpha in the rhs, we must look in the kinds of type variables -that occur there. - -NB: we may be able to remove the problem via expansion; see - Note [Occurs check expansion]. So we have to try that. - -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]) 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->*) - --} - -data MetaTyVarUpdateResult a - = MTVU_OK a - | MTVU_Bad -- Forall, predicate, or type family - | MTVU_HoleBlocker -- Blocking coercion hole - -- See Note [Equalities with incompatible kinds] in TcCanonical - | MTVU_Occurs - deriving (Functor) - -instance Applicative MetaTyVarUpdateResult where - pure = MTVU_OK - (<*>) = ap - -instance Monad MetaTyVarUpdateResult where - MTVU_OK x >>= k = k x - MTVU_Bad >>= _ = MTVU_Bad - MTVU_HoleBlocker >>= _ = MTVU_HoleBlocker - MTVU_Occurs >>= _ = MTVU_Occurs - -instance Outputable a => Outputable (MetaTyVarUpdateResult a) where - ppr (MTVU_OK a) = text "MTVU_OK" <+> ppr a - ppr MTVU_Bad = text "MTVU_Bad" - ppr MTVU_HoleBlocker = text "MTVU_HoleBlocker" - ppr MTVU_Occurs = text "MTVU_Occurs" - -occCheckForErrors :: DynFlags -> TcTyVar -> Type -> MetaTyVarUpdateResult () --- Just for error-message generation; so we return MetaTyVarUpdateResult --- so the caller can report the right kind of error --- Check whether --- a) the given variable occurs in the given type. --- b) there is a forall in the type (unless we have -XImpredicativeTypes) -occCheckForErrors dflags tv ty - = case preCheck dflags True tv ty of - MTVU_OK _ -> MTVU_OK () - MTVU_Bad -> MTVU_Bad - MTVU_HoleBlocker -> MTVU_HoleBlocker - MTVU_Occurs -> case occCheckExpand [tv] ty of - Nothing -> MTVU_Occurs - Just _ -> MTVU_OK () - ----------------- -metaTyVarUpdateOK :: DynFlags - -> TcTyVar -- tv :: k1 - -> TcType -- ty :: k2 - -> MetaTyVarUpdateResult TcType -- possibly-expanded ty --- (metaTyVarUpdateOK tv ty) --- We are about to update the meta-tyvar tv with ty --- Check (a) that tv doesn't occur in ty (occurs check) --- (b) that ty does not have any foralls --- (in the impredicative case), or type functions --- (c) that ty does not have any blocking coercion holes --- See Note [Equalities with incompatible kinds] in TcCanonical --- --- We have two possible outcomes: --- (1) Return the type to update the type variable with, --- [we know the update is ok] --- (2) Return Nothing, --- [the update might be dodgy] --- --- Note that "Nothing" does not mean "definite error". For example --- type family F a --- type instance F Int = Int --- consider --- a ~ F a --- This is perfectly reasonable, if we later get a ~ Int. For now, though, --- we return Nothing, leaving it to the later constraint simplifier to --- sort matters out. --- --- See Note [Refactoring hazard: checkTauTvUpdate] - -metaTyVarUpdateOK dflags tv ty - = case preCheck dflags False tv ty of - -- False <=> type families not ok - -- See Note [Prevent unification with type families] - MTVU_OK _ -> MTVU_OK ty - MTVU_Bad -> MTVU_Bad -- forall, predicate, type function - MTVU_HoleBlocker -> MTVU_HoleBlocker -- coercion hole - MTVU_Occurs -> case occCheckExpand [tv] ty of - Just expanded_ty -> MTVU_OK expanded_ty - Nothing -> MTVU_Occurs - -preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> MetaTyVarUpdateResult () --- A quick check for --- (a) a forall type (unless -XImpredicativeTypes) --- (b) a predicate type (unless -XImpredicativeTypes) --- (c) a type family --- (d) a blocking coercion hole --- (e) an occurrence of the type variable (occurs check) --- --- For (a), (b), and (c) we check only the top level of the type, NOT --- inside the kinds of variables it mentions. For (d) we look deeply --- in coercions, and for (e) we do look in the kinds of course. - -preCheck dflags ty_fam_ok tv ty - = fast_check ty - where - details = tcTyVarDetails tv - impredicative_ok = canUnifyWithPolyType dflags details - - ok :: MetaTyVarUpdateResult () - ok = MTVU_OK () - - fast_check :: TcType -> MetaTyVarUpdateResult () - fast_check (TyVarTy tv') - | tv == tv' = MTVU_Occurs - | otherwise = fast_check_occ (tyVarKind tv') - -- See Note [Occurrence checking: look inside kinds] - - fast_check (TyConApp tc tys) - | bad_tc tc = MTVU_Bad - | otherwise = mapM fast_check tys >> ok - fast_check (LitTy {}) = ok - fast_check (FunTy{ft_af = af, ft_arg = a, ft_res = r}) - | InvisArg <- af - , not impredicative_ok = MTVU_Bad - | otherwise = fast_check a >> fast_check r - fast_check (AppTy fun arg) = fast_check fun >> fast_check arg - fast_check (CastTy ty co) = fast_check ty >> fast_check_co co - fast_check (CoercionTy co) = fast_check_co co - fast_check (ForAllTy (Bndr tv' _) ty) - | not impredicative_ok = MTVU_Bad - | tv == tv' = ok - | otherwise = do { fast_check_occ (tyVarKind tv') - ; fast_check_occ ty } - -- Under a forall we look only for occurrences of - -- the type variable - - -- For kinds, we only do an occurs check; we do not worry - -- about type families or foralls - -- See Note [Checking for foralls] - fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs - | otherwise = ok - - -- no bother about impredicativity in coercions, as they're - -- inferred - fast_check_co co | not (gopt Opt_DeferTypeErrors dflags) - , badCoercionHoleCo co = MTVU_HoleBlocker - -- Wrinkle (4b) in TcCanonical Note [Equalities with incompatible kinds] - - | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs - | otherwise = ok - - bad_tc :: TyCon -> Bool - bad_tc tc - | not (impredicative_ok || isTauTyCon tc) = True - | not (ty_fam_ok || isFamFreeTyCon tc) = True - | otherwise = False - -canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool -canUnifyWithPolyType dflags details - = case details of - MetaTv { mtv_info = TyVarTv } -> False - MetaTv { mtv_info = TauTv } -> xopt LangExt.ImpredicativeTypes dflags - _other -> True - -- We can have non-meta tyvars in given constraints diff --git a/compiler/typecheck/TcUnify.hs-boot b/compiler/typecheck/TcUnify.hs-boot deleted file mode 100644 --- a/compiler/typecheck/TcUnify.hs-boot +++ /dev/null @@ -1,15 +0,0 @@ -module TcUnify where - -import GhcPrelude -import TcType ( TcTauType ) -import TcRnTypes ( TcM ) -import TcEvidence ( TcCoercion ) -import GHC.Hs.Expr ( HsExpr ) -import GHC.Hs.Types ( HsType ) -import GHC.Hs.Extension ( GhcRn ) - --- This boot file exists only to tie the knot between --- TcUnify and Inst - -unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion -unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs deleted file mode 100644 --- a/compiler/typecheck/TcValidity.hs +++ /dev/null @@ -1,2907 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP, TupleSections, ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcValidity ( - Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, - checkValidTheta, - checkValidInstance, checkValidInstHead, validDerivPred, - checkTySynRhs, - checkValidCoAxiom, checkValidCoAxBranch, - checkValidTyFamEqn, checkConsistentFamInst, - badATErr, arityErr, - checkTyConTelescope, - allDistinctTyVars - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Maybes - --- friends: -import TcUnify ( tcSubType_NC ) -import TcSimplify ( simplifyAmbiguityCheck ) -import ClsInst ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) ) -import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr -import TcType hiding ( sizeType, sizeTypes ) -import TysWiredIn ( heqTyConName, eqTyConName, coercibleTyConName ) -import PrelNames -import GHC.Core.Type -import GHC.Core.Unify ( tcMatchTyX_BM, BindFlag(..) ) -import GHC.Core.Coercion -import GHC.Core.Coercion.Axiom -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Core.Predicate -import TcOrigin - --- others: -import GHC.Iface.Type ( pprIfaceType, pprIfaceTypeApp ) -import GHC.CoreToIface ( toIfaceTyCon, toIfaceTcArgs, toIfaceType ) -import GHC.Hs -- HsType -import TcRnMonad -- TcType, amongst others -import TcEnv ( tcInitTidyEnv, tcInitOpenTidyEnv ) -import FunDeps -import GHC.Core.FamInstEnv - ( isDominatedBy, injectiveBranches, InjectivityCheckResult(..) ) -import FamInst -import GHC.Types.Name -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Var ( VarBndr(..), mkTyVar ) -import FV -import ErrUtils -import GHC.Driver.Session -import Util -import ListSetOps -import GHC.Types.SrcLoc -import Outputable -import GHC.Types.Unique ( mkAlphaTyVarUnique ) -import Bag ( emptyBag ) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Foldable -import Data.List ( (\\), nub ) -import qualified Data.List.NonEmpty as NE - -{- -************************************************************************ -* * - Checking for ambiguity -* * -************************************************************************ - -Note [The ambiguity check for type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -checkAmbiguity is a check on *user-supplied type signatures*. It is -*purely* there to report functions that cannot possibly be called. So for -example we want to reject: - f :: C a => Int -The idea is there can be no legal calls to 'f' because every call will -give rise to an ambiguous constraint. We could soundly omit the -ambiguity check on type signatures entirely, at the expense of -delaying ambiguity errors to call sites. Indeed, the flag --XAllowAmbiguousTypes switches off the ambiguity check. - -What about things like this: - class D a b | a -> b where .. - h :: D Int b => Int -The Int may well fix 'b' at the call site, so that signature should -not be rejected. Moreover, using *visible* fundeps is too -conservative. Consider - class X a b where ... - class D a b | a -> b where ... - instance D a b => X [a] b where... - h :: X a b => a -> a -Here h's type looks ambiguous in 'b', but here's a legal call: - ...(h [True])... -That gives rise to a (X [Bool] beta) constraint, and using the -instance means we need (D Bool beta) and that fixes 'beta' via D's -fundep! - -Behind all these special cases there is a simple guiding principle. -Consider - - f :: - f = ...blah... - - g :: - g = f - -You would think that the definition of g would surely typecheck! -After all f has exactly the same type, and g=f. But in fact f's type -is instantiated and the instantiated constraints are solved against -the originals, so in the case an ambiguous type it won't work. -Consider our earlier example f :: C a => Int. Then in g's definition, -we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a), -and fail. - -So in fact we use this as our *definition* of ambiguity. We use a -very similar test for *inferred* types, to ensure that they are -unambiguous. See Note [Impedance matching] in TcBinds. - -This test is very conveniently implemented by calling - tcSubType -This neatly takes account of the functional dependency stuff above, -and implicit parameter (see Note [Implicit parameters and ambiguity]). -And this is what checkAmbiguity does. - -What about this, though? - g :: C [a] => Int -Is every call to 'g' ambiguous? After all, we might have - instance C [a] where ... -at the call site. So maybe that type is ok! Indeed even f's -quintessentially ambiguous type might, just possibly be callable: -with -XFlexibleInstances we could have - instance C a where ... -and now a call could be legal after all! Well, we'll reject this -unless the instance is available *here*. - -Note [When to call checkAmbiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We call checkAmbiguity - (a) on user-specified type signatures - (b) in checkValidType - -Conncerning (b), you might wonder about nested foralls. What about - f :: forall b. (forall a. Eq a => b) -> b -The nested forall is ambiguous. Originally we called checkAmbiguity -in the forall case of check_type, but that had two bad consequences: - * We got two error messages about (Eq b) in a nested forall like this: - g :: forall a. Eq a => forall b. Eq b => a -> a - * If we try to check for ambiguity of a nested forall like - (forall a. Eq a => b), the implication constraint doesn't bind - all the skolems, which results in "No skolem info" in error - messages (see #10432). - -To avoid this, we call checkAmbiguity once, at the top, in checkValidType. -(I'm still a bit worried about unbound skolems when the type mentions -in-scope type variables.) - -In fact, because of the co/contra-variance implemented in tcSubType, -this *does* catch function f above. too. - -Concerning (a) the ambiguity check is only used for *user* types, not -for types coming from interface files. The latter can legitimately -have ambiguous types. Example - - class S a where s :: a -> (Int,Int) - instance S Char where s _ = (1,1) - f:: S a => [a] -> Int -> (Int,Int) - f (_::[a]) x = (a*x,b) - where (a,b) = s (undefined::a) - -Here the worker for f gets the type - fw :: forall a. S a => Int -> (# Int, Int #) - - -Note [Implicit parameters and ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Only a *class* predicate can give rise to ambiguity -An *implicit parameter* cannot. For example: - foo :: (?x :: [a]) => Int - foo = length ?x -is fine. The call site will supply a particular 'x' - -Furthermore, the type variables fixed by an implicit parameter -propagate to the others. E.g. - foo :: (Show a, ?x::[a]) => Int - foo = show (?x++?x) -The type of foo looks ambiguous. But it isn't, because at a call site -we might have - let ?x = 5::Int in foo -and all is well. In effect, implicit parameters are, well, parameters, -so we can take their type variables into account as part of the -"tau-tvs" stuff. This is done in the function 'FunDeps.grow'. --} - -checkAmbiguity :: UserTypeCtxt -> Type -> TcM () -checkAmbiguity ctxt ty - | wantAmbiguityCheck ctxt - = 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 $ - tcSubType_NC ctxt ty ty - ; simplifyAmbiguityCheck ty wanted - - ; traceTc "Done ambiguity check for" (ppr ty) } - - | otherwise - = return () - where - mk_msg allow_ambiguous - = vcat [ text "In the ambiguity check for" <+> what - , ppUnless allow_ambiguous ambig_msg ] - ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes" - what | Just n <- isSigMaybe ctxt = quotes (ppr n) - | otherwise = pprUserTypeCtxt ctxt - -wantAmbiguityCheck :: UserTypeCtxt -> Bool -wantAmbiguityCheck ctxt - = case ctxt of -- See Note [When we don't check for ambiguity] - GhciCtxt {} -> False - TySynCtxt {} -> False - TypeAppCtxt -> False - StandaloneKindSigCtxt{} -> False - _ -> True - -checkUserTypeError :: Type -> TcM () --- Check to see if the type signature mentions "TypeError blah" --- anywhere in it, and fail if so. --- --- Very unsatisfactorily (#11144) we need to tidy the type --- because it may have come from an /inferred/ signature, not a --- user-supplied one. This is really only a half-baked fix; --- the other errors in checkValidType don't do tidying, and so --- may give bad error messages when given an inferred type. -checkUserTypeError = check - where - check ty - | Just msg <- userTypeError_maybe ty = fail_with msg - | Just (_,ts) <- splitTyConApp_maybe ty = mapM_ check ts - | Just (t1,t2) <- splitAppTy_maybe ty = check t1 >> check t2 - | Just (_,t1) <- splitForAllTy_maybe ty = check t1 - | otherwise = return () - - fail_with msg = do { env0 <- tcInitTidyEnv - ; let (env1, tidy_msg) = tidyOpenType env0 msg - ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) } - - -{- Note [When we don't check for ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a few places we do not want to check a user-specified type for ambiguity - -* GhciCtxt: Allow ambiguous types in GHCi's :kind command - E.g. type family T a :: * -- T :: forall k. k -> * - Then :k T should work in GHCi, not complain that - (T k) is ambiguous! - -* TySynCtxt: type T a b = C a b => blah - It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow - cure the ambiguity. So we defer the ambiguity check to the use site. - - There is also an implementation reason (#11608). In the RHS of - a type synonym we don't (currently) instantiate 'a' and 'b' with - TcTyVars before calling checkValidType, so we get assertion failures - from doing an ambiguity check on a type with TyVars in it. Fixing this - would not be hard, but let's wait till there's a reason. - -* TypeAppCtxt: visible type application - f @ty - No need to check ty for ambiguity - -* StandaloneKindSigCtxt: type T :: ksig - Kinds need a different ambiguity check than types, and the currently - implemented check is only good for types. See #14419, in particular - https://gitlab.haskell.org/ghc/ghc/issues/14419#note_160844 - -************************************************************************ -* * - Checking validity of a user-defined type -* * -************************************************************************ - -When dealing with a user-written type, we first translate it from an HsType -to a Type, performing kind checking, and then check various things that should -be true about it. We don't want to perform these checks at the same time -as the initial translation because (a) they are unnecessary for interface-file -types and (b) when checking a mutually recursive group of type and class decls, -we can't "look" at the tycons/classes yet. Also, the checks are rather -diverse, and used to really mess up the other code. - -One thing we check for is 'rank'. - - Rank 0: monotypes (no foralls) - Rank 1: foralls at the front only, Rank 0 inside - Rank 2: foralls at the front, Rank 1 on left of fn arrow, - - basic ::= tyvar | T basic ... basic - - r2 ::= forall tvs. cxt => r2a - r2a ::= r1 -> r2a | basic - r1 ::= forall tvs. cxt => r0 - r0 ::= r0 -> r0 | basic - -Another thing is to check that type synonyms are saturated. -This might not necessarily show up in kind checking. - type A i = i - data T k = MkT (k Int) - f :: T A -- BAD! --} - -checkValidType :: UserTypeCtxt -> Type -> TcM () --- Checks that a user-written type is valid for the given context --- Assumes argument is fully zonked --- Not used for instance decls; checkValidInstance instead -checkValidType ctxt ty - = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) - ; rankn_flag <- xoptM LangExt.RankNTypes - ; impred_flag <- xoptM LangExt.ImpredicativeTypes - ; let gen_rank :: Rank -> Rank - gen_rank r | rankn_flag = ArbitraryRank - | otherwise = r - - rank1 = gen_rank r1 - rank0 = gen_rank r0 - - r0 = rankZeroMonoType - r1 = LimitedRank True r0 - - rank - = case ctxt of - DefaultDeclCtxt-> MustBeMonoType - ResSigCtxt -> MustBeMonoType - PatSigCtxt -> rank0 - RuleSigCtxt _ -> rank1 - TySynCtxt _ -> rank0 - - ExprSigCtxt -> rank1 - KindSigCtxt -> rank1 - StandaloneKindSigCtxt{} -> rank1 - TypeAppCtxt | impred_flag -> ArbitraryRank - | otherwise -> tyConArgMonoType - -- Normally, ImpredicativeTypes is handled in check_arg_type, - -- but visible type applications don't go through there. - -- So we do this check here. - - FunSigCtxt {} -> rank1 - InfSigCtxt {} -> rank1 -- Inferred types should obey the - -- same rules as declared ones - - ConArgCtxt _ -> rank1 -- We are given the type of the entire - -- constructor, hence rank 1 - PatSynCtxt _ -> rank1 - - ForSigCtxt _ -> rank1 - SpecInstCtxt -> rank1 - ThBrackCtxt -> rank1 - GhciCtxt {} -> ArbitraryRank - - TyVarBndrKindCtxt _ -> rank0 - DataKindCtxt _ -> rank1 - TySynKindCtxt _ -> rank1 - TyFamResKindCtxt _ -> rank1 - - _ -> panic "checkValidType" - -- Can't happen; not used for *user* sigs - - ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) - ; expand <- initialExpandMode - ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt - , ve_rank = rank, ve_expand = expand } - - -- Check the internal validity of the type itself - -- Fail if bad things happen, else we misleading - -- (and more complicated) errors in checkAmbiguity - ; checkNoErrs $ - do { check_type ve ty - ; checkUserTypeError ty - ; traceTc "done ct" (ppr ty) } - - -- Check for ambiguous types. See Note [When to call checkAmbiguity] - -- NB: this will happen even for monotypes, but that should be cheap; - -- and there may be nested foralls for the subtype test to examine - ; checkAmbiguity ctxt ty - - ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) } - -checkValidMonoType :: Type -> TcM () --- Assumes argument is fully zonked -checkValidMonoType ty - = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) - ; expand <- initialExpandMode - ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = SigmaCtxt - , ve_rank = MustBeMonoType, ve_expand = expand } - ; check_type ve ty } - -checkTySynRhs :: UserTypeCtxt -> TcType -> TcM () -checkTySynRhs ctxt ty - | tcReturnsConstraintKind actual_kind - = do { ck <- xoptM LangExt.ConstraintKinds - ; if ck - then when (tcIsConstraintKind actual_kind) - (do { dflags <- getDynFlags - ; expand <- initialExpandMode - ; check_pred_ty emptyTidyEnv dflags ctxt expand ty }) - else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) } - - | otherwise - = return () - where - actual_kind = tcTypeKind ty - -{- -Note [Higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~ -Technically - Int -> forall a. a->a -is still a rank-1 type, but it's not Haskell 98 (#5957). So the -validity checker allow a forall after an arrow only if we allow it -before -- that is, with Rank2Types or RankNTypes --} - -data Rank = ArbitraryRank -- Any rank ok - - | LimitedRank -- Note [Higher rank types] - Bool -- Forall ok at top - Rank -- Use for function arguments - - | MonoType SDoc -- Monotype, with a suggestion of how it could be a polytype - - | MustBeMonoType -- Monotype regardless of flags - -instance Outputable Rank where - ppr ArbitraryRank = text "ArbitraryRank" - ppr (LimitedRank top_forall_ok r) - = text "LimitedRank" <+> ppr top_forall_ok - <+> parens (ppr r) - ppr (MonoType msg) = text "MonoType" <+> parens msg - ppr MustBeMonoType = text "MustBeMonoType" - -rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank -rankZeroMonoType = MonoType (text "Perhaps you intended to use RankNTypes") -tyConArgMonoType = MonoType (text "GHC doesn't yet support impredicative polymorphism") -synArgMonoType = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms") -constraintMonoType = MonoType (vcat [ text "A constraint must be a monotype" - , text "Perhaps you intended to use QuantifiedConstraints" ]) - -funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result -funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) -funArgResRank other_rank = (other_rank, other_rank) - -forAllAllowed :: Rank -> Bool -forAllAllowed ArbitraryRank = True -forAllAllowed (LimitedRank forall_ok _) = forall_ok -forAllAllowed _ = False - -allConstraintsAllowed :: UserTypeCtxt -> Bool --- We don't allow arbitrary constraints in kinds -allConstraintsAllowed (TyVarBndrKindCtxt {}) = False -allConstraintsAllowed (DataKindCtxt {}) = False -allConstraintsAllowed (TySynKindCtxt {}) = False -allConstraintsAllowed (TyFamResKindCtxt {}) = False -allConstraintsAllowed (StandaloneKindSigCtxt {}) = False -allConstraintsAllowed _ = True - --- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the --- context for the type of a term, where visible, dependent quantification is --- currently disallowed. --- --- An example of something that is unambiguously the type of a term is the --- @forall a -> a -> a@ in @foo :: forall a -> a -> a@. On the other hand, the --- same type in @type family Foo :: forall a -> a -> a@ is unambiguously the --- kind of a type, not the type of a term, so it is permitted. --- --- For more examples, see --- @testsuite/tests/dependent/should_compile/T16326_Compile*.hs@ (for places --- where VDQ is permitted) and --- @testsuite/tests/dependent/should_fail/T16326_Fail*.hs@ (for places where --- VDQ is disallowed). -vdqAllowed :: UserTypeCtxt -> Bool --- Currently allowed in the kinds of types... -vdqAllowed (KindSigCtxt {}) = True -vdqAllowed (StandaloneKindSigCtxt {}) = True -vdqAllowed (TySynCtxt {}) = True -vdqAllowed (ThBrackCtxt {}) = True -vdqAllowed (GhciCtxt {}) = True -vdqAllowed (TyVarBndrKindCtxt {}) = True -vdqAllowed (DataKindCtxt {}) = True -vdqAllowed (TySynKindCtxt {}) = True -vdqAllowed (TyFamResKindCtxt {}) = True --- ...but not in the types of terms. -vdqAllowed (ConArgCtxt {}) = False - -- We could envision allowing VDQ in data constructor types so long as the - -- constructor is only ever used at the type level, but for now, GHC adopts - -- the stance that VDQ is never allowed in data constructor types. -vdqAllowed (FunSigCtxt {}) = False -vdqAllowed (InfSigCtxt {}) = False -vdqAllowed (ExprSigCtxt {}) = False -vdqAllowed (TypeAppCtxt {}) = False -vdqAllowed (PatSynCtxt {}) = False -vdqAllowed (PatSigCtxt {}) = False -vdqAllowed (RuleSigCtxt {}) = False -vdqAllowed (ResSigCtxt {}) = False -vdqAllowed (ForSigCtxt {}) = False -vdqAllowed (DefaultDeclCtxt {}) = False --- We count class constraints as "types of terms". All of the cases below deal --- with class constraints. -vdqAllowed (InstDeclCtxt {}) = False -vdqAllowed (SpecInstCtxt {}) = False -vdqAllowed (GenSigCtxt {}) = False -vdqAllowed (ClassSCCtxt {}) = False -vdqAllowed (SigmaCtxt {}) = False -vdqAllowed (DataTyCtxt {}) = False -vdqAllowed (DerivClauseCtxt {}) = False - -{- -Note [Correctness and performance of type synonym validity checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the type A arg1 arg2, where A is a type synonym. How should we check -this type for validity? We have three distinct choices, corresponding to the -three constructors of ExpandMode: - -1. Expand the application of A, and check the resulting type (`Expand`). -2. Don't expand the application of A. Only check the arguments (`NoExpand`). -3. Check the arguments *and* check the expanded type (`Both`). - -It's tempting to think that we could always just pick choice (3), but this -results in serious performance issues when checking a type like in the -signature for `f` below: - - type S = ... - f :: S (S (S (S (S (S ....(S Int)...)))) - -When checking the type of `f`, we'll check the outer `S` application with and -without expansion, and in *each* of those checks, we'll check the next `S` -application with and without expansion... the result is exponential blowup! So -clearly we don't want to use `Both` 100% of the time. - -On the other hand, neither is it correct to use exclusively `Expand` or -exclusively `NoExpand` 100% of the time: - -* If one always expands, then one can miss erroneous programs like the one in - the `tcfail129` test case: - - type Foo a = String -> Maybe a - type Bar m = m Int - blah = undefined :: Bar Foo - - If we expand `Bar Foo` immediately, we'll miss the fact that the `Foo` type - synonyms is unsaturated. -* If one never expands and only checks the arguments, then one can miss - erroneous programs like the one in #16059: - - type Foo b = Eq b => b - f :: forall b (a :: Foo b). Int - - The kind of `a` contains a constraint, which is illegal, but this will only - be caught if `Foo b` is expanded. - -Therefore, it's impossible to have these validity checks be simultaneously -correct and performant if one sticks exclusively to a single `ExpandMode`. In -that case, the solution is to vary the `ExpandMode`s! In more detail: - -1. When we start validity checking, we start with `Expand` if - LiberalTypeSynonyms is enabled (see Note [Liberal type synonyms] for why we - do this), and we start with `Both` otherwise. The `initialExpandMode` - function is responsible for this. -2. When expanding an application of a type synonym (in `check_syn_tc_app`), we - determine which things to check based on the current `ExpandMode` argument. - Importantly, if the current mode is `Both`, then we check the arguments in - `NoExpand` mode and check the expanded type in `Both` mode. - - Switching to `NoExpand` when checking the arguments is vital to avoid - exponential blowup. One consequence of this choice is that if you have - the following type synonym in one module (with RankNTypes enabled): - - {-# LANGUAGE RankNTypes #-} - module A where - type A = forall a. a - - And you define the following in a separate module *without* RankNTypes - enabled: - - module B where - - import A - - type Const a b = a - f :: Const Int A -> Int - - Then `f` will be accepted, even though `A` (which is technically a rank-n - type) appears in its type. We view this as an acceptable compromise, since - `A` never appears in the type of `f` post-expansion. If `A` _did_ appear in - a type post-expansion, such as in the following variant: - - g :: Const A A -> Int - - Then that would be rejected unless RankNTypes were enabled. --} - --- | When validity-checking an application of a type synonym, should we --- check the arguments, check the expanded type, or both? --- See Note [Correctness and performance of type synonym validity checking] -data ExpandMode - = Expand -- ^ Only check the expanded type. - | NoExpand -- ^ Only check the arguments. - | Both -- ^ Check both the arguments and the expanded type. - -instance Outputable ExpandMode where - ppr e = text $ case e of - Expand -> "Expand" - NoExpand -> "NoExpand" - Both -> "Both" - --- | If @LiberalTypeSynonyms@ is enabled, we start in 'Expand' mode for the --- reasons explained in @Note [Liberal type synonyms]@. Otherwise, we start --- in 'Both' mode. -initialExpandMode :: TcM ExpandMode -initialExpandMode = do - liberal_flag <- xoptM LangExt.LiberalTypeSynonyms - pure $ if liberal_flag then Expand else Both - --- | Information about a type being validity-checked. -data ValidityEnv = ValidityEnv - { ve_tidy_env :: TidyEnv - , ve_ctxt :: UserTypeCtxt - , ve_rank :: Rank - , ve_expand :: ExpandMode } - -instance Outputable ValidityEnv where - ppr (ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt - , ve_rank = rank, ve_expand = expand }) = - hang (text "ValidityEnv") - 2 (vcat [ text "ve_tidy_env" <+> ppr env - , text "ve_ctxt" <+> pprUserTypeCtxt ctxt - , text "ve_rank" <+> ppr rank - , text "ve_expand" <+> ppr expand ]) - ----------------------------------------- -check_type :: ValidityEnv -> Type -> TcM () --- The args say what the *type context* requires, independent --- of *flag* settings. You test the flag settings at usage sites. --- --- Rank is allowed rank for function args --- Rank 0 means no for-alls anywhere - -check_type _ (TyVarTy _) = return () - -check_type ve (AppTy ty1 ty2) - = do { check_type ve ty1 - ; check_arg_type False ve ty2 } - -check_type ve ty@(TyConApp tc tys) - | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc - = check_syn_tc_app ve ty tc tys - | isUnboxedTupleTyCon tc = check_ubx_tuple ve ty tys - | otherwise = mapM_ (check_arg_type False ve) tys - -check_type _ (LitTy {}) = return () - -check_type ve (CastTy ty _) = check_type ve ty - --- Check for rank-n types, such as (forall x. x -> x) or (Show x => x). --- --- Critically, this case must come *after* the case for TyConApp. --- See Note [Liberal type synonyms]. -check_type ve@(ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt - , ve_rank = rank, ve_expand = expand }) ty - | not (null tvbs && null theta) - = do { traceTc "check_type" (ppr ty $$ ppr rank) - ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty) - -- Reject e.g. (Maybe (?x::Int => Int)), - -- with a decent error message - - ; checkConstraintsOK ve theta ty - -- Reject forall (a :: Eq b => b). blah - -- In a kind signature we don't allow constraints - - ; checkTcM (all (isInvisibleArgFlag . binderArgFlag) tvbs - || vdqAllowed ctxt) - (illegalVDQTyErr env ty) - -- Reject visible, dependent quantification in the type of a - -- term (e.g., `f :: forall a -> a -> Maybe a`) - - ; check_valid_theta env' SigmaCtxt expand theta - -- Allow type T = ?x::Int => Int -> Int - -- but not type T = ?x::Int - - ; check_type (ve{ve_tidy_env = env'}) tau - -- Allow foralls to right of arrow - - ; checkEscapingKind env' tvbs' theta tau } - where - (tvbs, phi) = tcSplitForAllVarBndrs ty - (theta, tau) = tcSplitPhiTy phi - (env', tvbs') = tidyTyCoVarBinders env tvbs - -check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy _ arg_ty res_ty) - = do { check_type (ve{ve_rank = arg_rank}) arg_ty - ; check_type (ve{ve_rank = res_rank}) res_ty } - where - (arg_rank, res_rank) = funArgResRank rank - -check_type _ ty = pprPanic "check_type" (ppr ty) - ----------------------------------------- -check_syn_tc_app :: ValidityEnv - -> KindOrType -> TyCon -> [KindOrType] -> TcM () --- Used for type synonyms and type synonym families, --- which must be saturated, --- but not data families, which need not be saturated -check_syn_tc_app (ve@ValidityEnv{ ve_ctxt = ctxt, ve_expand = expand }) - ty tc tys - | tys `lengthAtLeast` tc_arity -- Saturated - -- Check that the synonym has enough args - -- This applies equally to open and closed synonyms - -- It's OK to have an *over-applied* type synonym - -- data Tree a b = ... - -- type Foo a = Tree [a] - -- f :: Foo a b -> ... - = case expand of - _ | isTypeFamilyTyCon tc - -> check_args_only expand - -- See Note [Correctness and performance of type synonym validity - -- checking] - Expand -> check_expansion_only expand - NoExpand -> check_args_only expand - Both -> check_args_only NoExpand *> check_expansion_only Both - - | GhciCtxt True <- ctxt -- Accept outermost under-saturated type synonym or - -- type family constructors in GHCi :kind commands. - -- See Note [Unsaturated type synonyms in GHCi] - = check_args_only expand - - | otherwise - = failWithTc (tyConArityErr tc tys) - where - tc_arity = tyConArity tc - - check_arg :: ExpandMode -> KindOrType -> TcM () - check_arg expand = - check_arg_type (isTypeSynonymTyCon tc) (ve{ve_expand = expand}) - - check_args_only, check_expansion_only :: ExpandMode -> TcM () - check_args_only expand = mapM_ (check_arg expand) tys - - check_expansion_only expand - = ASSERT2( isTypeSynonymTyCon tc, ppr tc ) - case tcView ty of - Just ty' -> let err_ctxt = text "In the expansion of type synonym" - <+> quotes (ppr tc) - in addErrCtxt err_ctxt $ - check_type (ve{ve_expand = expand}) ty' - Nothing -> pprPanic "check_syn_tc_app" (ppr ty) - -{- -Note [Unsaturated type synonyms in GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking, GHC disallows unsaturated uses of type synonyms or type -families. For instance, if one defines `type Const a b = a`, then GHC will not -permit using `Const` unless it is applied to (at least) two arguments. There is -an exception to this rule, however: GHCi's :kind command. For instance, it -is quite common to look up the kind of a type constructor like so: - - λ> :kind Const - Const :: j -> k -> j - λ> :kind Const Int - Const Int :: k -> Type - -Strictly speaking, the two uses of `Const` above are unsaturated, but this -is an extremely benign (and useful) example of unsaturation, so we allow it -here as a special case. - -That being said, we do not allow unsaturation carte blanche in GHCi. Otherwise, -this GHCi interaction would be possible: - - λ> newtype Fix f = MkFix (f (Fix f)) - λ> type Id a = a - λ> :kind Fix Id - Fix Id :: Type - -This is rather dodgy, so we move to disallow this. We only permit unsaturated -synonyms in GHCi if they are *top-level*—that is, if the synonym is the -outermost type being applied. This allows `Const` and `Const Int` in the -first example, but not `Fix Id` in the second example, as `Id` is not the -outermost type being applied (`Fix` is). - -We track this outermost property in the GhciCtxt constructor of UserTypeCtxt. -A field of True in GhciCtxt indicates that we're in an outermost position. Any -time we invoke `check_arg` to check the validity of an argument, we switch the -field to False. --} - ----------------------------------------- -check_ubx_tuple :: ValidityEnv -> KindOrType -> [KindOrType] -> TcM () -check_ubx_tuple (ve@ValidityEnv{ve_tidy_env = env}) ty tys - = do { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples - ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty) - - ; impred <- xoptM LangExt.ImpredicativeTypes - ; let rank' = if impred then ArbitraryRank else tyConArgMonoType - -- c.f. check_arg_type - -- However, args are allowed to be unlifted, or - -- more unboxed tuples, so can't use check_arg_ty - ; mapM_ (check_type (ve{ve_rank = rank'})) tys } - ----------------------------------------- -check_arg_type - :: Bool -- ^ Is this the argument to a type synonym? - -> ValidityEnv -> KindOrType -> TcM () --- The sort of type that can instantiate a type variable, --- or be the argument of a type constructor. --- Not an unboxed tuple, but now *can* be a forall (since impredicativity) --- Other unboxed types are very occasionally allowed as type --- arguments depending on the kind of the type constructor --- --- For example, we want to reject things like: --- --- instance Ord a => Ord (forall s. T s a) --- and --- g :: T s (forall b.b) --- --- NB: unboxed tuples can have polymorphic or unboxed args. --- This happens in the workers for functions returning --- product types with polymorphic components. --- But not in user code. --- Anyway, they are dealt with by a special case in check_tau_type - -check_arg_type _ _ (CoercionTy {}) = return () - -check_arg_type type_syn (ve@ValidityEnv{ve_ctxt = ctxt, ve_rank = rank}) ty - = do { impred <- xoptM LangExt.ImpredicativeTypes - ; let rank' = case rank of -- Predictive => must be monotype - -- Rank-n arguments to type synonyms are OK, provided - -- that LiberalTypeSynonyms is enabled. - _ | type_syn -> synArgMonoType - MustBeMonoType -> MustBeMonoType -- Monotype, regardless - _other | impred -> ArbitraryRank - | otherwise -> tyConArgMonoType - -- Make sure that MustBeMonoType is propagated, - -- so that we don't suggest -XImpredicativeTypes in - -- (Ord (forall a.a)) => a -> a - -- and so that if it Must be a monotype, we check that it is! - ctxt' :: UserTypeCtxt - ctxt' - | GhciCtxt _ <- ctxt = GhciCtxt False - -- When checking an argument, set the field of GhciCtxt to - -- False to indicate that we are no longer in an outermost - -- position (and thus unsaturated synonyms are no longer - -- allowed). - -- See Note [Unsaturated type synonyms in GHCi] - | otherwise = ctxt - - ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty } - ----------------------------------------- -forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc) -forAllTyErr env rank ty - = ( env - , vcat [ hang herald 2 (ppr_tidy env ty) - , suggestion ] ) - where - (tvs, _theta, _tau) = tcSplitSigmaTy ty - herald | null tvs = text "Illegal qualified type:" - | otherwise = text "Illegal polymorphic type:" - suggestion = case rank of - LimitedRank {} -> text "Perhaps you intended to use RankNTypes" - MonoType d -> d - _ -> Outputable.empty -- Polytype is always illegal - --- | Reject type variables that would escape their escape through a kind. --- See @Note [Type variables escaping through kinds]@. -checkEscapingKind :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> TcM () -checkEscapingKind env tvbs theta tau = - case occCheckExpand (binderVars tvbs) phi_kind of - -- Ensure that none of the tvs occur in the kind of the forall - -- /after/ expanding type synonyms. - -- See Note [Phantom type variables in kinds] in GHC.Core.Type - Nothing -> failWithTcM $ forAllEscapeErr env tvbs theta tau tau_kind - Just _ -> pure () - where - tau_kind = tcTypeKind tau - phi_kind | null theta = tau_kind - | otherwise = liftedTypeKind - -- If there are any constraints, the kind is *. (#11405) - -forAllEscapeErr :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> Kind - -> (TidyEnv, SDoc) -forAllEscapeErr env tvbs theta tau tau_kind - = ( env - , vcat [ hang (text "Quantified type's kind mentions quantified type variable") - 2 (text "type:" <+> quotes (ppr (mkSigmaTy tvbs theta tau))) - -- NB: Don't tidy this type since the tvbs were already tidied - -- previously, and re-tidying them will make the names of type - -- variables different from tau_kind. - , hang (text "where the body of the forall has this kind:") - 2 (quotes (ppr_tidy env tau_kind)) ] ) - -{- -Note [Type variables escaping through kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - - type family T (r :: RuntimeRep) :: TYPE r - foo :: forall r. T r - -Something smells funny about the type of `foo`. If you spell out the kind -explicitly, it becomes clearer from where the smell originates: - - foo :: ((forall r. T r) :: TYPE r) - -The type variable `r` appears in the result kind, which escapes the scope of -its binding site! This is not desirable, so we establish a validity check -(`checkEscapingKind`) to catch any type variables that might escape through -kinds in this way. --} - -ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -ubxArgTyErr env ty - = ( env, vcat [ sep [ text "Illegal unboxed tuple type as function argument:" - , ppr_tidy env ty ] - , text "Perhaps you intended to use UnboxedTuples" ] ) - -checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM () -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) $ - constraintTyErr (ve_tidy_env ve) ty - -constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -constraintTyErr env ty - = (env, text "Illegal constraint in a kind:" <+> ppr_tidy env ty) - --- | Reject a use of visible, dependent quantification in the type of a term. -illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -illegalVDQTyErr env ty = - (env, vcat - [ hang (text "Illegal visible, dependent quantification" <+> - text "in the type of a term:") - 2 (ppr_tidy env ty) - , text "(GHC does not yet support this)" ] ) - -{- -Note [Liberal type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If -XLiberalTypeSynonyms is on, expand closed type synonyms *before* -doing validity checking. This allows us to instantiate a synonym defn -with a for-all type, or with a partially-applied type synonym. - e.g. type T a b = a - type S m = m () - f :: S (T Int) -Here, T is partially applied, so it's illegal in H98. But if you -expand S first, then T we get just - f :: Int -which is fine. - -IMPORTANT: suppose T is a type synonym. Then we must do validity -checking on an application (T ty1 ty2) - - *either* before expansion (i.e. check ty1, ty2) - *or* after expansion (i.e. expand T ty1 ty2, and then check) - BUT NOT BOTH - -If we do both, we get exponential behaviour!! - - data TIACons1 i r c = c i ::: r c - type TIACons2 t x = TIACons1 t (TIACons1 t x) - type TIACons3 t x = TIACons2 t (TIACons1 t x) - type TIACons4 t x = TIACons2 t (TIACons2 t x) - type TIACons7 t x = TIACons4 t (TIACons3 t x) - -The order in which you do validity checking is also somewhat delicate. Consider -the `check_type` function, which drives the validity checking for unsaturated -uses of type synonyms. There is a special case for rank-n types, such as -(forall x. x -> x) or (Show x => x), since those require at least one language -extension to use. It used to be the case that this case came before every other -case, but this can lead to bugs. Imagine you have this scenario (from #15954): - - type A a = Int - type B (a :: Type -> Type) = forall x. x -> x - type C = B A - -If the rank-n case came first, then in the process of checking for `forall`s -or contexts, we would expand away `B A` to `forall x. x -> x`. This is because -the functions that split apart `forall`s/contexts -(tcSplitForAllVarBndrs/tcSplitPhiTy) expand type synonyms! If `B A` is expanded -away to `forall x. x -> x` before the actually validity checks occur, we will -have completely obfuscated the fact that we had an unsaturated application of -the `A` type synonym. - -We have since learned from our mistakes and now put this rank-n case /after/ -the case for TyConApp, which ensures that an unsaturated `A` TyConApp will be -caught properly. But be careful! We can't make the rank-n case /last/ either, -as the FunTy case must came after the rank-n case. Otherwise, something like -(Eq a => Int) would be treated as a function type (FunTy), which just -wouldn't do. - -************************************************************************ -* * -\subsection{Checking a theta or source type} -* * -************************************************************************ - -Note [Implicit parameters in instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Implicit parameters _only_ allowed in type signatures; not in instance -decls, superclasses etc. The reason for not allowing implicit params in -instances is a bit subtle. If we allowed - instance (?x::Int, Eq a) => Foo [a] where ... -then when we saw - (e :: (?x::Int) => t) -it would be unclear how to discharge all the potential uses of the ?x -in e. For example, a constraint Foo [Int] might come out of e, and -applying the instance decl would show up two uses of ?x. #8912. --} - -checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM () --- Assumes argument is fully zonked -checkValidTheta ctxt theta - = addErrCtxtM (checkThetaCtxt ctxt theta) $ - do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta) - ; expand <- initialExpandMode - ; check_valid_theta env ctxt expand theta } - -------------------------- -check_valid_theta :: TidyEnv -> UserTypeCtxt -> ExpandMode - -> [PredType] -> TcM () -check_valid_theta _ _ _ [] - = return () -check_valid_theta env ctxt expand theta - = do { dflags <- getDynFlags - ; warnTcM (Reason Opt_WarnDuplicateConstraints) - (wopt Opt_WarnDuplicateConstraints dflags && notNull dups) - (dupPredWarn env dups) - ; traceTc "check_valid_theta" (ppr theta) - ; mapM_ (check_pred_ty env dflags ctxt expand) theta } - where - (_,dups) = removeDups nonDetCmpType theta - -- It's OK to use nonDetCmpType because dups only appears in the - -- warning - -------------------------- -{- Note [Validity checking for constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We look through constraint synonyms so that we can see the underlying -constraint(s). For example - type Foo = ?x::Int - instance Foo => C T -We should reject the instance because it has an implicit parameter in -the context. - -But we record, in 'under_syn', whether we have looked under a synonym -to avoid requiring language extensions at the use site. Main example -(#9838): - - {-# LANGUAGE ConstraintKinds #-} - module A where - type EqShow a = (Eq a, Show a) - - module B where - import A - foo :: EqShow a => a -> String - -We don't want to require ConstraintKinds in module B. --} - -check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> ExpandMode - -> PredType -> TcM () --- Check the validity of a predicate in a signature --- See Note [Validity checking for constraints] -check_pred_ty env dflags ctxt expand pred - = do { check_type ve pred - ; check_pred_help False env dflags ctxt pred } - where - rank | xopt LangExt.QuantifiedConstraints dflags - = ArbitraryRank - | otherwise - = constraintMonoType - - ve :: ValidityEnv - ve = ValidityEnv{ ve_tidy_env = env - , ve_ctxt = SigmaCtxt - , ve_rank = rank - , ve_expand = expand } - -check_pred_help :: Bool -- True <=> under a type synonym - -> TidyEnv - -> DynFlags -> UserTypeCtxt - -> PredType -> TcM () -check_pred_help under_syn env dflags ctxt pred - | Just pred' <- tcView pred -- Switch on under_syn when going under a - -- synonym (#9838, yuk) - = check_pred_help True env dflags ctxt pred' - - | otherwise -- A bit like classifyPredType, but not the same - -- E.g. we treat (~) like (~#); and we look inside tuples - = case classifyPredType pred of - ClassPred cls tys - | isCTupleClass cls -> check_tuple_pred under_syn env dflags ctxt pred tys - | otherwise -> check_class_pred env dflags ctxt pred cls tys - - EqPred _ _ _ -> pprPanic "check_pred_help" (ppr pred) - -- EqPreds, such as (t1 ~ #t2) or (t1 ~R# t2), don't even have kind Constraint - -- and should never appear before the '=>' of a type. Thus - -- f :: (a ~# b) => blah - -- is wrong. For user written signatures, it'll be rejected by kind-checking - -- well before we get to validity checking. For inferred types we are careful - -- to box such constraints in TcType.pickQuantifiablePreds, as described - -- in Note [Lift equality constraints when quantifying] in TcType - - ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head - IrredPred {} -> check_irred_pred under_syn env dflags ctxt pred - -check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM () -check_eq_pred env dflags pred - = -- Equational constraints are valid in all contexts if type - -- families are permitted - checkTcM (xopt LangExt.TypeFamilies dflags - || xopt LangExt.GADTs dflags) - (eqPredTyErr env pred) - -check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt - -> PredType -> ThetaType -> PredType -> TcM () -check_quant_pred env dflags ctxt pred theta head_pred - = addErrCtxt (text "In the quantified constraint" <+> quotes (ppr pred)) $ - do { -- Check the instance head - case classifyPredType head_pred of - -- SigmaCtxt tells checkValidInstHead that - -- this is the head of a quantified constraint - ClassPred cls tys -> do { checkValidInstHead SigmaCtxt cls tys - ; check_pred_help False env dflags ctxt head_pred } - -- need check_pred_help to do extra pred-only validity - -- checks, such as for (~). Otherwise, we get #17563 - -- NB: checks for the context are covered by the check_type - -- in check_pred_ty - IrredPred {} | hasTyVarHead head_pred - -> return () - _ -> failWithTcM (badQuantHeadErr env pred) - - -- Check for termination - ; unless (xopt LangExt.UndecidableInstances dflags) $ - checkInstTermination theta head_pred - } - -check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM () -check_tuple_pred under_syn env dflags ctxt pred ts - = do { -- See Note [ConstraintKinds in predicates] - checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags) - (predTupleErr env pred) - ; mapM_ (check_pred_help under_syn env dflags ctxt) ts } - -- This case will not normally be executed because without - -- -XConstraintKinds tuple types are only kind-checked as * - -check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM () -check_irred_pred under_syn env dflags ctxt pred - -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint - -- where X is a type function - = do { -- If it looks like (x t1 t2), require ConstraintKinds - -- see Note [ConstraintKinds in predicates] - -- But (X t1 t2) is always ok because we just require ConstraintKinds - -- at the definition site (#9838) - failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags) - && hasTyVarHead pred) - (predIrredErr env pred) - - -- Make sure it is OK to have an irred pred in this context - -- See Note [Irreducible predicates in superclasses] - ; failIfTcM (is_superclass ctxt - && not (xopt LangExt.UndecidableInstances dflags) - && has_tyfun_head pred) - (predSuperClassErr env pred) } - where - is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False } - has_tyfun_head ty - = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> isTypeFamilyTyCon tc - Nothing -> False - -{- Note [ConstraintKinds in predicates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Don't check for -XConstraintKinds under a type synonym, because that -was done at the type synonym definition site; see #9838 -e.g. module A where - type C a = (Eq a, Ix a) -- Needs -XConstraintKinds - module B where - import A - f :: C a => a -> a -- Does *not* need -XConstraintKinds - -Note [Irreducible predicates in superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Allowing type-family calls in class superclasses is somewhat dangerous -because we can write: - - type family Fooish x :: * -> Constraint - type instance Fooish () = Foo - class Fooish () a => Foo a where - -This will cause the constraint simplifier to loop because every time we canonicalise a -(Foo a) class constraint we add a (Fooish () a) constraint which will be immediately -solved to add+canonicalise another (Foo a) constraint. -} - -------------------------- -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, - -- but here we want to treat them as equalities - = check_eq_pred env dflags pred - - | isIPClass cls - = do { check_arity - ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) } - - | otherwise -- Includes Coercible - = do { check_arity - ; checkSimplifiableClassConstraint env dflags ctxt cls tys - ; checkTcM arg_tys_ok (predTyVarErr env pred) } - where - check_arity = checkTc (tys `lengthIs` classArity cls) - (tyConArityErr (classTyCon cls) tys) - - -- Check the arguments of a class constraint - flexible_contexts = xopt LangExt.FlexibleContexts dflags - undecidable_ok = xopt LangExt.UndecidableInstances dflags - arg_tys_ok = case ctxt of - SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine - InstDeclCtxt {} -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys - -- Further checks on head and theta - -- in checkInstTermination - _ -> checkValidClsArgs flexible_contexts cls tys - -checkSimplifiableClassConstraint :: TidyEnv -> DynFlags -> UserTypeCtxt - -> Class -> [TcType] -> TcM () --- See Note [Simplifiable given constraints] -checkSimplifiableClassConstraint env dflags ctxt cls tys - | not (wopt Opt_WarnSimplifiableClassConstraints dflags) - = return () - | xopt LangExt.MonoLocalBinds dflags - = return () - - | DataTyCtxt {} <- ctxt -- Don't do this check for the "stupid theta" - = return () -- of a data type declaration - - | cls `hasKey` coercibleTyConKey - = return () -- Oddly, we treat (Coercible t1 t2) as unconditionally OK - -- matchGlobalInst will reply "yes" because we can reduce - -- (Coercible a b) to (a ~R# b) - - | otherwise - = do { result <- matchGlobalInst dflags False cls tys - ; case result of - OneInst { cir_what = what } - -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints) - (simplifiable_constraint_warn 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") ] - -{- Note [Simplifiable given constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A type signature like - f :: Eq [(a,b)] => a -> b -is very fragile, for reasons described at length in TcInteract -Note [Instance and Given overlap]. As that Note discusses, for the -most part the clever stuff in TcInteract 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). - -So this warning is switched on only if we have NoMonoLocalBinds; in -that case the warning discourages users from writing simplifiable -class constraints. - -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 -TcInteract.matchInstEnv fires an interaction with the top -level instances. For example (#13526), consider - - instance {-# OVERLAPPABLE #-} Eq (T a) where ... - instance Eq (T Char) where .. - f :: Eq (T a) => ... - -We don't want to complain about this, even though the context -(Eq (T a)) matches an instance, because the user may be -deliberately deferring the choice so that the Eq (T Char) -has a chance to fire when 'f' is called. And the fragility -only matters when there's a risk that the instance might -fire instead of the local 'given'; and there is no such -risk in this case. Just use the same rules as for instance -firing! --} - -------------------------- -okIPCtxt :: UserTypeCtxt -> Bool - -- See Note [Implicit parameters in instance decls] -okIPCtxt (FunSigCtxt {}) = True -okIPCtxt (InfSigCtxt {}) = True -okIPCtxt ExprSigCtxt = True -okIPCtxt TypeAppCtxt = True -okIPCtxt PatSigCtxt = True -okIPCtxt ResSigCtxt = True -okIPCtxt GenSigCtxt = True -okIPCtxt (ConArgCtxt {}) = True -okIPCtxt (ForSigCtxt {}) = True -- ?? -okIPCtxt ThBrackCtxt = True -okIPCtxt (GhciCtxt {}) = True -okIPCtxt SigmaCtxt = True -okIPCtxt (DataTyCtxt {}) = True -okIPCtxt (PatSynCtxt {}) = True -okIPCtxt (TySynCtxt {}) = True -- e.g. type Blah = ?x::Int - -- #11466 - -okIPCtxt (KindSigCtxt {}) = False -okIPCtxt (StandaloneKindSigCtxt {}) = False -okIPCtxt (ClassSCCtxt {}) = False -okIPCtxt (InstDeclCtxt {}) = False -okIPCtxt (SpecInstCtxt {}) = False -okIPCtxt (RuleSigCtxt {}) = False -okIPCtxt DefaultDeclCtxt = False -okIPCtxt DerivClauseCtxt = False -okIPCtxt (TyVarBndrKindCtxt {}) = False -okIPCtxt (DataKindCtxt {}) = False -okIPCtxt (TySynKindCtxt {}) = False -okIPCtxt (TyFamResKindCtxt {}) = False - -{- -Note [Kind polymorphic type classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -MultiParam check: - - class C f where... -- C :: forall k. k -> Constraint - instance C Maybe where... - - The dictionary gets type [C * Maybe] even if it's not a MultiParam - type class. - -Flexibility check: - - class C f where... -- C :: forall k. k -> Constraint - data D a = D a - instance C D where - - The dictionary gets type [C * (D *)]. IA0_TODO it should be - generalized actually. --} - -checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc) -checkThetaCtxt ctxt theta env - = return ( env - , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta) - , text "While checking" <+> pprUserTypeCtxt ctxt ] ) - -eqPredTyErr, predTupleErr, predIrredErr, - predSuperClassErr, badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) -badQuantHeadErr env pred - = ( env - , hang (text "Quantified predicate must have a class or type variable head:") - 2 (ppr_tidy env pred) ) -eqPredTyErr env pred - = ( env - , text "Illegal equational constraint" <+> ppr_tidy env pred $$ - parens (text "Use GADTs or TypeFamilies to permit this") ) -predTupleErr env pred - = ( env - , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred) - 2 (parens constraintKindsMsg) ) -predIrredErr env pred - = ( env - , hang (text "Illegal constraint:" <+> ppr_tidy env pred) - 2 (parens constraintKindsMsg) ) -predSuperClassErr env pred - = ( env - , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred) - <+> text "in a superclass context") - 2 (parens undecidableMsg) ) - -predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) -predTyVarErr env pred - = (env - , vcat [ hang (text "Non type-variable argument") - 2 (text "in the constraint:" <+> ppr_tidy env pred) - , parens (text "Use FlexibleContexts to permit this") ]) - -badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc) -badIPPred env pred - = ( env - , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) ) - -constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -constraintSynErr env kind - = ( env - , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind)) - 2 (parens constraintKindsMsg) ) - -dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc) -dupPredWarn env dups - = ( env - , text "Duplicate constraint" <> plural primaryDups <> text ":" - <+> pprWithCommas (ppr_tidy env) primaryDups ) - where - primaryDups = map NE.head dups - -tyConArityErr :: TyCon -> [TcType] -> SDoc --- For type-constructor arity errors, be careful to report --- the number of /visible/ arguments required and supplied, --- 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 - where - vis_tks = filterOutInvisibleTypes tc tks - - -- tc_type_arity = number of *type* args expected - -- tc_type_args = number of *type* args encountered - tc_type_arity = count isVisibleTyConBinder (tyConBinders tc) - tc_type_args = length vis_tks - -arityErr :: Outputable a => SDoc -> a -> Int -> Int -> SDoc -arityErr what name n m - = 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"] - -{- -************************************************************************ -* * -\subsection{Checking for a decent instance head type} -* * -************************************************************************ - -@checkValidInstHead@ checks the type {\em and} its syntactic constraints: -it must normally look like: @instance Foo (Tycon a b c ...) ...@ - -The exceptions to this syntactic checking: (1)~if the @GlasgowExts@ -flag is on, or (2)~the instance is imported (they must have been -compiled elsewhere). In these cases, we let them go through anyway. - -We can also have instances for functions: @instance Foo (a -> b) ...@. --} - -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 - ; checkValidTypePats (classTyCon clas) cls_args - } - -{- - -Note [Instances of built-in classes in signature files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -User defined instances for KnownNat, KnownSymbol and Typeable are -disallowed -- they are generated when needed by GHC itself on-the-fly. - -However, if they occur in a Backpack signature file, they have an -entirely different meaning. Suppose in M.hsig we see - - signature M where - data T :: Nat - instance KnownNat T - -That says that any module satisfying M.hsig must provide a KnownNat -instance for T. We absolultely need that instance when compiling a -module that imports M.hsig: see #15379 and -Note [Fabricating Evidence for Literals in Backpack] in ClsInst. - -Hence, checkValidInstHead accepts a user-written instance declaration -in hsig files, where `is_sig` is True. - --} - -check_special_inst_head :: DynFlags -> Bool -> Bool - -> UserTypeCtxt -> Class -> [Type] -> TcM () --- Wow! There are a surprising number of ad-hoc special cases here. -check_special_inst_head dflags is_boot is_sig ctxt clas cls_args - - -- If not in an hs-boot file, abstract classes cannot have instances - | isAbstractClass clas - , not is_boot - = failWithTc abstract_class_msg - - -- For Typeable, don't complain about instances for - -- standalone deriving; they are no-ops, and we warn about - -- it in TcDeriv.deriveStandalone. - | clas_nm == typeableClassName - , not is_sig - -- Note [Instances of built-in classes in signature files] - , hand_written_bindings - = failWithTc rejected_class_msg - - -- Handwritten instances of KnownNat/KnownSymbol class - -- are always forbidden (#12837) - | clas_nm `elem` [ knownNatClassName, knownSymbolClassName ] - , not is_sig - -- Note [Instances of built-in classes in signature files] - , hand_written_bindings - = failWithTc rejected_class_msg - - -- 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 ] - , not quantified_constraint - = failWithTc rejected_class_msg - - -- Check for hand-written Generic instances (disallowed in Safe Haskell) - | clas_nm `elem` genericClassNames - , hand_written_bindings - = do { failIfTc (safeLanguageOn dflags) gen_inst_err - ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } - - | clas_nm == hasFieldClassName - = checkHasFieldInst clas cls_args - - | isCTupleClass clas - = failWithTc tuple_class_msg - - -- 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) - - | otherwise - = pure () - where - clas_nm = getName clas - ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args - - hand_written_bindings - = case ctxt of - InstDeclCtxt stand_alone -> not stand_alone - SpecInstCtxt -> False - DerivClauseCtxt -> False - _ -> True - - check_h98_arg_shape = case ctxt of - SpecInstCtxt -> False - DerivClauseCtxt -> False - SigmaCtxt -> False - _ -> True - -- SigmaCtxt: once we are in quantified-constraint land, we - -- aren't so picky about enforcing H98-language restrictions - -- E.g. we want to allow a head like Coercible (m a) (m b) - - - -- When we are looking at the head of a quantified constraint, - -- check_quant_pred sets ctxt to SigmaCtxt - quantified_constraint = case ctxt of - 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." - - rejected_class_msg = text "Class" <+> quotes (ppr clas_nm) - <+> text "does not support user-specified instances" - tuple_class_msg = text "You can't specify an instance for a tuple constraint" - - gen_inst_err = rejected_class_msg $$ nest 2 (text "(in Safe Haskell)") - - abstract_class_msg = text "Cannot define instance for abstract class" - <+> quotes (ppr clas_nm) - - mb_ty_args_msg - | not (xopt LangExt.TypeSynonymInstances dflags) - , not (all tcInstHeadTyNotSynonym ty_args) - = Just head_type_synonym_msg - - | not (xopt LangExt.FlexibleInstances dflags) - , not (all tcInstHeadTyAppAllTyVars ty_args) - = Just head_type_args_tyvars_msg - - | length ty_args /= 1 - , not (xopt LangExt.MultiParamTypeClasses dflags) - , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args) - = Just head_one_type_msg - - | otherwise - = Nothing - -tcInstHeadTyNotSynonym :: Type -> Bool --- Used in Haskell-98 mode, for the argument types of an instance head --- These must not be type synonyms, but everywhere else type synonyms --- are transparent, so we need a special function here -tcInstHeadTyNotSynonym ty - = case ty of -- Do not use splitTyConApp, - -- because that expands synonyms! - TyConApp tc _ -> not (isTypeSynonymTyCon tc) - _ -> True - -tcInstHeadTyAppAllTyVars :: Type -> Bool --- Used in Haskell-98 mode, for the argument types of an instance head --- These must be a constructor applied to type variable arguments --- or a type-level literal. --- But we allow kind instantiations. -tcInstHeadTyAppAllTyVars ty - | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty) - = ok (filterOutInvisibleTypes tc tys) -- avoid kinds - | LitTy _ <- ty = True -- accept type literals (#13833) - | otherwise - = False - where - -- Check that all the types are type variables, - -- and that each is distinct - ok tys = equalLength tvs tys && hasNoDups tvs - where - tvs = mapMaybe tcGetTyVar_maybe tys - -dropCasts :: Type -> Type --- See Note [Casts during validity checking] --- This function can turn a well-kinded type into an ill-kinded --- one, so I've kept it local to this module --- To consider: drop only HoleCo casts -dropCasts (CastTy ty _) = dropCasts ty -dropCasts (AppTy t1 t2) = mkAppTy (dropCasts t1) (dropCasts t2) -dropCasts ty@(FunTy _ t1 t2) = ty { ft_arg = dropCasts t1, ft_res = dropCasts t2 } -dropCasts (TyConApp tc tys) = mkTyConApp tc (map dropCasts tys) -dropCasts (ForAllTy b ty) = ForAllTy (dropCastsB b) (dropCasts ty) -dropCasts ty = ty -- LitTy, TyVarTy, CoercionTy - -dropCastsB :: TyVarBinder -> TyVarBinder -dropCastsB b = b -- Don't bother in the kind of a forall - -instTypeErr :: Class -> [Type] -> SDoc -> SDoc -instTypeErr cls tys msg - = 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] = - case splitTyConApp_maybe r_ty of - Nothing -> whoops (text "Record data type must be specified") - Just (tc, _) - | isFamilyTyCon tc - -> whoops (text "Record data type may not be a data family") - | otherwise -> case isStrLitTy x_ty of - Just lbl - | isJust (lookupTyConFieldLabel lbl tc) - -> whoops (ppr tc <+> text "already has a field" - <+> quotes (ppr lbl)) - | otherwise -> return () - Nothing - | null (tyConFieldLabels tc) -> return () - | otherwise -> whoops (ppr tc <+> text "has fields") - where - whoops = addErrTc . instTypeErr cls tys -checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys) - -{- Note [Casts during validity checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the (bogus) - instance Eq Char# -We elaborate to 'Eq (Char# |> UnivCo(hole))' where the hole is an -insoluble equality constraint for * ~ #. We'll report the insoluble -constraint separately, but we don't want to *also* complain that Eq is -not applied to a type constructor. So we look gaily look through -CastTys here. - -Another example: Eq (Either a). Then we actually get a cast in -the middle: - Eq ((Either |> g) a) - - -Note [Validity checking of HasField instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The HasField class has magic constraint solving behaviour (see Note -[HasField instances] in TcInteract). However, we permit users to -declare their own instances, provided they do not clash with the -built-in behaviour. In particular, we forbid: - - 1. `HasField _ r _` where r is a variable - - 2. `HasField _ (T ...) _` if T is a data family - (because it might have fields introduced later) - - 3. `HasField x (T ...) _` where x is a variable, - if T has any fields at all - - 4. `HasField "foo" (T ...) _` if T has a "foo" field - -The usual functional dependency checks also apply. - - -Note [Valid 'deriving' predicate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -validDerivPred checks for OK 'deriving' context. See Note [Exotic -derived instance contexts] in TcDeriv. However the predicate is -here because it uses sizeTypes, fvTypes. - -It checks for three things - - * No repeated variables (hasNoDups fvs) - - * No type constructors. This is done by comparing - sizeTypes tys == length (fvTypes tys) - sizeTypes counts variables and constructors; fvTypes returns variables. - So if they are the same, there must be no constructors. But there - might be applications thus (f (g x)). - - Note that tys only includes 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 sizeTypes - would count as a constructor! See #11833. - - * Also check for a bizarre corner case, when the derived instance decl - would look like - 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. - -Note [Equality class instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can't have users writing instances for the equality classes. But we -still need to be able to write instances for them ourselves. So we allow -instances only in the defining module. - --} - -validDerivPred :: TyVarSet -> PredType -> Bool --- See Note [Valid 'deriving' predicate] -validDerivPred tv_set pred - = case classifyPredType pred of - ClassPred cls tys -> cls `hasKey` typeableClassKey - -- Typeable constraints are bigger than they appear due - -- to kind polymorphism, but that's OK - || check_tys cls tys - EqPred {} -> False -- reject equality constraints - _ -> True -- Non-class predicates are ok - where - check_tys cls tys - = hasNoDups fvs - -- use sizePred to ignore implicit args - && lengthIs fvs (sizePred pred) - && all (`elemVarSet` tv_set) fvs - where tys' = filterOutInvisibleTypes (classTyCon cls) tys - fvs = fvTypes tys' - -{- -************************************************************************ -* * -\subsection{Checking instance for termination} -* * -************************************************************************ --} - -{- Note [Instances and constraint synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Currently, we don't allow instances for constraint synonyms at all. -Consider these (#13267): - type C1 a = Show (a -> Bool) - instance C1 Int where -- I1 - show _ = "ur" - -This elicits "show is not a (visible) method of class C1", which isn't -a great message. But it comes from the renamer, so it's hard to improve. - -This needs a bit more care: - type C2 a = (Show a, Show Int) - instance C2 Int -- I2 - -If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose -the instance head, we'll expand the synonym on fly, and it'll look like - instance (%,%) (Show Int, Show Int) -and we /really/ don't want that. So we carefully do /not/ expand -synonyms, by matching on TyConApp directly. --} - -checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () -checkValidInstance ctxt hs_type ty - | not is_tc_app - = failWithTc (hang (text "Instance head is not headed by a class:") - 2 ( ppr tau)) - - | isNothing mb_cls - = failWithTc (vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc) - , text "A class instance must be for a class" ]) - - | not arity_ok - = failWithTc (text "Arity mis-match in instance head") - - | otherwise - = do { setSrcSpan head_loc $ - checkValidInstHead ctxt clas inst_tys - - ; traceTc "checkValidInstance {" (ppr ty) - - ; env0 <- tcInitTidyEnv - ; expand <- initialExpandMode - ; check_valid_theta env0 ctxt expand theta - - -- The Termination and Coverate Conditions - -- Check that instance inference will terminate (if we care) - -- For Haskell 98 this will already have been done by checkValidTheta, - -- but as we may be using other extensions we need to check. - -- - -- Note that the Termination Condition is *more conservative* than - -- the checkAmbiguity test we do on other type signatures - -- e.g. Bar a => Bar Int is ambiguous, but it also fails - -- the termination condition, because 'a' appears more often - -- in the constraint than in the head - ; undecidable_ok <- xoptM LangExt.UndecidableInstances - ; if undecidable_ok - then checkAmbiguity ctxt ty - else checkInstTermination theta tau - - ; 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 - - ; return () } - where - (_tvs, theta, tau) = tcSplitSigmaTy ty - is_tc_app = case tau of { TyConApp {} -> True; _ -> False } - TyConApp tc inst_tys = tau -- See Note [Instances and constraint synonyms] - mb_cls = tyConClass_maybe tc - Just clas = mb_cls - arity_ok = inst_tys `lengthIs` classArity clas - - -- The location of the "head" of the instance - head_loc = getLoc (getLHsInstDeclHead hs_type) - -{- -Note [Paterson conditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Termination test: the so-called "Paterson conditions" (see Section 5 of -"Understanding functional dependencies via Constraint Handling Rules, -JFP Jan 2007). - -We check that each assertion in the context satisfies: - (1) no variable has more occurrences in the assertion than in the head, and - (2) the assertion has fewer constructors and variables (taken together - and counting repetitions) than the head. -This is only needed with -fglasgow-exts, as Haskell 98 restrictions -(which have already been checked) guarantee termination. - -The underlying idea is that - - for any ground substitution, each assertion in the - context has fewer type constructors than the head. --} - -checkInstTermination :: ThetaType -> TcPredType -> TcM () --- See Note [Paterson conditions] -checkInstTermination theta head_pred - = check_preds emptyVarSet theta - where - head_fvs = fvType head_pred - head_size = sizeType head_pred - - check_preds :: VarSet -> [PredType] -> TcM () - check_preds foralld_tvs preds = mapM_ (check foralld_tvs) preds - - check :: VarSet -> PredType -> TcM () - check foralld_tvs pred - = case classifyPredType pred of - EqPred {} -> return () -- See #4200. - IrredPred {} -> check2 foralld_tvs pred (sizeType pred) - ClassPred cls tys - | isTerminatingClass cls - -> return () - - | isCTupleClass cls -- Look inside tuple predicates; #8359 - -> check_preds foralld_tvs tys - - | otherwise -- Other ClassPreds - -> check2 foralld_tvs pred bogus_size - where - bogus_size = 1 + sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys) - -- See Note [Invisible arguments and termination] - - ForAllPred tvs _ head_pred' - -> check (foralld_tvs `extendVarSetList` tvs) head_pred' - -- Termination of the quantified predicate itself is checked - -- when the predicates are individually checked for validity - - check2 foralld_tvs pred pred_size - | not (null bad_tvs) = failWithTc (noMoreMsg bad_tvs what (ppr head_pred)) - | not (isTyFamFree pred) = failWithTc (nestedMsg what) - | pred_size >= head_size = failWithTc (smallerMsg what (ppr head_pred)) - | otherwise = return () - -- isTyFamFree: see Note [Type families in instance contexts] - where - what = text "constraint" <+> quotes (ppr pred) - bad_tvs = filterOut (`elemVarSet` foralld_tvs) (fvType pred) - \\ head_fvs - -smallerMsg :: SDoc -> SDoc -> SDoc -smallerMsg what inst_head - = vcat [ hang (text "The" <+> what) - 2 (sep [ text "is no smaller than" - , text "the instance head" <+> quotes inst_head ]) - , parens undecidableMsg ] - -noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -> SDoc -noMoreMsg tvs what inst_head - = vcat [ hang (text "Variable" <> plural tvs1 <+> quotes (pprWithCommas ppr tvs1) - <+> occurs <+> text "more often") - 2 (sep [ text "in the" <+> what - , text "than in the instance head" <+> quotes inst_head ]) - , parens undecidableMsg ] - where - tvs1 = nub tvs - occurs = if isSingleton tvs1 then text "occurs" - else text "occur" - -undecidableMsg, constraintKindsMsg :: SDoc -undecidableMsg = text "Use UndecidableInstances to permit this" -constraintKindsMsg = text "Use ConstraintKinds to permit this" - -{- Note [Type families in instance contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Are these OK? - type family F a - instance F a => C (Maybe [a]) where ... - instance C (F a) => C [[[a]]] where ... - -No: the type family in the instance head might blow up to an -arbitrarily large type, depending on how 'a' is instantiated. -So we require UndecidableInstances if we have a type family -in the instance head. #15172. - -Note [Invisible arguments and termination] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When checking the ​Paterson conditions for termination an instance -declaration, we check for the number of "constructors and variables" -in the instance head and constraints. Question: Do we look at - - * All the arguments, visible or invisible? - * Just the visible arguments? - -I think both will ensure termination, provided we are consistent. -Currently we are /not/ consistent, which is really a bug. It's -described in #15177, which contains a number of examples. -The suspicious bits are the calls to filterOutInvisibleTypes. --} - - -{- -************************************************************************ -* * - Checking type instance well-formedness and termination -* * -************************************************************************ --} - -checkValidCoAxiom :: CoAxiom Branched -> TcM () -checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) - = do { mapM_ (checkValidCoAxBranch fam_tc) branch_list - ; foldlM_ check_branch_compat [] branch_list } - where - branch_list = fromBranches branches - injectivity = tyConInjectivityInfo fam_tc - - check_branch_compat :: [CoAxBranch] -- previous branches in reverse order - -> CoAxBranch -- current branch - -> TcM [CoAxBranch]-- current branch : previous branches - -- Check for - -- (a) this branch is dominated by previous ones - -- (b) failure of injectivity - check_branch_compat prev_branches cur_branch - | cur_branch `isDominatedBy` prev_branches - = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $ - inaccessibleCoAxBranch fam_tc cur_branch - ; return prev_branches } - | otherwise - = do { check_injectivity prev_branches cur_branch - ; return (cur_branch : prev_branches) } - - -- Injectivity check: check whether a new (CoAxBranch) can extend - -- already checked equations without violating injectivity - -- annotation supplied by the user. - -- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv - check_injectivity prev_branches cur_branch - | Injective inj <- injectivity - = do { dflags <- getDynFlags - ; let conflicts = - fst $ foldl' (gather_conflicts inj prev_branches cur_branch) - ([], 0) prev_branches - ; reportConflictingInjectivityErrs fam_tc conflicts cur_branch - ; reportInjectivityErrors dflags ax cur_branch inj } - | otherwise - = return () - - gather_conflicts inj prev_branches cur_branch (acc, n) branch - -- n is 0-based index of branch in prev_branches - = case injectiveBranches inj cur_branch branch of - -- Case 1B2 in Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv - InjectivityUnified ax1 ax2 - | ax1 `isDominatedBy` (replace_br prev_branches n ax2) - -> (acc, n + 1) - | otherwise - -> (branch : acc, n + 1) - InjectivityAccepted -> (acc, n + 1) - - -- Replace n-th element in the list. Assumes 0-based indexing. - replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch] - replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs - - --- Check that a "type instance" is well-formed (which includes decidability --- unless -XUndecidableInstances is given). --- -checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM () -checkValidCoAxBranch fam_tc - (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_lhs = typats - , cab_rhs = rhs, cab_loc = loc }) - = setSrcSpan loc $ - checkValidTyFamEqn fam_tc (tvs++cvs) typats rhs - --- | Do validity checks on a type family equation, including consistency --- with any enclosing class instance head, termination, and lack of --- polytypes. -checkValidTyFamEqn :: TyCon -- ^ of the type family - -> [Var] -- ^ Bound variables in the equation - -> [Type] -- ^ Type patterns - -> Type -- ^ Rhs - -> TcM () -checkValidTyFamEqn fam_tc qvs typats rhs - = do { checkValidTypePats fam_tc typats - - -- Check for things used on the right but not bound on the left - ; checkFamPatBinders fam_tc qvs typats rhs - - -- Check for oversaturated visible kind arguments in a type family - -- equation. - -- See Note [Oversaturated type family equations] - ; when (isTypeFamilyTyCon fam_tc) $ - case drop (tyConArity fam_tc) typats of - [] -> pure () - spec_arg:_ -> - addErr $ text "Illegal oversaturated visible kind argument:" - <+> quotes (char '@' <> pprParendType spec_arg) - - -- The argument patterns, and RHS, are all boxed tau types - -- E.g Reject type family F (a :: k1) :: k2 - -- type instance F (forall a. a->a) = ... - -- type instance F Int# = ... - -- type instance F Int = forall a. a->a - -- type instance F Int = Int# - -- See #9357 - ; checkValidMonoType rhs - - -- We have a decidable instance unless otherwise permitted - ; undecidable_ok <- xoptM LangExt.UndecidableInstances - ; traceTc "checkVTFE" (ppr fam_tc $$ ppr rhs $$ ppr (tcTyFamInsts rhs)) - ; unless undecidable_ok $ - mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) } - --- Make sure that each type family application is --- (1) strictly smaller than the lhs, --- (2) mentions no type variable more often than the lhs, and --- (3) does not contain any further type family instances. --- -checkFamInstRhs :: TyCon -> [Type] -- LHS - -> [(TyCon, [Type])] -- type family calls in RHS - -> [MsgDoc] -checkFamInstRhs lhs_tc lhs_tys famInsts - = mapMaybe check famInsts - where - lhs_size = sizeTyConAppArgs lhs_tc lhs_tys - inst_head = pprType (TyConApp lhs_tc lhs_tys) - lhs_fvs = fvTypes lhs_tys - check (tc, tys) - | not (all isTyFamFree tys) = Just (nestedMsg what) - | not (null bad_tvs) = Just (noMoreMsg bad_tvs what inst_head) - | lhs_size <= fam_app_size = Just (smallerMsg what inst_head) - | otherwise = Nothing - where - what = text "type family application" - <+> quotes (pprType (TyConApp tc tys)) - fam_app_size = sizeTyConAppArgs tc tys - bad_tvs = fvTypes tys \\ lhs_fvs - -- The (\\) is list difference; e.g. - -- [a,b,a,a] \\ [a,a] = [b,a] - -- So we are counting repetitions - ------------------ -checkFamPatBinders :: TyCon - -> [TcTyVar] -- Bound on LHS of family instance - -> [TcType] -- LHS patterns - -> Type -- RHS - -> TcM () --- We do these binder checks now, in tcFamTyPatsAndGen, rather --- than later, in checkValidFamEqn, for two reasons: --- - We have the implicitly and explicitly --- bound type variables conveniently to hand --- - If implicit variables are out of scope it may --- cause a crash; notably in tcConDecl in tcDataFamInstDecl -checkFamPatBinders fam_tc qtvs pats rhs - = do { traceTc "checkFamPatBinders" $ - vcat [ debugPprType (mkTyConApp fam_tc pats) - , ppr (mkTyConApp fam_tc pats) - , text "qtvs:" <+> ppr qtvs - , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs) - , text "pat_tvs:" <+> ppr pat_tvs - , text "inj_pat_tvs:" <+> ppr inj_pat_tvs ] - - -- Check for implicitly-bound tyvars, mentioned on the - -- RHS but not bound on the LHS - -- data T = MkT (forall (a::k). blah) - -- data family D Int = MkD (forall (a::k). blah) - -- 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 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") - } - where - pat_tvs = tyCoVarsOfTypes pats - inj_pat_tvs = fvVarSet $ injectiveVarsOfTypes False pats - -- The type variables that are in injective positions. - -- See Note [Dodgy binding sites in type family instances] - -- NB: The False above is irrelevant, as we never have type families in - -- patterns. - -- - -- NB: It's OK to use the nondeterministic `fvVarSet` function here, - -- since the order of `inj_pat_tvs` is never revealed in an error - -- message. - rhs_fvs = tyCoFVsOfType rhs - used_tvs = pat_tvs `unionVarSet` fvVarSet rhs_fvs - bad_qtvs = filterOut (`elemVarSet` used_tvs) qtvs - -- Bound but not used at all - bad_rhs_tvs = filterOut (`elemVarSet` inj_pat_tvs) (fvVarList rhs_fvs) - -- Used on RHS but not bound on LHS - dodgy_tvs = pat_tvs `minusVarSet` inj_pat_tvs - - check_tvs tvs what what2 - = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ - 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)) - - --- | Checks that a list of type patterns is valid in a matching (LHS) --- position of a class instances or type/data family instance. --- --- Specifically: --- * All monotypes --- * No type-family applications -checkValidTypePats :: TyCon -> [Type] -> TcM () -checkValidTypePats tc pat_ty_args - = do { -- Check that each of pat_ty_args is a monotype. - -- One could imagine generalising to allow - -- instance C (forall a. a->a) - -- but we don't know what all the consequences might be. - traverse_ checkValidMonoType pat_ty_args - - -- 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 $ - ty_fam_inst_illegal_err tf_is_invis_arg - (mkTyConApp 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) - -nestedMsg :: SDoc -> SDoc -nestedMsg what - = sep [ text "Illegal nested" <+> what - , parens undecidableMsg ] - -badATErr :: Name -> Name -> SDoc -badATErr clas op - = hsep [text "Class", quotes (ppr clas), - text "does not have an associated type", quotes (ppr op)] - - -------------------------- -checkConsistentFamInst :: AssocInstInfo - -> TyCon -- ^ Family tycon - -> CoAxBranch - -> TcM () --- See Note [Checking consistent instantiation] - -checkConsistentFamInst NotAssociated _ _ - = return () - -checkConsistentFamInst (InClsInst { ai_class = clas - , ai_tyvars = inst_tvs - , ai_inst_env = mini_env }) - fam_tc branch - = do { traceTc "checkConsistentFamInst" (vcat [ ppr inst_tvs - , ppr arg_triples - , ppr mini_env - , ppr ax_tvs - , ppr ax_arg_tys - , ppr arg_triples ]) - -- 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) - (badATErr (className clas) (tyConName fam_tc)) - - ; check_match arg_triples - } - where - (ax_tvs, ax_arg_tys, _) = etaExpandCoAxBranch branch - - arg_triples :: [(Type,Type, ArgFlag)] - arg_triples = [ (cls_arg_ty, at_arg_ty, vis) - | (fam_tc_tv, vis, at_arg_ty) - <- zip3 (tyConTyVars fam_tc) - (tyConArgFlags fam_tc ax_arg_tys) - ax_arg_tys - , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ] - - pp_wrong_at_arg vis - = pprWithExplicitKindsWhen (isInvisibleArgFlag 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) (mkTyVarOcc "_") noSrcSpan - - -- For check_match, bind_me, see - -- Note [Matching in the consistent-instantiation check] - check_match :: [(Type,Type,ArgFlag)] -> TcM () - check_match triples = go emptyTCvSubst emptyTCvSubst triples - - go _ _ [] = return () - go lr_subst rl_subst ((ty1,ty2,vis):triples) - | Just lr_subst1 <- tcMatchTyX_BM bind_me lr_subst ty1 ty2 - , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1 - = go lr_subst1 rl_subst1 triples - | otherwise - = addErrTc (pp_wrong_at_arg vis) - - -- The /scoped/ type variables from the class-instance header - -- should not be alpha-renamed. Inferred ones can be. - no_bind_set = mkVarSet inst_tvs - bind_me tv | tv `elemVarSet` no_bind_set = Skolem - | otherwise = BindMe - - -{- Note [Check type-family instance binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a type family instance, we require (of course), type variables -used on the RHS are matched on the LHS. This is checked by -checkFamPatBinders. Here is an interesting example: - - type family T :: k - type instance T = (Nothing :: Maybe a) - -Upon a cursory glance, it may appear that the kind variable `a` is unbound -since there are no (visible) LHS patterns in `T`. However, there is an -*invisible* pattern due to the return kind, so inside of GHC, the instance -looks closer to this: - - type family T @k :: k - type instance T @(Maybe a) = (Nothing :: Maybe a) - -Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in -fact not unbound. Contrast that with this example (#13985) - - type instance T = Proxy (Nothing :: Maybe a) - -This would looks like this inside of GHC: - - type instance T @(*) = Proxy (Nothing :: Maybe a) - -So this time, `a` is neither bound by a visible nor invisible type pattern on -the LHS, so `a` would be reported as not in scope. - -Finally, here's one more brain-teaser (from #9574). In the example below: - - class Funct f where - type Codomain f :: * - instance Funct ('KProxy :: KProxy o) where - type Codomain 'KProxy = NatTr (Proxy :: o -> *) - -As it turns out, `o` is in scope in this example. That is because `o` is -bound by the kind signature of the LHS type pattern 'KProxy. To make this more -obvious, one can also write the instance like so: - - instance Funct ('KProxy :: KProxy o) where - type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *) - -Note [Dodgy binding sites in type family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example (from #7536): - - type T a = Int - type instance F (T a) = a - -This `F` instance is extremely fishy, since the RHS, `a`, purports to be -"bound" by the LHS pattern `T a`. "Bound" has scare quotes around it because -`T a` expands to `Int`, which doesn't mention at all, so it's as if one had -actually written: - - type instance F Int = a - -That is clearly bogus, so to reject this, we check that every type variable -that is mentioned on the RHS is /actually/ bound on the LHS. In other words, -we need to do something slightly more sophisticated that just compute the free -variables of the LHS patterns. - -It's tempting to just expand all type synonyms on the LHS and then compute -their free variables, but even that isn't sophisticated enough. After all, -an impish user could write the following (#17008): - - type family ConstType (a :: Type) :: Type where - ConstType _ = Type - - type family F (x :: ConstType a) :: Type where - F (x :: ConstType a) = a - -Just like in the previous example, the `a` on the RHS isn't actually bound -on the LHS, but this time a type family is responsible for the deception, not -a type synonym. - -We avoid both issues by requiring that all RHS type variables are mentioned -in injective positions on the left-hand side (by way of -`injectiveVarsOfTypes`). For instance, the `a` in `T a` is not in an injective -position, as `T` is not an injective type constructor, so we do not count that. -Similarly for the `a` in `ConstType a`. - -Note [Matching in the consistent-instantiation check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Matching the class-instance header to family-instance tyvars is -tricker than it sounds. Consider (#13972) - class C (a :: k) where - type T k :: Type - instance C Left where - type T (a -> Either a b) = Int - -Here there are no lexically-scoped variables from (C Left). -Yet the real class-instance header is C @(p -> Either @p @q)) (Left @p @q) -while the type-family instance is T (a -> Either @a @b) -So we allow alpha-renaming of variables that don't come -from the class-instance header. - -We track the lexically-scoped type variables from the -class-instance header in ai_tyvars. - -Here's another example (#14045a) - class C (a :: k) where - data S (a :: k) - instance C (z :: Bool) where - data S :: Bool -> Type where - -Again, there is no lexical connection, but we will get - class-instance header: C @Bool (z::Bool) - family instance S @Bool (a::Bool) - -When looking for mis-matches, we check left-to-right, -kinds first. If we look at types first, we'll fail to -suggest -fprint-explicit-kinds for a mis-match with - T @k vs T @Type -somewhere deep inside the type - -Note [Checking consistent instantiation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #11450 for background discussion on this check. - - class C a b where - type T a x b - -With this class decl, if we have an instance decl - instance C ty1 ty2 where ... -then the type instance must look like - type T ty1 v ty2 = ... -with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'. -For example: - - instance C [p] Int - type T [p] y Int = (p,y,y) - -Note that - -* We used to allow completely different bound variables in the - associated type instance; e.g. - instance C [p] Int - type T [q] y Int = ... - But from GHC 8.2 onwards, we don't. It's much simpler this way. - See #11450. - -* When the class variable isn't used on the RHS of the type instance, - it's tempting to allow wildcards, thus - instance C [p] Int - type T [_] y Int = (y,y) - But it's awkward to do the test, and it doesn't work if the - variable is repeated: - instance C (p,p) Int - type T (_,_) y Int = (y,y) - Even though 'p' is not used on the RHS, we still need to use 'p' - on the LHS to establish the repeated pattern. So to keep it simple - we just require equality. - -* For variables in associated type families that are not bound by the class - itself, we do _not_ check if they are over-specific. In other words, - it's perfectly acceptable to have an instance like this: - - instance C [p] Int where - type T [p] (Maybe x) Int = x - - While the first and third arguments to T are required to be exactly [p] and - Int, respectively, since they are bound by C, the second argument is allowed - to be more specific than just a type variable. Furthermore, it is permissible - to define multiple equations for T that differ only in the non-class-bound - argument: - - instance C [p] Int where - type T [p] (Maybe x) Int = x - type T [p] (Either x y) Int = x -> y - - We once considered requiring that non-class-bound variables in associated - type family instances be instantiated with distinct type variables. However, - that requirement proved too restrictive in practice, as there were examples - of extremely simple associated type family instances that this check would - reject, and fixing them required tiresome boilerplate in the form of - auxiliary type families. For instance, you would have to define the above - example as: - - instance C [p] Int where - type T [p] x Int = CAux x - - type family CAux x where - CAux (Maybe x) = x - CAux (Either x y) = x -> y - - We decided that this restriction wasn't buying us much, so we opted not - to pursue that design (see also GHC #13398). - -Implementation - * Form the mini-envt from the class type variables a,b - to the instance decl types [p],Int: [a->[p], b->Int] - - * Look at the tyvars a,x,b of the type family constructor T - (it shares tyvars with the class C) - - * Apply the mini-evnt to them, and check that the result is - consistent with the instance types [p] y Int. (where y can be any type, as - it is not scoped over the class type variables. - -We make all the instance type variables scope over the -type instances, of course, which picks up non-obvious kinds. Eg - class Foo (a :: k) where - type F a - instance Foo (b :: k -> k) where - type F b = Int -Here the instance is kind-indexed and really looks like - type F (k->k) (b::k->k) = Int -But if the 'b' didn't scope, we would make F's instance too -poly-kinded. - -Note [Printing conflicts with class header] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's remarkably painful to give a decent error message for conflicts -with the class header. Consider - clase C b where - type F a b c - instance C [b] where - type F x Int _ _ = ... - -Here we want to report a conflict between - Expected: F _ [b] _ - Actual: F x Int _ _ - -But if the type instance shadows the class variable like this -(rename/should_fail/T15828): - instance C [b] where - type forall b. F x (Tree b) _ _ = ... - -then we must use a fresh variable name - Expected: F _ [b] _ - Actual: F x [b1] _ _ - -Notice that: - - We want to print an underscore in the "Expected" type in - positions where the class header has no influence over the - parameter. Hence the fancy footwork in pp_expected_ty - - - Although the binders in the axiom are already tidy, we must - re-tidy them to get a fresh variable name when we shadow - - - The (ax_tvs \\ inst_tvs) is to avoid tidying one of the - class-instance variables a second time, from 'a' to 'a1' say. - Remember, the ax_tvs of the axiom share identity with the - class-instance variables, inst_tvs.. - - - We use tidyCoAxBndrsForUser to get underscores rather than - _1, _2, etc in the axiom tyvars; see the definition of - tidyCoAxBndrsForUser - -This all seems absurdly complicated. - -Note [Unused explicitly bound variables in a family pattern] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Why is 'unusedExplicitForAllErr' not just a warning? - -Consider the following examples: - - type instance F a = Maybe b - type instance forall b. F a = Bool - type instance forall b. F a = Maybe b - -In every case, b is a type variable not determined by the LHS pattern. The -first is caught by the renamer, but we catch the last two here. Perhaps one -could argue that the second should be accepted, albeit with a warning, but -consider the fact that in a type family instance, there is no way to interact -with such a varable. At least with @x :: forall a. Int@ we can use visibile -type application, like @x \@Bool 1@. (Of course it does nothing, but it is -permissible.) In the type family case, the only sensible explanation is that -the user has made a mistake -- thus we throw an error. - -Note [Oversaturated type family equations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Type family tycons have very rigid arities. We want to reject something like -this: - - type family Foo :: Type -> Type where - Foo x = ... - -Because Foo has arity zero (i.e., it doesn't bind anything to the left of the -double colon), we want to disallow any equation for Foo that has more than zero -arguments, such as `Foo x = ...`. The algorithm here is pretty simple: if an -equation has more arguments than the arity of the type family, reject. - -Things get trickier when visible kind application enters the picture. Consider -the following example: - - type family Bar (x :: j) :: forall k. Either j k where - Bar 5 @Symbol = ... - -The arity of Bar is two, since it binds two variables, `j` and `x`. But even -though Bar's equation has two arguments, it's still invalid. Imagine the same -equation in Core: - - Bar Nat 5 Symbol = ... - -Here, it becomes apparent that Bar is actually taking /three/ arguments! So -we can't just rely on a simple counting argument to reject -`Bar 5 @Symbol = ...`, since it only has two user-written arguments. -Moreover, there's one explicit argument (5) and one visible kind argument -(@Symbol), which matches up perfectly with the fact that Bar has one required -binder (x) and one specified binder (j), so that's not a valid way to detect -oversaturation either. - -To solve this problem in a robust way, we do the following: - -1. When kind-checking, we count the number of user-written *required* - arguments and check if there is an equal number of required tycon binders. - If not, reject. (See `wrongNumberOfParmsErr` in TcTyClsDecls.) - - We perform this step during kind-checking, not during validity checking, - since we can give better error messages if we catch it early. -2. When validity checking, take all of the (Core) type patterns from on - equation, drop the first n of them (where n is the arity of the type family - tycon), and check if there are any types leftover. If so, reject. - - Why does this work? We know that after dropping the first n type patterns, - none of the leftover types can be required arguments, since step (1) would - have already caught that. Moreover, the only places where visible kind - applications should be allowed are in the first n types, since those are the - only arguments that can correspond to binding forms. Therefore, the - remaining arguments must correspond to oversaturated uses of visible kind - applications, which are precisely what we want to reject. - -Note that we only perform this check for type families, and not for data -families. This is because it is perfectly acceptable to oversaturate data -family instance equations: see Note [Arity of data families] in GHC.Core.FamInstEnv. - -************************************************************************ -* * - Telescope checking -* * -************************************************************************ - -Note [Bad TyCon telescopes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Now that we can mix type and kind variables, there are an awful lot of -ways to shoot yourself in the foot. Here are some. - - data SameKind :: k -> k -> * -- just to force unification - -1. data T1 a k (b :: k) (x :: SameKind a b) - -The problem here is that we discover that a and b should have the same -kind. But this kind mentions k, which is bound *after* a. -(Testcase: dependent/should_fail/BadTelescope) - -2. data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) - -Note that b is not bound. Yet its kind mentions a. Because we have -a nice rule that all implicitly bound variables come before others, -this is bogus. - -To catch these errors, we call checkTyConTelescope during kind-checking -datatype declarations. This checks for - -* Ill-scoped binders. From (1) and (2) above we can get putative - kinds like - T1 :: forall (a:k) (k:*) (b:k). SameKind a b -> * - where 'k' is mentioned a's kind before k is bound - - This is easy to check for: just look for - out-of-scope variables in the kind - -* We should arguably also check for ambiguous binders - but we don't. See Note [Ambiguous kind vars]. - -See also - * Note [Required, Specified, and Inferred for types] in TcTyClsDecls. - * Note [Checking telescopes] in Constraint discusses how - this check works for `forall x y z.` written in a type. - -Note [Ambiguous kind vars] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to be concerned about ambiguous binders. Suppose we have the kind - S1 :: forall k -> * -> * - S2 :: forall k. * -> * -Here S1 is OK, because k is Required, and at a use of S1 we will -see (S1 *) or (S1 (*->*)) or whatever. - -But S2 is /not/ OK because 'k' is Specfied (and hence invisible) and -we have no way (ever) to figure out how 'k' should be instantiated. -For example if we see (S2 Int), that tells us nothing about k's -instantiation. (In this case we'll instantiate it to Any, but that -seems wrong.) This is really the same test as we make for ambiguous -type in term type signatures. - -Now, it's impossible for a Specified variable not to occur -at all in the kind -- after all, it is Specified so it must have -occurred. (It /used/ to be possible; see tests T13983 and T7873. But -with the advent of the forall-or-nothing rule for kind variables, -those strange cases went away.) - -But one might worry about - type v k = * - S3 :: forall k. V k -> * -which appears to mention 'k' but doesn't really. Or - S4 :: forall k. F k -> * -where F is a type function. But we simply don't check for -those cases of ambiguity, yet anyway. The worst that can happen -is ambiguity at the call sites. - -Historical note: this test used to be called reportFloatingKvs. --} - --- | Check a list of binders to see if they make a valid telescope. --- See Note [Bad TyCon telescopes] -type TelescopeAcc - = ( TyVarSet -- Bound earlier in the telescope - , Bool -- At least one binder occurred (in a kind) before - -- it was bound in the telescope. E.g. - ) -- T :: forall (a::k) k. blah - -checkTyConTelescope :: TyCon -> TcM () -checkTyConTelescope tc - | bad_scope - = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes] - addErr $ - 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) ] - - | otherwise - = return () - where - tcbs = tyConBinders tc - tvs = binderVars tcbs - sorted_tvs = scopedSort tvs - - (_, bad_scope) = foldl add_one (emptyVarSet, False) tcbs - - add_one :: TelescopeAcc -> TyConBinder -> TelescopeAcc - add_one (bound, bad_scope) tcb - = ( bound `extendVarSet` tv - , bad_scope || not (isEmptyVarSet (fkvs `minusVarSet` bound)) ) - where - tv = binderVar tcb - fkvs = tyCoVarsOfType (tyVarKind tv) - - inferred_tvs = [ binderVar tcb - | tcb <- tcbs, Inferred == tyConBinderArgFlag tcb ] - specified_tvs = [ binderVar tcb - | tcb <- tcbs, Specified == tyConBinderArgFlag 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]]) - -{- -************************************************************************ -* * -\subsection{Auxiliary functions} -* * -************************************************************************ --} - --- Free variables of a type, retaining repetitions, and expanding synonyms --- This ignores coercions, as coercions aren't user-written -fvType :: Type -> [TyCoVar] -fvType ty | Just exp_ty <- tcView ty = fvType exp_ty -fvType (TyVarTy tv) = [tv] -fvType (TyConApp _ tys) = fvTypes tys -fvType (LitTy {}) = [] -fvType (AppTy fun arg) = fvType fun ++ fvType arg -fvType (FunTy _ arg res) = fvType arg ++ fvType res -fvType (ForAllTy (Bndr tv _) ty) - = fvType (tyVarKind tv) ++ - filter (/= tv) (fvType ty) -fvType (CastTy ty _) = fvType ty -fvType (CoercionTy {}) = [] - -fvTypes :: [Type] -> [TyVar] -fvTypes tys = concatMap fvType tys - -sizeType :: Type -> Int --- Size of a type: the number of variables and constructors -sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty -sizeType (TyVarTy {}) = 1 -sizeType (TyConApp tc tys) = 1 + sizeTyConAppArgs tc tys -sizeType (LitTy {}) = 1 -sizeType (AppTy fun arg) = sizeType fun + sizeType arg -sizeType (FunTy _ arg res) = sizeType arg + sizeType res + 1 -sizeType (ForAllTy _ ty) = sizeType ty -sizeType (CastTy ty _) = sizeType ty -sizeType (CoercionTy _) = 0 - -sizeTypes :: [Type] -> Int -sizeTypes = foldr ((+) . sizeType) 0 - -sizeTyConAppArgs :: TyCon -> [Type] -> Int -sizeTyConAppArgs _tc tys = sizeTypes tys -- (filterOutInvisibleTypes tc tys) - -- See Note [Invisible arguments and termination] - --- Size of a predicate --- --- We are considering whether class constraints terminate. --- Equality constraints and constraints for the implicit --- parameter class always terminate so it is safe to say "size 0". --- See #4200. -sizePred :: PredType -> Int -sizePred ty = goClass ty - where - goClass p = go (classifyPredType p) - - go (ClassPred cls tys') - | isTerminatingClass cls = 0 - | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys') - -- The filtering looks bogus - -- See Note [Invisible arguments and termination] - go (EqPred {}) = 0 - go (IrredPred ty) = sizeType ty - go (ForAllPred _ _ pred) = goClass pred - --- | When this says "True", ignore this class constraint during --- a termination check -isTerminatingClass :: Class -> Bool -isTerminatingClass cls - = isIPClass cls -- Implicit parameter constraints always terminate because - -- there are no instances for them --- they are only solved - -- by "local instances" in expressions - || isEqPredClass cls - || cls `hasKey` typeableClassKey - || cls `hasKey` coercibleTyConKey - --- | Tidy before printing a type -ppr_tidy :: TidyEnv -> Type -> SDoc -ppr_tidy env ty = pprType (tidyType env ty) - -allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool --- (allDistinctTyVars tvs tys) returns True if tys are --- a) all tyvars --- b) all distinct --- c) disjoint from tvs -allDistinctTyVars _ [] = True -allDistinctTyVars tkvs (ty : tys) - = case getTyVar_maybe ty of - Nothing -> False - Just tv | tv `elemVarSet` tkvs -> False - | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys diff --git a/compiler/utils/AsmUtils.hs b/compiler/utils/AsmUtils.hs deleted file mode 100644 --- a/compiler/utils/AsmUtils.hs +++ /dev/null @@ -1,21 +0,0 @@ --- | Various utilities used in generating assembler. --- --- These are used not only by the native code generator, but also by the --- GHC.Driver.Pipeline -module AsmUtils - ( sectionType - ) where - -import GhcPrelude - -import GHC.Platform -import Outputable - --- | Generate a section type (e.g. @\@progbits@). See #13937. -sectionType :: Platform -- ^ Target platform - -> String -- ^ section type - -> SDoc -- ^ pretty assembler fragment -sectionType platform ty = - case platformArch platform of - ArchARM{} -> char '%' <> text ty - _ -> char '@' <> text ty diff --git a/compiler/utils/GraphBase.hs b/compiler/utils/GraphBase.hs deleted file mode 100644 --- a/compiler/utils/GraphBase.hs +++ /dev/null @@ -1,107 +0,0 @@ - --- | Types for the general graph colorer. -module GraphBase ( - Triv, - Graph (..), - initGraph, - graphMapModify, - - Node (..), newNode, -) - - -where - -import GhcPrelude - -import GHC.Types.Unique.Set -import GHC.Types.Unique.FM - - --- | A fn to check if a node is trivially colorable --- For graphs who's color classes are disjoint then a node is 'trivially colorable' --- when it has less neighbors and exclusions than available colors for that node. --- --- For graph's who's color classes overlap, ie some colors alias other colors, then --- this can be a bit more tricky. There is a general way to calculate this, but --- it's likely be too slow for use in the code. The coloring algorithm takes --- a canned function which can be optimised by the user to be specific to the --- specific graph being colored. --- --- for details, see "A Generalised Algorithm for Graph-Coloring Register Allocation" --- Smith, Ramsey, Holloway - PLDI 2004. --- -type Triv k cls color - = cls -- the class of the node we're trying to color. - -> UniqSet k -- the node's neighbors. - -> UniqSet color -- the node's exclusions. - -> Bool - - --- | The Interference graph. --- There used to be more fields, but they were turfed out in a previous revision. --- maybe we'll want more later.. --- -data Graph k cls color - = Graph { - -- | All active nodes in the graph. - graphMap :: UniqFM (Node k cls color) } - - --- | An empty graph. -initGraph :: Graph k cls color -initGraph - = Graph - { graphMap = emptyUFM } - - --- | Modify the finite map holding the nodes in the graph. -graphMapModify - :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color)) - -> Graph k cls color -> Graph k cls color - -graphMapModify f graph - = graph { graphMap = f (graphMap graph) } - - - --- | Graph nodes. --- Represents a thing that can conflict with another thing. --- For the register allocater the nodes represent registers. --- -data Node k cls color - = Node { - -- | A unique identifier for this node. - nodeId :: k - - -- | The class of this node, - -- determines the set of colors that can be used. - , nodeClass :: cls - - -- | The color of this node, if any. - , nodeColor :: Maybe color - - -- | Neighbors which must be colored differently to this node. - , nodeConflicts :: UniqSet k - - -- | Colors that cannot be used by this node. - , nodeExclusions :: UniqSet color - - -- | Colors that this node would prefer to be, in descending order. - , nodePreference :: [color] - - -- | Neighbors that this node would like to be colored the same as. - , nodeCoalesce :: UniqSet k } - - --- | An empty node. -newNode :: k -> cls -> Node k cls color -newNode k cls - = Node - { nodeId = k - , nodeClass = cls - , nodeColor = Nothing - , nodeConflicts = emptyUniqSet - , nodeExclusions = emptyUniqSet - , nodePreference = [] - , nodeCoalesce = emptyUniqSet } diff --git a/compiler/utils/GraphColor.hs b/compiler/utils/GraphColor.hs deleted file mode 100644 --- a/compiler/utils/GraphColor.hs +++ /dev/null @@ -1,375 +0,0 @@ --- | Graph Coloring. --- This is a generic graph coloring library, abstracted over the type of --- the node keys, nodes and colors. --- - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module GraphColor ( - module GraphBase, - module GraphOps, - module GraphPpr, - colorGraph -) - -where - -import GhcPrelude - -import GraphBase -import GraphOps -import GraphPpr - -import GHC.Types.Unique -import GHC.Types.Unique.FM -import GHC.Types.Unique.Set -import Outputable - -import Data.Maybe -import Data.List - - --- | Try to color a graph with this set of colors. --- Uses Chaitin's algorithm to color the graph. --- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes --- are pushed onto a stack and removed from the graph. --- Once this process is complete the graph can be colored by removing nodes from --- the stack (ie in reverse order) and assigning them colors different to their neighbors. --- -colorGraph - :: ( Uniquable k, Uniquable cls, Uniquable color - , Eq cls, Ord k - , Outputable k, Outputable cls, Outputable color) - => Bool -- ^ whether to do iterative coalescing - -> Int -- ^ how many times we've tried to color this graph so far. - -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. - -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. - -> Graph k cls color -- ^ the graph to color. - - -> ( Graph k cls color -- the colored graph. - , UniqSet k -- the set of nodes that we couldn't find a color for. - , UniqFM k ) -- map of regs (r1 -> r2) that were coalesced - -- r1 should be replaced by r2 in the source - -colorGraph iterative spinCount colors triv spill graph0 - = let - -- If we're not doing iterative coalescing then do an aggressive coalescing first time - -- around and then conservative coalescing for subsequent passes. - -- - -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if - -- there is a lot of register pressure and we do it on every round then it can make the - -- graph less colorable and prevent the algorithm from converging in a sensible number - -- of cycles. - -- - (graph_coalesced, kksCoalesce1) - = if iterative - then (graph0, []) - else if spinCount == 0 - then coalesceGraph True triv graph0 - else coalesceGraph False triv graph0 - - -- run the scanner to slurp out all the trivially colorable nodes - -- (and do coalescing if iterative coalescing is enabled) - (ksTriv, ksProblems, kksCoalesce2) - = colorScan iterative triv spill graph_coalesced - - -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. - -- We need to apply all the coalescences found by the scanner to the original - -- graph before doing assignColors. - -- - -- Because we've got the whole, non-pruned graph here we turn on aggressive coalescing - -- to force all the (conservative) coalescences found during scanning. - -- - (graph_scan_coalesced, _) - = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 - - -- color the trivially colorable nodes - -- during scanning, keys of triv nodes were added to the front of the list as they were found - -- this colors them in the reverse order, as required by the algorithm. - (graph_triv, ksNoTriv) - = assignColors colors graph_scan_coalesced ksTriv - - -- try and color the problem nodes - -- problem nodes are the ones that were left uncolored because they weren't triv. - -- theres a change we can color them here anyway. - (graph_prob, ksNoColor) - = assignColors colors graph_triv ksProblems - - -- if the trivially colorable nodes didn't color then something is probably wrong - -- with the provided triv function. - -- - in if not $ null ksNoTriv - then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty - ( empty - $$ text "ksTriv = " <> ppr ksTriv - $$ text "ksNoTriv = " <> ppr ksNoTriv - $$ text "colors = " <> ppr colors - $$ empty - $$ dotGraph (\_ -> text "white") triv graph_triv) - - else ( graph_prob - , mkUniqSet ksNoColor -- the nodes that didn't color (spills) - , if iterative - then (listToUFM kksCoalesce2) - else (listToUFM kksCoalesce1)) - - --- | Scan through the conflict graph separating out trivially colorable and --- potentially uncolorable (problem) nodes. --- --- Checking whether a node is trivially colorable or not is a reasonably expensive operation, --- so after a triv node is found and removed from the graph it's no good to return to the 'start' --- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. --- --- To ward against this, during each pass through the graph we collect up a list of triv nodes --- that were found, and only remove them once we've finished the pass. The more nodes we can delete --- at once the more likely it is that nodes we've already checked will become trivially colorable --- for the next pass. --- --- TODO: add work lists to finding triv nodes is easier. --- If we've just scanned the graph, and removed triv nodes, then the only --- nodes that we need to rescan are the ones we've removed edges from. - -colorScan - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool -- ^ whether to do iterative coalescing - -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable - -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. - -> Graph k cls color -- ^ the graph to scan - - -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce - -colorScan iterative triv spill graph - = colorScan_spin iterative triv spill graph [] [] [] - -colorScan_spin - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool - -> Triv k cls color - -> (Graph k cls color -> k) - -> Graph k cls color - -> [k] - -> [k] - -> [(k, k)] - -> ([k], [k], [(k, k)]) - -colorScan_spin iterative triv spill graph - ksTriv ksSpill kksCoalesce - - -- if the graph is empty then we're done - | isNullUFM $ graphMap graph - = (ksTriv, ksSpill, reverse kksCoalesce) - - -- Simplify: - -- Look for trivially colorable nodes. - -- If we can find some then remove them from the graph and go back for more. - -- - | nsTrivFound@(_:_) - <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - - -- for iterative coalescing we only want non-move related - -- nodes here - && (not iterative || isEmptyUniqSet (nodeCoalesce node))) - $ graph - - , ksTrivFound <- map nodeId nsTrivFound - , graph2 <- foldr (\k g -> let Just g' = delNode k g - in g') - graph ksTrivFound - - = colorScan_spin iterative triv spill graph2 - (ksTrivFound ++ ksTriv) - ksSpill - kksCoalesce - - -- Coalesce: - -- If we're doing iterative coalescing and no triv nodes are available - -- then it's time for a coalescing pass. - | iterative - = case coalesceGraph False triv graph of - - -- we were able to coalesce something - -- go back to Simplify and see if this frees up more nodes to be trivially colorable. - (graph2, kksCoalesceFound@(_:_)) - -> colorScan_spin iterative triv spill graph2 - ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) - - -- Freeze: - -- nothing could be coalesced (or was triv), - -- time to choose a node to freeze and give up on ever coalescing it. - (graph2, []) - -> case freezeOneInGraph graph2 of - - -- we were able to freeze something - -- hopefully this will free up something for Simplify - (graph3, True) - -> colorScan_spin iterative triv spill graph3 - ksTriv ksSpill kksCoalesce - - -- we couldn't find something to freeze either - -- time for a spill - (graph3, False) - -> colorScan_spill iterative triv spill graph3 - ksTriv ksSpill kksCoalesce - - -- spill time - | otherwise - = colorScan_spill iterative triv spill graph - ksTriv ksSpill kksCoalesce - - --- Select: --- we couldn't find any triv nodes or things to freeze or coalesce, --- and the graph isn't empty yet.. We'll have to choose a spill --- candidate and leave it uncolored. --- -colorScan_spill - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool - -> Triv k cls color - -> (Graph k cls color -> k) - -> Graph k cls color - -> [k] - -> [k] - -> [(k, k)] - -> ([k], [k], [(k, k)]) - -colorScan_spill iterative triv spill graph - ksTriv ksSpill kksCoalesce - - = let kSpill = spill graph - Just graph' = delNode kSpill graph - in colorScan_spin iterative triv spill graph' - ksTriv (kSpill : ksSpill) kksCoalesce - - --- | Try to assign a color to all these nodes. - -assignColors - :: ( Uniquable k, Uniquable cls, Uniquable color - , Outputable cls) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Graph k cls color -- ^ the graph - -> [k] -- ^ nodes to assign a color to. - -> ( Graph k cls color -- the colored graph - , [k]) -- the nodes that didn't color. - -assignColors colors graph ks - = assignColors' colors graph [] ks - - where assignColors' _ graph prob [] - = (graph, prob) - - assignColors' colors graph prob (k:ks) - = case assignColor colors k graph of - - -- couldn't color this node - Nothing -> assignColors' colors graph (k : prob) ks - - -- this node colored ok, so do the rest - Just graph' -> assignColors' colors graph' prob ks - - - assignColor colors u graph - | Just c <- selectColor colors graph u - = Just (setColor u c graph) - - | otherwise - = Nothing - - - --- | Select a color for a certain node --- taking into account preferences, neighbors and exclusions. --- returns Nothing if no color can be assigned to this node. --- -selectColor - :: ( Uniquable k, Uniquable cls, Uniquable color - , Outputable cls) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Graph k cls color -- ^ the graph - -> k -- ^ key of the node to select a color for. - -> Maybe color - -selectColor colors graph u - = let -- lookup the node - Just node = lookupNode graph u - - -- lookup the available colors for the class of this node. - colors_avail - = case lookupUFM colors (nodeClass node) of - Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) - Just cs -> cs - - -- find colors we can't use because they're already being used - -- by a node that conflicts with this one. - Just nsConflicts - = sequence - $ map (lookupNode graph) - $ nonDetEltsUniqSet - $ nodeConflicts node - -- See Note [Unique Determinism and code generation] - - colors_conflict = mkUniqSet - $ catMaybes - $ map nodeColor nsConflicts - - -- the prefs of our neighbors - colors_neighbor_prefs - = mkUniqSet - $ concatMap nodePreference nsConflicts - - -- colors that are still valid for us - colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) - colors_ok = minusUniqSet colors_ok_ex colors_conflict - - -- the colors that we prefer, and are still ok - colors_ok_pref = intersectUniqSets - (mkUniqSet $ nodePreference node) colors_ok - - -- the colors that we could choose while being nice to our neighbors - colors_ok_nice = minusUniqSet - colors_ok colors_neighbor_prefs - - -- the best of all possible worlds.. - colors_ok_pref_nice - = intersectUniqSets - colors_ok_nice colors_ok_pref - - -- make the decision - chooseColor - - -- everyone is happy, yay! - | not $ isEmptyUniqSet colors_ok_pref_nice - , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) - (nodePreference node) - = Just c - - -- we've got one of our preferences - | not $ isEmptyUniqSet colors_ok_pref - , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) - (nodePreference node) - = Just c - - -- it wasn't a preference, but it was still ok - | not $ isEmptyUniqSet colors_ok - , c : _ <- nonDetEltsUniqSet colors_ok - -- See Note [Unique Determinism and code generation] - = Just c - - -- no colors were available for us this time. - -- looks like we're going around the loop again.. - | otherwise - = Nothing - - in chooseColor - - - diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs deleted file mode 100644 --- a/compiler/utils/GraphOps.hs +++ /dev/null @@ -1,682 +0,0 @@ --- | Basic operations on graphs. --- - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module GraphOps ( - addNode, delNode, getNode, lookupNode, modNode, - size, - union, - addConflict, delConflict, addConflicts, - addCoalesce, delCoalesce, - addExclusion, addExclusions, - addPreference, - coalesceNodes, coalesceGraph, - freezeNode, freezeOneInGraph, freezeAllInGraph, - scanGraph, - setColor, - validateGraph, - slurpNodeConflictCount -) -where - -import GhcPrelude - -import GraphBase - -import Outputable -import GHC.Types.Unique -import GHC.Types.Unique.Set -import GHC.Types.Unique.FM - -import Data.List hiding (union) -import Data.Maybe - --- | Lookup a node from the graph. -lookupNode - :: Uniquable k - => Graph k cls color - -> k -> Maybe (Node k cls color) - -lookupNode graph k - = lookupUFM (graphMap graph) k - - --- | Get a node from the graph, throwing an error if it's not there -getNode - :: Uniquable k - => Graph k cls color - -> k -> Node k cls color - -getNode graph k - = case lookupUFM (graphMap graph) k of - Just node -> node - Nothing -> panic "ColorOps.getNode: not found" - - --- | Add a node to the graph, linking up its edges -addNode :: Uniquable k - => k -> Node k cls color - -> Graph k cls color -> Graph k cls color - -addNode k node graph - = let - -- add back conflict edges from other nodes to this one - map_conflict = - nonDetFoldUniqSet - -- It's OK to use nonDetFoldUFM here because the - -- operation is commutative - (adjustUFM_C (\n -> n { nodeConflicts = - addOneToUniqSet (nodeConflicts n) k})) - (graphMap graph) - (nodeConflicts node) - - -- add back coalesce edges from other nodes to this one - map_coalesce = - nonDetFoldUniqSet - -- It's OK to use nonDetFoldUFM here because the - -- operation is commutative - (adjustUFM_C (\n -> n { nodeCoalesce = - addOneToUniqSet (nodeCoalesce n) k})) - map_conflict - (nodeCoalesce node) - - in graph - { graphMap = addToUFM map_coalesce k node} - - --- | Delete a node and all its edges from the graph. -delNode :: (Uniquable k) - => k -> Graph k cls color -> Maybe (Graph k cls color) - -delNode k graph - | Just node <- lookupNode graph k - = let -- delete conflict edges from other nodes to this one. - graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph - $ nonDetEltsUniqSet (nodeConflicts node) - - -- delete coalesce edge from other nodes to this one. - graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 - $ nonDetEltsUniqSet (nodeCoalesce node) - -- See Note [Unique Determinism and code generation] - - -- delete the node - graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 - - in Just graph3 - - | otherwise - = Nothing - - --- | Modify a node in the graph. --- returns Nothing if the node isn't present. --- -modNode :: Uniquable k - => (Node k cls color -> Node k cls color) - -> k -> Graph k cls color -> Maybe (Graph k cls color) - -modNode f k graph - = case lookupNode graph k of - Just Node{} - -> Just - $ graphMapModify - (\fm -> let Just node = lookupUFM fm k - node' = f node - in addToUFM fm k node') - graph - - Nothing -> Nothing - - --- | Get the size of the graph, O(n) -size :: Graph k cls color -> Int - -size graph - = sizeUFM $ graphMap graph - - --- | Union two graphs together. -union :: Graph k cls color -> Graph k cls color -> Graph k cls color - -union graph1 graph2 - = Graph - { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } - - --- | Add a conflict between nodes to the graph, creating the nodes required. --- Conflicts are virtual regs which need to be colored differently. -addConflict - :: Uniquable k - => (k, cls) -> (k, cls) - -> Graph k cls color -> Graph k cls color - -addConflict (u1, c1) (u2, c2) - = let addNeighbor u c u' - = adjustWithDefaultUFM - (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) - (newNode u c) { nodeConflicts = unitUniqSet u' } - u - - in graphMapModify - ( addNeighbor u1 c1 u2 - . addNeighbor u2 c2 u1) - - --- | Delete a conflict edge. k1 -> k2 --- returns Nothing if the node isn't in the graph -delConflict - :: Uniquable k - => k -> k - -> Graph k cls color -> Maybe (Graph k cls color) - -delConflict k1 k2 - = modNode - (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) - k1 - - --- | Add some conflicts to the graph, creating nodes if required. --- All the nodes in the set are taken to conflict with each other. -addConflicts - :: Uniquable k - => UniqSet k -> (k -> cls) - -> Graph k cls color -> Graph k cls color - -addConflicts conflicts getClass - - -- just a single node, but no conflicts, create the node anyway. - | (u : []) <- nonDetEltsUniqSet conflicts - = graphMapModify - $ adjustWithDefaultUFM - id - (newNode u (getClass u)) - u - - | otherwise - = graphMapModify - $ \fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm - $ nonDetEltsUniqSet conflicts - -- See Note [Unique Determinism and code generation] - - -addConflictSet1 :: Uniquable k - => k -> (k -> cls) -> UniqSet k - -> UniqFM (Node k cls color) - -> UniqFM (Node k cls color) -addConflictSet1 u getClass set - = case delOneFromUniqSet set u of - set' -> adjustWithDefaultUFM - (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) - (newNode u (getClass u)) { nodeConflicts = set' } - u - - --- | Add an exclusion to the graph, creating nodes if required. --- These are extra colors that the node cannot use. -addExclusion - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> color - -> Graph k cls color -> Graph k cls color - -addExclusion u getClass color - = graphMapModify - $ adjustWithDefaultUFM - (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) - (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } - u - -addExclusions - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> [color] - -> Graph k cls color -> Graph k cls color - -addExclusions u getClass colors graph - = foldr (addExclusion u getClass) graph colors - - --- | Add a coalescence edge to the graph, creating nodes if required. --- It is considered adventageous to assign the same color to nodes in a coalesence. -addCoalesce - :: Uniquable k - => (k, cls) -> (k, cls) - -> Graph k cls color -> Graph k cls color - -addCoalesce (u1, c1) (u2, c2) - = let addCoalesce u c u' - = adjustWithDefaultUFM - (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) - (newNode u c) { nodeCoalesce = unitUniqSet u' } - u - - in graphMapModify - ( addCoalesce u1 c1 u2 - . addCoalesce u2 c2 u1) - - --- | Delete a coalescence edge (k1 -> k2) from the graph. -delCoalesce - :: Uniquable k - => k -> k - -> Graph k cls color -> Maybe (Graph k cls color) - -delCoalesce k1 k2 - = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) - k1 - - --- | Add a color preference to the graph, creating nodes if required. --- The most recently added preference is the most preferred. --- The algorithm tries to assign a node it's preferred color if possible. --- -addPreference - :: Uniquable k - => (k, cls) -> color - -> Graph k cls color -> Graph k cls color - -addPreference (u, c) color - = graphMapModify - $ adjustWithDefaultUFM - (\node -> node { nodePreference = color : (nodePreference node) }) - (newNode u c) { nodePreference = [color] } - u - - --- | Do aggressive coalescing on this graph. --- returns the new graph and the list of pairs of nodes that got coalesced together. --- for each pair, the resulting node will have the least key and be second in the pair. --- -coalesceGraph - :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Bool -- ^ If True, coalesce nodes even if this might make the graph - -- less colorable (aggressive coalescing) - -> Triv k cls color - -> Graph k cls color - -> ( Graph k cls color - , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the - -- coalescing was applied. - -coalesceGraph aggressive triv graph - = coalesceGraph' aggressive triv graph [] - -coalesceGraph' - :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Bool - -> Triv k cls color - -> Graph k cls color - -> [(k, k)] - -> ( Graph k cls color - , [(k, k)]) -coalesceGraph' aggressive triv graph kkPairsAcc - = let - -- find all the nodes that have coalescence edges - cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - -- build a list of pairs of keys for node's we'll try and coalesce - -- every pair of nodes will appear twice in this list - -- ie [(k1, k2), (k2, k1) ... ] - -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for - -- build a list of what nodes get coalesced together for later on. - -- - cList = [ (nodeId node1, k2) - | node1 <- cNodes - , k2 <- nonDetEltsUniqSet $ nodeCoalesce node1 ] - -- See Note [Unique Determinism and code generation] - - -- do the coalescing, returning the new graph and a list of pairs of keys - -- that got coalesced together. - (graph', mPairs) - = mapAccumL (coalesceNodes aggressive triv) graph cList - - -- keep running until there are no more coalesces can be found - in case catMaybes mPairs of - [] -> (graph', reverse kkPairsAcc) - pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) - - --- | Coalesce this pair of nodes unconditionally \/ aggressively. --- The resulting node is the one with the least key. --- --- returns: Just the pair of keys if the nodes were coalesced --- the second element of the pair being the least one --- --- Nothing if either of the nodes weren't in the graph - -coalesceNodes - :: (Uniquable k, Ord k, Eq cls) - => Bool -- ^ If True, coalesce nodes even if this might make the graph - -- less colorable (aggressive coalescing) - -> Triv k cls color - -> Graph k cls color - -> (k, k) -- ^ keys of the nodes to be coalesced - -> (Graph k cls color, Maybe (k, k)) - -coalesceNodes aggressive triv graph (k1, k2) - | (kMin, kMax) <- if k1 < k2 - then (k1, k2) - else (k2, k1) - - -- the nodes being coalesced must be in the graph - , Just nMin <- lookupNode graph kMin - , Just nMax <- lookupNode graph kMax - - -- can't coalesce conflicting modes - , not $ elementOfUniqSet kMin (nodeConflicts nMax) - , not $ elementOfUniqSet kMax (nodeConflicts nMin) - - -- can't coalesce the same node - , nodeId nMin /= nodeId nMax - - = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - - -- don't do the coalescing after all - | otherwise - = (graph, Nothing) - -coalesceNodes_merge - :: (Uniquable k, Eq cls) - => Bool - -> Triv k cls color - -> Graph k cls color - -> k -> k - -> Node k cls color - -> Node k cls color - -> (Graph k cls color, Maybe (k, k)) - -coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - - -- sanity checks - | nodeClass nMin /= nodeClass nMax - = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes." - - | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) - = error "GraphOps.coalesceNodes: can't coalesce colored nodes." - - --- - | otherwise - = let - -- the new node gets all the edges from its two components - node = - Node { nodeId = kMin - , nodeClass = nodeClass nMin - , nodeColor = Nothing - - -- nodes don't conflict with themselves.. - , nodeConflicts - = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) - `delOneFromUniqSet` kMin - `delOneFromUniqSet` kMax - - , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) - , nodePreference = nodePreference nMin ++ nodePreference nMax - - -- nodes don't coalesce with themselves.. - , nodeCoalesce - = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) - `delOneFromUniqSet` kMin - `delOneFromUniqSet` kMax - } - - in coalesceNodes_check aggressive triv graph kMin kMax node - -coalesceNodes_check - :: Uniquable k - => Bool - -> Triv k cls color - -> Graph k cls color - -> k -> k - -> Node k cls color - -> (Graph k cls color, Maybe (k, k)) - -coalesceNodes_check aggressive triv graph kMin kMax node - - -- Unless we're coalescing aggressively, if the result node is not trivially - -- colorable then don't do the coalescing. - | not aggressive - , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - = (graph, Nothing) - - | otherwise - = let -- delete the old nodes from the graph and add the new one - Just graph1 = delNode kMax graph - Just graph2 = delNode kMin graph1 - graph3 = addNode kMin node graph2 - - in (graph3, Just (kMax, kMin)) - - --- | Freeze a node --- This is for the iterative coalescer. --- By freezing a node we give up on ever coalescing it. --- Move all its coalesce edges into the frozen set - and update --- back edges from other nodes. --- -freezeNode - :: Uniquable k - => k -- ^ key of the node to freeze - -> Graph k cls color -- ^ the graph - -> Graph k cls color -- ^ graph with that node frozen - -freezeNode k - = graphMapModify - $ \fm -> - let -- freeze all the edges in the node to be frozen - Just node = lookupUFM fm k - node' = node - { nodeCoalesce = emptyUniqSet } - - fm1 = addToUFM fm k node' - - -- update back edges pointing to this node - freezeEdge k node - = if elementOfUniqSet k (nodeCoalesce node) - then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } - else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" - -- If the edge isn't actually in the coelesce set then just ignore it. - - fm2 = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1 - -- It's OK to use nonDetFoldUFM here because the operation - -- is commutative - $ nodeCoalesce node - - in fm2 - - --- | Freeze one node in the graph --- This if for the iterative coalescer. --- Look for a move related node of low degree and freeze it. --- --- We probably don't need to scan the whole graph looking for the node of absolute --- lowest degree. Just sample the first few and choose the one with the lowest --- degree out of those. Also, we don't make any distinction between conflicts of different --- classes.. this is just a heuristic, after all. --- --- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv --- right here, and add it to a worklist if known triv\/non-move nodes. --- -freezeOneInGraph - :: (Uniquable k) - => Graph k cls color - -> ( Graph k cls color -- the new graph - , Bool ) -- whether we found a node to freeze - -freezeOneInGraph graph - = let compareNodeDegree n1 n2 - = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) - - candidates - = sortBy compareNodeDegree - $ take 5 -- 5 isn't special, it's just a small number. - $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph - - in case candidates of - - -- there wasn't anything available to freeze - [] -> (graph, False) - - -- we found something to freeze - (n : _) - -> ( freezeNode (nodeId n) graph - , True) - - --- | Freeze all the nodes in the graph --- for debugging the iterative allocator. --- -freezeAllInGraph - :: (Uniquable k) - => Graph k cls color - -> Graph k cls color - -freezeAllInGraph graph - = foldr freezeNode graph - $ map nodeId - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - --- | Find all the nodes in the graph that meet some criteria --- -scanGraph - :: (Node k cls color -> Bool) - -> Graph k cls color - -> [Node k cls color] - -scanGraph match graph - = filter match $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - --- | validate the internal structure of a graph --- all its edges should point to valid nodes --- If they don't then throw an error --- -validateGraph - :: (Uniquable k, Outputable k, Eq color) - => SDoc -- ^ extra debugging info to display on error - -> Bool -- ^ whether this graph is supposed to be colored. - -> Graph k cls color -- ^ graph to validate - -> Graph k cls color -- ^ validated graph - -validateGraph doc isColored graph - - -- Check that all edges point to valid nodes. - | edges <- unionManyUniqSets - ( (map nodeConflicts $ nonDetEltsUFM $ graphMap graph) - ++ (map nodeCoalesce $ nonDetEltsUFM $ graphMap graph)) - - , nodes <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph - , badEdges <- minusUniqSet edges nodes - , not $ isEmptyUniqSet badEdges - = pprPanic "GraphOps.validateGraph" - ( text "Graph has edges that point to non-existent nodes" - $$ text " bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr) - $$ doc ) - - -- Check that no conflicting nodes have the same color - | badNodes <- filter (not . (checkNode graph)) - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Node has same color as one of it's conflicts" - $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc) - - -- If this is supposed to be a colored graph, - -- check that all nodes have a color. - | isColored - , badNodes <- filter (\n -> isNothing $ nodeColor n) - $ nonDetEltsUFM $ graphMap graph - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Supposably colored graph has uncolored nodes." - $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc ) - - - -- graph looks ok - | otherwise - = graph - - --- | If this node is colored, check that all the nodes which --- conflict with it have different colors. -checkNode - :: (Uniquable k, Eq color) - => Graph k cls color - -> Node k cls color - -> Bool -- ^ True if this node is ok - -checkNode graph node - | Just color <- nodeColor node - , Just neighbors <- sequence $ map (lookupNode graph) - $ nonDetEltsUniqSet $ nodeConflicts node - -- See Note [Unique Determinism and code generation] - - , neighbourColors <- catMaybes $ map nodeColor neighbors - , elem color neighbourColors - = False - - | otherwise - = True - - - --- | Slurp out a map of how many nodes had a certain number of conflict neighbours - -slurpNodeConflictCount - :: Graph k cls color - -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) - -slurpNodeConflictCount graph - = addListToUFM_C - (\(c1, n1) (_, n2) -> (c1, n1 + n2)) - emptyUFM - $ map (\node - -> let count = sizeUniqSet $ nodeConflicts node - in (count, (count, 1))) - $ nonDetEltsUFM - -- See Note [Unique Determinism and code generation] - $ graphMap graph - - --- | Set the color of a certain node -setColor - :: Uniquable k - => k -> color - -> Graph k cls color -> Graph k cls color - -setColor u color - = graphMapModify - $ adjustUFM_C - (\n -> n { nodeColor = Just color }) - u - - -{-# INLINE adjustWithDefaultUFM #-} -adjustWithDefaultUFM - :: Uniquable k - => (a -> a) -> a -> k - -> UniqFM a -> UniqFM a - -adjustWithDefaultUFM f def k map - = addToUFM_C - (\old _ -> f old) - map - k def - --- Argument order different from UniqFM's adjustUFM -{-# INLINE adjustUFM_C #-} -adjustUFM_C - :: Uniquable k - => (a -> a) - -> k -> UniqFM a -> UniqFM a - -adjustUFM_C f k map - = case lookupUFM map k of - Nothing -> map - Just a -> addToUFM map k (f a) - diff --git a/compiler/utils/GraphPpr.hs b/compiler/utils/GraphPpr.hs deleted file mode 100644 --- a/compiler/utils/GraphPpr.hs +++ /dev/null @@ -1,173 +0,0 @@ - --- | Pretty printing of graphs. - -module GraphPpr ( - dumpGraph, - dotGraph -) -where - -import GhcPrelude - -import GraphBase - -import Outputable -import GHC.Types.Unique -import GHC.Types.Unique.Set -import GHC.Types.Unique.FM - -import Data.List (mapAccumL) -import Data.Maybe - - --- | Pretty print a graph in a somewhat human readable format. -dumpGraph - :: (Outputable k, Outputable color) - => Graph k cls color -> SDoc - -dumpGraph graph - = text "Graph" - $$ pprUFM (graphMap graph) (vcat . map dumpNode) - -dumpNode - :: (Outputable k, Outputable color) - => Node k cls color -> SDoc - -dumpNode node - = text "Node " <> ppr (nodeId node) - $$ text "conflicts " - <> parens (int (sizeUniqSet $ nodeConflicts node)) - <> text " = " - <> ppr (nodeConflicts node) - - $$ text "exclusions " - <> parens (int (sizeUniqSet $ nodeExclusions node)) - <> text " = " - <> ppr (nodeExclusions node) - - $$ text "coalesce " - <> parens (int (sizeUniqSet $ nodeCoalesce node)) - <> text " = " - <> ppr (nodeCoalesce node) - - $$ space - - - --- | Pretty print a graph in graphviz .dot format. --- Conflicts get solid edges. --- Coalescences get dashed edges. -dotGraph - :: ( Uniquable k - , Outputable k, Outputable cls, Outputable color) - => (color -> SDoc) -- ^ What graphviz color to use for each node color - -- It's usually safe to return X11 style colors here, - -- ie "red", "green" etc or a hex triplet #aaff55 etc - -> Triv k cls color - -> Graph k cls color -> SDoc - -dotGraph colorMap triv graph - = let nodes = nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - in vcat - ( [ text "graph G {" ] - ++ map (dotNode colorMap triv) nodes - ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes) - ++ [ text "}" - , space ]) - - -dotNode :: ( Outputable k, Outputable cls, Outputable color) - => (color -> SDoc) - -> Triv k cls color - -> Node k cls color -> SDoc - -dotNode colorMap triv node - = let name = ppr $ nodeId node - cls = ppr $ nodeClass node - - excludes - = hcat $ punctuate space - $ map (\n -> text "-" <> ppr n) - $ nonDetEltsUniqSet $ nodeExclusions node - -- See Note [Unique Determinism and code generation] - - preferences - = hcat $ punctuate space - $ map (\n -> text "+" <> ppr n) - $ nodePreference node - - expref = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)] - then empty - else text "\\n" <> (excludes <+> preferences) - - -- if the node has been colored then show that, - -- otherwise indicate whether it looks trivially colorable. - color - | Just c <- nodeColor node - = text "\\n(" <> ppr c <> text ")" - - | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - = text "\\n(" <> text "triv" <> text ")" - - | otherwise - = text "\\n(" <> text "spill?" <> text ")" - - label = name <> text " :: " <> cls - <> expref - <> color - - pcolorC = case nodeColor node of - Nothing -> text "style=filled fillcolor=white" - Just c -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c) - - - pout = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]" - <> space <> doubleQuotes name - <> text ";" - - in pout - - --- | Nodes in the graph are doubly linked, but we only want one edge for each --- conflict if the graphviz graph. Traverse over the graph, but make sure --- to only print the edges for each node once. - -dotNodeEdges - :: ( Uniquable k - , Outputable k) - => UniqSet k - -> Node k cls color - -> (UniqSet k, Maybe SDoc) - -dotNodeEdges visited node - | elementOfUniqSet (nodeId node) visited - = ( visited - , Nothing) - - | otherwise - = let dconflicts - = map (dotEdgeConflict (nodeId node)) - $ nonDetEltsUniqSet - -- See Note [Unique Determinism and code generation] - $ minusUniqSet (nodeConflicts node) visited - - dcoalesces - = map (dotEdgeCoalesce (nodeId node)) - $ nonDetEltsUniqSet - -- See Note [Unique Determinism and code generation] - $ minusUniqSet (nodeCoalesce node) visited - - out = vcat dconflicts - $$ vcat dcoalesces - - in ( addOneToUniqSet visited (nodeId node) - , Just out) - - where dotEdgeConflict u1 u2 - = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) - <> text ";" - - dotEdgeCoalesce u1 u2 - = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) - <> space <> text "[ style = dashed ];" diff --git a/compiler/utils/State.hs b/compiler/utils/State.hs deleted file mode 100644 --- a/compiler/utils/State.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE UnboxedTuples #-} - -module State where - -import GhcPrelude - -newtype State s a = State { runState' :: s -> (# a, s #) } - deriving (Functor) - -instance Applicative (State s) where - pure x = State $ \s -> (# x, s #) - m <*> n = State $ \s -> case runState' m s of - (# f, s' #) -> case runState' n s' of - (# x, s'' #) -> (# f x, s'' #) - -instance Monad (State s) where - m >>= n = State $ \s -> case runState' m s of - (# r, s' #) -> runState' (n r) s' - -get :: State s s -get = State $ \s -> (# s, s #) - -gets :: (s -> a) -> State s a -gets f = State $ \s -> (# f s, s #) - -put :: s -> State s () -put s' = State $ \_ -> (# (), s' #) - -modify :: (s -> s) -> State s () -modify f = State $ \s -> (# (), f s #) - - -evalState :: State s a -> s -> a -evalState s i = case runState' s i of - (# a, _ #) -> a - - -execState :: State s a -> s -> s -execState s i = case runState' s i of - (# _, s' #) -> s' - - -runState :: State s a -> s -> (a, s) -runState s i = case runState' s i of - (# a, s' #) -> (a, s') diff --git a/compiler/utils/UnVarGraph.hs b/compiler/utils/UnVarGraph.hs deleted file mode 100644 --- a/compiler/utils/UnVarGraph.hs +++ /dev/null @@ -1,145 +0,0 @@ -{- - -Copyright (c) 2014 Joachim Breitner - -A data structure for undirected graphs of variables -(or in plain terms: Sets of unordered pairs of numbers) - - -This is very specifically tailored for the use in CallArity. In particular it -stores the graph as a union of complete and complete bipartite graph, which -would be very expensive to store as sets of edges or as adjanceny lists. - -It does not normalize the graphs. This means that g `unionUnVarGraph` g is -equal to g, but twice as expensive and large. - --} -module UnVarGraph - ( UnVarSet - , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets - , delUnVarSet - , elemUnVarSet, isEmptyUnVarSet - , UnVarGraph - , emptyUnVarGraph - , unionUnVarGraph, unionUnVarGraphs - , completeGraph, completeBipartiteGraph - , neighbors - , hasLoopAt - , delNode - ) where - -import GhcPrelude - -import GHC.Types.Id -import GHC.Types.Var.Env -import GHC.Types.Unique.FM -import Outputable -import Bag -import GHC.Types.Unique - -import qualified Data.IntSet as S - --- We need a type for sets of variables (UnVarSet). --- We do not use VarSet, because for that we need to have the actual variable --- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet. --- Therefore, use a IntSet directly (which is likely also a bit more efficient). - --- Set of uniques, i.e. for adjancet nodes -newtype UnVarSet = UnVarSet (S.IntSet) - deriving Eq - -k :: Var -> Int -k v = getKey (getUnique v) - -emptyUnVarSet :: UnVarSet -emptyUnVarSet = UnVarSet S.empty - -elemUnVarSet :: Var -> UnVarSet -> Bool -elemUnVarSet v (UnVarSet s) = k v `S.member` s - - -isEmptyUnVarSet :: UnVarSet -> Bool -isEmptyUnVarSet (UnVarSet s) = S.null s - -delUnVarSet :: UnVarSet -> Var -> UnVarSet -delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s - -mkUnVarSet :: [Var] -> UnVarSet -mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs - -varEnvDom :: VarEnv a -> UnVarSet -varEnvDom ae = UnVarSet $ ufmToSet_Directly ae - -unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet -unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2) - -unionUnVarSets :: [UnVarSet] -> UnVarSet -unionUnVarSets = foldr unionUnVarSet emptyUnVarSet - -instance Outputable UnVarSet where - ppr (UnVarSet s) = braces $ - hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s] - - --- The graph type. A list of complete bipartite graphs -data Gen = CBPG UnVarSet UnVarSet -- complete bipartite - | CG UnVarSet -- complete -newtype UnVarGraph = UnVarGraph (Bag Gen) - -emptyUnVarGraph :: UnVarGraph -emptyUnVarGraph = UnVarGraph emptyBag - -unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph -{- -Premature optimisation, it seems. -unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) - | s1 == s3 && s2 == s4 - = pprTrace "unionUnVarGraph fired" empty $ - completeGraph (s1 `unionUnVarSet` s2) -unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) - | s2 == s3 && s1 == s4 - = pprTrace "unionUnVarGraph fired2" empty $ - completeGraph (s1 `unionUnVarSet` s2) --} -unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2) - = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $ - UnVarGraph (g1 `unionBags` g2) - -unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph -unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph - --- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B } -completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph -completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2 - -completeGraph :: UnVarSet -> UnVarGraph -completeGraph s = prune $ UnVarGraph $ unitBag $ CG s - -neighbors :: UnVarGraph -> Var -> UnVarSet -neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g - where go (CG s) = (if v `elemUnVarSet` s then [s] else []) - go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++ - (if v `elemUnVarSet` s2 then [s1] else []) - --- hasLoopAt G v <=> v--v ∈ G -hasLoopAt :: UnVarGraph -> Var -> Bool -hasLoopAt (UnVarGraph g) v = any go $ bagToList g - where go (CG s) = v `elemUnVarSet` s - go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2 - - -delNode :: UnVarGraph -> Var -> UnVarGraph -delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g - where go (CG s) = CG (s `delUnVarSet` v) - go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v) - -prune :: UnVarGraph -> UnVarGraph -prune (UnVarGraph g) = UnVarGraph $ filterBag go g - where go (CG s) = not (isEmptyUnVarSet s) - go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2) - -instance Outputable Gen where - ppr (CG s) = ppr s <> char '²' - ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2 -instance Outputable UnVarGraph where - ppr (UnVarGraph g) = ppr g diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib -version: 0.20200401 +version: 0.20200501 license: BSD3 license-file: LICENSE category: Development @@ -40,13 +40,14 @@ ghc-lib/stage0/compiler/build/primop-vector-tys-exports.hs-incl ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl + ghc-lib/stage0/compiler/build/primop-docs.hs-incl includes/ghcconfig.h includes/MachDeps.h includes/stg/MachRegs.h includes/CodeGen.Platform.hs compiler/HsVersions.h compiler/Unique.h -tested-with: GHC==8.8.2, GHC==8.6.5, GHC==8.4.4 +tested-with: GHC==8.10.1, GHC==8.8.2, GHC==8.6.5, GHC==8.4.4 source-repository head type: git location: git@github.com:digital-asset/ghc-lib.git @@ -68,8 +69,8 @@ else build-depends: Win32 build-depends: - ghc-prim > 0.2 && < 0.6, - base >= 4.11 && < 4.14, + ghc-prim > 0.2 && < 0.7, + base >= 4.11 && < 4.15, containers >= 0.5 && < 0.7, bytestring >= 0.9 && < 0.11, binary == 0.8.*, @@ -82,7 +83,7 @@ transformers == 0.5.*, process >= 1 && < 1.7, hpc == 0.6.*, - ghc-lib-parser == 0.20200401 + ghc-lib-parser == 0.20200501 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns @@ -121,44 +122,20 @@ ghc-lib/stage0/libraries/ghc-boot/build ghc-lib/stage0/compiler/build libraries/template-haskell - compiler/typecheck libraries/ghc-boot - compiler/prelude - compiler/iface - compiler/utils libraries/ghci - compiler/main compiler/. compiler autogen-modules: Paths_ghc_lib reexported-modules: - ApiAnnotation, - Bag, - BinFingerprint, - Binary, - BooleanFormula, - BufWrite, - CliOption, Config, - Constants, - Constraint, - Ctype, - Digraph, - Encoding, - EnumSet, - ErrUtils, - Exception, - FV, - FastFunctions, - FastMutInt, - FastString, - FastStringEnv, - FileCleanup, - FileSettings, - Fingerprint, - FiniteMap, GHC.BaseDir, + GHC.Builtin.Names, + GHC.Builtin.PrimOps, + GHC.Builtin.Types, + GHC.Builtin.Types.Prim, + GHC.Builtin.Uniques, GHC.ByteCode.Types, GHC.Cmm, GHC.Cmm.BlockId, @@ -172,6 +149,7 @@ GHC.Cmm.Node, GHC.Cmm.Switch, GHC.Cmm.Type, + GHC.CmmToAsm.Config, GHC.Core, GHC.Core.Arity, GHC.Core.Class, @@ -185,14 +163,12 @@ GHC.Core.InstEnv, GHC.Core.Make, GHC.Core.Map, - GHC.Core.Op.ConstantFold, - GHC.Core.Op.Monad, - GHC.Core.Op.OccurAnal, - GHC.Core.Op.Tidy, + GHC.Core.Opt.ConstantFold, + GHC.Core.Opt.Monad, + GHC.Core.Opt.OccurAnal, GHC.Core.PatSyn, GHC.Core.Ppr, GHC.Core.Predicate, - GHC.Core.Rules, GHC.Core.Seq, GHC.Core.SimpleOpt, GHC.Core.Stats, @@ -208,12 +184,27 @@ GHC.Core.Unify, GHC.Core.Utils, GHC.CoreToIface, + GHC.Data.Bag, + GHC.Data.BooleanFormula, + GHC.Data.EnumSet, + GHC.Data.FastMutInt, + GHC.Data.FastString, + GHC.Data.FastString.Env, + GHC.Data.FiniteMap, + GHC.Data.Graph.Directed, + GHC.Data.IOEnv, + GHC.Data.List.SetOps, + GHC.Data.Maybe, + GHC.Data.OrdList, + GHC.Data.Pair, + GHC.Data.Stream, + GHC.Data.StringBuffer, + GHC.Data.TrieMap, GHC.Driver.Backpack.Syntax, GHC.Driver.CmdLine, GHC.Driver.Flags, GHC.Driver.Hooks, GHC.Driver.Monad, - GHC.Driver.Packages, GHC.Driver.Phases, GHC.Driver.Pipeline.Monad, GHC.Driver.Plugins, @@ -244,12 +235,19 @@ GHC.Hs.Types, GHC.Hs.Utils, GHC.HsToCore.PmCheck.Types, + GHC.Iface.Recomp.Binary, GHC.Iface.Syntax, GHC.Iface.Type, GHC.LanguageExtensions, GHC.LanguageExtensions.Type, GHC.Lexeme, - GHC.PackageDb, + GHC.Parser, + GHC.Parser.Annotation, + GHC.Parser.CharClass, + GHC.Parser.Header, + GHC.Parser.Lexer, + GHC.Parser.PostProcess, + GHC.Parser.PostProcess.Haddock, GHC.Platform, GHC.Platform.ARM, GHC.Platform.ARM64, @@ -262,12 +260,24 @@ GHC.Platform.SPARC, GHC.Platform.X86, GHC.Platform.X86_64, + GHC.Prelude, GHC.Runtime.Eval.Types, GHC.Runtime.Heap.Layout, GHC.Runtime.Interpreter.Types, GHC.Runtime.Linker.Types, GHC.Serialized, + GHC.Settings, + GHC.Settings.Constants, GHC.Stg.Syntax, + GHC.SysTools.BaseDir, + GHC.SysTools.FileCleanup, + GHC.SysTools.Terminal, + GHC.Tc.Errors.Hole.FitTypes, + GHC.Tc.Types, + GHC.Tc.Types.Constraint, + GHC.Tc.Types.Evidence, + GHC.Tc.Types.Origin, + GHC.Tc.Utils.TcType, GHC.Types.Annotations, GHC.Types.Avail, GHC.Types.Basic, @@ -281,7 +291,6 @@ GHC.Types.Id.Info, GHC.Types.Id.Make, GHC.Types.Literal, - GHC.Types.Module, GHC.Types.Name, GHC.Types.Name.Cache, GHC.Types.Name.Env, @@ -300,20 +309,42 @@ GHC.Types.Var.Env, GHC.Types.Var.Set, GHC.UniqueSubdir, + GHC.Unit, + GHC.Unit.Database, + GHC.Unit.Info, + GHC.Unit.Module, + GHC.Unit.Module.Env, + GHC.Unit.Module.Location, + GHC.Unit.Module.Name, + GHC.Unit.Parser, + GHC.Unit.Ppr, + GHC.Unit.State, + GHC.Unit.Subst, + GHC.Unit.Types, + GHC.Utils.Binary, + GHC.Utils.BufHandle, + GHC.Utils.CliOption, + GHC.Utils.Encoding, + GHC.Utils.Error, + GHC.Utils.Exception, + GHC.Utils.FV, + GHC.Utils.Fingerprint, + GHC.Utils.IO.Unsafe, + GHC.Utils.Json, GHC.Utils.Lexeme, + GHC.Utils.Misc, + GHC.Utils.Monad, + GHC.Utils.Outputable, + GHC.Utils.Panic, + GHC.Utils.Panic.Plain, + GHC.Utils.Ppr, + GHC.Utils.Ppr.Colour, GHC.Version, GHCi.BreakArray, GHCi.FFI, GHCi.Message, GHCi.RemoteTypes, GHCi.TH.Binary, - GhcNameVersion, - GhcPrelude, - HaddockUtils, - HeaderInfo, - IOEnv, - Json, - KnownUniques, Language.Haskell.TH, Language.Haskell.TH.LanguageExtensions, Language.Haskell.TH.Lib, @@ -322,50 +353,13 @@ Language.Haskell.TH.Ppr, Language.Haskell.TH.PprLib, Language.Haskell.TH.Syntax, - Lexer, - ListSetOps, - Maybes, - MonadUtils, - OrdList, - Outputable, - Pair, - Panic, - Parser, - PlainPanic, - PlatformConstants, - PprColour, - PrelNames, - Pretty, - PrimOp, - RdrHsSyn, - Settings, - SizedSeq, - Stream, - StringBuffer, - SysTools.BaseDir, - SysTools.Terminal, - TcEvidence, - TcHoleFitTypes, - TcOrigin, - TcRnTypes, - TcType, - ToolSettings, - TrieMap, - TysPrim, - TysWiredIn, - UnitInfo, - Util + SizedSeq exposed-modules: Paths_ghc_lib - Ar - AsmUtils - BuildTyCl - ClsInst - Elf - FamInst - FlagChecker - FunDeps GHC + GHC.Builtin.Names.TH + GHC.Builtin.Types.Literals + GHC.Builtin.Utils GHC.ByteCode.Asm GHC.ByteCode.InfoTable GHC.ByteCode.Instr @@ -398,7 +392,6 @@ GHC.CmmToAsm.CFG GHC.CmmToAsm.CFG.Dominators GHC.CmmToAsm.CPrim - GHC.CmmToAsm.Config GHC.CmmToAsm.Dwarf GHC.CmmToAsm.Dwarf.Constants GHC.CmmToAsm.Dwarf.Types @@ -467,30 +460,37 @@ GHC.CmmToLlvm.Ppr GHC.CmmToLlvm.Regs GHC.Core.Lint - GHC.Core.Op.CSE - GHC.Core.Op.CallArity - GHC.Core.Op.CprAnal - GHC.Core.Op.DmdAnal - GHC.Core.Op.Exitify - GHC.Core.Op.FloatIn - GHC.Core.Op.FloatOut - GHC.Core.Op.LiberateCase - GHC.Core.Op.SetLevels - GHC.Core.Op.Simplify - GHC.Core.Op.Simplify.Driver - GHC.Core.Op.Simplify.Env - GHC.Core.Op.Simplify.Monad - GHC.Core.Op.Simplify.Utils - GHC.Core.Op.SpecConstr - GHC.Core.Op.Specialise - GHC.Core.Op.StaticArgs - GHC.Core.Op.WorkWrap - GHC.Core.Op.WorkWrap.Lib + GHC.Core.Opt.CSE + GHC.Core.Opt.CallArity + GHC.Core.Opt.CprAnal + GHC.Core.Opt.DmdAnal + GHC.Core.Opt.Driver + GHC.Core.Opt.Exitify + GHC.Core.Opt.FloatIn + GHC.Core.Opt.FloatOut + GHC.Core.Opt.LiberateCase + GHC.Core.Opt.SetLevels + GHC.Core.Opt.Simplify + GHC.Core.Opt.Simplify.Env + GHC.Core.Opt.Simplify.Monad + GHC.Core.Opt.Simplify.Utils + GHC.Core.Opt.SpecConstr + GHC.Core.Opt.Specialise + GHC.Core.Opt.StaticArgs + GHC.Core.Opt.WorkWrap + GHC.Core.Opt.WorkWrap.Utils GHC.Core.Ppr.TyThing + GHC.Core.Rules + GHC.Core.Tidy GHC.CoreToByteCode GHC.CoreToStg GHC.CoreToStg.Prep GHC.Data.Bitmap + GHC.Data.Graph.Base + GHC.Data.Graph.Color + GHC.Data.Graph.Ops + GHC.Data.Graph.Ppr + GHC.Data.Graph.UnVar GHC.Driver.Backpack GHC.Driver.CodeOutput GHC.Driver.Finder @@ -499,6 +499,7 @@ GHC.Driver.MakeFile GHC.Driver.Pipeline GHC.HandleEncoding + GHC.Hs.Stats GHC.HsToCore GHC.HsToCore.Arrows GHC.HsToCore.Binds @@ -529,8 +530,11 @@ GHC.Iface.Load GHC.Iface.Make GHC.Iface.Recomp + GHC.Iface.Recomp.Flags GHC.Iface.Rename GHC.Iface.Tidy + GHC.Iface.Tidy.StaticPtrTable + GHC.Iface.UpdateCafInfos GHC.IfaceToCore GHC.Llvm GHC.Llvm.MetaData @@ -539,16 +543,16 @@ GHC.Llvm.Types GHC.Platform.Host GHC.Plugins - GHC.Rename.Binds + GHC.Rename.Bind GHC.Rename.Doc GHC.Rename.Env GHC.Rename.Expr GHC.Rename.Fixity + GHC.Rename.HsType + GHC.Rename.Module GHC.Rename.Names GHC.Rename.Pat - GHC.Rename.Source GHC.Rename.Splice - GHC.Rename.Types GHC.Rename.Unbound GHC.Rename.Utils GHC.Runtime.Debugger @@ -557,7 +561,9 @@ GHC.Runtime.Interpreter GHC.Runtime.Linker GHC.Runtime.Loader - GHC.Settings + GHC.Settings.IO + GHC.Settings.Platform + GHC.Settings.Utils GHC.Stg.CSE GHC.Stg.DepAnal GHC.Stg.FVs @@ -587,8 +593,64 @@ GHC.StgToCmm.Prof GHC.StgToCmm.Ticky GHC.StgToCmm.Utils + GHC.SysTools + GHC.SysTools.Ar + GHC.SysTools.Elf + GHC.SysTools.ExtraObj + GHC.SysTools.Info + GHC.SysTools.Process + GHC.SysTools.Tasks + GHC.Tc.Deriv + GHC.Tc.Deriv.Functor + GHC.Tc.Deriv.Generate + GHC.Tc.Deriv.Generics + GHC.Tc.Deriv.Infer + GHC.Tc.Deriv.Utils + GHC.Tc.Errors + GHC.Tc.Errors.Hole + GHC.Tc.Gen.Annotation + GHC.Tc.Gen.Arrow + GHC.Tc.Gen.Bind + GHC.Tc.Gen.Default + GHC.Tc.Gen.Export + GHC.Tc.Gen.Expr + GHC.Tc.Gen.Foreign + GHC.Tc.Gen.HsType + GHC.Tc.Gen.Match + GHC.Tc.Gen.Pat + GHC.Tc.Gen.Rule + GHC.Tc.Gen.Sig + GHC.Tc.Gen.Splice + GHC.Tc.Instance.Class + GHC.Tc.Instance.Family + GHC.Tc.Instance.FunDeps + GHC.Tc.Instance.Typeable + GHC.Tc.Module + GHC.Tc.Plugin + GHC.Tc.Solver + GHC.Tc.Solver.Canonical + GHC.Tc.Solver.Flatten + GHC.Tc.Solver.Interact + GHC.Tc.Solver.Monad + GHC.Tc.TyCl + GHC.Tc.TyCl.Build + GHC.Tc.TyCl.Class + GHC.Tc.TyCl.Instance + GHC.Tc.TyCl.PatSyn + GHC.Tc.TyCl.Utils + GHC.Tc.Types.EvTerm + GHC.Tc.Utils.Backpack + GHC.Tc.Utils.Env + GHC.Tc.Utils.Instantiate + GHC.Tc.Utils.Monad + GHC.Tc.Utils.TcMType + GHC.Tc.Utils.Unify + GHC.Tc.Utils.Zonk + GHC.Tc.Validity GHC.ThToHs GHC.Types.Name.Shape + GHC.Utils.Asm + GHC.Utils.Monad.State GHCi.BinaryArray GHCi.CreateBCO GHCi.InfoTable @@ -598,65 +660,4 @@ GHCi.Signals GHCi.StaticPtrTable GHCi.TH - GraphBase - GraphColor - GraphOps - GraphPpr - HscStats - Inst Language.Haskell.TH.Quote - PrelInfo - State - StaticPtrTable - SysTools - SysTools.ExtraObj - SysTools.Info - SysTools.Process - SysTools.Settings - SysTools.Tasks - THNames - TcAnnotations - TcArrows - TcBackpack - TcBinds - TcCanonical - TcClassDcl - TcDefaults - TcDeriv - TcDerivInfer - TcDerivUtils - TcEnv - TcErrors - TcEvTerm - TcExpr - TcFlatten - TcForeign - TcGenDeriv - TcGenFunctor - TcGenGenerics - TcHoleErrors - TcHsSyn - TcHsType - TcInstDcls - TcInteract - TcMType - TcMatches - TcPat - TcPatSyn - TcPluginM - TcRnDriver - TcRnExports - TcRnMonad - TcRules - TcSMonad - TcSigs - TcSimplify - TcSplice - TcTyClsDecls - TcTyDecls - TcTypeNats - TcTypeable - TcUnify - TcValidity - UnVarGraph - UpdateCafInfos diff --git a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl @@ -0,0 +1,875 @@ +primOpDocs = + [ ("->","The builtin function type, written in infix form as @a -> b@ and\n in prefix form as @(->) a b@. Values of this type are functions\n taking inputs of type @a@ and producing outputs of type @b@.\n\n Note that @a -> b@ permits levity-polymorphism in both @a@ and\n @b@, so that types like @Int\\# -> Int\\#@ can still be well-kinded.\n ") + , ("*#","Low word of signed integer multiply.") + , ("timesInt2#","Return a triple (isHighNeeded,high,low) where high and low are respectively\n the high and low bits of the double-word result. isHighNeeded is a cheap way\n to test if the high word is a sign-extension of the low word (isHighNeeded =\n 0#) or not (isHighNeeded = 1#).") + , ("mulIntMayOflo#","Return non-zero if there is any possibility that the upper word of a\n signed integer multiply might contain useful information. Return\n zero only if you are completely sure that no overflow can occur.\n On a 32-bit platform, the recommended implementation is to do a\n 32 x 32 -> 64 signed multiply, and subtract result[63:32] from\n (result[31] >>signed 31). If this is zero, meaning that the\n upper word is merely a sign extension of the lower one, no\n overflow can occur.\n\n On a 64-bit platform it is not always possible to\n acquire the top 64 bits of the result. Therefore, a recommended\n implementation is to take the absolute value of both operands, and\n return 0 iff bits[63:31] of them are zero, since that means that their\n magnitudes fit within 31 bits, so the magnitude of the product must fit\n into 62 bits.\n\n If in doubt, return non-zero, but do make an effort to create the\n correct answer for small args, since otherwise the performance of\n @(*) :: Integer -> Integer -> Integer@ will be poor.\n ") + , ("quotInt#","Rounds towards zero. The behavior is undefined if the second argument is\n zero.\n ") + , ("remInt#","Satisfies @(quotInt\\# x y) *\\# y +\\# (remInt\\# x y) == x@. The\n behavior is undefined if the second argument is zero.\n ") + , ("quotRemInt#","Rounds towards zero.") + , ("andI#","Bitwise \"and\".") + , ("orI#","Bitwise \"or\".") + , ("xorI#","Bitwise \"xor\".") + , ("notI#","Bitwise \"not\", also known as the binary complement.") + , ("negateInt#","Unary negation.\n Since the negative @Int#@ range extends one further than the\n positive range, @negateInt#@ of the most negative number is an\n identity operation. This way, @negateInt#@ is always its own inverse.") + , ("addIntC#","Add signed integers reporting overflow.\n First member of result is the sum truncated to an @Int#@;\n second member is zero if the true sum fits in an @Int#@,\n nonzero if overflow occurred (the sum is either too large\n or too small to fit in an @Int#@).") + , ("subIntC#","Subtract signed integers reporting overflow.\n First member of result is the difference truncated to an @Int#@;\n second member is zero if the true difference fits in an @Int#@,\n nonzero if overflow occurred (the difference is either too large\n or too small to fit in an @Int#@).") + , ("uncheckedIShiftL#","Shift left. Result undefined if shift amount is not\n in the range 0 to word size - 1 inclusive.") + , ("uncheckedIShiftRA#","Shift right arithmetic. Result undefined if shift amount is not\n in the range 0 to word size - 1 inclusive.") + , ("uncheckedIShiftRL#","Shift right logical. Result undefined if shift amount is not\n in the range 0 to word size - 1 inclusive.") + , ("addWordC#","Add unsigned integers reporting overflow.\n The first element of the pair is the result. The second element is\n the carry flag, which is nonzero on overflow. See also @plusWord2#@.") + , ("subWordC#","Subtract unsigned integers reporting overflow.\n The first element of the pair is the result. The second element is\n the carry flag, which is nonzero on overflow.") + , ("plusWord2#","Add unsigned integers, with the high part (carry) in the first\n component of the returned pair and the low part in the second\n component of the pair. See also @addWordC#@.") + , ("quotRemWord2#"," Takes high word of dividend, then low word of dividend, then divisor.\n Requires that high word < divisor.") + , ("uncheckedShiftL#","Shift left logical. Result undefined if shift amount is not\n in the range 0 to word size - 1 inclusive.") + , ("uncheckedShiftRL#","Shift right logical. Result undefined if shift amount is not\n in the range 0 to word size - 1 inclusive.") + , ("popCnt8#","Count the number of set bits in the lower 8 bits of a word.") + , ("popCnt16#","Count the number of set bits in the lower 16 bits of a word.") + , ("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.") + , ("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.") + , ("clz64#","Count leading zeros in a 64-bit word.") + , ("clz#","Count leading zeros in a word.") + , ("ctz8#","Count trailing zeros in the lower 8 bits of a word.") + , ("ctz16#","Count trailing zeros in the lower 16 bits of a word.") + , ("ctz32#","Count trailing zeros in the lower 32 bits of a word.") + , ("ctz64#","Count trailing zeros in a 64-bit word.") + , ("ctz#","Count trailing zeros in a word.") + , ("byteSwap16#","Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. ") + , ("byteSwap32#","Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. ") + , ("byteSwap64#","Swap bytes in a 64 bits of a word.") + , ("byteSwap#","Swap bytes in a word.") + , ("bitReverse8#","Reverse the order of the bits in a 8-bit word.") + , ("bitReverse16#","Reverse the order of the bits in a 16-bit word.") + , ("bitReverse32#","Reverse the order of the bits in a 32-bit word.") + , ("bitReverse64#","Reverse the order of the bits in a 64-bit word.") + , ("bitReverse#","Reverse the order of the bits in a word.") + , ("double2Int#","Truncates a @Double#@ value to the nearest @Int#@.\n Results are undefined if the truncation if truncation yields\n a value outside the range of @Int#@.") + , ("**##","Exponentiation.") + , ("decodeDouble_2Int#","Convert to integer.\n First component of the result is -1 or 1, indicating the sign of the\n mantissa. The next two are the high and low 32 bits of the mantissa\n respectively, and the last is the exponent.") + , ("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.") + , ("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.") + , ("sizeofArray#","Return the number of elements in the array.") + , ("sizeofMutableArray#","Return the number of elements in the array.") + , ("indexArray#","Read from the specified index of an immutable array. The result is packaged\n into an unboxed unary tuple; the result itself is not yet\n evaluated. Pattern matching on the tuple forces the indexing of the\n array to happen but does not evaluate the element itself. Evaluating\n the thunk prevents additional thunks from building up on the\n heap. Avoiding these thunks, in turn, reduces references to the\n argument array, allowing it to be garbage collected more promptly.") + , ("unsafeFreezeArray#","Make a mutable array immutable, without copying.") + , ("unsafeThawArray#","Make an immutable array mutable, without copying.") + , ("copyArray#","Given a source array, an offset into the source array, a\n destination array, an offset into the destination array, and a\n number of elements to copy, copy the elements from the source array\n to the destination array. Both arrays must fully contain the\n specified ranges, but this is not checked. The two arrays must not\n be the same array in different states, but this is not checked\n either.") + , ("copyMutableArray#","Given a source array, an offset into the source array, a\n destination array, an offset into the destination array, and a\n number of elements to copy, copy the elements from the source array\n to the destination array. Both arrays must fully contain the\n specified ranges, but this is not checked. In the case where\n the source and destination are the same array the source and\n destination regions may overlap.") + , ("cloneArray#","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.") + , ("cloneMutableArray#","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.") + , ("freezeArray#","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.") + , ("thawArray#","Given a source array, an offset into the source array, and a number\n of elements to copy, create a new array with the elements from the\n source array. The provided array must fully contain the specified\n range, but this is not checked.") + , ("casArray#","Given an array, an offset, the expected old value, and\n the new value, perform an atomic compare and swap (i.e. write the new\n value if the current value and the old value are the same pointer).\n Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns\n the element at the offset after the operation completes. This means that\n on a success the new value is returned, and on a failure the actual old\n value (not the expected one) is returned. Implies a full memory barrier.\n The use of a pointer equality on a lifted value makes this function harder\n to use correctly than @casIntArray\\#@. All of the difficulties\n of using @reallyUnsafePtrEquality\\#@ correctly apply to\n @casArray\\#@ as well.\n ") + , ("newSmallArray#","Create a new mutable array with the specified number of elements,\n in the specified state thread,\n with each element containing the specified initial value.") + , ("shrinkSmallMutableArray#","Shrink mutable array to new specified size, in\n the specified state thread. The new size argument must be less than or\n equal to the current size as reported by @sizeofSmallMutableArray\\#@.") + , ("readSmallArray#","Read from specified index of mutable array. Result is not yet evaluated.") + , ("writeSmallArray#","Write to specified index of mutable array.") + , ("sizeofSmallArray#","Return the number of elements in the array.") + , ("sizeofSmallMutableArray#","Return the number of elements in the array. Note that this is deprecated\n as it is unsafe in the presence of resize operations on the\n same byte array.") + , ("getSizeofSmallMutableArray#","Return the number of elements in the array.") + , ("indexSmallArray#","Read from specified index of immutable array. Result is packaged into\n an unboxed singleton; the result itself is not yet evaluated.") + , ("unsafeFreezeSmallArray#","Make a mutable array immutable, without copying.") + , ("unsafeThawSmallArray#","Make an immutable array mutable, without copying.") + , ("copySmallArray#","Given a source array, an offset into the source array, a\n destination array, an offset into the destination array, and a\n number of elements to copy, copy the elements from the source array\n to the destination array. Both arrays must fully contain the\n specified ranges, but this is not checked. The two arrays must not\n be the same array in different states, but this is not checked\n either.") + , ("copySmallMutableArray#","Given a source array, an offset into the source array, a\n destination array, an offset into the destination array, and a\n number of elements to copy, copy the elements from the source array\n to the destination array. The source and destination arrays can\n refer to the same array. Both arrays must fully contain the\n specified ranges, but this is not checked.\n The regions are allowed to overlap, although this is only possible when the same\n array is provided as both the source and the destination. ") + , ("cloneSmallArray#","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.") + , ("cloneSmallMutableArray#","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.") + , ("freezeSmallArray#","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.") + , ("thawSmallArray#","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.") + , ("casSmallArray#","Unsafe, machine-level atomic compare and swap on an element within an array.\n See the documentation of @casArray\\#@.") + , ("newByteArray#","Create a new mutable byte array of specified size (in bytes), in\n the specified state thread.") + , ("newPinnedByteArray#","Create a mutable byte array that the GC guarantees not to move.") + , ("newAlignedPinnedByteArray#","Create a mutable byte array, aligned by the specified amount, that the GC guarantees not to move.") + , ("isMutableByteArrayPinned#","Determine whether a @MutableByteArray\\#@ is guaranteed not to move\n during GC.") + , ("isByteArrayPinned#","Determine whether a @ByteArray\\#@ is guaranteed not to move during GC.") + , ("byteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!") + , ("shrinkMutableByteArray#","Shrink mutable byte array to new specified size (in bytes), in\n the specified state thread. The new size argument must be less than or\n equal to the current size as reported by @sizeofMutableByteArray\\#@.") + , ("resizeMutableByteArray#","Resize (unpinned) mutable byte array to new specified size (in bytes).\n The returned @MutableByteArray\\#@ is either the original\n @MutableByteArray\\#@ resized in-place or, if not possible, a newly\n allocated (unpinned) @MutableByteArray\\#@ (with the original content\n copied over).\n\n To avoid undefined behaviour, the original @MutableByteArray\\#@ shall\n not be accessed anymore after a @resizeMutableByteArray\\#@ has been\n performed. Moreover, no reference to the old one should be kept in order\n to allow garbage collection of the original @MutableByteArray\\#@ in\n case a new @MutableByteArray\\#@ had to be allocated.") + , ("unsafeFreezeByteArray#","Make a mutable byte array immutable, without copying.") + , ("sizeofByteArray#","Return the size of the array in bytes.") + , ("sizeofMutableByteArray#","Return the size of the array in bytes. Note that this is deprecated as it is\n unsafe in the presence of resize operations on the same byte\n array.") + , ("getSizeofMutableByteArray#","Return the number of elements in the array.") + , ("indexCharArray#","Read 8-bit character; offset in bytes.") + , ("indexWideCharArray#","Read 31-bit character; offset in 4-byte words.") + , ("indexInt8Array#","Read 8-bit integer; offset in bytes.") + , ("indexInt16Array#","Read 16-bit integer; offset in 16-bit words.") + , ("indexInt32Array#","Read 32-bit integer; offset in 32-bit words.") + , ("indexInt64Array#","Read 64-bit integer; offset in 64-bit words.") + , ("indexWord8Array#","Read 8-bit word; offset in bytes.") + , ("indexWord16Array#","Read 16-bit word; offset in 16-bit words.") + , ("indexWord32Array#","Read 32-bit word; offset in 32-bit words.") + , ("indexWord64Array#","Read 64-bit word; offset in 64-bit words.") + , ("indexWord8ArrayAsChar#","Read 8-bit character; offset in bytes.") + , ("indexWord8ArrayAsWideChar#","Read 31-bit character; offset in bytes.") + , ("indexWord8ArrayAsAddr#","Read address; offset in bytes.") + , ("indexWord8ArrayAsFloat#","Read float; offset in bytes.") + , ("indexWord8ArrayAsDouble#","Read double; offset in bytes.") + , ("indexWord8ArrayAsStablePtr#","Read stable pointer; offset in bytes.") + , ("indexWord8ArrayAsInt16#","Read 16-bit int; offset in bytes.") + , ("indexWord8ArrayAsInt32#","Read 32-bit int; offset in bytes.") + , ("indexWord8ArrayAsInt64#","Read 64-bit int; offset in bytes.") + , ("indexWord8ArrayAsInt#","Read int; offset in bytes.") + , ("indexWord8ArrayAsWord16#","Read 16-bit word; offset in bytes.") + , ("indexWord8ArrayAsWord32#","Read 32-bit word; offset in bytes.") + , ("indexWord8ArrayAsWord64#","Read 64-bit word; offset in bytes.") + , ("indexWord8ArrayAsWord#","Read word; offset in bytes.") + , ("readCharArray#","Read 8-bit character; offset in bytes.") + , ("readWideCharArray#","Read 31-bit character; offset in 4-byte words.") + , ("readIntArray#","Read integer; offset in machine words.") + , ("readWordArray#","Read word; offset in machine words.") + , ("writeCharArray#","Write 8-bit character; offset in bytes.") + , ("writeWideCharArray#","Write 31-bit character; offset in 4-byte words.") + , ("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.") + , ("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.") + , ("setByteArray#","@setByteArray# ba off len c@ sets the byte range @[off, off+len]@ of\n the @MutableByteArray#@ to the byte @c@.") + , ("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.") + , ("fetchAddIntArray#","Given an array, and offset in machine words, and a value to add,\n atomically add the value to the element. Returns the value of the\n element before the operation. Implies a full memory barrier.") + , ("fetchSubIntArray#","Given an array, and offset in machine words, and a value to subtract,\n atomically subtract the value to the element. Returns the value of\n the element before the operation. Implies a full memory barrier.") + , ("fetchAndIntArray#","Given an array, and offset in machine words, and a value to AND,\n atomically AND the value to the element. Returns the value of the\n element before the operation. Implies a full memory barrier.") + , ("fetchNandIntArray#","Given an array, and offset in machine words, and a value to NAND,\n atomically NAND the value to the element. Returns the value of the\n element before the operation. Implies a full memory barrier.") + , ("fetchOrIntArray#","Given an array, and offset in machine words, and a value to OR,\n atomically OR the value to the element. Returns the value of the\n element before the operation. Implies a full memory barrier.") + , ("fetchXorIntArray#","Given an array, and offset in machine words, and a value to XOR,\n atomically XOR the value to the element. Returns the value of the\n element before the operation. Implies a full memory barrier.") + , ("newArrayArray#","Create a new mutable array of arrays with the specified number of elements,\n in the specified state thread, with each element recursively referring to the\n newly created array.") + , ("unsafeFreezeArrayArray#","Make a mutable array of arrays immutable, without copying.") + , ("sizeofArrayArray#","Return the number of elements in the array.") + , ("sizeofMutableArrayArray#","Return the number of elements in the array.") + , ("copyArrayArray#","Copy a range of the ArrayArray\\# to the specified region in the MutableArrayArray\\#.\n Both arrays must fully contain the specified ranges, but this is not checked.\n The two arrays must not be the same array in different states, but this is not checked either.") + , ("copyMutableArrayArray#","Copy a range of the first MutableArrayArray# to the specified region in the second\n MutableArrayArray#.\n Both arrays must fully contain the specified ranges, but this is not checked.\n The regions are allowed to overlap, although this is only possible when the same\n array is provided as both the source and the destination.\n ") + , ("Addr#"," An arbitrary machine address assumed to point outside\n the garbage-collected heap. ") + , ("nullAddr#"," The null address. ") + , ("minusAddr#","Result is meaningless if two @Addr\\#@s are so far apart that their\n difference doesn't fit in an @Int\\#@.") + , ("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.") + , ("MutVar#","A @MutVar\\#@ behaves like a single-element mutable array.") + , ("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. ") + , ("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. ") + , ("raiseDivZero#","Raise a 'DivideByZero' arithmetic exception.") + , ("raiseUnderflow#","Raise an 'Underflow' arithmetic exception.") + , ("raiseOverflow#","Raise an 'Overflow' arithmetic exception.") + , ("newTVar#","Create a new @TVar\\#@ holding a specified initial value.") + , ("readTVar#","Read contents of @TVar\\#@. Result is not yet evaluated.") + , ("readTVarIO#","Read contents of @TVar\\#@ outside an STM transaction") + , ("writeTVar#","Write contents of @TVar\\#@.") + , ("MVar#"," A shared mutable variable (/not/ the same as a @MutVar\\#@!).\n (Note: in a non-concurrent implementation, @(MVar\\# a)@ can be\n represented by @(MutVar\\# (Maybe a))@.) ") + , ("newMVar#","Create new @MVar\\#@; initially empty.") + , ("takeMVar#","If @MVar\\#@ is empty, block until it becomes full.\n Then remove and return its contents, and set it empty.") + , ("tryTakeMVar#","If @MVar\\#@ is empty, immediately return with integer 0 and value undefined.\n Otherwise, return with integer 1 and contents of @MVar\\#@, and set @MVar\\#@ empty.") + , ("putMVar#","If @MVar\\#@ is full, block until it becomes empty.\n Then store value arg as its new contents.") + , ("tryPutMVar#","If @MVar\\#@ is full, immediately return with integer 0.\n Otherwise, store value arg as @MVar\\#@'s new contents, and return with integer 1.") + , ("readMVar#","If @MVar\\#@ is empty, block until it becomes full.\n Then read its contents without modifying the MVar, without possibility\n of intervention from other threads.") + , ("tryReadMVar#","If @MVar\\#@ is empty, immediately return with integer 0 and value undefined.\n Otherwise, return with integer 1 and contents of @MVar\\#@.") + , ("isEmptyMVar#","Return 1 if @MVar\\#@ is empty; 0 otherwise.") + , ("delay#","Sleep specified number of microseconds.") + , ("waitRead#","Block until input is available on specified file descriptor.") + , ("waitWrite#","Block until output is possible on specified file descriptor.") + , ("State#"," @State\\#@ is the primitive, unlifted type of states. It has\n one type parameter, thus @State\\# RealWorld@, or @State\\# s@,\n where s is a type variable. The only purpose of the type parameter\n is to keep different state threads separate. It is represented by\n nothing at all. ") + , ("RealWorld"," @RealWorld@ is deeply magical. It is /primitive/, but it is not\n /unlifted/ (hence @ptrArg@). We never manipulate values of type\n @RealWorld@; it's only used in the type system, to parameterise @State\\#@. ") + , ("ThreadId#","(In a non-concurrent implementation, this can be a singleton\n type, whose (unique) value is returned by @myThreadId\\#@. The\n other operations can be omitted.)") + , ("mkWeak#"," @mkWeak# k v finalizer s@ creates a weak reference to value @k@,\n with an associated reference to some value @v@. If @k@ is still\n alive then @v@ can be retrieved using @deRefWeak#@. Note that\n the type of @k@ must be represented by a pointer (i.e. of kind @TYPE 'LiftedRep@ or @TYPE 'UnliftedRep@). ") + , ("addCFinalizerToWeak#"," @addCFinalizerToWeak# fptr ptr flag eptr w@ attaches a C\n function pointer @fptr@ to a weak pointer @w@ as a finalizer. If\n @flag@ is zero, @fptr@ will be called with one argument,\n @ptr@. Otherwise, it will be called with two arguments,\n @eptr@ and @ptr@. @addCFinalizerToWeak#@ returns\n 1 on success, or 0 if @w@ is already dead. ") + , ("finalizeWeak#"," Finalize a weak pointer. The return value is an unboxed tuple\n containing the new state of the world and an \"unboxed Maybe\",\n represented by an @Int#@ and a (possibly invalid) finalization\n action. An @Int#@ of @1@ indicates that the finalizer is valid. The\n return value @b@ from the finalizer should be ignored. ") + , ("compactNew#"," Create a new CNF with a single compact block. The argument is\n the capacity of the compact block (in bytes, not words).\n The capacity is rounded up to a multiple of the allocator block size\n and is capped to one mega block. ") + , ("compactResize#"," Set the new allocation size of the CNF. This value (in bytes)\n determines the capacity of each compact block in the CNF. It\n does not retroactively affect existing compact blocks in the CNF. ") + , ("compactContains#"," Returns 1\\# if the object is contained in the CNF, 0\\# otherwise. ") + , ("compactContainsAny#"," Returns 1\\# if the object is in any CNF at all, 0\\# otherwise. ") + , ("compactGetFirstBlock#"," Returns the address and the utilized size (in bytes) of the\n first compact block of a CNF.") + , ("compactGetNextBlock#"," Given a CNF and the address of one its compact blocks, returns the\n next compact block and its utilized size, or @nullAddr\\#@ if the\n argument was the last compact block in the CNF. ") + , ("compactAllocateBlock#"," Attempt to allocate a compact block with the capacity (in\n bytes) given by the first argument. The @Addr\\#@ is a pointer\n to previous compact block of the CNF or @nullAddr\\#@ to create a\n new CNF with a single compact block.\n\n The resulting block is not known to the GC until\n @compactFixupPointers\\#@ is called on it, and care must be taken\n so that the address does not escape or memory will be leaked.\n ") + , ("compactFixupPointers#"," Given the pointer to the first block of a CNF and the\n address of the root object in the old address space, fix up\n the internal pointers inside the CNF to account for\n a different position in memory than when it was serialized.\n This method must be called exactly once after importing\n a serialized CNF. It returns the new CNF and the new adjusted\n root address. ") + , ("compactAdd#"," Recursively add a closure and its transitive closure to a\n @Compact\\#@ (a CNF), evaluating any unevaluated components\n at the same time. Note: @compactAdd\\#@ is not thread-safe, so\n only one thread may call @compactAdd\\#@ with a particular\n @Compact\\#@ at any given time. The primop does not\n enforce any mutual exclusion; the caller is expected to\n arrange this. ") + , ("compactAddWithSharing#"," Like @compactAdd\\#@, but retains sharing and cycles\n during compaction. ") + , ("compactSize#"," Return the total capacity (in bytes) of all the compact blocks\n in the CNF. ") + , ("reallyUnsafePtrEquality#"," Returns @1\\#@ if the given pointers are equal and @0\\#@ otherwise. ") + , ("numSparks#"," Returns the number of sparks in the local spark pool. ") + , ("BCO"," Primitive bytecode type. ") + , ("addrToAny#"," Convert an @Addr\\#@ to a followable Any type. ") + , ("anyToAddr#"," Retrieve the address of any Haskell value. This is\n essentially an @unsafeCoerce\\#@, but if implemented as such\n the core lint pass complains and fails to compile.\n As a primop, it is opaque to core/stg, and only appears\n in cmm (where the copy propagation pass will get rid of it).\n Note that \"a\" must be a value, not a thunk! It's too late\n for strictness analysis to enforce this, so you're on your\n own to guarantee this. Also note that @Addr\\#@ is not a GC\n pointer - up to you to guarantee that it does not become\n a dangling pointer immediately after you get it.") + , ("mkApUpd0#"," Wrap a BCO in a @AP_UPD@ thunk which will be updated with the value of\n the BCO when evaluated. ") + , ("newBCO#"," @newBCO\\# instrs lits ptrs arity bitmap@ creates a new bytecode object. The\n resulting object encodes a function of the given arity with the instructions\n encoded in @instrs@, and a static reference table usage bitmap given by\n @bitmap@. ") + , ("unpackClosure#"," @unpackClosure\\# closure@ copies the closure and pointers in the\n payload of the given closure into two new arrays, and returns a pointer to\n the first word of the closure's info table, a non-pointer array for the raw\n bytes of the closure, and a pointer array for the pointers in the payload. ") + , ("closureSize#"," @closureSize\\# closure@ returns the size of the given closure in\n machine words. ") + , ("getCurrentCCS#"," Returns the current @CostCentreStack@ (value is @NULL@ if\n not profiling). Takes a dummy argument which can be used to\n avoid the call to @getCurrentCCS\\#@ being floated out by the\n simplifier, which would result in an uninformative stack\n (\"CAF\"). ") + , ("clearCCS#"," Run the supplied IO action with an empty CCS. For example, this\n is used by the interpreter to run an interpreted computation\n without the call stack showing that it was invoked from GHC. ") + , ("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 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. ") + , ("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 runtime-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. ") + , ("broadcastInt64X2#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastInt8X32#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastInt16X16#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastInt32X8#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastInt64X4#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastInt8X64#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastInt16X32#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastInt32X16#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastInt64X8#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastWord8X16#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastWord16X8#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastWord32X4#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastWord64X2#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastWord8X32#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastWord16X16#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastWord32X8#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastWord64X4#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastWord8X64#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastWord16X32#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastWord32X16#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastWord64X8#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastFloatX4#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastDoubleX2#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastFloatX8#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastDoubleX4#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastFloatX16#"," Broadcast a scalar to all elements of a vector. ") + , ("broadcastDoubleX8#"," Broadcast a scalar to all elements of a vector. ") + , ("packInt8X16#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packInt16X8#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packInt32X4#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packInt64X2#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packInt8X32#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packInt16X16#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packInt32X8#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packInt64X4#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packInt8X64#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packInt16X32#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packInt32X16#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packInt64X8#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packWord8X16#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packWord16X8#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packWord32X4#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packWord64X2#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packWord8X32#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packWord16X16#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packWord32X8#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packWord64X4#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packWord8X64#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packWord16X32#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packWord32X16#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packWord64X8#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packFloatX4#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packDoubleX2#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packFloatX8#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packDoubleX4#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packFloatX16#"," Pack the elements of an unboxed tuple into a vector. ") + , ("packDoubleX8#"," Pack the elements of an unboxed tuple into a vector. ") + , ("unpackInt8X16#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackInt16X8#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackInt32X4#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackInt64X2#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackInt8X32#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackInt16X16#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackInt32X8#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackInt64X4#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackInt8X64#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackInt16X32#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackInt32X16#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackInt64X8#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackWord8X16#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackWord16X8#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackWord32X4#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackWord64X2#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackWord8X32#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackWord16X16#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackWord32X8#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackWord64X4#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackWord8X64#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackWord16X32#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackWord32X16#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackWord64X8#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackFloatX4#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackDoubleX2#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackFloatX8#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackDoubleX4#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackFloatX16#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("unpackDoubleX8#"," Unpack the elements of a vector into an unboxed tuple. #") + , ("insertInt8X16#"," Insert a scalar at the given position in a vector. ") + , ("insertInt16X8#"," Insert a scalar at the given position in a vector. ") + , ("insertInt32X4#"," Insert a scalar at the given position in a vector. ") + , ("insertInt64X2#"," Insert a scalar at the given position in a vector. ") + , ("insertInt8X32#"," Insert a scalar at the given position in a vector. ") + , ("insertInt16X16#"," Insert a scalar at the given position in a vector. ") + , ("insertInt32X8#"," Insert a scalar at the given position in a vector. ") + , ("insertInt64X4#"," Insert a scalar at the given position in a vector. ") + , ("insertInt8X64#"," Insert a scalar at the given position in a vector. ") + , ("insertInt16X32#"," Insert a scalar at the given position in a vector. ") + , ("insertInt32X16#"," Insert a scalar at the given position in a vector. ") + , ("insertInt64X8#"," Insert a scalar at the given position in a vector. ") + , ("insertWord8X16#"," Insert a scalar at the given position in a vector. ") + , ("insertWord16X8#"," Insert a scalar at the given position in a vector. ") + , ("insertWord32X4#"," Insert a scalar at the given position in a vector. ") + , ("insertWord64X2#"," Insert a scalar at the given position in a vector. ") + , ("insertWord8X32#"," Insert a scalar at the given position in a vector. ") + , ("insertWord16X16#"," Insert a scalar at the given position in a vector. ") + , ("insertWord32X8#"," Insert a scalar at the given position in a vector. ") + , ("insertWord64X4#"," Insert a scalar at the given position in a vector. ") + , ("insertWord8X64#"," Insert a scalar at the given position in a vector. ") + , ("insertWord16X32#"," Insert a scalar at the given position in a vector. ") + , ("insertWord32X16#"," Insert a scalar at the given position in a vector. ") + , ("insertWord64X8#"," Insert a scalar at the given position in a vector. ") + , ("insertFloatX4#"," Insert a scalar at the given position in a vector. ") + , ("insertDoubleX2#"," Insert a scalar at the given position in a vector. ") + , ("insertFloatX8#"," Insert a scalar at the given position in a vector. ") + , ("insertDoubleX4#"," Insert a scalar at the given position in a vector. ") + , ("insertFloatX16#"," Insert a scalar at the given position in a vector. ") + , ("insertDoubleX8#"," Insert a scalar at the given position in a vector. ") + , ("plusInt8X16#"," Add two vectors element-wise. ") + , ("plusInt16X8#"," Add two vectors element-wise. ") + , ("plusInt32X4#"," Add two vectors element-wise. ") + , ("plusInt64X2#"," Add two vectors element-wise. ") + , ("plusInt8X32#"," Add two vectors element-wise. ") + , ("plusInt16X16#"," Add two vectors element-wise. ") + , ("plusInt32X8#"," Add two vectors element-wise. ") + , ("plusInt64X4#"," Add two vectors element-wise. ") + , ("plusInt8X64#"," Add two vectors element-wise. ") + , ("plusInt16X32#"," Add two vectors element-wise. ") + , ("plusInt32X16#"," Add two vectors element-wise. ") + , ("plusInt64X8#"," Add two vectors element-wise. ") + , ("plusWord8X16#"," Add two vectors element-wise. ") + , ("plusWord16X8#"," Add two vectors element-wise. ") + , ("plusWord32X4#"," Add two vectors element-wise. ") + , ("plusWord64X2#"," Add two vectors element-wise. ") + , ("plusWord8X32#"," Add two vectors element-wise. ") + , ("plusWord16X16#"," Add two vectors element-wise. ") + , ("plusWord32X8#"," Add two vectors element-wise. ") + , ("plusWord64X4#"," Add two vectors element-wise. ") + , ("plusWord8X64#"," Add two vectors element-wise. ") + , ("plusWord16X32#"," Add two vectors element-wise. ") + , ("plusWord32X16#"," Add two vectors element-wise. ") + , ("plusWord64X8#"," Add two vectors element-wise. ") + , ("plusFloatX4#"," Add two vectors element-wise. ") + , ("plusDoubleX2#"," Add two vectors element-wise. ") + , ("plusFloatX8#"," Add two vectors element-wise. ") + , ("plusDoubleX4#"," Add two vectors element-wise. ") + , ("plusFloatX16#"," Add two vectors element-wise. ") + , ("plusDoubleX8#"," Add two vectors element-wise. ") + , ("minusInt8X16#"," Subtract two vectors element-wise. ") + , ("minusInt16X8#"," Subtract two vectors element-wise. ") + , ("minusInt32X4#"," Subtract two vectors element-wise. ") + , ("minusInt64X2#"," Subtract two vectors element-wise. ") + , ("minusInt8X32#"," Subtract two vectors element-wise. ") + , ("minusInt16X16#"," Subtract two vectors element-wise. ") + , ("minusInt32X8#"," Subtract two vectors element-wise. ") + , ("minusInt64X4#"," Subtract two vectors element-wise. ") + , ("minusInt8X64#"," Subtract two vectors element-wise. ") + , ("minusInt16X32#"," Subtract two vectors element-wise. ") + , ("minusInt32X16#"," Subtract two vectors element-wise. ") + , ("minusInt64X8#"," Subtract two vectors element-wise. ") + , ("minusWord8X16#"," Subtract two vectors element-wise. ") + , ("minusWord16X8#"," Subtract two vectors element-wise. ") + , ("minusWord32X4#"," Subtract two vectors element-wise. ") + , ("minusWord64X2#"," Subtract two vectors element-wise. ") + , ("minusWord8X32#"," Subtract two vectors element-wise. ") + , ("minusWord16X16#"," Subtract two vectors element-wise. ") + , ("minusWord32X8#"," Subtract two vectors element-wise. ") + , ("minusWord64X4#"," Subtract two vectors element-wise. ") + , ("minusWord8X64#"," Subtract two vectors element-wise. ") + , ("minusWord16X32#"," Subtract two vectors element-wise. ") + , ("minusWord32X16#"," Subtract two vectors element-wise. ") + , ("minusWord64X8#"," Subtract two vectors element-wise. ") + , ("minusFloatX4#"," Subtract two vectors element-wise. ") + , ("minusDoubleX2#"," Subtract two vectors element-wise. ") + , ("minusFloatX8#"," Subtract two vectors element-wise. ") + , ("minusDoubleX4#"," Subtract two vectors element-wise. ") + , ("minusFloatX16#"," Subtract two vectors element-wise. ") + , ("minusDoubleX8#"," Subtract two vectors element-wise. ") + , ("timesInt8X16#"," Multiply two vectors element-wise. ") + , ("timesInt16X8#"," Multiply two vectors element-wise. ") + , ("timesInt32X4#"," Multiply two vectors element-wise. ") + , ("timesInt64X2#"," Multiply two vectors element-wise. ") + , ("timesInt8X32#"," Multiply two vectors element-wise. ") + , ("timesInt16X16#"," Multiply two vectors element-wise. ") + , ("timesInt32X8#"," Multiply two vectors element-wise. ") + , ("timesInt64X4#"," Multiply two vectors element-wise. ") + , ("timesInt8X64#"," Multiply two vectors element-wise. ") + , ("timesInt16X32#"," Multiply two vectors element-wise. ") + , ("timesInt32X16#"," Multiply two vectors element-wise. ") + , ("timesInt64X8#"," Multiply two vectors element-wise. ") + , ("timesWord8X16#"," Multiply two vectors element-wise. ") + , ("timesWord16X8#"," Multiply two vectors element-wise. ") + , ("timesWord32X4#"," Multiply two vectors element-wise. ") + , ("timesWord64X2#"," Multiply two vectors element-wise. ") + , ("timesWord8X32#"," Multiply two vectors element-wise. ") + , ("timesWord16X16#"," Multiply two vectors element-wise. ") + , ("timesWord32X8#"," Multiply two vectors element-wise. ") + , ("timesWord64X4#"," Multiply two vectors element-wise. ") + , ("timesWord8X64#"," Multiply two vectors element-wise. ") + , ("timesWord16X32#"," Multiply two vectors element-wise. ") + , ("timesWord32X16#"," Multiply two vectors element-wise. ") + , ("timesWord64X8#"," Multiply two vectors element-wise. ") + , ("timesFloatX4#"," Multiply two vectors element-wise. ") + , ("timesDoubleX2#"," Multiply two vectors element-wise. ") + , ("timesFloatX8#"," Multiply two vectors element-wise. ") + , ("timesDoubleX4#"," Multiply two vectors element-wise. ") + , ("timesFloatX16#"," Multiply two vectors element-wise. ") + , ("timesDoubleX8#"," Multiply two vectors element-wise. ") + , ("divideFloatX4#"," Divide two vectors element-wise. ") + , ("divideDoubleX2#"," Divide two vectors element-wise. ") + , ("divideFloatX8#"," Divide two vectors element-wise. ") + , ("divideDoubleX4#"," Divide two vectors element-wise. ") + , ("divideFloatX16#"," Divide two vectors element-wise. ") + , ("divideDoubleX8#"," Divide two vectors element-wise. ") + , ("quotInt8X16#"," Rounds towards zero element-wise. ") + , ("quotInt16X8#"," Rounds towards zero element-wise. ") + , ("quotInt32X4#"," Rounds towards zero element-wise. ") + , ("quotInt64X2#"," Rounds towards zero element-wise. ") + , ("quotInt8X32#"," Rounds towards zero element-wise. ") + , ("quotInt16X16#"," Rounds towards zero element-wise. ") + , ("quotInt32X8#"," Rounds towards zero element-wise. ") + , ("quotInt64X4#"," Rounds towards zero element-wise. ") + , ("quotInt8X64#"," Rounds towards zero element-wise. ") + , ("quotInt16X32#"," Rounds towards zero element-wise. ") + , ("quotInt32X16#"," Rounds towards zero element-wise. ") + , ("quotInt64X8#"," Rounds towards zero element-wise. ") + , ("quotWord8X16#"," Rounds towards zero element-wise. ") + , ("quotWord16X8#"," Rounds towards zero element-wise. ") + , ("quotWord32X4#"," Rounds towards zero element-wise. ") + , ("quotWord64X2#"," Rounds towards zero element-wise. ") + , ("quotWord8X32#"," Rounds towards zero element-wise. ") + , ("quotWord16X16#"," Rounds towards zero element-wise. ") + , ("quotWord32X8#"," Rounds towards zero element-wise. ") + , ("quotWord64X4#"," Rounds towards zero element-wise. ") + , ("quotWord8X64#"," Rounds towards zero element-wise. ") + , ("quotWord16X32#"," Rounds towards zero element-wise. ") + , ("quotWord32X16#"," Rounds towards zero element-wise. ") + , ("quotWord64X8#"," Rounds towards zero element-wise. ") + , ("remInt8X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remInt16X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remInt32X4#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remInt64X2#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remInt8X32#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remInt16X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remInt32X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remInt64X4#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remInt8X64#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remInt16X32#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remInt32X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remInt64X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remWord8X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remWord16X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remWord32X4#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remWord64X2#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remWord8X32#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remWord16X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remWord32X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remWord64X4#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remWord8X64#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remWord16X32#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remWord32X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remWord64X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("negateInt8X16#"," Negate element-wise. ") + , ("negateInt16X8#"," Negate element-wise. ") + , ("negateInt32X4#"," Negate element-wise. ") + , ("negateInt64X2#"," Negate element-wise. ") + , ("negateInt8X32#"," Negate element-wise. ") + , ("negateInt16X16#"," Negate element-wise. ") + , ("negateInt32X8#"," Negate element-wise. ") + , ("negateInt64X4#"," Negate element-wise. ") + , ("negateInt8X64#"," Negate element-wise. ") + , ("negateInt16X32#"," Negate element-wise. ") + , ("negateInt32X16#"," Negate element-wise. ") + , ("negateInt64X8#"," Negate element-wise. ") + , ("negateFloatX4#"," Negate element-wise. ") + , ("negateDoubleX2#"," Negate element-wise. ") + , ("negateFloatX8#"," Negate element-wise. ") + , ("negateDoubleX4#"," Negate element-wise. ") + , ("negateFloatX16#"," Negate element-wise. ") + , ("negateDoubleX8#"," Negate element-wise. ") + , ("indexInt8X16Array#"," Read a vector from specified index of immutable array. ") + , ("indexInt16X8Array#"," Read a vector from specified index of immutable array. ") + , ("indexInt32X4Array#"," Read a vector from specified index of immutable array. ") + , ("indexInt64X2Array#"," Read a vector from specified index of immutable array. ") + , ("indexInt8X32Array#"," Read a vector from specified index of immutable array. ") + , ("indexInt16X16Array#"," Read a vector from specified index of immutable array. ") + , ("indexInt32X8Array#"," Read a vector from specified index of immutable array. ") + , ("indexInt64X4Array#"," Read a vector from specified index of immutable array. ") + , ("indexInt8X64Array#"," Read a vector from specified index of immutable array. ") + , ("indexInt16X32Array#"," Read a vector from specified index of immutable array. ") + , ("indexInt32X16Array#"," Read a vector from specified index of immutable array. ") + , ("indexInt64X8Array#"," Read a vector from specified index of immutable array. ") + , ("indexWord8X16Array#"," Read a vector from specified index of immutable array. ") + , ("indexWord16X8Array#"," Read a vector from specified index of immutable array. ") + , ("indexWord32X4Array#"," Read a vector from specified index of immutable array. ") + , ("indexWord64X2Array#"," Read a vector from specified index of immutable array. ") + , ("indexWord8X32Array#"," Read a vector from specified index of immutable array. ") + , ("indexWord16X16Array#"," Read a vector from specified index of immutable array. ") + , ("indexWord32X8Array#"," Read a vector from specified index of immutable array. ") + , ("indexWord64X4Array#"," Read a vector from specified index of immutable array. ") + , ("indexWord8X64Array#"," Read a vector from specified index of immutable array. ") + , ("indexWord16X32Array#"," Read a vector from specified index of immutable array. ") + , ("indexWord32X16Array#"," Read a vector from specified index of immutable array. ") + , ("indexWord64X8Array#"," Read a vector from specified index of immutable array. ") + , ("indexFloatX4Array#"," Read a vector from specified index of immutable array. ") + , ("indexDoubleX2Array#"," Read a vector from specified index of immutable array. ") + , ("indexFloatX8Array#"," Read a vector from specified index of immutable array. ") + , ("indexDoubleX4Array#"," Read a vector from specified index of immutable array. ") + , ("indexFloatX16Array#"," Read a vector from specified index of immutable array. ") + , ("indexDoubleX8Array#"," Read a vector from specified index of immutable array. ") + , ("readInt8X16Array#"," Read a vector from specified index of mutable array. ") + , ("readInt16X8Array#"," Read a vector from specified index of mutable array. ") + , ("readInt32X4Array#"," Read a vector from specified index of mutable array. ") + , ("readInt64X2Array#"," Read a vector from specified index of mutable array. ") + , ("readInt8X32Array#"," Read a vector from specified index of mutable array. ") + , ("readInt16X16Array#"," Read a vector from specified index of mutable array. ") + , ("readInt32X8Array#"," Read a vector from specified index of mutable array. ") + , ("readInt64X4Array#"," Read a vector from specified index of mutable array. ") + , ("readInt8X64Array#"," Read a vector from specified index of mutable array. ") + , ("readInt16X32Array#"," Read a vector from specified index of mutable array. ") + , ("readInt32X16Array#"," Read a vector from specified index of mutable array. ") + , ("readInt64X8Array#"," Read a vector from specified index of mutable array. ") + , ("readWord8X16Array#"," Read a vector from specified index of mutable array. ") + , ("readWord16X8Array#"," Read a vector from specified index of mutable array. ") + , ("readWord32X4Array#"," Read a vector from specified index of mutable array. ") + , ("readWord64X2Array#"," Read a vector from specified index of mutable array. ") + , ("readWord8X32Array#"," Read a vector from specified index of mutable array. ") + , ("readWord16X16Array#"," Read a vector from specified index of mutable array. ") + , ("readWord32X8Array#"," Read a vector from specified index of mutable array. ") + , ("readWord64X4Array#"," Read a vector from specified index of mutable array. ") + , ("readWord8X64Array#"," Read a vector from specified index of mutable array. ") + , ("readWord16X32Array#"," Read a vector from specified index of mutable array. ") + , ("readWord32X16Array#"," Read a vector from specified index of mutable array. ") + , ("readWord64X8Array#"," Read a vector from specified index of mutable array. ") + , ("readFloatX4Array#"," Read a vector from specified index of mutable array. ") + , ("readDoubleX2Array#"," Read a vector from specified index of mutable array. ") + , ("readFloatX8Array#"," Read a vector from specified index of mutable array. ") + , ("readDoubleX4Array#"," Read a vector from specified index of mutable array. ") + , ("readFloatX16Array#"," Read a vector from specified index of mutable array. ") + , ("readDoubleX8Array#"," Read a vector from specified index of mutable array. ") + , ("writeInt8X16Array#"," Write a vector to specified index of mutable array. ") + , ("writeInt16X8Array#"," Write a vector to specified index of mutable array. ") + , ("writeInt32X4Array#"," Write a vector to specified index of mutable array. ") + , ("writeInt64X2Array#"," Write a vector to specified index of mutable array. ") + , ("writeInt8X32Array#"," Write a vector to specified index of mutable array. ") + , ("writeInt16X16Array#"," Write a vector to specified index of mutable array. ") + , ("writeInt32X8Array#"," Write a vector to specified index of mutable array. ") + , ("writeInt64X4Array#"," Write a vector to specified index of mutable array. ") + , ("writeInt8X64Array#"," Write a vector to specified index of mutable array. ") + , ("writeInt16X32Array#"," Write a vector to specified index of mutable array. ") + , ("writeInt32X16Array#"," Write a vector to specified index of mutable array. ") + , ("writeInt64X8Array#"," Write a vector to specified index of mutable array. ") + , ("writeWord8X16Array#"," Write a vector to specified index of mutable array. ") + , ("writeWord16X8Array#"," Write a vector to specified index of mutable array. ") + , ("writeWord32X4Array#"," Write a vector to specified index of mutable array. ") + , ("writeWord64X2Array#"," Write a vector to specified index of mutable array. ") + , ("writeWord8X32Array#"," Write a vector to specified index of mutable array. ") + , ("writeWord16X16Array#"," Write a vector to specified index of mutable array. ") + , ("writeWord32X8Array#"," Write a vector to specified index of mutable array. ") + , ("writeWord64X4Array#"," Write a vector to specified index of mutable array. ") + , ("writeWord8X64Array#"," Write a vector to specified index of mutable array. ") + , ("writeWord16X32Array#"," Write a vector to specified index of mutable array. ") + , ("writeWord32X16Array#"," Write a vector to specified index of mutable array. ") + , ("writeWord64X8Array#"," Write a vector to specified index of mutable array. ") + , ("writeFloatX4Array#"," Write a vector to specified index of mutable array. ") + , ("writeDoubleX2Array#"," Write a vector to specified index of mutable array. ") + , ("writeFloatX8Array#"," Write a vector to specified index of mutable array. ") + , ("writeDoubleX4Array#"," Write a vector to specified index of mutable array. ") + , ("writeFloatX16Array#"," Write a vector to specified index of mutable array. ") + , ("writeDoubleX8Array#"," Write a vector to specified index of mutable array. ") + , ("indexInt8X16OffAddr#"," Reads vector; offset in bytes. ") + , ("indexInt16X8OffAddr#"," Reads vector; offset in bytes. ") + , ("indexInt32X4OffAddr#"," Reads vector; offset in bytes. ") + , ("indexInt64X2OffAddr#"," Reads vector; offset in bytes. ") + , ("indexInt8X32OffAddr#"," Reads vector; offset in bytes. ") + , ("indexInt16X16OffAddr#"," Reads vector; offset in bytes. ") + , ("indexInt32X8OffAddr#"," Reads vector; offset in bytes. ") + , ("indexInt64X4OffAddr#"," Reads vector; offset in bytes. ") + , ("indexInt8X64OffAddr#"," Reads vector; offset in bytes. ") + , ("indexInt16X32OffAddr#"," Reads vector; offset in bytes. ") + , ("indexInt32X16OffAddr#"," Reads vector; offset in bytes. ") + , ("indexInt64X8OffAddr#"," Reads vector; offset in bytes. ") + , ("indexWord8X16OffAddr#"," Reads vector; offset in bytes. ") + , ("indexWord16X8OffAddr#"," Reads vector; offset in bytes. ") + , ("indexWord32X4OffAddr#"," Reads vector; offset in bytes. ") + , ("indexWord64X2OffAddr#"," Reads vector; offset in bytes. ") + , ("indexWord8X32OffAddr#"," Reads vector; offset in bytes. ") + , ("indexWord16X16OffAddr#"," Reads vector; offset in bytes. ") + , ("indexWord32X8OffAddr#"," Reads vector; offset in bytes. ") + , ("indexWord64X4OffAddr#"," Reads vector; offset in bytes. ") + , ("indexWord8X64OffAddr#"," Reads vector; offset in bytes. ") + , ("indexWord16X32OffAddr#"," Reads vector; offset in bytes. ") + , ("indexWord32X16OffAddr#"," Reads vector; offset in bytes. ") + , ("indexWord64X8OffAddr#"," Reads vector; offset in bytes. ") + , ("indexFloatX4OffAddr#"," Reads vector; offset in bytes. ") + , ("indexDoubleX2OffAddr#"," Reads vector; offset in bytes. ") + , ("indexFloatX8OffAddr#"," Reads vector; offset in bytes. ") + , ("indexDoubleX4OffAddr#"," Reads vector; offset in bytes. ") + , ("indexFloatX16OffAddr#"," Reads vector; offset in bytes. ") + , ("indexDoubleX8OffAddr#"," Reads vector; offset in bytes. ") + , ("readInt8X16OffAddr#"," Reads vector; offset in bytes. ") + , ("readInt16X8OffAddr#"," Reads vector; offset in bytes. ") + , ("readInt32X4OffAddr#"," Reads vector; offset in bytes. ") + , ("readInt64X2OffAddr#"," Reads vector; offset in bytes. ") + , ("readInt8X32OffAddr#"," Reads vector; offset in bytes. ") + , ("readInt16X16OffAddr#"," Reads vector; offset in bytes. ") + , ("readInt32X8OffAddr#"," Reads vector; offset in bytes. ") + , ("readInt64X4OffAddr#"," Reads vector; offset in bytes. ") + , ("readInt8X64OffAddr#"," Reads vector; offset in bytes. ") + , ("readInt16X32OffAddr#"," Reads vector; offset in bytes. ") + , ("readInt32X16OffAddr#"," Reads vector; offset in bytes. ") + , ("readInt64X8OffAddr#"," Reads vector; offset in bytes. ") + , ("readWord8X16OffAddr#"," Reads vector; offset in bytes. ") + , ("readWord16X8OffAddr#"," Reads vector; offset in bytes. ") + , ("readWord32X4OffAddr#"," Reads vector; offset in bytes. ") + , ("readWord64X2OffAddr#"," Reads vector; offset in bytes. ") + , ("readWord8X32OffAddr#"," Reads vector; offset in bytes. ") + , ("readWord16X16OffAddr#"," Reads vector; offset in bytes. ") + , ("readWord32X8OffAddr#"," Reads vector; offset in bytes. ") + , ("readWord64X4OffAddr#"," Reads vector; offset in bytes. ") + , ("readWord8X64OffAddr#"," Reads vector; offset in bytes. ") + , ("readWord16X32OffAddr#"," Reads vector; offset in bytes. ") + , ("readWord32X16OffAddr#"," Reads vector; offset in bytes. ") + , ("readWord64X8OffAddr#"," Reads vector; offset in bytes. ") + , ("readFloatX4OffAddr#"," Reads vector; offset in bytes. ") + , ("readDoubleX2OffAddr#"," Reads vector; offset in bytes. ") + , ("readFloatX8OffAddr#"," Reads vector; offset in bytes. ") + , ("readDoubleX4OffAddr#"," Reads vector; offset in bytes. ") + , ("readFloatX16OffAddr#"," Reads vector; offset in bytes. ") + , ("readDoubleX8OffAddr#"," Reads vector; offset in bytes. ") + , ("writeInt8X16OffAddr#"," Write vector; offset in bytes. ") + , ("writeInt16X8OffAddr#"," Write vector; offset in bytes. ") + , ("writeInt32X4OffAddr#"," Write vector; offset in bytes. ") + , ("writeInt64X2OffAddr#"," Write vector; offset in bytes. ") + , ("writeInt8X32OffAddr#"," Write vector; offset in bytes. ") + , ("writeInt16X16OffAddr#"," Write vector; offset in bytes. ") + , ("writeInt32X8OffAddr#"," Write vector; offset in bytes. ") + , ("writeInt64X4OffAddr#"," Write vector; offset in bytes. ") + , ("writeInt8X64OffAddr#"," Write vector; offset in bytes. ") + , ("writeInt16X32OffAddr#"," Write vector; offset in bytes. ") + , ("writeInt32X16OffAddr#"," Write vector; offset in bytes. ") + , ("writeInt64X8OffAddr#"," Write vector; offset in bytes. ") + , ("writeWord8X16OffAddr#"," Write vector; offset in bytes. ") + , ("writeWord16X8OffAddr#"," Write vector; offset in bytes. ") + , ("writeWord32X4OffAddr#"," Write vector; offset in bytes. ") + , ("writeWord64X2OffAddr#"," Write vector; offset in bytes. ") + , ("writeWord8X32OffAddr#"," Write vector; offset in bytes. ") + , ("writeWord16X16OffAddr#"," Write vector; offset in bytes. ") + , ("writeWord32X8OffAddr#"," Write vector; offset in bytes. ") + , ("writeWord64X4OffAddr#"," Write vector; offset in bytes. ") + , ("writeWord8X64OffAddr#"," Write vector; offset in bytes. ") + , ("writeWord16X32OffAddr#"," Write vector; offset in bytes. ") + , ("writeWord32X16OffAddr#"," Write vector; offset in bytes. ") + , ("writeWord64X8OffAddr#"," Write vector; offset in bytes. ") + , ("writeFloatX4OffAddr#"," Write vector; offset in bytes. ") + , ("writeDoubleX2OffAddr#"," Write vector; offset in bytes. ") + , ("writeFloatX8OffAddr#"," Write vector; offset in bytes. ") + , ("writeDoubleX4OffAddr#"," Write vector; offset in bytes. ") + , ("writeFloatX16OffAddr#"," Write vector; offset in bytes. ") + , ("writeDoubleX8OffAddr#"," Write vector; offset in bytes. ") + , ("indexInt8ArrayAsInt8X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexInt16ArrayAsInt16X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexInt32ArrayAsInt32X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexInt64ArrayAsInt64X2#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexInt8ArrayAsInt8X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexInt16ArrayAsInt16X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexInt32ArrayAsInt32X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexInt64ArrayAsInt64X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexInt8ArrayAsInt8X64#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexInt16ArrayAsInt16X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexInt32ArrayAsInt32X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexInt64ArrayAsInt64X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexWord8ArrayAsWord8X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexWord16ArrayAsWord16X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexWord32ArrayAsWord32X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexWord64ArrayAsWord64X2#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexWord8ArrayAsWord8X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexWord16ArrayAsWord16X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexWord32ArrayAsWord32X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexWord64ArrayAsWord64X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexWord8ArrayAsWord8X64#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexWord16ArrayAsWord16X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexWord32ArrayAsWord32X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexWord64ArrayAsWord64X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexFloatArrayAsFloatX4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexDoubleArrayAsDoubleX2#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexFloatArrayAsFloatX8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexDoubleArrayAsDoubleX4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexFloatArrayAsFloatX16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("indexDoubleArrayAsDoubleX8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ") + , ("readInt8ArrayAsInt8X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readInt16ArrayAsInt16X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readInt32ArrayAsInt32X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readInt64ArrayAsInt64X2#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readInt8ArrayAsInt8X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readInt16ArrayAsInt16X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readInt32ArrayAsInt32X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readInt64ArrayAsInt64X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readInt8ArrayAsInt8X64#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readInt16ArrayAsInt16X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readInt32ArrayAsInt32X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readInt64ArrayAsInt64X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readWord8ArrayAsWord8X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readWord16ArrayAsWord16X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readWord32ArrayAsWord32X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readWord64ArrayAsWord64X2#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readWord8ArrayAsWord8X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readWord16ArrayAsWord16X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readWord32ArrayAsWord32X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readWord64ArrayAsWord64X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readWord8ArrayAsWord8X64#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readWord16ArrayAsWord16X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readWord32ArrayAsWord32X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readWord64ArrayAsWord64X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readFloatArrayAsFloatX4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readDoubleArrayAsDoubleX2#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readFloatArrayAsFloatX8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readDoubleArrayAsDoubleX4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readFloatArrayAsFloatX16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("readDoubleArrayAsDoubleX8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeInt8ArrayAsInt8X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeInt16ArrayAsInt16X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeInt32ArrayAsInt32X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeInt64ArrayAsInt64X2#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeInt8ArrayAsInt8X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeInt16ArrayAsInt16X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeInt32ArrayAsInt32X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeInt64ArrayAsInt64X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeInt8ArrayAsInt8X64#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeInt16ArrayAsInt16X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeInt32ArrayAsInt32X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeInt64ArrayAsInt64X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeWord8ArrayAsWord8X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeWord16ArrayAsWord16X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeWord32ArrayAsWord32X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeWord64ArrayAsWord64X2#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeWord8ArrayAsWord8X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeWord16ArrayAsWord16X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeWord32ArrayAsWord32X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeWord64ArrayAsWord64X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeWord8ArrayAsWord8X64#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeWord16ArrayAsWord16X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeWord32ArrayAsWord32X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeWord64ArrayAsWord64X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeFloatArrayAsFloatX4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeDoubleArrayAsDoubleX2#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeFloatArrayAsFloatX8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeDoubleArrayAsDoubleX4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeFloatArrayAsFloatX16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("writeDoubleArrayAsDoubleX8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ") + , ("indexInt8OffAddrAsInt8X16#"," Reads vector; offset in scalar elements. ") + , ("indexInt16OffAddrAsInt16X8#"," Reads vector; offset in scalar elements. ") + , ("indexInt32OffAddrAsInt32X4#"," Reads vector; offset in scalar elements. ") + , ("indexInt64OffAddrAsInt64X2#"," Reads vector; offset in scalar elements. ") + , ("indexInt8OffAddrAsInt8X32#"," Reads vector; offset in scalar elements. ") + , ("indexInt16OffAddrAsInt16X16#"," Reads vector; offset in scalar elements. ") + , ("indexInt32OffAddrAsInt32X8#"," Reads vector; offset in scalar elements. ") + , ("indexInt64OffAddrAsInt64X4#"," Reads vector; offset in scalar elements. ") + , ("indexInt8OffAddrAsInt8X64#"," Reads vector; offset in scalar elements. ") + , ("indexInt16OffAddrAsInt16X32#"," Reads vector; offset in scalar elements. ") + , ("indexInt32OffAddrAsInt32X16#"," Reads vector; offset in scalar elements. ") + , ("indexInt64OffAddrAsInt64X8#"," Reads vector; offset in scalar elements. ") + , ("indexWord8OffAddrAsWord8X16#"," Reads vector; offset in scalar elements. ") + , ("indexWord16OffAddrAsWord16X8#"," Reads vector; offset in scalar elements. ") + , ("indexWord32OffAddrAsWord32X4#"," Reads vector; offset in scalar elements. ") + , ("indexWord64OffAddrAsWord64X2#"," Reads vector; offset in scalar elements. ") + , ("indexWord8OffAddrAsWord8X32#"," Reads vector; offset in scalar elements. ") + , ("indexWord16OffAddrAsWord16X16#"," Reads vector; offset in scalar elements. ") + , ("indexWord32OffAddrAsWord32X8#"," Reads vector; offset in scalar elements. ") + , ("indexWord64OffAddrAsWord64X4#"," Reads vector; offset in scalar elements. ") + , ("indexWord8OffAddrAsWord8X64#"," Reads vector; offset in scalar elements. ") + , ("indexWord16OffAddrAsWord16X32#"," Reads vector; offset in scalar elements. ") + , ("indexWord32OffAddrAsWord32X16#"," Reads vector; offset in scalar elements. ") + , ("indexWord64OffAddrAsWord64X8#"," Reads vector; offset in scalar elements. ") + , ("indexFloatOffAddrAsFloatX4#"," Reads vector; offset in scalar elements. ") + , ("indexDoubleOffAddrAsDoubleX2#"," Reads vector; offset in scalar elements. ") + , ("indexFloatOffAddrAsFloatX8#"," Reads vector; offset in scalar elements. ") + , ("indexDoubleOffAddrAsDoubleX4#"," Reads vector; offset in scalar elements. ") + , ("indexFloatOffAddrAsFloatX16#"," Reads vector; offset in scalar elements. ") + , ("indexDoubleOffAddrAsDoubleX8#"," Reads vector; offset in scalar elements. ") + , ("readInt8OffAddrAsInt8X16#"," Reads vector; offset in scalar elements. ") + , ("readInt16OffAddrAsInt16X8#"," Reads vector; offset in scalar elements. ") + , ("readInt32OffAddrAsInt32X4#"," Reads vector; offset in scalar elements. ") + , ("readInt64OffAddrAsInt64X2#"," Reads vector; offset in scalar elements. ") + , ("readInt8OffAddrAsInt8X32#"," Reads vector; offset in scalar elements. ") + , ("readInt16OffAddrAsInt16X16#"," Reads vector; offset in scalar elements. ") + , ("readInt32OffAddrAsInt32X8#"," Reads vector; offset in scalar elements. ") + , ("readInt64OffAddrAsInt64X4#"," Reads vector; offset in scalar elements. ") + , ("readInt8OffAddrAsInt8X64#"," Reads vector; offset in scalar elements. ") + , ("readInt16OffAddrAsInt16X32#"," Reads vector; offset in scalar elements. ") + , ("readInt32OffAddrAsInt32X16#"," Reads vector; offset in scalar elements. ") + , ("readInt64OffAddrAsInt64X8#"," Reads vector; offset in scalar elements. ") + , ("readWord8OffAddrAsWord8X16#"," Reads vector; offset in scalar elements. ") + , ("readWord16OffAddrAsWord16X8#"," Reads vector; offset in scalar elements. ") + , ("readWord32OffAddrAsWord32X4#"," Reads vector; offset in scalar elements. ") + , ("readWord64OffAddrAsWord64X2#"," Reads vector; offset in scalar elements. ") + , ("readWord8OffAddrAsWord8X32#"," Reads vector; offset in scalar elements. ") + , ("readWord16OffAddrAsWord16X16#"," Reads vector; offset in scalar elements. ") + , ("readWord32OffAddrAsWord32X8#"," Reads vector; offset in scalar elements. ") + , ("readWord64OffAddrAsWord64X4#"," Reads vector; offset in scalar elements. ") + , ("readWord8OffAddrAsWord8X64#"," Reads vector; offset in scalar elements. ") + , ("readWord16OffAddrAsWord16X32#"," Reads vector; offset in scalar elements. ") + , ("readWord32OffAddrAsWord32X16#"," Reads vector; offset in scalar elements. ") + , ("readWord64OffAddrAsWord64X8#"," Reads vector; offset in scalar elements. ") + , ("readFloatOffAddrAsFloatX4#"," Reads vector; offset in scalar elements. ") + , ("readDoubleOffAddrAsDoubleX2#"," Reads vector; offset in scalar elements. ") + , ("readFloatOffAddrAsFloatX8#"," Reads vector; offset in scalar elements. ") + , ("readDoubleOffAddrAsDoubleX4#"," Reads vector; offset in scalar elements. ") + , ("readFloatOffAddrAsFloatX16#"," Reads vector; offset in scalar elements. ") + , ("readDoubleOffAddrAsDoubleX8#"," Reads vector; offset in scalar elements. ") + , ("writeInt8OffAddrAsInt8X16#"," Write vector; offset in scalar elements. ") + , ("writeInt16OffAddrAsInt16X8#"," Write vector; offset in scalar elements. ") + , ("writeInt32OffAddrAsInt32X4#"," Write vector; offset in scalar elements. ") + , ("writeInt64OffAddrAsInt64X2#"," Write vector; offset in scalar elements. ") + , ("writeInt8OffAddrAsInt8X32#"," Write vector; offset in scalar elements. ") + , ("writeInt16OffAddrAsInt16X16#"," Write vector; offset in scalar elements. ") + , ("writeInt32OffAddrAsInt32X8#"," Write vector; offset in scalar elements. ") + , ("writeInt64OffAddrAsInt64X4#"," Write vector; offset in scalar elements. ") + , ("writeInt8OffAddrAsInt8X64#"," Write vector; offset in scalar elements. ") + , ("writeInt16OffAddrAsInt16X32#"," Write vector; offset in scalar elements. ") + , ("writeInt32OffAddrAsInt32X16#"," Write vector; offset in scalar elements. ") + , ("writeInt64OffAddrAsInt64X8#"," Write vector; offset in scalar elements. ") + , ("writeWord8OffAddrAsWord8X16#"," Write vector; offset in scalar elements. ") + , ("writeWord16OffAddrAsWord16X8#"," Write vector; offset in scalar elements. ") + , ("writeWord32OffAddrAsWord32X4#"," Write vector; offset in scalar elements. ") + , ("writeWord64OffAddrAsWord64X2#"," Write vector; offset in scalar elements. ") + , ("writeWord8OffAddrAsWord8X32#"," Write vector; offset in scalar elements. ") + , ("writeWord16OffAddrAsWord16X16#"," Write vector; offset in scalar elements. ") + , ("writeWord32OffAddrAsWord32X8#"," Write vector; offset in scalar elements. ") + , ("writeWord64OffAddrAsWord64X4#"," Write vector; offset in scalar elements. ") + , ("writeWord8OffAddrAsWord8X64#"," Write vector; offset in scalar elements. ") + , ("writeWord16OffAddrAsWord16X32#"," Write vector; offset in scalar elements. ") + , ("writeWord32OffAddrAsWord32X16#"," Write vector; offset in scalar elements. ") + , ("writeWord64OffAddrAsWord64X8#"," Write vector; offset in scalar elements. ") + , ("writeFloatOffAddrAsFloatX4#"," Write vector; offset in scalar elements. ") + , ("writeDoubleOffAddrAsDoubleX2#"," Write vector; offset in scalar elements. ") + , ("writeFloatOffAddrAsFloatX8#"," Write vector; offset in scalar elements. ") + , ("writeDoubleOffAddrAsDoubleX4#"," Write vector; offset in scalar elements. ") + , ("writeFloatOffAddrAsFloatX16#"," Write vector; offset in scalar elements. ") + , ("writeDoubleOffAddrAsDoubleX8#"," Write vector; offset in scalar elements. ") + ] diff --git a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl @@ -5,7 +5,6 @@ primOpStrictness RaiseDivZeroOp = \ _arity -> mkClosedStrictSig [topDmd] botDiv primOpStrictness RaiseUnderflowOp = \ _arity -> mkClosedStrictSig [topDmd] botDiv primOpStrictness RaiseOverflowOp = \ _arity -> mkClosedStrictSig [topDmd] botDiv -primOpStrictness RaiseIOOp = \ _arity -> mkClosedStrictSig [topDmd, topDmd] botDiv primOpStrictness MaskAsyncExceptionsOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv primOpStrictness MaskUninterruptibleOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv primOpStrictness UnmaskAsyncExceptionsOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv diff --git a/ghc-lib/stage0/lib/DerivedConstants.h b/ghc-lib/stage0/lib/DerivedConstants.h --- a/ghc-lib/stage0/lib/DerivedConstants.h +++ b/ghc-lib/stage0/lib/DerivedConstants.h @@ -455,8 +455,8 @@ #define OFFSET_MessageBlackHole_bh 16 #define REP_MessageBlackHole_bh b64 #define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh] -#define SIZEOF_StgCompactNFData_NoHdr 64 -#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+64) +#define SIZEOF_StgCompactNFData_NoHdr 72 +#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+72) #define OFFSET_StgCompactNFData_totalW 0 #define REP_StgCompactNFData_totalW b64 #define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW] diff --git a/ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs b/ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs --- a/ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs +++ b/ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs @@ -116,7 +116,6 @@ cLONG_LONG_SIZE, bITMAP_BITS_SHIFT, tAG_BITS, - wORDS_BIGENDIAN, dYNAMIC_BY_DEFAULT, lDV_SHIFT, iLDV_CREATE_MASK, diff --git a/ghc-lib/stage0/lib/GHCConstantsHaskellType.hs b/ghc-lib/stage0/lib/GHCConstantsHaskellType.hs --- a/ghc-lib/stage0/lib/GHCConstantsHaskellType.hs +++ b/ghc-lib/stage0/lib/GHCConstantsHaskellType.hs @@ -123,7 +123,6 @@ pc_CLONG_LONG_SIZE :: Int, pc_BITMAP_BITS_SHIFT :: Int, pc_TAG_BITS :: Int, - pc_WORDS_BIGENDIAN :: Bool, pc_DYNAMIC_BY_DEFAULT :: Bool, pc_LDV_SHIFT :: Int, pc_ILDV_CREATE_MASK :: Integer, diff --git a/ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs b/ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs --- a/ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs +++ b/ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs @@ -234,8 +234,6 @@ bITMAP_BITS_SHIFT dflags = pc_BITMAP_BITS_SHIFT (platformConstants dflags) tAG_BITS :: DynFlags -> Int tAG_BITS dflags = pc_TAG_BITS (platformConstants dflags) -wORDS_BIGENDIAN :: DynFlags -> Bool -wORDS_BIGENDIAN dflags = pc_WORDS_BIGENDIAN (platformConstants dflags) dYNAMIC_BY_DEFAULT :: DynFlags -> Bool dYNAMIC_BY_DEFAULT dflags = pc_DYNAMIC_BY_DEFAULT (platformConstants dflags) lDV_SHIFT :: DynFlags -> Int diff --git a/ghc-lib/stage0/lib/ghcversion.h b/ghc-lib/stage0/lib/ghcversion.h --- a/ghc-lib/stage0/lib/ghcversion.h +++ b/ghc-lib/stage0/lib/ghcversion.h @@ -6,7 +6,7 @@ #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0 -#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200331 +#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200430 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \ diff --git a/ghc-lib/stage0/lib/platformConstants b/ghc-lib/stage0/lib/platformConstants --- a/ghc-lib/stage0/lib/platformConstants +++ b/ghc-lib/stage0/lib/platformConstants @@ -123,7 +123,6 @@ pc_CLONG_LONG_SIZE = 8, pc_BITMAP_BITS_SHIFT = 6, pc_TAG_BITS = 3, - pc_WORDS_BIGENDIAN = False, pc_DYNAMIC_BY_DEFAULT = False, pc_LDV_SHIFT = 30, pc_ILDV_CREATE_MASK = 1152921503533105152, 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 @@ -26,6 +26,7 @@ ,("target os", "OSDarwin") ,("target arch", "ArchX86_64") ,("target word size", "8") +,("target word big endian", "NO") ,("target has GNU nonexec stack", "NO") ,("target has .ident directive", "YES") ,("target has subsections via symbols", "YES") diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs --- a/includes/CodeGen.Platform.hs +++ b/includes/CodeGen.Platform.hs @@ -2,7 +2,7 @@ import GHC.Cmm.Expr #if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \ || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc)) -import PlainPanic +import GHC.Utils.Panic.Plain #endif import GHC.Platform.Reg diff --git a/libraries/ghc-boot/GHC/Settings.hs b/libraries/ghc-boot/GHC/Settings.hs deleted file mode 100644 --- a/libraries/ghc-boot/GHC/Settings.hs +++ /dev/null @@ -1,106 +0,0 @@ --- Note [Settings file] --- ~~~~~~~~~~~~~~~~~~~~ --- --- GHC has a file, `${top_dir}/settings`, which is the main source of run-time --- configuration. ghc-pkg needs just a little bit of it: the target platform CPU --- arch and OS. It uses that to figure out what subdirectory of `~/.ghc` is --- associated with the current version/target. --- --- This module has just enough code to read key value pairs from the settings --- file, and read the target platform from those pairs. --- --- The "0" suffix is because the caller will partially apply it, and that will --- in turn be used a few more times. -module GHC.Settings where - -import Prelude -- See Note [Why do we import Prelude here?] - -import GHC.BaseDir -import GHC.Platform - -import Data.Char (isSpace) -import Data.Map (Map) -import qualified Data.Map as Map - ------------------------------------------------------------------------------ --- parts of settings file - -getTargetPlatform - :: FilePath -> RawSettings -> Either String Platform -getTargetPlatform settingsFile mySettings = do - let - getBooleanSetting = getBooleanSetting0 settingsFile mySettings - readSetting :: (Show a, Read a) => String -> Either String a - readSetting = readSetting0 settingsFile mySettings - - targetArch <- readSetting "target arch" - targetOS <- readSetting "target os" - targetWordSize <- readSetting "target word size" - targetUnregisterised <- getBooleanSetting "Unregisterised" - targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack" - targetHasIdentDirective <- getBooleanSetting "target has .ident directive" - targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols" - crossCompiling <- getBooleanSetting "cross compiling" - - pure $ Platform - { platformMini = PlatformMini - { platformMini_arch = targetArch - , platformMini_os = targetOS - } - , platformWordSize = targetWordSize - , platformUnregisterised = targetUnregisterised - , platformHasGnuNonexecStack = targetHasGnuNonexecStack - , platformHasIdentDirective = targetHasIdentDirective - , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols - , platformIsCrossCompiling = crossCompiling - } - ------------------------------------------------------------------------------ --- settings file helpers - -type RawSettings = Map String String - --- | See Note [Settings file] for "0" suffix -getSetting0 - :: FilePath -> RawSettings -> String -> Either String String -getSetting0 settingsFile mySettings key = case Map.lookup key mySettings of - Just xs -> Right xs - Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile - --- | See Note [Settings file] for "0" suffix -getFilePathSetting0 - :: FilePath -> FilePath -> RawSettings -> String -> Either String String -getFilePathSetting0 top_dir settingsFile mySettings key = - expandTopDir top_dir <$> getSetting0 settingsFile mySettings key - --- | See Note [Settings file] for "0" suffix -getBooleanSetting0 - :: FilePath -> RawSettings -> String -> Either String Bool -getBooleanSetting0 settingsFile mySettings key = do - rawValue <- getSetting0 settingsFile mySettings key - case rawValue of - "YES" -> Right True - "NO" -> Right False - xs -> Left $ "Bad value for " ++ show key ++ ": " ++ show xs - --- | See Note [Settings file] for "0" suffix -readSetting0 - :: (Show a, Read a) => FilePath -> RawSettings -> String -> Either String a -readSetting0 settingsFile mySettings key = case Map.lookup key mySettings of - Just xs -> case maybeRead xs of - Just v -> Right v - Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs - Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile - ------------------------------------------------------------------------------ --- read helpers - -maybeRead :: Read a => String -> Maybe a -maybeRead str = case reads str of - [(x, "")] -> Just x - _ -> Nothing - -maybeReadFuzzy :: Read a => String -> Maybe a -maybeReadFuzzy str = case reads str of - [(x, s)] | all isSpace s -> Just x - _ -> Nothing diff --git a/libraries/ghc-boot/GHC/Settings/Platform.hs b/libraries/ghc-boot/GHC/Settings/Platform.hs new file mode 100644 --- /dev/null +++ b/libraries/ghc-boot/GHC/Settings/Platform.hs @@ -0,0 +1,95 @@ +-- Note [Settings file] +-- ~~~~~~~~~~~~~~~~~~~~ +-- +-- GHC has a file, `${top_dir}/settings`, which is the main source of run-time +-- configuration. ghc-pkg needs just a little bit of it: the target platform CPU +-- arch and OS. It uses that to figure out what subdirectory of `~/.ghc` is +-- associated with the current version/target. +-- +-- This module has just enough code to read key value pairs from the settings +-- file, and read the target platform from those pairs. +-- +-- The "0" suffix is because the caller will partially apply it, and that will +-- in turn be used a few more times. +module GHC.Settings.Platform where + +import Prelude -- See Note [Why do we import Prelude here?] + +import GHC.BaseDir +import GHC.Platform +import GHC.Settings.Utils + +import Data.Map (Map) +import qualified Data.Map as Map + +----------------------------------------------------------------------------- +-- parts of settings file + +getTargetPlatform + :: FilePath -> RawSettings -> Either String Platform +getTargetPlatform settingsFile mySettings = do + let + getBooleanSetting = getBooleanSetting0 settingsFile mySettings + readSetting :: (Show a, Read a) => String -> Either String a + readSetting = readSetting0 settingsFile mySettings + + targetArch <- readSetting "target arch" + targetOS <- readSetting "target os" + targetWordSize <- readSetting "target word size" + targetWordBigEndian <- getBooleanSetting "target word big endian" + targetUnregisterised <- getBooleanSetting "Unregisterised" + targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack" + targetHasIdentDirective <- getBooleanSetting "target has .ident directive" + targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols" + crossCompiling <- getBooleanSetting "cross compiling" + + pure $ Platform + { platformMini = PlatformMini + { platformMini_arch = targetArch + , platformMini_os = targetOS + } + , platformWordSize = targetWordSize + , platformByteOrder = if targetWordBigEndian then BigEndian else LittleEndian + , platformUnregisterised = targetUnregisterised + , platformHasGnuNonexecStack = targetHasGnuNonexecStack + , platformHasIdentDirective = targetHasIdentDirective + , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols + , platformIsCrossCompiling = crossCompiling + } + +----------------------------------------------------------------------------- +-- settings file helpers + +type RawSettings = Map String String + +-- | See Note [Settings file] for "0" suffix +getSetting0 + :: FilePath -> RawSettings -> String -> Either String String +getSetting0 settingsFile mySettings key = case Map.lookup key mySettings of + Just xs -> Right xs + Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile + +-- | See Note [Settings file] for "0" suffix +getFilePathSetting0 + :: FilePath -> FilePath -> RawSettings -> String -> Either String String +getFilePathSetting0 top_dir settingsFile mySettings key = + expandTopDir top_dir <$> getSetting0 settingsFile mySettings key + +-- | See Note [Settings file] for "0" suffix +getBooleanSetting0 + :: FilePath -> RawSettings -> String -> Either String Bool +getBooleanSetting0 settingsFile mySettings key = do + rawValue <- getSetting0 settingsFile mySettings key + case rawValue of + "YES" -> Right True + "NO" -> Right False + xs -> Left $ "Bad value for " ++ show key ++ ": " ++ show xs + +-- | See Note [Settings file] for "0" suffix +readSetting0 + :: (Show a, Read a) => FilePath -> RawSettings -> String -> Either String a +readSetting0 settingsFile mySettings key = case Map.lookup key mySettings of + Just xs -> case maybeRead xs of + Just v -> Right v + Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs + Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile diff --git a/libraries/ghc-boot/GHC/Settings/Utils.hs b/libraries/ghc-boot/GHC/Settings/Utils.hs new file mode 100644 --- /dev/null +++ b/libraries/ghc-boot/GHC/Settings/Utils.hs @@ -0,0 +1,15 @@ +module GHC.Settings.Utils where + +import Prelude -- See Note [Why do we import Prelude here?] + +import Data.Char (isSpace) + +maybeRead :: Read a => String -> Maybe a +maybeRead str = case reads str of + [(x, "")] -> Just x + _ -> Nothing + +maybeReadFuzzy :: Read a => String -> Maybe a +maybeReadFuzzy str = case reads str of + [(x, s)] | all isSpace s -> Just x + _ -> Nothing diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs --- a/libraries/ghci/GHCi/TH.hs +++ b/libraries/ghci/GHCi/TH.hs @@ -19,7 +19,7 @@ Initialisation ~~~~~~~~~~~~~~ -GHC sends a StartTH message to the server (see TcSplice.getTHState): +GHC sends a StartTH message to the server (see GHC.Tc.Gen.Splice.getTHState): StartTH :: Message (RemoteRef (IORef QState)) @@ -79,7 +79,7 @@ After typechecking ~~~~~~~~~~~~~~~~~~ -GHC sends a FinishTH message to the server (see TcSplice.finishTH). +GHC sends a FinishTH message to the server (see GHC.Tc.Gen.Splice.finishTH). The server runs any finalizers that were added by addModuleFinalizer. @@ -87,8 +87,7 @@ * Note [Remote GHCi] in compiler/ghci/GHCi.hs * Note [External GHCi pointers] in compiler/ghci/GHCi.hs - * Note [TH recover with -fexternal-interpreter] in - compiler/typecheck/TcSplice.hs + * Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice -} import Prelude -- See note [Why do we import Prelude here?] @@ -168,7 +167,7 @@ qNewName str = ghcCmd (NewName str) qReport isError msg = ghcCmd (Report isError msg) - -- See Note [TH recover with -fexternal-interpreter] in TcSplice + -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do remoteTHCall (qsPipe s) StartRecover e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s